Refactor wall drawing
This commit is contained in:
+27
-28
@@ -239,21 +239,14 @@ drawSmokeShadow w sm@(Smoke {_smPos = p, _smRad = r', _smColor = c, _smPs = ps,
|
||||
trap' p' = line [pa' p', pb' p', pbo' p', pao' p',pa' p']
|
||||
semiCirc' p' = uncurry translate p' $ rotate (0 - (a p')) $ arcSolid 0 180 r'
|
||||
|
||||
drawWallFloor :: Wall -> Drawing
|
||||
drawWallFloor (Wall {_wlIsSeeThrough = False, _wlLine = ps, _wlColor = c})
|
||||
= onLayerL [levLayer WlLayer, 2] $ color c $ polygon $ ps
|
||||
drawWallFloor wl = case _wlDraw wl of
|
||||
Nothing -> onLayerL [levLayer WlLayer, layer2] $ color c $ polygon [x,x +.+ n2,y +.+ n2, y]
|
||||
Just d -> d wl
|
||||
drawWallFloor :: Wall -> Picture
|
||||
drawWallFloor wl = if _wlIsSeeThrough wl
|
||||
then onLayerL [levLayer WlLayer] $ color c $ polygon [x,x +.+ n2,y+.+n2, y]
|
||||
else blank
|
||||
where
|
||||
(x:y:_) = _wlLine wl
|
||||
c = _wlColor wl
|
||||
t = 5 *.* errorNormalizeVDR (y -.- x)
|
||||
n = vNormal t
|
||||
n2 = 3 *.* n
|
||||
layer2 | _wlIsSeeThrough wl = 0
|
||||
| isJust $ wl ^? doorMech = 1
|
||||
| otherwise = 2
|
||||
n2 = 15 *.* (vNormal . errorNormalizeVDR $ y -.- x)
|
||||
|
||||
errorNormalizeVDR :: Point2 -> Point2
|
||||
errorNormalizeVDR (0,0) = error $ "problem with function: errorNormalizeVDR in DodgeRendering"
|
||||
@@ -304,31 +297,37 @@ lineOnScreen w (p1:p2:_) = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9
|
||||
where sp = screenPolygon w
|
||||
sps = zip sp (tail sp ++ [head sp])
|
||||
|
||||
drawWallFace :: World -> Wall -> Drawing
|
||||
drawWallFace :: World -> Wall -> Picture
|
||||
drawWallFace w wall
|
||||
| isRHS sightFrom x y = blank
|
||||
| otherwise = colorAndLayer $ polygon $ points
|
||||
where
|
||||
colorAndLayer | _wlIsSeeThrough wall = setLayer 2
|
||||
. onLayerL [levLayer ShadowLayer,3]
|
||||
. color (withAlpha 0.2 $ _wlColor wall)
|
||||
| otherwise = setLayer 2
|
||||
. onLayerL [levLayer ShadowLayer,2]
|
||||
. color (withAlpha 0.5 $ _wlColor wall)
|
||||
| otherwise = setLayer 0
|
||||
. onLayerL [levLayer ShadowLayer,l]
|
||||
. color (_wlColor wall)
|
||||
(x:y:_) = _wlLine wall
|
||||
ds = map (\p -> safeNormalizeV (p -.- sightFrom)) [x,y]
|
||||
p's = zipWith (\d x -> (15 *.* d) +.+ x) ds [x,y]
|
||||
points = extendConeToScreenEdge w sightFrom (x,y)
|
||||
sightFrom = _cameraCenter w
|
||||
corns = screenPolygon w
|
||||
borders = filter g $ zip corns (tail corns ++ [head corns])
|
||||
g (a,b) = isLHS a b sightFrom
|
||||
borderps = mapMaybe f borders ++ mapMaybe f' borders ++ shadowedCorners
|
||||
coneTop = nub $ concatMap (\(a,b) -> [a,b]) $ borders
|
||||
shadowedCorners = filter isShadowed coneTop
|
||||
isShadowed p = isLHS sightFrom x p && isRHS sightFrom y p
|
||||
f (bpa,bpb) = intersectSegLineFrom' bpa bpb x (head p's)
|
||||
f' (bpa,bpb) = intersectSegLineFrom' bpa bpb y (last p's)
|
||||
points = orderPolygon (borderps ++ [x,y])
|
||||
l = case wall of
|
||||
Door {} -> 1
|
||||
_ -> 2
|
||||
|
||||
-- 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 a b)
|
||||
. makeLoopPairs
|
||||
$ screenPolygon w
|
||||
|
||||
extendConeToScreenEdge :: World -> Point2 -> (Point2,Point2) -> [Point2]
|
||||
extendConeToScreenEdge w c (x,y) = orderPolygon $ [x,y] ++ borderPs ++ cornerPs
|
||||
where borderPs = mapMaybe (intersectLinefromScreen w c) [x,y]
|
||||
cornerPs = filter (pointIsInCone c (x,y)) $ screenPolygon w
|
||||
|
||||
displayInv :: Int -> World -> Picture
|
||||
displayInv n w = pictures $ zipWith (translate (15-halfWidth w))
|
||||
|
||||
@@ -35,7 +35,6 @@ moveCamera w = w & cameraPos .~ idealPos
|
||||
idealOffset = rotateV (_cameraRot w) (aimRangeFactor * aimingMult *.* _mousePos w)
|
||||
currentOffset = currentPos -.- camCenter
|
||||
idealPos = camCenter +.+ rotateV (_cameraRot w)
|
||||
-- (aimRangeFactor * aimTimeFactor *.* _mousePos w)
|
||||
(aimRangeFactor * aimingMult *.* _mousePos w)
|
||||
currentPos = _cameraPos w
|
||||
camCenter = ypos +.+ scope
|
||||
@@ -96,7 +95,7 @@ zoomOutLongGun w | currentZoom > 0.5 = over (wpPointer . itAttachment . _Just .
|
||||
Just currentZoom = wp ^? itAttachment . _Just . scopeZoom
|
||||
currentCursorDisplacement = fromJust $ _itAttachment wp
|
||||
|
||||
rotCam = rotateCameraL . rotateCameraR . zoomCamIn . zoomCamOut . zoomCam
|
||||
rotCam = rotateCameraL . rotateCameraR . zoomCamIn . zoomCamOut . autoZoomCam
|
||||
|
||||
rotateCameraL :: World -> World
|
||||
rotateCameraL w | SDL.KeycodeQ `S.member` _keys w
|
||||
@@ -119,8 +118,8 @@ zoomCamOut w | SDL.KeycodeK `S.member` _keys w
|
||||
= w {_cameraZoom = max (_cameraZoom w - 0.01) 0.01}
|
||||
| otherwise = w
|
||||
|
||||
zoomCam :: World -> World
|
||||
zoomCam w = over cameraZoom changeZoom w
|
||||
autoZoomCam :: World -> World
|
||||
autoZoomCam w = over cameraZoom changeZoom w
|
||||
where maxViewDistance = 800
|
||||
camPos = _cameraCenter w
|
||||
camRot = _cameraRot w
|
||||
|
||||
@@ -347,3 +347,13 @@ lineInPolygon a b ps = pointInPolygon a ps || pointInPolygon b ps
|
||||
|| any (isJust . uncurry (intersectSegSeg' a b)) pss
|
||||
where pss = zip ps (tail ps ++ [head ps])
|
||||
|
||||
makeLoopPairs :: [Point2] -> [(Point2,Point2)]
|
||||
makeLoopPairs [] = error "tried to make loop with empty list of points"
|
||||
makeLoopPairs (x:[]) = error "tried to make loop with singleton list of points"
|
||||
makeLoopPairs (x:xs) = zip (x:xs) (xs ++ [x])
|
||||
|
||||
-- note the pair is ordered
|
||||
-- doesn't work for obtuse angles
|
||||
pointIsInCone :: Point2 -> (Point2,Point2) -> Point2 -> Bool
|
||||
pointIsInCone c (rightp,leftp) p = isLHS c rightp p && isLHS leftp c p
|
||||
|
||||
|
||||
Reference in New Issue
Block a user