Fix wall bug, refactor placements

src/Dodge/Base.hs

@@ -7,7 +7,7 @@ module Dodge.Base
     where
 import Dodge.Data
 import Dodge.Zone
-import Dodge.Zone.Data
+--import Dodge.Zone.Data
 import Dodge.Base.Window
 import Geometry
 --import Picture

src/Dodge/Initialisation.hs

@@ -23,7 +23,7 @@ import System.Random
 import qualified Data.Set as S
 import qualified Data.IntMap.Strict as IM
 import qualified Data.Map as M
-import Data.Maybe
+--import Data.Maybe
 --import Control.Lens
 --import Data.List (partition)
 --import Data.List (sortOn)
@@ -61,24 +61,11 @@ initialWorld = defaultWorld
     , _worldState = M.empty
     }
 testStringInit :: World -> [String]
---testStringInit _ = []
+testStringInit _ = []
---testStringInit w = 
+--testStringInit = mapMaybe f . IM.elems . flattenIMIMIM . _znObjects . _wallsZone
---    [show $ _worldMinX w
---    ,show $ _worldMaxX w
---    ,show $ _worldMinY w
---    ,show $ _worldMaxY w
---    ]
---testStringInit = mapMaybe f . IM.elems . wallsDoubleScreen
 --  where
---    f (dr@Door{}) = Just . show $ _wlLine dr
+--    f dr | _wlColor dr == V4 0 1 0 1 = Just . show $ _wlLine dr
---    f _ = Nothing
+--         | otherwise = Nothing
---testStringInit = map show . filter ((== col) . snd) . fst . wallsAndWindows
---  where
---    col = dim $ dim $ bright red
-testStringInit = mapMaybe f . IM.elems . _walls
-  where
-    f dr | _wlColor dr == V4 0 1 0 1 = Just . show $ _wlLine dr
-         | otherwise = Nothing
 --testStringInit _ = []
 --testStringInit w = [show . length $ newSounds w]
 --testStringInit w = (show . _crPos $ _creatures w IM.! 0) 

src/Dodge/Layout.hs

@@ -7,7 +7,6 @@ import Dodge.LevelGen.StaticWalls
 --import Dodge.LevelGen.Data
 import Dodge.Base
 import Dodge.Zone
-import Dodge.Zone.Data
 import Dodge.GameRoom
 import Dodge.Bounds
 --import Dodge.RandomHelp

src/Dodge/LevelGen.hs

@@ -123,18 +123,8 @@ placeProp
 placeProp pr p a w = (i, w & props %~ addProp)
   where 
     i = IM.newKey $ _props w
-    addProp prs = IM.insert (IM.newKey prs) (over pjRot (+a) pr {_pjPos = p, _pjID = IM.newKey prs}) prs
+    addProp prs = IM.insert i (f pr) prs
-
+    f = (pjRot +~ a) . (pjPos %~ ( (p +.+) . (rotateV a) )) . (pjID .~ i)
-placePropID 
-    :: Prop
-    -> Point2
-    -> Float -- ^ Rotation
-    -> World
-    -> (World,Int)
-placePropID pr p a w = (w & props %~ addProp , k)
-  where 
-    k = IM.newKey (_props w)
-    addProp prs = IM.insert (IM.newKey prs) (over pjRot (+a) pr {_pjPos = p, _pjID = IM.newKey prs}) prs
 
 placeBt 
     :: Button
@@ -142,10 +132,12 @@ placeBt
     -> Float -- ^ Rotation
     -> World
     -> (Int, World)
-placeBt bt p rot w = (i , over buttons addBT w)
+placeBt bt p a w = (i , over buttons addBT w)
   where 
     i = IM.newKey $ _buttons w
-    addBT bts = IM.insert (IM.newKey bts) (bt {_btPos = p, _btRot = rot, _btID = IM.newKey bts}) bts
+    addBT xs = IM.insert i (f bt) xs
+    f = (btRot +~ a) . (btPos %~ ( (p +.+) . (rotateV a) )) . (btID .~ i)
+    --addBT bts = IM.insert (IM.newKey bts) (bt {_btPos = p, _btRot = rot, _btID = IM.newKey bts}) bts
 {- Creates a floor item at a given point.
 Assigns an id correctly.  -}
 placeFlIt
