From 1ecbe2375d4c3ae00b811c423323091a7a0822f8 Mon Sep 17 00:00:00 2001 From: jgk Date: Sun, 21 Mar 2021 15:38:58 +0100 Subject: [PATCH] Refactor wall drawing --- src/Dodge/Rendering.hs | 55 +++++++++++++++++++------------------- src/Dodge/Update/Camera.hs | 7 +++-- src/Geometry.hs | 10 +++++++ 3 files changed, 40 insertions(+), 32 deletions(-) diff --git a/src/Dodge/Rendering.hs b/src/Dodge/Rendering.hs index a75699626..6d0fe3e7a 100644 --- a/src/Dodge/Rendering.hs +++ b/src/Dodge/Rendering.hs @@ -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)) diff --git a/src/Dodge/Update/Camera.hs b/src/Dodge/Update/Camera.hs index dd265d3c0..66061796c 100644 --- a/src/Dodge/Update/Camera.hs +++ b/src/Dodge/Update/Camera.hs @@ -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 diff --git a/src/Geometry.hs b/src/Geometry.hs index e2e2d40af..e41cb800c 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -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 +