Separate placement spot from placement type

src/Dodge/LevelGen.hs

@@ -24,12 +24,12 @@ import qualified Data.IntSet as IS
 
 placeSpot :: World -> ((Point2,Float) , Placement) -> World
 placeSpot w (shift, plmnt@Placement{}) =
-    let (i,w') =  placeSpotID (shiftPSBy shift (_placementSpot plmnt)) w
+    let (i,w') =  placeSpotID (shiftPSBy shift (_placementSpot plmnt)) (_psType 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)
+shiftPlacement shift (Placement ps pt f) = Placement (shiftPSBy shift ps) pt
      (fmap (fmap $ shiftPlacement shift) f)
 shiftPlacement shift (PlacementPos p f) = PlacementPos (shiftPoint3By shift p)
      (fmap (shiftPlacement shift) f)
@@ -41,8 +41,8 @@ shiftPSBy (pos,rot) ps = ps
 
 -- the Int here allows for passing parameters down to other placements:
 -- button ids, etc
-placeSpotID :: PlacementSpot -> World -> (Int, World)
+placeSpotID :: PlacementSpot -> PSType -> World -> (Int, World)
-placeSpotID ps w = case _psType ps of
+placeSpotID ps pt w = case pt of
     PutProp prop -> placeProp prop p rot w
     PutButton bt -> placeBt bt p rot w
     PutFlIt itm -> placeFlIt itm p rot w
@@ -50,7 +50,7 @@ placeSpotID ps w = case _psType ps of
     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)
+    RandPS rgen -> placeSpotID ps evaluatedType (set randGen g w)
       where 
         (evaluatedType, g) = runState rgen (_randGen w)
     PutDoor col f pss -> placeDoor col f (map (bimap doShift doShift) pss) w

src/Dodge/LevelGen/Data.hs

@@ -31,19 +31,19 @@ data PSType = PutCrit {_unPutCrit :: Creature}
 data PlacementSpot = PS
     { _psPos :: Point2
     , _psRot :: Float
-    , _psType :: PSType
     }
 data Placement = Placement 
     { _placementSpot :: PlacementSpot
+    , _psType :: PSType
     , _idPlacement :: Int -> Maybe Placement 
     }
   | PlacementPos Point3 (Point3 -> Placement)
 
 sPS :: Point2 -> Float -> PSType -> Placement
-sPS p a pt = Placement (PS p a pt) (const Nothing)
+sPS p a pt = Placement (PS p a) pt (const Nothing)
 
 jsps :: Point2 -> Float -> PSType -> Maybe Placement
-jsps p a pst = Just $ Placement (PS p a pst) $ const Nothing
+jsps p a pst = Just $ Placement (PS p a) pst $ const Nothing
 
 jsps0 :: PSType -> Maybe Placement
 jsps0 pst = Just $ sPS (V2 0 0) 0 pst
@@ -52,19 +52,19 @@ sps0 :: PSType -> Placement
 sps0 = sPS (V2 0 0) 0
 
 jspsJ :: Point2 -> Float -> PSType -> Placement -> Maybe Placement
-jspsJ p a pst plm = Just $ Placement (PS p a pst) $ \_ -> Just plm
+jspsJ p a pst plm = Just $ Placement (PS p a) pst $ \_ -> Just plm
 
 jsps0J :: PSType -> Placement -> Maybe Placement
-jsps0J pst plm = Just $ Placement (PS (V2 0 0) 0 pst) $ \_ -> Just plm
+jsps0J pst plm = Just $ Placement (PS (V2 0 0) 0) pst $ \_ -> Just plm
 
 ps0 :: PSType -> (Int -> Maybe Placement) -> Placement
-ps0 pst = Placement (PS (V2 0 0) 0 pst)
+ps0 pst = Placement (PS (V2 0 0) 0) pst
 
 jps0 :: PSType -> (Int -> Maybe Placement) -> Maybe Placement
-jps0 pst = Just . Placement (PS (V2 0 0) 0 pst)
+jps0 pst = Just . Placement (PS (V2 0 0) 0) pst
 
 ps0j :: PSType -> Placement -> Placement
-ps0j pst plmnt = Placement (PS (V2 0 0) 0 pst) (const $ Just plmnt)
+ps0j pst plmnt = Placement (PS (V2 0 0) 0) pst (const $ Just plmnt)
 
 makeLenses ''PSType
 makeLenses ''PlacementSpot

src/Dodge/Machine/Sensor.hs

@@ -16,7 +16,7 @@ import Data.Either
 damageSensor 
     :: (DamageType -> Either Int Int) -- Left gets sensed, Right does damage
     -> Point2 -> Float -> Placement
-damageSensor damF p r = Placement (PS p r $ PutLS theLS)
+damageSensor damF p r = Placement (PS p r) ( PutLS theLS)
     $ \lsid -> jsps p r $ PutMachine blue (reverse $ square wdth) defaultMachine
         { _mcDraw = sensorSPic 
         , _mcUpdate = sensorUpdate damF

src/Dodge/Placements/Button.hs

@@ -12,11 +12,11 @@ import Dodge.Placements.LightSource
 import Control.Lens
 
 putLitButtonID :: Color -> Point2 -> Float -> (Int -> Maybe Placement) -> Placement
-putLitButtonID col p a subpl = mountLightlID ls p'' (addZ 40 p')
+putLitButtonID col p a subpl = mountLightAID ls p'' (addZ 40 p')
     $ \lsid -> jps0 (PutButton (makeButton col (changeLight lsid)) {_btPos = p, _btRot = a})
     subpl
   where
-    p'  = p -.- 20 *.* vNormal (unitVectorAtAngle a)
+    p'  = p -.- 30 *.* vNormal (unitVectorAtAngle a)
     p'' = p +.+ 10 *.* vNormal (unitVectorAtAngle a)
     changeLight lsid = lightSources . ix lsid . lsIntensity .~ V3 0 0.5 0
     ls = defaultLS { _lsRad = 75 , _lsIntensity = V3 0.5 0 0 }

src/Dodge/Placements/Door.hs

@@ -17,7 +17,7 @@ putDoubleDoor pathing col cond a b speed = putDoubleDoorThen pathing col cond a
 putDoubleDoorThen :: Bool -> Color -> (World -> Bool) 
     -> Point2 -> Point2 -> Float -> Maybe Placement -> Placement
 putDoubleDoorThen pathing col cond a b speed mayp = ps0j (PutSlideDoor pathing col cond a half speed)
-    $ Placement (PS (V2 0 0) 0 (PutSlideDoor pathing col cond b half speed)) $ const mayp
+    $ Placement (PS (V2 0 0) 0) ( (PutSlideDoor pathing col cond b half speed)) $ const mayp
   where
     half = 0.5 *.* (a +.+ b)
 
@@ -31,7 +31,7 @@ putAutoDoor a b = PlacementPos (addZ 0 a)
     cond az bz = any (crNearSeg 40 (stripZ az) (stripZ bz)) . IM.filter isAnimate . _creatures
 
 switchDoor :: Point2 -> Float -> Point2 -> Point2 -> Color -> Placement
-switchDoor btpos btrot dra drb col = Placement (PS btpos btrot $ PutButton $ makeSwitch col red id id)
+switchDoor btpos btrot dra drb col = Placement (PS btpos btrot) (PutButton $ makeSwitch col red id id)
     $ \btid -> jsps0J (PutSlideDoor False col (cond btid) dra drc 2)
     $          sps0   (PutSlideDoor False col (cond btid) drb drc 2)
   where

src/Dodge/Placements/LightSource.hs

@@ -72,35 +72,38 @@ mountLightlID = mountLightOnShape f
 mountLightll :: Point2 -> Point3 -> Placement
 mountLightll = redMID mountLightlID
 
+mountLightAID :: LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
+mountLightAID = mountLightOnShape f
+  where
+    f wallpos (V3 x y z) = girder (z+10) 20 10 pout wallpos
+      where
+        pout = V2 x y -.- 2 *.* safeNormalizeV (V2 x y -.- wallpos)
+
 mountLightA :: Point2 -> Point3 -> Placement
-mountLightA wallpos lamppos@(V3 x y z)
+mountLightA = redMID mountLightAID
-    = ps0 (PutLS $ colorLightAt 0.75 lamppos 0)
-    $ \_ -> jsps0 $ PutForeground $ girder (z+10) 20 10 pout wallpos
-  where
-    pout = V2 x y -.- 2 *.* safeNormalizeV (V2 x y -.- wallpos)
 
-mountColLightI :: Point3 -> Float -> Point2 -> Point2 -> Placement
+mountLightVID :: LightSource -> Point2 -> Point3 -> (Int -> Maybe Placement) -> Placement
-mountColLightI col h a b = ps0j (PutLS $ colorLightAt col (V3 x y h) 0)
+mountLightVID = mountLightOnShape f
-    $ sps0 $ PutForeground $ highPipe (h + 5) a b
   where
-    V2 x y = 0.5 *.* (a +.+ b)
+    f wallpos (V3 x y z) = thinHighBar (z + 5) wallposUp (lxy `extendAway` wallposUp)
-
+        <> thinHighBar (z + 5) wallposDown (lxy `extendAway` wallposDown)
-mountLightI :: Float -> Point2 -> Point2 -> Placement
+      where
-mountLightI h a b = ps0j (PutLS $ lightAt (V3 x y h) 0)
+        lxy = V2 x y
-    $ sps0 $ PutForeground $ highPipe (h + 5) a b
+        n = vNormal (wallpos -.- lxy)
-  where
+        wallposUp = wallpos +.+ n
-    V2 x y = 0.5 *.* (a +.+ b)
+        wallposDown = wallpos -.- n
 
 mountLightV :: Point2 -> Point3 -> Placement
-mountLightV wallpos lamppos@(V3 x y z)
+mountLightV = redMID mountLightVID
-    = ps0 (PutLS $ colorLightAt 0.75 lamppos 0)
+
-    $ \_ -> jsps0 $ PutForeground $ thinHighBar (z + 5) wallposUp (lxy `extendAway` wallposUp)
+spanColLightI :: Point3 -> Float -> Point2 -> Point2 -> Placement
-        <> thinHighBar (z + 5) wallposDown (lxy `extendAway` wallposDown)
+spanColLightI col h a b = ps0j (PutLS $ colorLightAt col (V3 x y h) 0)
+    $ sps0 $ PutForeground $ highPipe (h + 5) a b
   where
-    lxy = V2 x y
+    V2 x y = 0.5 *.* (a +.+ b)
-    n = vNormal (wallpos -.- lxy)
+
-    wallposUp = wallpos +.+ n
+spanLightI :: Float -> Point2 -> Point2 -> Placement
-    wallposDown = wallpos -.- n
+spanLightI = spanColLightI 0.75
 
 extendAway :: Point2 -> Point2 -> Point2
 extendAway p x = p +.+ safeNormalizeV (p -.- x)
@@ -110,4 +113,3 @@ putColorLamp col = PutCrit (colorLamp col 90)
 
 putLamp :: PSType
 putLamp = PutCrit (lamp 90)
-

src/Dodge/Placements/Wall.hs

@@ -21,33 +21,20 @@ 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 = Placement PS
+blockLine a b = sps0 $ PutLineBlock baseBlockPane 9 9 a b
-    { _psPos    = V2 0 0
-    , _psRot    = 0
-    , _psType   = PutLineBlock baseBlockPane 9 9 a b
-    } (const Nothing)
 
 {-
 Places an breakable window between two points.
 Width 8, also extends out from each point by 8.
  -}
 windowLine :: Point2 -> Point2 -> Placement
-windowLine a b = Placement PS 
+windowLine a b = sps0 $ PutLineBlock baseWindowPane 8 8 a b
-    { _psPos    = V2 0 0
-    , _psRot    = 0
-    , _psType   = PutLineBlock baseWindowPane 8 8 a b
-    } (const Nothing)
-
 {-
 Places an unbreakable window between two points.
 Width 7, also extends out from each point by 7.
  -}
 crystalLine :: Point2 -> Point2 -> Placement
-crystalLine a b = Placement PS 
+crystalLine a b = sps0 $ PutWall ps defaultCrystalWall
-    { _psPos    = V2 0 0
-    , _psRot    = 0
-    , _psType   = PutWall ps defaultCrystalWall
-    } (const Nothing)
   where
     ps = 
         [ a +.+ left +.+ up
@@ -61,14 +48,9 @@ crystalLine a b = Placement PS
 Depth 15, does not extend wider than points.
  -}
 wallLine :: Point2 -> Point2 -> Placement
-wallLine a b = Placement PS 
+wallLine a b = sps0 $ PutWall ps defaultWall
-    { _psPos    = V2 0 0
-    , _psRot    = 0
-    , _psType   = PutWall ps defaultWall
-    } (const Nothing)
   where
-    ps = 
+    ps = [ a  +.+ up
-        [ a  +.+ up
         , a  -.- up
         , b  -.- up
         , b  +.+ up
@@ -107,14 +89,14 @@ replacePutID
     -> Room 
     -> Room
 replacePutID i psts r =
-    r & rmPS %~ flip (subZipWith (isPutID i) (\ps pt -> ps & placementSpot . psType .~ pt)) psts
+    r & rmPS %~ flip (subZipWith (isPutID i) (\ps pt -> ps & psType .~ 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 partition
+    -> [a]              -- ^ List to be partitioned
     -> [b]              -- ^ Modifying list
     -> [a]
 subZipWith f g xs ys =
@@ -122,7 +104,7 @@ subZipWith f g xs ys =
     in  zipWith g zs ys ++ ws
 
 isPutID :: Int -> Placement -> Bool
-isPutID i ps = Just i == ps ^? placementSpot . psType . putID
+isPutID i ps = Just i == ps ^? psType . putID
 
 putBlockRect :: Float -> Float -> Float -> Float -> [Placement]
 putBlockRect a x b y =

src/Dodge/Room.hs

@@ -66,7 +66,7 @@ roomPadCut ps p = defaultRoom
 roomPillars :: Room
 roomPillars = over rmLinks init $ set rmPS plmnts $ roomRect 240 240 2 2
   where 
-    plmnts = mountLightI 70 (V2 120 24) (V2 120 216) 
+    plmnts = spanLightI 70 (V2 120 24) (V2 120 216) 
         : mountLightV (V2 12 12) (V3 25 25 70)
         : mountLightV (V2 228 228) (V3 215 215 70)
         : sps0 (PutForeground $ thinHighBar 75 (V2 26 25) (V2 120 25))

src/Dodge/Room/Airlock.hs

@@ -25,10 +25,10 @@ airlock0 = defaultRoom
     , _rmLinks = lnks
     , _rmPath  = [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20  5) ]
     , _rmPS    = 
-        [Placement (PS (V2 (-35) 50) (negate $ pi/2) $ PutButton $ makeSwitch col red id id)
+        [Placement (PS (V2 (-35) 50) (negate $ pi/2)) (PutButton $ makeSwitch col red id id)
             $ \btid -> Just $ putDoubleDoorThen False col (not . cond' btid) (V2 (-1) 20) (V2 41 20) 2
                 $ Just $ putDoubleDoorThen False col (cond' btid) (V2 (-1) 80) (V2 41 80) 2 Nothing
-        ,mountLightI 70 (V2 (-2) 30) (V2 (-2) 70)
+        ,spanLightI 70 (V2 (-2) 30) (V2 (-2) 70)
         ,sps0 $ PutForeground $ thinHighBar 75 (V2 40 50) (V2 (-1) 50)
         ]
     , _rmBound = [rectNSWE 75 15 0 40]
@@ -61,7 +61,7 @@ airlock90 = defaultRoom
          ,(V2 40 0,V2 0 40)
          ]
     , _rmPS    = 
-        [ Placement (PS (V2 120 120) (3 * pi/4) (PutButton $ makeSwitch col red id id))
+        [ Placement (PS (V2 120 120) (3 * pi/4)) ((PutButton $ makeSwitch col red id id))
             $ \btid -> jsps (V2 5 5) 0 $ PutDoor col (cond btid) pss
         ,mountLightV (V2 20 20) (V3 70 70 50)
         ]
@@ -89,7 +89,7 @@ airlockCrystal = defaultRoom
     , _rmLinks = [(V2 20 130,0) ,(V2 20  0 ,pi) ]
     , _rmPath  = [ ]
     , _rmPS    = 
-        [ Placement (PS (V2 145 70) (pi/2) (PutButton $ makeSwitch col red id id))
+        [ Placement (PS (V2 145 70) (pi/2)) ( (PutButton $ makeSwitch col red id id))
             $ \btid -> jsps0 $ PutDoor col (cond btid) pss
         , crystalLine (V2 0 70) (V2 40 70)
         , mountLightV (V2 150 70) (V3 110 70 70)

src/Dodge/Room/Boss.hs

@@ -97,8 +97,8 @@ roomCross x y = defaultRoom
         ]
     , _rmPath  = []
     , _rmPS = 
-        [ mountLightI 70 (V2 (x+5) x) (V2 (x+5) (-x))
+        [ spanLightI 70 (V2 (x+5) x) (V2 (x+5) (-x))
-        , mountLightI 70 (V2 (-x-5) x) (V2 (-x-5) (-x))
+        , spanLightI 70 (V2 (-x-5) x) (V2 (-x-5) (-x))
         ]
     , _rmBound = 
         [rectNSWE y (-y) (-x) x

src/Dodge/Room/Corridor.hs

@@ -17,7 +17,7 @@ corridor = defaultRoom
     { _rmPolys = [poly]
     , _rmLinks = lnks
     , _rmPath  = concatMap (doublePair . (,) (V2 20 60) . fst) lnks
-    , _rmPS    = [ mountLightI 50 (V2 0 40) (V2 40 40) ]
+    , _rmPS    = [ spanLightI 50 (V2 0 40) (V2 40 40) ]
     , _rmBound = [ rectNSWE 50 30 0 40 ]
     , _rmFloor = [makeTileFromPoly poly 2]  
     }

src/Dodge/Room/Foreground.hs

@@ -110,12 +110,13 @@ girderV h d w x y = colorSH red $ mconcat $
     evenDouble (a:_:xs) = a:a:evenDouble xs
     evenDouble xs = xs
 
-girder 
+girderCol
-    :: Float -- ^ height
+    :: Color
+    -> Float -- ^ height
     -> Float -- ^ distance between cross bars
     -> Float -- ^ width
     -> Point2 -> Point2 -> Shape
-girder h d w x y = colorSH red $ mconcat $
+girderCol col h d w x y = colorSH col $ mconcat $
     [ thinHighBar h xt yt
     , thinHighBar h xb yb
     ]
@@ -129,6 +130,13 @@ girder h d w x y = colorSH red $ mconcat $
     ps = divideLineExact d xb yb
     qs = divideLineExact d xt yt
 
+girder 
+    :: Float -- ^ height
+    -> Float -- ^ distance between cross bars
+    -> Float -- ^ width
+    -> Point2 -> Point2 -> Shape
+girder = girderCol red
+
 robotArm :: Shape
 robotArm = undefined
 

src/Dodge/Room/LongDoor.hs

@@ -39,7 +39,7 @@ twinSlowDoorRoom w h x = defaultRoom
         ]
     , _rmPath   = []
     , _rmPS     = 
-        [ Placement (PS (V2 0 (h-5)) pi $ PutButton $ makeButton col id)
+        [ Placement (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col id)
             $ \btid -> jsps0J (PutSlideDoor False col (cond' btid) (V2 x 1) (V2 x h) wlSpeed)
             $ ps0 (PutSlideDoor False col (cond' btid) (V2 (-x) 1) (V2 (-x) h) wlSpeed)
             $ \did -> jps0 (PutLS (colorLightAt (V3 0.75 0 0) (V3 0 (h-1) lampHeight) 0))

src/Dodge/Room/Procedural.hs

@@ -169,7 +169,7 @@ fillNothingPlacement :: PSType -> Room -> Room
 fillNothingPlacement pst r =
     r & rmPS %~ replaceNothingWith pst
   where
-    replaceNothingWith x (Placement (PS p rot PutNothing) _: pss) = sPS p rot x : pss
+    replaceNothingWith x (Placement (PS p rot) PutNothing _: pss) = sPS p rot x : pss
     replaceNothingWith x (ps:pss) = ps : replaceNothingWith x pss
     replaceNothingWith _ [] = []
 {- | Successively fill 'PutNothing' placements with a list of given 'PSType's.
@@ -231,7 +231,7 @@ centerVaultRoom w h d = do
   where
     col = dim $ dim $ bright red
     theDoor = 
-        [ Placement (PS (V2 35 (d+4)) 0 $ PutButton $ makeSwitch col red id id)
+        [ Placement (PS (V2 35 (d+4)) 0) (PutButton $ makeSwitch col red id id)
             $ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDoor False col (cond' btid) (V2 (-21) 0) (V2 0 0) 2)
             $          sPS   (V2 0 (d-10)) 0 (PutSlideDoor False col (cond' btid) (V2   21  0) (V2 0 0) 2)
         ]

src/Dodge/Room/RoadBlock.hs

@@ -42,7 +42,7 @@ litCorridor90 = do
             ]
         , _rmPS    = 
             [ sPS (V2 20 (h-5)) 0     putLamp
-            , mountLightI 70 (V2 0 (0.4*h)) (V2 40 (0.4*h))
+            , spanLightI 70 (V2 0 (0.4*h)) (V2 40 (0.4*h))
             , windowLine (V2 0 (h-20)) (V2 40 (h-20))
             , sPS (V2 (-50) (h-85)) 0   putLamp
             , windowLine (V2 (-40) (h-60)) (V2 (-40) (h-100))
@@ -75,6 +75,6 @@ blockedCorridor = do
     let plmnts = 
             [sPS (V2 20 40) r $ PutBlock [5,5,5] (V4 (150/256) ( 75/256)  0 ( 250/256)) 
                                           $ reverse $ rectNSWE 10 (-10) (-10) 10
-            ,mountLightI 55 (V2 0 15) (V2 40 15)
+            ,spanLightI 55 (V2 0 15) (V2 40 15)
             ]
     sequence $ treeFromPost [] $ return $ Right $ set rmPS plmnts corridor

src/Dodge/Room/Start.hs

@@ -21,7 +21,7 @@ import System.Random
 
 rezBox :: Room
 rezBox = shiftRoomBy (V2 (-20) (-10),0) $ roomRect 40 20 1 1 
-    & rmPS .~ [ mountColLightI (V3 0 0.7 0.2) 70 (V2 0 10) (V2 40 10) ]
+    & rmPS .~ [ spanColLightI (V3 0 0.7 0.2) 70 (V2 0 10) (V2 40 10) ]
 
 startRoom :: RandomGen g => State g (Tree (Either Room Room))
 startRoom = do