Improve forcefield visuals

src/Dodge/Base/Collide.hs

@@ -12,6 +12,8 @@ module Dodge.Base.Collide
     , isWalkable
     , canSee
     , hasLOSIndirect
+    , wlIsOpaque
+    , wlIsSeeThrough
     ) where
 import Dodge.Data
 import Dodge.Zone
@@ -126,7 +128,14 @@ collidePointWalkable p1 p2 ws
 --    p3 = p1 +.+ d *.* safeNormalizeV (p2 -.- p1)
 
 wlIsOpaque :: Wall -> Bool
-wlIsOpaque wl = _wlOpacity wl == Opaque
+wlIsOpaque wl = case _wlOpacity wl of
+    Opaque -> True
+    _ -> False
+
+wlIsSeeThrough :: Wall -> Bool
+wlIsSeeThrough wl = case _wlOpacity wl of
+    SeeThrough -> True
+    _ -> False
 
 --collidePointUpToIndirect
 --    :: Point2   -- ^start point

src/Dodge/Data.hs

@@ -1042,8 +1042,8 @@ data Wall = Wall
 data Opacity
     = SeeThrough
     | SeeAbove
+    | DrawnWall {_opDraw :: Wall -> SPic}
     | Opaque
-  deriving (Eq,Ord,Show)
 data WallStructure 
     = StandaloneWall
     | DoorPart    { _wlStDoor    :: Int }
@@ -1585,6 +1585,7 @@ makeLenses ''Modification
 makeLenses ''Particle
 makeLenses ''Wall
 makeLenses ''WallStructure
+makeLenses ''Opacity
 makeLenses ''PressPlate
 makeLenses ''Button
 makeLenses ''ActionPlan

src/Dodge/Debug/Picture.hs

@@ -1,6 +1,7 @@
 module Dodge.Debug.Picture where
 import Dodge.Data
 import Dodge.Base.Window
+import Dodge.Base.Collide
 import Geometry
 import Picture
 
@@ -46,7 +47,7 @@ pointOnScreen cfig w p = pointInPolygon p . reverse $ screenPolygon cfig w
 
 drawWallFace :: Configuration -> World -> Wall -> Picture
 drawWallFace cfig w wall
-    | isRHS sightFrom x y || _wlOpacity wall /= Opaque = blank
+    | isRHS sightFrom x y || not (wlIsOpaque wall) = blank
     | otherwise = setDepth (-1) . color (withAlpha 0 black) . polygon $ points
   where 
     (x,y) = _wlLine wall 

src/Dodge/Item/Equipment.hs

@@ -9,6 +9,7 @@ import Dodge.Default.Wall
 import Dodge.Creature.Test
 import Dodge.Creature.HandPos
 import Dodge.Wall
+import Dodge.Wall.ForceField
 import Dodge.Magnet
 import Picture
 import Geometry
@@ -80,7 +81,7 @@ wristArmour = defaultEquipment
 onEquipWristShield :: Item -> Creature -> World -> World
 onEquipWristShield itm cr w = w
     & creatures . ix (_crID cr) . crInv . ix (fromJust (_itInvPos itm)) . itUse . eqEq . eqParams .~ EquipID i
-    & walls . at i ?~ (shieldWall (_crID cr)) {_wlDraw = True,_wlID = i}
+    & walls . at i ?~ forceField {_wlID = i}
     & setWristShieldPos (itm & itUse . eqEq . eqParams .~ EquipID i) cr
   where
     i = IM.newKey (_walls w)

src/Dodge/Item/Weapon/LaserPath.hs

@@ -5,6 +5,7 @@ import Dodge.Data
 import Dodge.Wall.Reflect
 --import Dodge.Creature.HandPos
 import Dodge.WorldEvent
+import Dodge.Base.Collide
 --import Dodge.Default
 --import Dodge.Item.Weapon.InventoryDisplay
 --import Dodge.Item.Weapon.TriggerType
@@ -27,7 +28,7 @@ reflectLaserAlong phasev seenWl sp ep w = case find (notseen seenWl)
     Just (p,Right wl) 
         | _wlReflect wl -> second (p:) $ reflectLaserAlong phasev (wl:seenWl) p 
             (p +.+ 800 *.* unitVectorAtAngle (reflDirWall sp p wl)) w
-        | _wlOpacity wl == SeeThrough -> second (p:) $ reflectLaserAlong phasev (wl:seenWl) p 
+        | wlIsSeeThrough wl -> second (p:) $ reflectLaserAlong phasev (wl:seenWl) p 
             (refract sp ep wl p) w
         | otherwise -> (Just (p,Right wl), [p])
     Just (p,obj) -> (Just (p,obj), [p])

src/Dodge/Render.hs

@@ -38,7 +38,7 @@ doDrawing pdata u = do
         trans   = _cameraCenter w
         wins@(V2 winx winy) = V2 (_windowX cfig) (_windowY cfig)
         resFact             = resFactorNum $ cfig ^. graphics_resolution_factor
-        (wallPointsCol,windowPoints) = wallsAndWindows cfig w
+        (wallPointsCol,windowPoints,wallSPics) = wallsToDrawStreams cfig w
         lightPoints             = lightsForGloom w
         viewFroms@(V2 vfx vfy)  = _cameraViewFrom w
         viewFrom3d              = Vector3 vfx vfy 20
@@ -50,7 +50,7 @@ doDrawing pdata u = do
     shapeCounts  <- UMV.replicate 3 0
     wlwiflCounts <- UMV.replicate 3 0
     -- attempt to poke in parallel