@@ -197,7 +189,7 @@ placeLS :: LightSource -> Point3 -> Float -> World -> (Int,World)
 placeLS ls (V3 x y z) rot w = (i, over lightSources addLS w)
   where 
     i = IM.newKey $ _lightSources w
-    startPos = _lsPos ls
+    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}) 

src/Dodge/LevelGen/Block.hs

@@ -4,7 +4,6 @@ import Dodge.Data
 import Dodge.Data.SoundOrigin
 import Dodge.Base
 import Dodge.Zone
-import Dodge.Zone.Data
 import Dodge.SoundLogic
 import Dodge.SoundLogic.LoadSound
 import Dodge.WorldEvent.Sound

src/Dodge/LevelGen/Data.hs

@@ -1,23 +1,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE StrictData #-}
 module Dodge.LevelGen.Data
-    ( PSType (..)
+    where
-    , PlacementSpot (..)
-    , Placement (..)
-    , sPS
-    -- lenses
-    , placementSpot
-    , psType
-    , psPos
-    , psRot
-    , putID
-    , pwPoly
-    , pwWall
-    , unPutCrit
---    , groupPlacementID
---    , groupUpdate
-    , idPlacement
-    ) where
 import Dodge.Data
 import Picture
 import Geometry.Data
@@ -44,12 +28,12 @@ data PSType = PutCrit {_unPutCrit :: Creature}
     | PutForeground Shape
     | PutNothing
     | PutID { _putID :: Int}
+-- maybe there is a monadic implementation of this?
 data PlacementSpot = PS
     { _psPos :: Point2
     , _psRot :: Float
     , _psType :: PSType
     }
--- maybe there is a monadic implementation of this?
 data Placement = Placement 
     { _placementSpot :: PlacementSpot
     , _idPlacement :: Int -> Maybe Placement 

src/Dodge/LevelGen/MoveDoor.hs

@@ -7,7 +7,6 @@ module Dodge.LevelGen.MoveDoor
 import Dodge.Data
 import Dodge.Base
 import Dodge.Zone
-import Dodge.Zone.Data
 import Geometry
 
 import Control.Lens

src/Dodge/LightSources/Fitting.hs

@@ -3,6 +3,7 @@ module Dodge.LightSources.Fitting
 import Dodge.LightSources.Lamp
 import Dodge.LevelGen.Data
 import Dodge.Room.Foreground
+import Dodge.Placement
 import Geometry
 
 wallMount :: Point2 -> Point3 -> Placement
@@ -66,9 +67,3 @@ wallMountV wallpos lamppos@(V3 x y z)
 
 extendAway :: Point2 -> Point2 -> Point2
 extendAway p x = p +.+ safeNormalizeV (p -.- x)
-
-jsps0 :: PSType -> Maybe Placement
-jsps0 pst = Just $ sPS (V2 0 0) 0 pst
-
-place0 :: PSType -> (Int -> Maybe Placement) -> Placement
-place0 pst = Placement (PS (V2 0 0) 0 pst)

src/Dodge/LightSources/Lamp.hs

@@ -86,9 +86,9 @@ lampCover h = ShapeProp
     , _prDraw = drawLampCover h
     , _prToggle = True
     }
