Refactor doors

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
-    -> Int              -- ^ Wall id
-    -> [(Point2,Point2)]       -- ^ List of positions: closed to open
+    -> (World -> Bool)      -- ^ Opening condition
+    -> Int                  -- ^ Wall id
+    -> [(Point2,Point2)]    -- ^ List of positions: closed to open
     -> Wall
 triggerDoorPane c cond n poss = Door
     { _wlLine = head poss