-    let (ws,wp) = worldSPic cfig w
+    let (ws,wp) = wallSPics <> worldSPic cfig w
     MP.bindM3 (\ _ _ _ -> return ())
         ( pokeBindFoldableLayer shadV layerCounts wp)
         ( pokeWallsWindowsFloor

src/Dodge/Render/Walls.hs

@@ -1,20 +1,42 @@
 module Dodge.Render.Walls
-    ( wallsAndWindows
+    ( wallsToDrawStreams
     ) where
 import Dodge.Data
 import Dodge.Zone
+import Dodge.Base.Collide
 import Geometry
+import ShapePicture
 
-import Data.List
-import qualified Data.IntMap.Strict as IM
-wallsAndWindows
+import Control.Lens
+--import Data.Maybe
+import qualified Control.Foldl as L
+--import Data.List
+--import qualified Data.IntMap.Strict as IM
+wallsToDrawStreams
     :: Configuration
     -> World
-    -> ( [((Point2,Point2),Point4)]  ,[((Point2,Point2),Point4)] )
-wallsAndWindows cfig w
-    = (map f wls, map f wins)
+    -> ( [((Point2,Point2),Point4)]  ,[((Point2,Point2),Point4)], SPic )
+wallsToDrawStreams cfig w
+    = ( wls, wins,spic)
   where
     f wl = (_wlLine wl, _wlColor wl)
-    (wins,wls) = partition theTest . IM.elems . IM.filter _wlDraw $ wallsDoubleScreen cfig w
-    theTest wl = _wlOpacity wl /= Opaque
+    (wls, wins, spic) = L.fold ((,,)
+        <$> L.prefilter wlOpaqueDraw (L.premap f L.list)
+        <*> L.prefilter wlSeeThroughDraw (L.premap f L.list)
+        <*> L.premap getWallSPic L.mconcat
+        ) (wallsDoubleScreen cfig w)
+wlOpaqueDraw :: Wall -> Bool
+wlOpaqueDraw wl = wlIsOpaque wl && _wlDraw wl
+wlSeeThroughDraw :: Wall -> Bool
+wlSeeThroughDraw wl = wlIsSeeThrough wl && _wlDraw wl
+
+getWallSPic :: Wall -> SPic
+getWallSPic wl = case wl ^? wlOpacity . opDraw of
+    Nothing -> mempty
+    Just f  -> f wl
+
+--    (wins,wls) = partition theTest . IM.elems . IM.filter _wlDraw $ wallsDoubleScreen cfig w
+--    theTest wl = case _wlOpacity wl of
+--        Opaque -> False
+--        _ -> True
 

src/Dodge/Update.hs

@@ -399,7 +399,7 @@ crCrSpring c1 c2 w
 {- Finds the visible walls from a point to another point.  -}
 visibleWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall]
 visibleWalls p1 p2 ws 
-    = takeUntil isOpaque
+    = takeUntil wlIsOpaque
     . map snd 
     . sortOn (dist p1 . fromJust . fst) 
     . filter (isJust . fst) 
@@ -407,7 +407,6 @@ visibleWalls p1 p2 ws
     $ IM.elems ws
   where 
     f wl = (uncurry intersectSegSeg (_wlLine wl) p1 p2, wl)
-    isOpaque wl = _wlOpacity wl == Opaque
 
 updateDelayedEvents :: World -> World
 updateDelayedEvents w = let (neww,newde) = mapAccumR f w (_delayedEvents w)

src/Dodge/Wall/ForceField.hs

@@ -2,11 +2,13 @@ module Dodge.Wall.ForceField where
 import Dodge.Data
 import Dodge.Default.Wall
 import Color
+import Picture
+import ShapePicture
 
 forceField :: Wall
 forceField = defaultWall
     {_wlColor = orange
-    ,_wlOpacity = SeeAbove
+    ,_wlOpacity = DrawnWall drawForceField
     ,_wlPathable = True
     ,_wlWalkable = True
     ,_wlFireThrough = True
@@ -15,3 +17,13 @@ forceField = defaultWall
     ,_wlRotateTo = False
     ,_wlStructure = StandaloneWall
     }
+
+drawForceField :: Wall -> SPic
+drawForceField wl = (mempty
+    , setLayer BloomLayer
+        . setDepth 20
+        . color (_wlColor wl)
+        $ thickLine 5 [a,b]
+    )
+  where
+    (a,b) = _wlLine wl

src/FoldableHelp.hs

@@ -5,6 +5,7 @@ module FoldableHelp
     , safeMinimumOnMaybeF
     , safeMinimumOnMaybeL
     , safeMinMaybeL
+    , filter3
     , module Data.Foldable
     )
     where
@@ -62,6 +63,16 @@ safeMinimumOnMaybe f ys = fst <$> go Nothing ys
         _                 -> go (Just (y,cmin)) xs
     go m _ = m
 
+filter3 :: Foldable t 
+    => (a -> Bool) 
+    -> (a -> Bool) 
+    -> (a -> Bool)
+    -> t a
+    -> ([a],[a],[a])
+filter3 t1 t2 t3 = L.fold $ (,,) 
+    <$> L.prefilter t1 L.list 
+    <*> L.prefilter t2 L.list
+    <*> L.prefilter t3 L.list
 
 --{- | Partial. -}
 --minimumOn :: Ord b => (a -> b) -> [a] -> a