-lampCoverWhen :: (World -> Bool) -> Float -> Prop
+lampCoverWhen :: (World -> Bool) -> Point2 -> Float -> Prop
-lampCoverWhen cond h = ShapeProp
+lampCoverWhen cond pos h = ShapeProp
-    { _pjPos = V2 0 0
+    { _pjPos = pos
     , _pjID  = 0
     , _pjRot = 0
     , _pjUpdate = setToggle cond `chain` rotateProp 0.15
@@ -138,7 +138,6 @@ drawLampCover h pr | not (_prToggle pr) = mempty
         , translateSHz 1 . upperPrismPoly 1 $ rectNSEW 3 (-1) 3 2
         , translateSHz 2 . upperPrismPoly 1 $ rectNSEW 3 2    3 (-1)
         , translateSHz 2 . upperPrismPoly 1 $ rectNSEW 3 (-1) 3 2
-        --, translateSHz 2.5 . upperPrismPoly 1 $ [V2 5 5,V2 (-4) 5,V2 5 (-4)]
         , upperPrismPoly 1 [V2 2 2,V2 (-1) 2,V2 2 (-1)]
         ]
     , mempty

src/Dodge/Placement.hs

@@ -0,0 +1,10 @@
+module Dodge.Placement
+  where
+import Geometry
+import Dodge.LevelGen.Data
+
+jsps0 :: PSType -> Maybe Placement
+jsps0 pst = Just $ sPS (V2 0 0) 0 pst
+
+place0 :: PSType -> (Int -> Maybe Placement) -> Placement
+place0 pst = Placement (PS (V2 0 0) 0 pst)

src/Dodge/Render/Picture.hs

@@ -238,6 +238,7 @@ wallsAndWindows w
   where
     f wl = (_wlLine wl, _wlColor wl)
     (wins,wls) = partition _wlIsSeeThrough . IM.elems $ wallsDoubleScreen w
+    --(wins,wls) = partition _wlIsSeeThrough . IM.elems $ wallsOnScreen w
 
 wallsToList :: [((Point2,Point2),Point4)] -> [Float]
 wallsToList = concatMap (\((V2 a b,V2 c d),V4 e f g h) -> [a,b,c,d,e,f,g,h])

src/Dodge/Room/Airlock.hs

@@ -141,11 +141,11 @@ airlockCrystal n = defaultRoom
     , _rmPS    = 
         [sPS (V2 0 0) 0 $ PutDoor col (not . cond) pss
         ,sPS (V2 145 70) (pi/2) $ PutButton $ makeSwitch col red
-            (over worldState (M.insert (DoorNumOpen n) True))
             (over worldState (M.insert (DoorNumOpen n) False))
+            (over worldState (M.insert (DoorNumOpen n) True))
         ,crystalLine (V2 0 70) (V2 40 70)
-        ,sPS (V2 20  40) 0 putLamp
+        --,sPS (V2 20  40) 0 putLamp
-        ,sPS (V2 20  100) 0 putLamp
+        --,sPS (V2 20  100) 0 putLamp
         ]
     , _rmBound = 
         [         ]

src/Dodge/Room/LongDoor.hs

@@ -16,6 +16,7 @@ import Dodge.RandomHelp
 import Dodge.Creature.Inanimate
 import Dodge.Creature
 import Dodge.LightSources.Lamp
+import Dodge.Placement
 import Picture
 import Geometry
 
@@ -41,16 +42,13 @@ twinSlowDoorRoom drid w h x = defaultRoom
         ]
     , _rmPath   = []
     , _rmPS     = 
