Fix long door bug.

src/Dodge/LevelGen/Data.hs

@@ -19,6 +19,7 @@ data PSType = PutCrit {_unPutCrit :: Creature}
     | PutLineBlock Wall Float Float Point2 Point2
     | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
     | PutDoubleDoor Color (World -> Bool) Point2 Point2
+    | PutSingleDoor Color (World -> Bool) Point2 Point2
     | PutDoor Color (World -> Bool) [(Point2,Point2)]
     | PutBtDoor Color Point2 Float Point2 Point2
     | PutSwitchDoor Color Point2 Float Point2 Point2

src/Dodge/LevelGen/DoorPane.hs

@@ -1,6 +1,7 @@
 module Dodge.LevelGen.DoorPane
     ( linearPane
     , mkDoubleDoor
+    , mkSingleDoor
     ) where
 import Dodge.Data
 import Dodge.LevelGen.MoveDoor
@@ -33,6 +34,28 @@ linearPane c isPathable cond n closedPos openPos = Door
     openDoor = moveDoorToward openPos
     closeDoor = moveDoorToward 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)
+  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
+    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)

src/Dodge/LevelGen/TriggerDoor.hs

@@ -2,6 +2,7 @@
 module Dodge.LevelGen.TriggerDoor
     ( putDoor
     , putDoubleDoor
+    , putSingleDoor
     , addButtonDoor
     , addSwitchDoor
     ) where
@@ -81,16 +82,25 @@ putDoubleDoor c cond a b = over walls triggerDoubleDoor
       where
         is = [IM.newKey wls..]
 
+putSingleDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> World -> World
+putSingleDoor c cond a b = over walls putTheDoor
+  where
+    putTheDoor wls = IM.union wls $ IM.fromList $ zip is $ mkSingleDoor c False cond a b is
+      where
+        is = [IM.newKey wls..]
+
 mkTriggerDoor 
     :: Color 
     -> (World -> Bool)      -- ^ Opening condition
     -> [(Point2,Point2)]    -- ^ List of wall position pairs, closed to open
     -> [Int]                -- ^ Wall ids
     -> [Wall]
+{-# INLINE mkTriggerDoor #-}
 mkTriggerDoor c cond ppairs is = zipWith (triggerDoorPane c cond) is $
     transpose $ map toPanePoints ppairs
 
 toPanePoints :: (Point2,Point2) -> [(Point2,Point2)]
+{-# INLINE toPanePoints #-}
 toPanePoints (x,y) = 
     [ (y +.+ perp, y -.- perp)
     , (y -.- perp, x -.- perp)