Cleanup: broken pathfinding

2021-11-16 18:05:47 +00:00
parent cb8cbe03a4
commit ebe9ad6b90
42 changed files with 491 additions and 301 deletions
@@ -0,0 +1,131 @@
+module Dodge.Placement.Instance.Wall
+    where
+import Dodge.Data
+import Color
+import Geometry
+import Dodge.LevelGen.Data
+import Dodge.Default.Wall
+
+import Data.List
+import Control.Lens
+singleBlock :: Point2 -> [Placement]
+singleBlock a = 
+    [sPS a 0 
+        $ PutBlock [5,20,20] (greyN 0.5)
+        $ reverse 
+        $ rectNSWE 10 (-10) (-10) 10
+    ]
+{-
+Places a line of blocks between two points.
+Width 9, also extends out from each point by 9.
+ -}
+blockLine :: Point2 -> Point2 -> Placement
+blockLine a b = sps0 $ PutLineBlock baseBlockPane 9 9 a b
+
+{-
+Places an breakable window between two points.
+Width 8, also extends out from each point by 8.
+ -}
+windowLine :: Point2 -> Point2 -> Placement
+windowLine a b = sps0 $ PutLineBlock baseWindowPane 8 8 a b
+{-
+Places an unbreakable window between two points.
+Width 7, also extends out from each point by 7.
+ -}
+crystalLine :: Point2 -> Point2 -> Placement
+crystalLine a b = sps0 $ PutWall ps defaultCrystalWall
+  where
+    ps = 
+        [ a +.+ left +.+ up
+        , (a +.+ left) -.- up
+        , (b -.- left) -.- up
+        , (b -.- left) +.+ up
+        ]
+    left = 7 *.* normalizeV (a-.-b)
+    up   = vNormal left
+{- Places an unbreakable wall between two points.
+Depth 15, does not extend wider than points.
+ -}
+wallLine :: Point2 -> Point2 -> Placement
+wallLine a b = sps0 $ PutWall ps defaultWall
+  where
+    ps = [ a  +.+ up
+        , a  -.- up
+        , b  -.- up
+        , b  +.+ up
+        ]
+    left = 15 *.* normalizeV (a-.-b)
+    up   = vNormal left
+
+windowLineType :: Point2 -> Point2 -> PSType
+windowLineType = PutLineBlock baseWindowPane 8 8
+
+baseBlockPane :: Wall
+baseBlockPane = defaultWall
+    { _wlLine = (V2 0 0,V2 50 0)
+    , _wlID = 0
+    , _wlColor = greyN 0.5
+    , _wlSeen = False
+    , _wlOpacity = Opaque
+    , _wlDraw = True
+    , _wlFireThrough = True
+    }
+baseWindowPane :: Wall
+baseWindowPane = defaultWall
+    { _wlLine = (V2 0 0,V2 50 0)
+    , _wlID = 0
+    , _wlColor = withAlpha 0.2 cyan
+    , _wlSeen = False
+    , _wlOpacity = SeeThrough
+    , _wlDraw = True
+    , _wlFireThrough = True
+    }
+-- TODO find home for this
+{- Replaces instances of a given 'PutID' with 'PSType's drawn from a list.  -}
+replacePutID 
+    :: Int      -- ^ The id of 'PutID' to be replaced
+    -> [PSType] -- ^ List of replacements
+    -> Room 
+    -> Room
+replacePutID i psts r =
+    r & rmPmnts %~ flip (subZipWith (isPutID i) (\ps pt -> ps & plType .~ pt)) psts
+{- Partition a list by a predicate, apply a zip to those elements 
+that satisfy the predicate, concatenate 
+the new zipped list and the other (unchanged) half.  -}
+subZipWith 
+    :: (a -> Bool)      -- ^ Filter: elements to apply zip to
+    -> (a -> b -> a)    -- ^ Combining function
+    -> [a]              -- ^ List to be partitioned
+    -> [b]              -- ^ Modifying list
+    -> [a]
+subZipWith f g xs ys =
+    let (zs,ws) = partition f xs
+    in  zipWith g zs ys ++ ws
+
+isPutID :: Int -> Placement -> Bool
+isPutID i ps = Just i == ps ^? plType . putID
+
+putBlockRect :: Float -> Float -> Float -> Float -> [Placement]
+putBlockRect a x b y =
+    [ blockLine (V2 a b) (V2 a y)
+    , blockLine (V2 a y) (V2 x y)
+    , blockLine (V2 x y) (V2 x b)
+    , blockLine (V2 x b) (V2 a b)
+    ]
+putBlockV :: Float -> Float -> Float -> Float -> [Placement]
+putBlockV a x b y = 
+    [ blockLine (V2 a b) (V2 a y)
+    , blockLine (V2 x b) (V2 a b)
+    ]
+putBlockC :: Float -> Float -> Float -> Float -> [Placement]
+putBlockC a x b y = 
+    [ blockLine (V2 a b) (V2 a y)
+    , blockLine (V2 x b) (V2 a b)
+    , blockLine (V2 a y) (V2 x y)
+    ]
+putBlockN :: Float -> Float -> Float -> Float -> [Placement]
+putBlockN a x b y = 
+    [ blockLine (V2 a b) (V2 a y)
+    , blockLine (V2 x b) (V2 a b)
+    , blockLine (V2 x y) (V2 x b)
+    ]