81 lines
3.0 KiB
Haskell
81 lines
3.0 KiB
Haskell
module Dodge.Debug.Picture where
|
|
|
|
import Control.Lens
|
|
import Data.Maybe
|
|
import Dodge.Base.Wall
|
|
import Dodge.Base.Window
|
|
import Dodge.Data.Universe
|
|
import Geometry
|
|
import Picture
|
|
|
|
printPoint :: Point2 -> Picture
|
|
printPoint p = color white $ uncurryV translate p $ pictures [circle 3, scale 0.05 0.05 $ text (show p)]
|
|
|
|
printRotPoint :: Float -> Point2 -> Picture
|
|
printRotPoint r p =
|
|
color white
|
|
. uncurryV translate p
|
|
$ pictures [circle 3, rotate (negate r) $ scale 0.1 0.1 $ text (show p)]
|
|
|
|
outsideScreenPolygon :: Configuration -> Camera -> [Point2]
|
|
outsideScreenPolygon cfig w = [tr, tl, bl, br]
|
|
where
|
|
scRot = rotateV (w ^. camRot)
|
|
scZoom p
|
|
| (w ^. camZoom) /= 0 = (1 / (w ^. camZoom)) *.* p
|
|
| otherwise = error "Trying to set screen zoom to zero"
|
|
scTran p = p +.+ (w ^. camCenter)
|
|
tr = f 3 3
|
|
tl = f (-3) 3
|
|
br = f 3 (-3)
|
|
bl = f (-3) (-3)
|
|
f a b = scTran $ scRot $ scZoom $ V2 (a * halfWidth cfig) (b * halfHeight cfig)
|
|
|
|
-- cannot only test if walls are on screen, but also if they are on the cone
|
|
-- towards the center of sight
|
|
lineOnScreenCone :: Configuration -> World -> Point2 -> Point2 -> Bool
|
|
lineOnScreenCone cfig w p1 p2 =
|
|
pointInPolygon p1 sp
|
|
|| pointInPolygon p2 sp
|
|
|| any (isJust . uncurry (intersectSegSeg p1 p2)) sps
|
|
where
|
|
sp' = screenPolygon cfig (w ^. cWorld . cwCam)
|
|
vp = w ^. cWorld . cwCam . camViewFrom
|
|
sp
|
|
| pointInPolygon vp sp' = sp'
|
|
| otherwise = orderPolygon ((w ^. cWorld . cwCam . camViewFrom) : sp')
|
|
sps = zip sp (tail sp ++ [head sp])
|
|
|
|
pointOnScreen :: Configuration -> Camera -> Point2 -> Bool
|
|
pointOnScreen cfig w p = pointInPolygon p $ screenPolygon cfig w
|
|
|
|
drawWallFace :: Configuration -> World -> Wall -> Picture
|
|
drawWallFace cfig w wall
|
|
| isRHS sightFrom x y || not (wlIsOpaque wall) = blank
|
|
| otherwise = setDepth (-1) . color (withAlpha 0 black) . polygon $ points
|
|
where
|
|
(x, y) = _wlLine wall
|
|
points = extendConeToScreenEdge cfig w sightFrom (x, y)
|
|
sightFrom = w ^. cWorld . cwCam . camViewFrom
|
|
|
|
extendConeToScreenEdge :: Configuration -> World -> Point2 -> (Point2, Point2) -> [Point2]
|
|
extendConeToScreenEdge cfig w c (x, y) = orderPolygon $ wallScreenIntersect ++ [x, y] ++ borderPs ++ cornerPs
|
|
where
|
|
borderPs = mapMaybe (intersectLinefromScreen cfig w c) [x, y]
|
|
scpoly = reverse $ screenPolygon cfig (w ^. cWorld . cwCam)
|
|
cornerPs = filter (pointIsInCone c (x, y)) scpoly
|
|
wallScreenIntersect =
|
|
mapMaybe (uncurry $ intersectSegSeg y ((2 *.* y) -.- x))
|
|
. loopPairs
|
|
$ scpoly
|
|
|
|
-- the following assumes that the point a is inside the screen
|
|
-- it still works otherwise, but it might intersect two points:
|
|
-- it is not obvious which will be returned
|
|
intersectLinefromScreen :: Configuration -> World -> Point2 -> Point2 -> Maybe Point2
|
|
intersectLinefromScreen cfig w a b =
|
|
listToMaybe
|
|
. mapMaybe (\(x, y) -> intersectSegLineFrom x y b (b +.+ b -.- a))
|
|
. loopPairs
|
|
$ screenPolygon cfig (w ^. cWorld . cwCam)
|