Refactor doors

src/Dodge/LevelGen/AutoDoor.hs

@@ -1,19 +1,18 @@
+--{-# LANGUAGE BangPatterns #-}
 {- |
 Creation of doors that open when creatures approach them.
  -}
---{-# LANGUAGE BangPatterns #-}
 module Dodge.LevelGen.AutoDoor
-    where
+    ( addAutoDoor
+    ) where
 import Dodge.Data
---import Dodge.Creature.State.Data
 import Dodge.Base
-import Dodge.SoundLogic
-import Dodge.SoundLogic.Synonyms
 import Dodge.Creature.Property
-import Dodge.LevelGen.MoveDoor
+--import Dodge.LevelGen.MoveDoor
-import Geometry
+import Dodge.LevelGen.DoorPane
+--import Geometry
 import Picture
-import qualified DoubleStack as DS
+--import qualified DoubleStack as DS
 import qualified IntMapHelp as IM
 
 --import Data.List
@@ -35,69 +34,13 @@ autoDoorAt
     -> IM.IntMap Wall
 autoDoorAt a b wls = IM.union wls $ IM.fromList $ zip is $ mkAutoDoor a b is
   where 
-    i = IM.newKey wls
+    is = [IM.newKey wls..]
-    is = [i..]
 
 mkAutoDoor 
     :: Point2   -- ^ Left point
     -> Point2   -- ^ Right point (though the two points should be symmetric)
     -> [Int]    -- ^ Wall ids
     -> [Wall]
-mkAutoDoor pl pr xs = addSound 
+mkAutoDoor pl pr = mkDoubleDoor (dim yellow) True cond pl pr
-    $ zipWith3 (autoDoorPane (pl,pr))
+  where
-                xs
+    cond = any (crNearSeg 40 pl pr) . IM.filter isAnimate . _creatures
-                (lDoorClosed ++ rDoorClosed)
-                (map shiftL lDoorClosed ++ map shiftR rDoorClosed)
-  where 
-    lDoorClosed = [ (pld,hwd)
-                  , (hwd,hwu)
-                  , (hwu,plu)
-                  ]
-    rDoorClosed = [ (pru,hwu)
-                  , (hwu,hwd)
-                  , (hwd,prd)
-                  ]
-    norm = 10 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
-    hw = 0.5 *.* (pl +.+ pr)
-    parallel = 0.5 *.* (pl -.- pr)
-    plu = pl +.+ norm
-    pld = pl -.- norm
-    pru = pr +.+ norm
-    prd = pr -.- norm
-    hwu = hw +.+ norm
-    hwd = hw -.- norm
-    shiftL = h $ (+.+ parallel) . (-.- normalizeV parallel)
-    shiftR = h $ (-.- parallel) . (+.+ normalizeV parallel)
-    h func (x,y) = (func x,func y)
-
-    addSound (x:ys) = f x : ys
-    addSound _ = error "Trying to add a sound to malformed auto door"
-    f wl = over doorMech g wl
-    g dm w 
-        | dist wp pld > 2 && dist wp hwd > 2 
-            = soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0 $ dm w
-        | otherwise = dm w
-      where 
-        wp = snd (_wlLine $ _walls w IM.! head xs)
-
-autoDoorPane 
-    :: (Point2,Point2)  -- ^ Trigger line
-    -> Int              -- ^ Wall id
-    -> (Point2,Point2)  -- ^ Closed position
-    -> (Point2,Point2)  -- ^ Open position
-    -> Wall
-autoDoorPane (trigx,trigy) n closedPos openPos = Door
-    { _wlLine = closedPos
-    , _wlID = n
-    , _doorMech = dm
-    , _wlColor = dim yellow
-    , _wlSeen = False
-    , _wlIsSeeThrough = False
-    , _doorPathable = True
-    , _drPositions = DS.singleton closedPos
-    }
-  where 
-    dm = doorMechan n (zoneps closedPos) openDoor closeDoor cond 
-    cond = any (crNearSeg 40 trigx trigy) . IM.filter isAnimate . _creatures
-    openDoor  = moveDoorToward openPos
-    closeDoor = moveDoorToward closedPos

src/Dodge/LevelGen/MoveDoor.hs

@@ -1,13 +1,20 @@
 {-# LANGUAGE BangPatterns #-}
 module Dodge.LevelGen.MoveDoor
-    where
+    ( doorMechan
+    , zoneps
+    , moveDoorToward
+    , addSoundToDoor
+    ) where
 import Dodge.Data
 import Dodge.Base
 import Dodge.Base.Zone
+import Dodge.SoundLogic
+import Dodge.SoundLogic.Synonyms
 import Geometry
 
 import qualified Data.IntMap.Strict as IM
 import Control.Lens
+
 -- This deserves a clean up
 mvP :: Point2 -> Point2 -> Point2
 {-# INLINE mvP #-}
@@ -22,9 +29,11 @@ moveDoorToward :: (Point2,Point2) -> Wall -> Wall
 moveDoorToward (ex,ey) wls = wls & wlLine %~ mvPs (ex,ey)
 
 zoneps :: (Point2, Point2) -> [(Int,Int)]
+{-# INLINE zoneps #-}
 zoneps (a,b)
-    | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
+    | dist a b <= 2 * zoneSize 
-    | otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b
+                = [zoneOfPoint $ pHalf a b]
+    | otherwise = map zoneOfPoint $ divideLine zoneSize a b
 
 doorMechan 
     :: Int
@@ -35,15 +44,28 @@ doorMechan
     -> World 
     -> World
 doorMechan n zonePs openEff closeEff cond w
-    | cond w = flip (foldr $ changeZonedWall'' openEff n) zonePs
+    | cond w = flip (foldr $ changeZonedWall openEff n) zonePs
                 $ over walls (IM.adjust openEff n) w
-    | otherwise = flip (foldr $ changeZonedWall'' closeEff n) zonePs
+    | otherwise = flip (foldr $ changeZonedWall closeEff n) zonePs
                 $ over walls (IM.adjust closeEff n) w
 
-changeZonedWall''
+changeZonedWall
     :: (Wall -> Wall)
     -> Int
     -> (Int,Int)
     -> World
     -> World
-changeZonedWall'' eff n (x,y) = over wallsZone $ adjustIMZone eff x y n
+changeZonedWall eff n (x,y) = over wallsZone $ adjustIMZone eff x y n
+
+addSoundToDoor :: Int -> Point2 -> Point2 -> [Wall] -> [Wall]
+addSoundToDoor _ _   _   [] = error "When creating door tried to add sound to nothing"
+addSoundToDoor i pld hwd (x:ys) = f x : ys
+  where
+    f wl = over doorMech g wl
+      where
+        g dm w 
+            | dist wp pld > 2 && dist wp hwd > 2 
+                        = soundFrom (WallSound i) (fromIntegral doorSound) 1 0 $ dm w
+            | otherwise = dm w
+          where 
+            wp = snd $ _wlLine (_walls w IM.! i)

src/Dodge/LevelGen/TriggerDoor.hs

@@ -1,14 +1,17 @@
 --{-# LANGUAGE BangPatterns #-}
 module Dodge.LevelGen.TriggerDoor
-    where
+    ( putDoor
+    , putDoubleDoor
+    , addButtonDoor
+    , addSwitchDoor
+    ) where
 import Dodge.Data
 import Dodge.Base
 import Dodge.Base.Zone
-import Dodge.SoundLogic
-import Dodge.SoundLogic.Synonyms
 import Dodge.LevelGen.Switch
 import Dodge.LevelGen.Pathing
 import Dodge.LevelGen.MoveDoor
+import Dodge.LevelGen.DoorPane
 import Picture
 import Geometry
 import qualified DoubleStack as DS
@@ -37,7 +40,6 @@ addButtonDoor c btp btr a b w = over buttons (IM.insert bid bt)
     eff w' = over pathGraph' (removedPairs ++) 
              . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
     f (x,y) = (x,y,dist x y)
-
 -- this has been repeated at least three times: TO BE UNIFIED, REFACTORED
 addSwitchDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> World -> World
 addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt) 
@@ -59,10 +61,9 @@ addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt)
     closeDoor w' = over pathGraph' (\\ removedPairs)
                   . over pathGraph (flip run_ $ delMapEdgesM removedPairs) $ w'
 
-
 putDoor 
     :: Color 
-    -> (World -> Bool) 
+    -> (World -> Bool)      -- ^ Opening condition
     -> [(Point2,Point2)]   -- ^ Door positions, closed to open.
                     -- Bumped out up and down by 9, not widened
     -> World 
@@ -76,7 +77,7 @@ putDoor c cond pss = over walls triggerDoor
 putDoubleDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> World -> World
 putDoubleDoor c cond a b = over walls triggerDoubleDoor
   where
-    triggerDoubleDoor wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoubleDoor c cond a b is
+    triggerDoubleDoor wls = IM.union wls $ IM.fromList $ zip is $ mkDoubleDoor c False cond a b is
       where
         is = [IM.newKey wls..]
 
@@ -98,76 +99,14 @@ toPanePoints (x,y) =
     ]
   where
     perp = 9 *.* errorNormalizeV 49 ( vNormal (x -.- y))
-
-mkTriggerDoubleDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> [Int] -> [Wall]
-mkTriggerDoubleDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPaneLinear c cond)
-    xs
-    (leftDoor ++ rightDoor)
-    (map shiftLeft leftDoor ++ map shiftRight rightDoor)
-  where 
-    leftDoor = 
-        [ (pld +.+ perp,hwd)
-        , (hwd,         hwu)
-        , (hwu,         plu +.+ perp)
-        , (plu +.+ perp,pld +.+ perp)
-        ]
-    rightDoor =
-        [ (pru -.- perp,hwu)
-        , (hwu,         hwd)
-        , (hwd,         prd -.- perp)
-        , (prd -.- perp,pru -.- perp)
-        ]
-    shiftRight = h (+.+ (0.5 *.* (pr -.- pl)))
-    shiftLeft = h (+.+ (0.5 *.* (pl -.- pr)))
-    h func (x,y) = (func x,func y)
-    norm = 9 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
-    hw = 0.5 *.* (pl +.+ pr)
-    perp = 5 *.* normalizeV (pl -.- pr)
-    plu = pl +.+ norm
-    pld = pl -.- norm
-    pru = pr +.+ norm
-    prd = pr -.- norm
-    hwu = hw +.+ norm
-    hwd = hw -.- norm
-    addSound (x:ys) = f x : ys
-    addSound _ = error "When creating a trigger door, added a sound to nothing"
-    f wl = over doorMech g wl
-    g dm w 
-        | dist wp pld > 2 && dist wp hwd > 2 
-                    = soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0 $ dm w
-        | otherwise = dm w
-      where 
-        wp = snd $ _wlLine (_walls w IM.! head xs)
-
-triggerDoorPaneLinear
-    :: Color 
-    -> (World -> Bool)  -- ^ Opening condition
-    -> Int              -- ^ Wall id
-    -> (Point2,Point2)         -- ^ Closed position
-    -> (Point2,Point2)         -- ^ Open position
-    -> Wall
-triggerDoorPaneLinear c cond n closedPos openPos = Door
-    { _wlLine = closedPos
-    , _wlID = n
-    , _doorMech = dm
-    , _wlColor = c
-    , _wlSeen = False
-    , _wlIsSeeThrough = False
-    , _doorPathable = False
-    , _drPositions = DS.singleton closedPos
-    }
-  where 
-    dm = doorMechan n (zoneps closedPos) openDoor closeDoor cond 
-    openDoor = moveDoorToward openPos
-    closeDoor = moveDoorToward closedPos
 {- |
 Zoning might be an issue here.
 It is necessary in the current version, but I am not sure of its behaviour. -}
 triggerDoorPane
     :: Color 
-    -> (World -> Bool)  -- ^ Opening condition
+    -> (World -> Bool)      -- ^ Opening condition
-    -> Int              -- ^ Wall id
+    -> Int                  -- ^ Wall id
-    -> [(Point2,Point2)]       -- ^ List of positions: closed to open
+    -> [(Point2,Point2)]    -- ^ List of positions: closed to open
     -> Wall
 triggerDoorPane c cond n poss = Door
     { _wlLine = head poss