Hlinting
This commit is contained in:
+67
-59
@@ -22,7 +22,7 @@ worldPictures w = pictures $ concat
|
||||
, map clDraw . IM.elems $ _clouds w
|
||||
, map ppDraw . IM.elems $ _pressPlates w
|
||||
, map btDraw (IM.elems (_buttons w))
|
||||
, map (\pt -> _ptDraw pt pt) $ _particles' w
|
||||
, map (\pt -> _ptDraw pt pt) $ _particles w
|
||||
, map drawWallFloor (wallFloorsToDraw w)
|
||||
, testPic w
|
||||
]
|
||||
@@ -54,14 +54,16 @@ btDraw :: Button -> Picture
|
||||
btDraw c = uncurry translate (_btPos c) $ rotate (_btRot c) (_btPict c)
|
||||
|
||||
clDraw :: Cloud -> Picture
|
||||
clDraw c = uncurry translate (_clPos c) $ (_clPict c c)
|
||||
clDraw c = uncurry translate (_clPos c) (_clPict c c)
|
||||
|
||||
|
||||
wallFloorsToDraw :: World -> [Wall]
|
||||
wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w
|
||||
where onScreen wall = lineOnScreen w (_wlLine wall)
|
||||
isVisible wl | wl ^? blVisible == Just False = False
|
||||
| otherwise = onScreen wl
|
||||
where
|
||||
onScreen wall = lineOnScreen w (_wlLine wall)
|
||||
isVisible wl
|
||||
| wl ^? blVisible == Just False = False
|
||||
| otherwise = onScreen wl
|
||||
|
||||
wallsOnScreen :: World -> IM.IntMap Wall
|
||||
wallsOnScreen w = wallsNearZones (zoneOfScreen w) w
|
||||
@@ -76,26 +78,28 @@ drawWallFloor wl = if _wlIsSeeThrough wl
|
||||
n2 = 15 *.* (vNormal . errorNormalizeVDR $ y -.- x)
|
||||
|
||||
errorNormalizeVDR :: Point2 -> Point2
|
||||
errorNormalizeVDR (0,0) = error $ "problem with function: errorNormalizeVDR in DodgeRendering"
|
||||
errorNormalizeVDR (0,0) = error "problem with function: errorNormalizeVDR in DodgeRendering"
|
||||
errorNormalizeVDR p = normalizeV p
|
||||
|
||||
printPoint :: Point2 -> Picture
|
||||
printPoint p = color white $ uncurry translate p $ pictures [circle 3 ,scale 0.05 0.05 $ text (show p)]
|
||||
|
||||
printRotPoint :: Float -> Point2 -> Picture
|
||||
printRotPoint r p = color white $ uncurry translate p $ pictures [circle 3
|
||||
, rotate (0 - r) $ scale 0.1 0.1 $ text (show p)]
|
||||
printRotPoint r p = color white
|
||||
. uncurry translate p
|
||||
$ pictures [circle 3 , rotate (negate r) $ scale 0.1 0.1 $ text (show p)]
|
||||
|
||||
outsideScreenPolygon :: World -> [Point2]
|
||||
outsideScreenPolygon w = [tr,tl,bl,br]
|
||||
where scRot = rotateV (_cameraRot w)
|
||||
scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p
|
||||
scTran p = p +.+ _cameraCenter w
|
||||
tr = scTran $ scRot $ scZoom ( 3*halfWidth w , 3* halfHeight w)
|
||||
tl = scTran $ scRot $ scZoom (- (3*halfWidth w), 3* halfHeight w)
|
||||
br = scTran $ scRot $ scZoom ( 3*halfWidth w ,- (3* halfHeight w))
|
||||
bl = scTran $ scRot $ scZoom (- (3*halfWidth w),- (3* halfHeight w))
|
||||
x = halfWidth w + halfHeight w
|
||||
where
|
||||
scRot = rotateV (_cameraRot w)
|
||||
scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p
|
||||
scTran p = p +.+ _cameraCenter w
|
||||
tr = scTran $ scRot $ scZoom ( 3*halfWidth w , 3* halfHeight w)
|
||||
tl = scTran $ scRot $ scZoom (- (3*halfWidth w), 3* halfHeight w)
|
||||
br = scTran $ scRot $ scZoom ( 3*halfWidth w ,- (3* halfHeight w))
|
||||
bl = scTran $ scRot $ scZoom (- (3*halfWidth w),- (3* halfHeight w))
|
||||
x = halfWidth w + halfHeight w
|
||||
|
||||
wallShadowsToDraw :: World -> [Wall]
|
||||
wallShadowsToDraw w = filter (fromMaybe True . (^? blVisible))
|
||||
@@ -107,43 +111,46 @@ wallShadowsToDraw w = filter (fromMaybe True . (^? blVisible))
|
||||
lineOnScreenCone :: World -> [Point2] -> Bool
|
||||
lineOnScreenCone w (p1:p2:_) = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9 p2 sp
|
||||
|| any (isJust . uncurry (intersectSegSeg' p1 p2)) sps
|
||||
where sp' = screenPolygon w
|
||||
vp = _cameraViewFrom w
|
||||
sp | pointInPolygon vp sp' = sp'
|
||||
| otherwise = orderPolygon $ (_cameraViewFrom w : sp')
|
||||
sps = zip sp (tail sp ++ [head sp])
|
||||
where
|
||||
sp' = screenPolygon w
|
||||
vp = _cameraViewFrom w
|
||||
sp | pointInPolygon vp sp' = sp'
|
||||
| otherwise = orderPolygon (_cameraViewFrom w : sp')
|
||||
sps = zip sp (tail sp ++ [head sp])
|
||||
|
||||
|
||||
lineOnScreen :: World -> [Point2] -> Bool
|
||||
lineOnScreen w (p1:p2:_) = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9 p2 sp
|
||||
|| any (isJust . uncurry (intersectSegSeg' p1 p2)) sps
|
||||
where sp = screenPolygon w
|
||||
sps = zip sp (tail sp ++ [head sp])
|
||||
where
|
||||
sp = screenPolygon w
|
||||
sps = zip sp (tail sp ++ [head sp])
|
||||
|
||||
drawWallFace :: World -> Wall -> Picture
|
||||
drawWallFace w wall
|
||||
| isRHS sightFrom x y || _wlIsSeeThrough wall = blank
|
||||
| otherwise = setDepth (-1) . color (withAlpha 0 black) . polygon $ points
|
||||
where
|
||||
(x:y:_) = _wlLine wall
|
||||
points = extendConeToScreenEdge w sightFrom (x,y)
|
||||
sightFrom = _cameraViewFrom w
|
||||
where
|
||||
(x:y:_) = _wlLine wall
|
||||
points = extendConeToScreenEdge w sightFrom (x,y)
|
||||
sightFrom = _cameraViewFrom w
|
||||
|
||||
-- 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 :: World -> Point2 -> Point2 -> Maybe Point2
|
||||
intersectLinefromScreen w a b = listToMaybe
|
||||
. mapMaybe (\(x,y) -> intersectSegLineFrom' x y b (b +.+ b -.- a))
|
||||
. makeLoopPairs
|
||||
$ screenPolygon w
|
||||
. mapMaybe (\(x,y) -> intersectSegLineFrom' x y b (b +.+ b -.- a))
|
||||
. makeLoopPairs
|
||||
$ screenPolygon w
|
||||
|
||||
extendConeToScreenEdge :: World -> Point2 -> (Point2,Point2) -> [Point2]
|
||||
extendConeToScreenEdge w c (x,y) = orderPolygon $ wallScreenIntersect ++ [x,y] ++ borderPs ++ cornerPs
|
||||
where borderPs = mapMaybe (intersectLinefromScreen w c) [x,y]
|
||||
cornerPs = filter (pointIsInCone c (x,y)) $ screenPolygon w
|
||||
wallScreenIntersect = mapMaybe (uncurry $ intersectSegSeg' y ((2*.*y) -.- x))
|
||||
. makeLoopPairs $ screenPolygon w
|
||||
where
|
||||
borderPs = mapMaybe (intersectLinefromScreen w c) [x,y]
|
||||
cornerPs = filter (pointIsInCone c (x,y)) $ screenPolygon w
|
||||
wallScreenIntersect = mapMaybe (uncurry $ intersectSegSeg' y ((2*.*y) -.- x))
|
||||
. makeLoopPairs $ screenPolygon w
|
||||
|
||||
rectangleSolid x y = polygon [(x,y),(x,-y),(-x,-y),(-x,y)]
|
||||
|
||||
@@ -154,47 +161,48 @@ drawItem flIt = uncurry translate (_flItPos flIt)
|
||||
|
||||
ffToDraw :: World -> [ForceField]
|
||||
ffToDraw w = filter (lineOnScreen w . _ffLine) $
|
||||
IM.elems $ fmap (over ffLine (map (\p->p -.- _cameraCenter w))) $
|
||||
IM.elems $ over ffLine (map ( -.- _cameraCenter w)) <$>
|
||||
_forceFields w
|
||||
|
||||
drawFF :: ForceField -> Picture
|
||||
drawFF (FF {_ffLine = l, _ffColor = col}) = pictures [color white $ line l, color col
|
||||
$ lineOfThickness 6 l ]
|
||||
|
||||
|
||||
drawFFShadow :: World -> ForceField -> [Picture]
|
||||
drawFFShadow w ff
|
||||
| youOnFF = []
|
||||
| otherwise = map (rotate ( _cameraRot w) . pane)
|
||||
[0,0.05..0.25]
|
||||
where p = rotateV (-_cameraRot w) $ ypShift
|
||||
x = rotateV (-_cameraRot w) x'
|
||||
y = rotateV (-_cameraRot w) y'
|
||||
yp = _crPos $ you w
|
||||
(x1:y1:_) = _ffLine ff
|
||||
(x':y':_) | isRHS x1 y1 yp = (y1:x1:[])
|
||||
| otherwise = (x1:y1:[])
|
||||
fCol = color (_ffColor ff)
|
||||
col = _ffColor ff
|
||||
ypShift = yp -.- _cameraCenter w
|
||||
youOnFF = circOnSeg x' y' ypShift (_crRad $ you w)
|
||||
pane j = color (withAlpha 0.1 col)
|
||||
$ polygon
|
||||
$ [ x
|
||||
, x +.+ ((0.1 + j) *.* (x -.- ypShift))
|
||||
, y +.+ ((0.1 + j) *.* (y -.- ypShift))
|
||||
, y]
|
||||
| otherwise = map (rotate ( _cameraRot w) . pane) [0,0.05..0.25]
|
||||
where
|
||||
p = rotateV (-_cameraRot w) ypShift
|
||||
x = rotateV (-_cameraRot w) x'
|
||||
y = rotateV (-_cameraRot w) y'
|
||||
yp = _crPos $ you w
|
||||
(x1:y1:_) = _ffLine ff
|
||||
(x':y':_) | isRHS x1 y1 yp = [y1,x1]
|
||||
| otherwise = [x1,y1]
|
||||
fCol = color (_ffColor ff)
|
||||
col = _ffColor ff
|
||||
ypShift = yp -.- _cameraCenter w
|
||||
youOnFF = circOnSeg x' y' ypShift (_crRad $ you w)
|
||||
pane j = color (withAlpha 0.1 col)
|
||||
$ polygon
|
||||
[ x
|
||||
, x +.+ ((0.1 + j) *.* (x -.- ypShift))
|
||||
, y +.+ ((0.1 + j) *.* (y -.- ypShift))
|
||||
, y]
|
||||
|
||||
wallsPointsAndCols :: World -> [((Point2,Point2),Point4)]
|
||||
wallsPointsAndCols w = map f . filter (not . _wlIsSeeThrough) . IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
|
||||
where linePairs (x:y:_) = (x,y)
|
||||
f wl = (linePairs $ _wlLine wl, _wlColor wl)
|
||||
where
|
||||
linePairs (x:y:_) = (x,y)
|
||||
f wl = (linePairs $ _wlLine wl, _wlColor wl)
|
||||
|
||||
wallsWindows :: World -> [((Point2,Point2),Point4)]
|
||||
wallsWindows w = map f . filter (fromMaybe True . (^? blVisible)) .
|
||||
filter _wlIsSeeThrough . IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
|
||||
where linePairs (x:y:_) = (x,y)
|
||||
f wl = (linePairs $ _wlLine wl, _wlColor wl)
|
||||
where
|
||||
linePairs (x:y:_) = (x,y)
|
||||
f wl = (linePairs $ _wlLine wl, _wlColor wl)
|
||||
|
||||
wallsForShadows :: World -> [(Point2,Point2)]
|
||||
wallsForShadows w = map (linePairs . _wlLine)
|
||||
|
||||
Reference in New Issue
Block a user