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 Geometry
+--import Dodge.LevelGen.MoveDoor
+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 = [i..]
+    is = [IM.newKey wls..]
 
 mkAutoDoor 
     :: Point2   -- ^ Left point
     -> Point2   -- ^ Right point (though the two points should be symmetric)
     -> [Int]    -- ^ Wall ids
     -> [Wall]
-mkAutoDoor pl pr xs = addSound 
-    $ zipWith3 (autoDoorPane (pl,pr))
-                xs
-                (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
+mkAutoDoor pl pr = mkDoubleDoor (dim yellow) True cond pl pr
+  where
+    cond = any (crNearSeg 40 pl pr) . IM.filter isAnimate . _creatures