Add lights to buttons, cleanup

src/Dodge/LevelGen.hs

@@ -2,18 +2,14 @@
 -- | deals with placement of objects within the world
 -- after they have had their coordinates set by the layout
 module Dodge.LevelGen 
-    ( module Dodge.LevelGen
-    , cutWalls
-    , pairsToGraph
-    , makeButton
-    , makeSwitch
+    ( shiftPlacement
+    , shiftPointBy
+    , placeSpot
     ) where
 import Dodge.Data
 import Dodge.LevelGen.Block
 import Dodge.LevelGen.Pathing
-import Dodge.LevelGen.StaticWalls
 import Dodge.LevelGen.TriggerDoor
-import Dodge.LevelGen.Switch
 import Dodge.LevelGen.Data
 import Dodge.Default.Wall
 import Geometry
@@ -27,13 +23,16 @@ import Control.Lens
 import qualified Data.IntSet as IS
 
 placeSpot :: World -> ((Point2,Float) , Placement) -> World
-placeSpot w (shift, plmnt) =
+placeSpot w (shift, plmnt@Placement{}) =
     let (i,w') =  placeSpotID (shiftPSBy shift (_placementSpot plmnt)) w
     in  maybe w' (curry (placeSpot w') shift) (_idPlacement plmnt i)
+placeSpot w (shift, PlacementPos p subpl) = placeSpot w (shift, subpl (shiftPoint3By shift p))
 
 shiftPlacement :: (Point2,Float) -> Placement -> Placement
 shiftPlacement shift (Placement ps f) = Placement (shiftPSBy shift ps)
      (fmap (fmap $ shiftPlacement shift) f)
+shiftPlacement shift (PlacementPos p f) = PlacementPos (shiftPoint3By shift p)
+     (fmap (shiftPlacement shift) f)
 
 shiftPSBy :: (Point2,Float) -> PlacementSpot -> PlacementSpot
 shiftPSBy (pos,rot) ps = ps
@@ -54,13 +53,12 @@ placeSpotID ps w = case _psType ps of
     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 (bimap doShift doShift) pss) w
-    PutSlideDoor pathing col f a b speed 
-        -> placeSlideDoor pathing col f (doShift a) (doShift b) speed w
+    PutDoor col f pss -> placeDoor col f (map (bimap doShift doShift) pss) w
+    PutCoordinate coordp -> placeCoordinate (doShift coordp) w
+    PutSlideDoor pathing col f a b spd -> placeSlideDoor pathing col f (doShift a) (doShift b) spd w
     PutBlock (hp:hps) col ps' -> placeBlock (map doShift ps') hp col Opaque hps w
     PutBlock{} -> error "messed up block placement somehow"
-    PutLineBlock wl width depth a b
-        -> placeLineBlock wl width depth (doShift a) (doShift b) w
+    PutLineBlock wl wdth dpth a b -> placeLineBlock wl wdth dpth (doShift a) (doShift b) w
     PutWall { _pwPoly = ps', _pwWall = wl } -> (0,rmCrossPaths $ over walls (addWalls qs wl) w)
       where 
         qs = map doShift ps'
@@ -68,37 +66,18 @@ placeSpotID ps w = case _psType ps of
     PutForeground sh -> (0,w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
     PutNothing -> (0,w)
     PutID i -> (i, w)
-    --_   -> w
   where 
     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
-    translateS :: Point2 -> a -> a
-    rotateS    :: Float -> a -> a
-
-instance {-# OVERLAPPING #-} Shiftable Point2 where
-    translateS = (+.+)
-    rotateS    = rotateV
-
-instance (Shiftable a,Shiftable b) => Shiftable (a, b) where
-    translateS p (x,y) = (translateS p x,translateS p y)
-    rotateS    r (x,y) = (   rotateS r x,   rotateS r y)
-
-instance (Shiftable a) => Shiftable [a] where
-    translateS p x = map (translateS p) x
-    rotateS    r x = map (rotateS r)    x
-
-instance Shiftable PlacementSpot where
-    translateS p' (PS p r x) = PS (p +.+ p') r x
-    rotateS    r' (PS p r x) = PS (rotateV r' p) (r + r') x
-
 shiftPointBy :: (Point2,Float) -> Point2 -> Point2
 shiftPointBy (pos,rot) p = pos +.+ rotateV rot p
 
+shiftPoint3By :: (Point2,Float) -> Point3 -> Point3
+shiftPoint3By (pos,rot) (V3 x y z) = addZ z $ pos +.+ rotateV rot (V2 x y)
+
 addWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall
 addWalls qs wl wls = foldr (addPane wl) wls pairs
   where 
@@ -106,11 +85,14 @@ addWalls qs wl wls = foldr (addPane wl) wls pairs
     pairs = zip (ps ++ [p]) (p:ps)
 
 addPane :: Wall -> (Point2,Point2) -> IM.IntMap Wall -> IM.IntMap Wall
-addPane wl (p0,p1) wls = IM.insert (IM.newKey wls) (wl
-    { _wlLine = (p0,p1)
-    , _wlID = IM.newKey wls
-    })
-    wls
+addPane wl l wls = IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) wls
+  where
+    wlid = IM.newKey wls
+
+placeCoordinate :: Point2 -> World -> (Int,World)
+placeCoordinate p w = (i, w & coordinates %~ IM.insert i p)
+  where
+    i = IM.newKey $ _coordinates w
 
 placeProp 
     :: Prop
@@ -144,15 +126,9 @@ placeFlIt
     -> Float    -- ^ Rotation
     -> World
     -> (Int, World)
-placeFlIt itm p rot w = (i, w & floorItems %~ 
-    \ fis -> IM.insert i 
-        (FlIt
-            { _flItPos = p
-            , _flItRot = rot
-            , _flItID = i
-            , _flIt = itm
-            }
-        ) fis
+placeFlIt itm p rot w = (i, w & floorItems %~ \ fis -> IM.insert i 
+    ( FlIt { _flItPos = p , _flItRot = rot , _flItID = i , _flIt = itm }
+    ) fis
     )
   where
     i = IM.newKey $ _floorItems w
@@ -168,12 +144,6 @@ placePressPlate pp p rot w = (i , over pressPlates addPP w)
     i = IM.newKey $ _pressPlates w
     addPP pps = IM.insert (IM.newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps
 
-placeUpdateCr :: Creature -> Point2 -> Float -> World -> (World, PSType)
-placeUpdateCr scr p rot w = (w & creatures %~ IM.insert cid cr, PutCrit cr)
-  where 
-    cid = IM.newKey (_creatures w)
-    cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid} 
-
 placeCr :: Creature -> Point2 -> Float -> World -> (Int,World)
 placeCr crF p rot w = (cid, over creatures addCr w)
   where 
@@ -204,7 +174,4 @@ placeLS ls (V3 x y z) rot w = (i, over lightSources addLS w)
   where 
     i = IM.newKey $ _lightSources w
     startPos = onXY (rotateV rot) $ _lsPos ls
-    addLS lss = IM.insert 
-        (IM.newKey lss) 
-        (ls {_lsPos = V3 x y z +.+.+ startPos,_lsDir = rot,_lsID = IM.newKey lss}) 
-        lss
+    addLS = IM.insert i (ls {_lsPos = V3 x y z +.+.+ startPos,_lsDir = rot,_lsID = i})