Add objects based on walls, called machines

src/Dodge/LevelGen.hs

@@ -16,10 +16,12 @@ import Dodge.LevelGen.AutoDoor
 import Dodge.LevelGen.TriggerDoor
 import Dodge.LevelGen.Switch
 import Dodge.LevelGen.Data
+import Dodge.Default.Wall
 import Geometry
 import Geometry.Vector3D
 import Shape
 import qualified IntMapHelp as IM
+import Color
 
 import Control.Monad.State
 import Control.Lens
@@ -46,30 +48,30 @@ placeSpotID ps w = case _psType ps of
     PutButton bt -> placeBt bt p rot w
     PutFlIt itm -> placeFlIt itm p rot w
     PutCrit cr -> placeCr cr p rot w
+    PutMachine col wallpoly mc -> placeMachine col (map doShift wallpoly) mc p rot w
     PutLS ls -> placeLS ls p' rot w
     PutPressPlate pp -> placePressPlate pp p rot w
     RandPS rgen -> placeSpotID (set psType evaluatedType ps) (set randGen g w)
       where 
         (evaluatedType, g) = runState rgen (_randGen w)
-    PutDoor col f pss -> putDoor col f (map (mapBoth $ shiftPointBy (p,rot)) pss) w
+    PutDoor col f pss -> putDoor col f (map (mapBoth doShift) pss) w
       where 
         mapBoth fn (x,y) = (fn x, fn y) 
     PutSingleDoor col f a b speed 
-        -> putSingleDoor False col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w
+        -> putSingleDoor False col f (doShift a) (doShift b) speed w
     PutDoubleDoor col f a b speed 
-        -> (,) 0 $ insertDoubleDoor False col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w
-    PutAutoDoor a b -> (,) 0 $ addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
-    PutBlock (hp:hps) col ps' -> putBlock (map (shiftPointBy (p,rot)) ps') hp col False hps w
+        -> (,) 0 $ insertDoubleDoor False col f (doShift a) (doShift b) speed w
+    PutAutoDoor a b -> (,) 0 $ addAutoDoor (doShift a) (doShift b) w
+    PutBlock (hp:hps) col ps' -> placeBlock (map doShift ps') hp col Opaque hps w
     PutBlock{} -> error "messed up block placement somehow"
-    PutBtDoor c bp f a b speed 
-        -> addButtonDoor c (shiftPointBy (p,rot) bp) (f + rot) 
-                            (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) speed w
+    PutBtDoor c bp f a b speed -> addButtonDoor c (doShift bp) (f + rot) 
+                            (doShift a) (doShift b) speed w
     PutLineBlock wl width depth a b
-        -> putLineBlock wl width depth (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
-    PutWall { _pwPoly = ps', _pwWall = wl } -> (0,rmCrossPaths $ over walls (addWalls (q:qs) wl) w)
+        -> putLineBlock wl width depth (doShift a) (doShift b) w
+    PutWall { _pwPoly = ps', _pwWall = wl } -> (0,rmCrossPaths $ over walls (addWalls qs wl) w)
       where 
-        (q:qs) = map (shiftPointBy (p,rot)) ps'
-        rmCrossPaths w' = foldr (uncurry removePathsCrossing) w' $ zip (q:qs) (qs++[q])
+        qs = map doShift ps'
+        rmCrossPaths w' = foldr (uncurry removePathsCrossing) w' $ loopPairs qs
     PutForeground sh -> (0,w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
     PutNothing -> (0,w)
     PutID i -> (i, w)
@@ -78,6 +80,7 @@ placeSpotID ps w = case _psType ps of
     p@(V2 px py) = _psPos ps
     p' = V3 px py 0
     rot = _psRot ps
+    doShift = shiftPointBy (p,rot)
 
 -- TODO: remove this typeclass
 class Shiftable a where
@@ -179,13 +182,29 @@ placeUpdateCr scr p rot w = (w & creatures %~ IM.insert cid cr, PutCrit cr)
     cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid} 
 
 placeCr :: Creature -> Point2 -> Float -> World -> (Int,World)
-placeCr crF p rot w = (i, over creatures addCr w)
+placeCr crF p rot w = (cid, over creatures addCr w)
   where 
-    i = IM.newKey $ _creatures w
-    addCr crs = IM.insert 
-        (IM.newKey crs) 
-        (crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = IM.newKey crs}) 
-        crs
+    cid = IM.newKey $ _creatures w
+    addCr crs = IM.insert cid (crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid}) crs
+
+placeMachine :: Color -> [Point2] -> Machine -> Point2 -> Float -> World -> (Int,World)
+placeMachine color wallpoly mc p rot w = (mcid
+    , w & machines  %~ addMc
+        & walls     %~ placeMachineWalls color wallpoly mcid wlid
+    )
+  where 
+    mcid = IM.newKey $ _machines w
+    wlid = IM.newKey $ _walls w
+    wlids = [wlid .. wlid + length wallpoly]
+    addMc mcs = IM.insert mcid (mc {_mcPos = p,_mcDir = rot,_mcID = mcid, _mcWallIDs = wlids}) mcs
+-- TODO correctly remove/shift pathfinding lines (removePathsCrossing)
+placeMachineWalls :: Color -> [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall
+placeMachineWalls col poly mcid wlid = flip (foldr f) $ zip [wlid..] $ loopPairs poly
+  where
+    f (wid,l) = IM.insert wid baseWall{_wlID = wid, _wlLine = l}
+    baseWall = defaultMachineWall 
+        & wlColor .~ col
+        & wlStructure . wlStMachine .~ mcid
 
 placeLS :: LightSource -> Point3 -> Float -> World -> (Int,World)
 placeLS ls (V3 x y z) rot w = (i, over lightSources addLS w)