justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Refactor, try to limit dependencies

Browse Source
This commit is contained in:
justin
2022-07-28 00:59:56 +01:00
parent 8aa5c17ab9
commit 160560af5f
418 changed files with 15104 additions and 13342 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Debug/Picture.hs
+44 -39
View File
@@ -1,45 +1,48 @@
module Dodge.Debug.Picture where
import Dodge.Data
import Dodge.Base.Window
import Data.Maybe
import Dodge.Base.Wall
import Dodge.Base.Window
import Dodge.Data.Universe
import Geometry
import Picture
import Data.Maybe
--import Color
printPoint :: Point2 -> Picture
printPoint p = color white $ uncurryV translate p $ pictures [circle 3 ,scale 0.05 0.05 $ text (show p)]
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)]
printRotPoint r p =
color white
. uncurryV translate p
$ pictures [circle 3, rotate (negate r) $ scale 0.1 0.1 $ text (show p)]
outsideScreenPolygon :: Configuration -> World -> [Point2]
outsideScreenPolygon cfig w = [tr,tl,bl,br]
where
scRot = rotateV (_cameraRot (_cWorld w))
scZoom p | _cameraZoom (_cWorld w) /= 0 = (1/_cameraZoom (_cWorld w)) *.* p
| otherwise = error "Trying to set screen zoom to zero"
outsideScreenPolygon cfig w = [tr, tl, bl, br]
where
scRot = rotateV (_cameraRot (_cWorld w))
scZoom p
| _cameraZoom (_cWorld w) /= 0 = (1 / _cameraZoom (_cWorld w)) *.* p
| otherwise = error "Trying to set screen zoom to zero"
scTran p = p +.+ _cameraCenter (_cWorld w)
tr = f 3 3
tl = f (-3) 3
br = f 3 (-3)
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)
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
lineOnScreenCone cfig w p1 p2 =
pointInPolygon p1 sp
|| pointInPolygon p2 sp
|| any (isJust . uncurry (intersectSegSeg p1 p2)) sps
where
sp' = screenPolygon cfig w
vp = _cameraViewFrom (_cWorld w)
sp | pointInPolygon vp sp' = sp'
| otherwise = orderPolygon (_cameraViewFrom (_cWorld w) : sp')
sp
| pointInPolygon vp sp' = sp'
| otherwise = orderPolygon (_cameraViewFrom (_cWorld w) : sp')
sps = zip sp (tail sp ++ [head sp])
pointOnScreen :: Configuration -> World -> Point2 -> Bool
@@ -49,26 +52,28 @@ 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)
where
(x, y) = _wlLine wall
points = extendConeToScreenEdge cfig w sightFrom (x, y)
sightFrom = _cameraViewFrom (_cWorld w)
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]
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
cornerPs = filter (pointIsInCone c (x,y)) scpoly
wallScreenIntersect = mapMaybe (uncurry $ intersectSegSeg y ((2*.*y) -.- x))
. loopPairs $ scpoly
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
intersectLinefromScreen cfig w a b =
listToMaybe
. mapMaybe (\(x, y) -> intersectSegLineFrom x y b (b +.+ b -.- a))
. loopPairs
$ screenPolygon cfig w