-        [ sPS (V2 0 (h/2)) 0 putLamp
+        [ sPS (V2 0 0) 0 $ PutSingleDoor col cond (V2 x 1) (V2 x h) 1
-        , sPS (V2 25 5) 0 putLamp
-        , sPS (V2 (negate 25) 5) 0 putLamp
-        , sPS (V2 0 0) 0 $ PutSingleDoor col cond (V2 x 1) (V2 x h) 1
-        , Placement (PS (V2 0 0) 0 $ PutSingleDoor col cond (V2 (-x) 1) (V2 (-x) h) 1)
-            $ \did -> Just $ Placement (PS (V2 0 (h-1)) 0 $ PutLS (colorLightAt (V3 0.75 0 0) (V3 0 0 lampHeight) 0))
-            $ \lsid -> Just $ sPS (V2 0 (h-1)) 0 $ PutProp $ addColorChange lsid did $ lampCoverWhen (drmoving did) lampHeight
         , sPS (V2 0 (h-5)) pi $ PutButton $ makeSwitch col red
             (worldState %~ M.insert (DoorNumOpen drid) True )
             (worldState %~ M.insert (DoorNumOpen drid) False)
+        , place0 (PutSingleDoor col cond (V2 (-x) 1) (V2 (-x) h) 1)
+            $ \did -> Just $ place0 (PutLS (colorLightAt (V3 0.75 0 0) (V3 0 (h-1) lampHeight) 0))
+            $ \lsid -> jsps0 $ PutProp $ addColorChange lsid did $ lampCoverWhen (drmoving did) (V2 0 (h-1)) lampHeight
         ]
     , _rmBound  = ps
     , _rmName   = "twinSlowDoorRoom"
@@ -68,8 +66,7 @@ twinSlowDoorRoom drid w h x = defaultRoom
         ,rectNSWE 20 (-h) (negate x) x
         ]
     cond w' = or $ M.lookup (DoorNumOpen drid) (_worldState w')
-    --col = dim $ dim $ bright red
+    col = dim $ dim $ bright red
-    col = V4 0 1 0 1
 
 twinSlowDoorChasers 
     :: RandomGen g 

src/Dodge/Room/Procedural.hs

@@ -21,6 +21,7 @@ import Dodge.Item.Weapon
 import Dodge.RandomHelp
 import Dodge.LevelGen
 import Dodge.LevelGen.Data
+import Dodge.LightSources.Fitting
 import Dodge.Creature
 --import Dodge.Default
 import Geometry
@@ -49,7 +50,7 @@ roomRect x y xn yn = defaultRoom
     { _rmPolys = [rectNSWE  y 0 0 x ]
     , _rmLinks = lnks
     , _rmPath  = concatMap doublePair pth
-    , _rmPS    = [sPS (V2 (x/2) (y/2)) 0 putLamp]
+    , _rmPS    = [wallMountL (V2 (x/2) 0) (V3 (x/2) 40 50)]
     , _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
     , _rmFloor = [Tile 
             { _tilePoly = rectNSWE y 0 0 x

src/Dodge/WorldEvent/ThingsHit.hs

@@ -11,7 +11,7 @@ module Dodge.WorldEvent.ThingsHit
 import Dodge.Data
 import Dodge.Base
 import Dodge.Zone
-import Dodge.Zone.Data
+--import Dodge.Zone.Data
 import Geometry
 
 import qualified Data.IntMap.Strict as IM

src/Dodge/Zone.hs

@@ -16,6 +16,8 @@ module Dodge.Zone
     , cloudsNearPoint
     , wallsNearZones
     , zoneOfSight
+    , flattenIMIMIM
+    , module Dodge.Zone.Data
     )
     where
 import Dodge.Data
@@ -87,7 +89,9 @@ zoneOfSight w =
 
 wallsDoubleScreen :: World -> IM.IntMap Wall
 wallsDoubleScreen w
-    = foldl' (flip $ IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
+    -- = foldl' (flip $ IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
+    -- for some reason (TODO diagnose) the foldl' version causes errors
+    = foldr (IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
   where 
     innerFold m = foldl' (flip $ IM.union . \ j -> f j m) IM.empty ys
     f i m = case IM.lookup i m of 
@@ -168,3 +172,6 @@ wallsNearPoint p w =  IM.unions [f b $ f a $ _znObjects $ _wallsZone w | a<-[x-1
     f i m = case IM.lookup i m of 
         Just val -> val
         _ -> IM.empty
+
+flattenIMIMIM :: IM.IntMap (IM.IntMap (IM.IntMap a)) -> IM.IntMap a
+flattenIMIMIM = IM.unions . fmap IM.unions

src/Geometry/Vector3D.hs

@@ -104,3 +104,7 @@ projV3
 projV3 = undefined
 
 
+onXY :: (Point2 -> Point2) -> Point3 -> Point3
+onXY f (V3 x y z) = V3 x' y' z
+  where
+    V2 x' y' = f (V2 x y)