Add variable door speed, still buggy

src/Dodge/LevelGen/DoorPane.hs

@@ -9,17 +9,20 @@ import Picture
 import qualified DoubleStack as DS
 import Geometry.Vector
 
+import Data.Bifunctor
+
 -- | A door pane that moves linearly between open and closed positions using a
 -- boolean trigger.
 linearPane 
     :: Color 
     -> Bool             -- ^ Pathable flag
     -> (World -> Bool)  -- ^ Opening condition
+    -> Float            -- ^ speed
     -> Int              -- ^ Wall id
     -> (Point2,Point2)  -- ^ Closed position
     -> (Point2,Point2)  -- ^ Open position
     -> Wall
-linearPane c isPathable cond n closedPos openPos = Door
+linearPane c isPathable cond speed n closedPos openPos = Door
     { _wlLine = closedPos
     , _wlID = n
     , _doorMech = dm
@@ -31,34 +34,40 @@ linearPane c isPathable cond n closedPos openPos = Door
     }
   where 
     dm = doorMechan n (zoneps closedPos) openDoor closeDoor cond 
-    openDoor = moveDoorToward openPos
-    closeDoor = moveDoorToward closedPos
+    openDoor  = moveDoorToward speed openPos
+    closeDoor = moveDoorToward speed closedPos
 
-mkSingleDoor :: Color -> Bool -> (World -> Bool) -> Point2 -> Point2 -> [Int] -> [Wall]
-mkSingleDoor c isPathable cond pl hw is 
-    = addSoundToDoor (head is) pld hwd $ zipWith3 (linearPane c isPathable cond)
-    is
-    leftDoor
-    (map shiftLeft leftDoor)
+rectanglePairs :: Float -> Point2 -> Point2 -> [(Point2,Point2)]
+rectanglePairs wdth a b =
+    [ (aup, ad)
+    , (ad, bd)
+    , (bd, bu)
+    , (bu, aup)
+    ]
+  where
+    aup = a +.+ norm
+    ad = a -.- norm
+    bu = b +.+ norm
+    bd = b -.- norm
+    norm = wdth *.* normalizeV ( vNormal (b -.- a))
+
+mkSingleDoor :: Color -> Bool -> (World -> Bool) -> Point2 -> Point2 -> Float -> [Int] -> [Wall]
+mkSingleDoor c isPathable cond hingep hw speed is 
+    = addSoundToDoor (head is) pld hwd 
+    $ zipWith3 (linearPane c isPathable cond speed)
+        is
+        theDoor
+        (map (bimap shiftLeft shiftLeft) theDoor)
   where 
-    leftDoor = 
-        [ (pld +.+ perp,hwd)
-        , (hwd,         hwu)
-        , (hwu,         plu +.+ perp)
-        , (plu +.+ perp,pld +.+ perp)
-        ]
-    shiftLeft  = h (+.+ (pl -.- hw))
-    h func (x,y) = (func x,func y)
-    norm = 9 *.* normalizeV ( vNormal (hw -.- pl))
-    perp = 5 *.* normalizeV (pl -.- hw)
-    plu = pl +.+ norm
-    pld = pl -.- norm
-    hwu = hw +.+ norm
+    theDoor = rectanglePairs 9 hingep hw
+    shiftLeft  = (+.+ (hingep -.- hw))
+    norm = 9 *.* normalizeV ( vNormal (hw -.- hingep))
+    pld = hingep -.- norm
     hwd = hw -.- norm
 
-mkDoubleDoor :: Color -> Bool -> (World -> Bool) -> Point2 -> Point2 -> [Int] -> [Wall]
-mkDoubleDoor c isPathable cond pl pr is 
-    = addSoundToDoor (head is) pld hwd $ zipWith3 (linearPane c isPathable cond)
+mkDoubleDoor :: Color -> Bool -> (World -> Bool) -> Point2 -> Point2 -> Float -> [Int] -> [Wall]
+mkDoubleDoor c isPathable cond pl pr speed is 
+    = addSoundToDoor (head is) pld hwd $ zipWith3 (linearPane c isPathable cond speed)
     is
     (leftDoor ++ rightDoor)
     (map shiftLeft leftDoor ++ map shiftRight rightDoor)