Refactor wall drawing

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 -> Picture
-drawWallFloor (Wall {_wlIsSeeThrough = False, _wlLine = ps, _wlColor = c}) 
+drawWallFloor wl = if _wlIsSeeThrough wl
-        = onLayerL [levLayer WlLayer, 2] $ color c $ polygon $ ps
+                   then onLayerL [levLayer WlLayer] $ color c $ polygon [x,x +.+ n2,y+.+n2, y]
-drawWallFloor wl = case _wlDraw wl of
+                   else blank
-        Nothing -> onLayerL [levLayer WlLayer, layer2] $ color c $ polygon [x,x +.+ n2,y +.+ n2, y]
-        Just d -> d wl
     where 
         (x:y:_) = _wlLine wl
         c = _wlColor wl
-        t = 5 *.* errorNormalizeVDR (y -.- x)
+        n2 = 15 *.* (vNormal . errorNormalizeVDR $ y -.- x)
-        n = vNormal t
-        n2 = 3 *.* n
-        layer2 | _wlIsSeeThrough wl = 0
-               | isJust $ wl ^? doorMech = 1
-               | otherwise = 2
 
 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)
+                                                . color (withAlpha 0.5 $ _wlColor wall)
-                      | otherwise = setLayer 2 
+                      | otherwise = setLayer 0 
-                                        . onLayerL [levLayer ShadowLayer,2]
+                                        . onLayerL [levLayer ShadowLayer,l]
                                         . color (_wlColor wall)
         (x:y:_) = _wlLine wall 
-        ds = map (\p -> safeNormalizeV (p -.- sightFrom)) [x,y]
+        points = extendConeToScreenEdge w sightFrom (x,y)
-        p's = zipWith (\d x -> (15 *.* d) +.+ x) ds [x,y]
         sightFrom = _cameraCenter w
-        corns = screenPolygon w
+        l = case wall of
-        borders = filter g $ zip corns (tail corns ++ [head corns])
+                Door {} -> 1
-        g (a,b) = isLHS a b sightFrom
+                _ -> 2
-        borderps = mapMaybe f borders ++ mapMaybe f' borders ++ shadowedCorners
+
-        coneTop = nub $ concatMap (\(a,b) -> [a,b]) $ borders
+-- the following assumes that the point a is inside the screen
-        shadowedCorners = filter isShadowed coneTop
+-- it still works otherwise, but it might intersect two points:
-        isShadowed p = isLHS sightFrom x p && isRHS sightFrom y p
+-- it is not obvious which will be returned
-        f (bpa,bpb) = intersectSegLineFrom' bpa bpb x (head p's)
+intersectLinefromScreen :: World -> Point2 -> Point2 -> Maybe Point2
-        f' (bpa,bpb) = intersectSegLineFrom' bpa bpb y (last p's)
+intersectLinefromScreen w a b = listToMaybe 
-        points = orderPolygon (borderps ++ [x,y])
+        . 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)) 

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
+autoZoomCam :: World -> World
-zoomCam w = over cameraZoom changeZoom w
+autoZoomCam w = over cameraZoom changeZoom w
     where maxViewDistance = 800
           camPos = _cameraCenter w
           camRot = _cameraRot w

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
+