Fix long door bug.

src/Dodge/Creature/State.hs

@@ -82,7 +82,7 @@ crFriction _ _ = V2 0 0
 
 doDamage :: Creature -> Creature
 doDamage cr = set (crState . crDamage) [] 
-    $ over (crState . crPastDamage) (forceFoldable . take 20 . (dams :) ) damagedCr
+    $ over (crState . crPastDamage) (forceFoldable . take 10 . (dams :) ) damagedCr
   where 
     dams = _crDamage $ _crState cr
     damagedCr = snd $ _crApplyDamage cr dams cr

src/Dodge/LevelGen.hs

@@ -81,6 +81,7 @@ placeSpot ps w = case _psType ps of
       where 
         mapBoth fn (x,y) = (fn x, fn y) 
     PutDoubleDoor col f a b -> putDoubleDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
+    PutSingleDoor col f a b -> putSingleDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
     PutAutoDoor a b -> addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
     PutBlock (hp:hps) col ps' -> putBlock (map (shiftPointBy (p,rot)) ps') hp col False hps w
     PutBlock{} -> error "messed up block placement somehow"

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)

src/Dodge/Room/LongDoor.hs

@@ -42,8 +42,10 @@ twinSlowDoorRoom drID w h x = defaultRoom
         [ sPS (V2 0 (h/2)) 0 putLamp
         , sPS (V2 25 5) 0 putLamp
         , sPS (V2 (negate 25) 5) 0 putLamp
-        , sPS (V2 0 0) 0 $ PutDoor col (not . cond) drL
-        , sPS (V2 0 0) 0 $ PutDoor col (not . cond) drR
+        --, sPS (V2 0 0) 0 $ PutDoor col (not . cond) drL
+        --, sPS (V2 0 0) 0 $ PutDoor col (not . cond) drR
+        , sPS (V2 0 0) 0 $ PutSingleDoor col cond (V2   x  0) (V2   x  h)
+        , sPS (V2 0 0) 0 $ PutSingleDoor col cond (V2 (-x) 0) (V2 (-x) h)
         , sPS (V2 0 (h-5)) pi $ PutButton $ makeButton col 
             (over worldState (M.insert (DoorNumOpen drID) True))
         ]

src/DoubleStack.hs

@@ -3,7 +3,6 @@ module DoubleStack
 
 newtype DS a = DS (a,[a],[a])
     deriving (Eq, Ord, Read, Show)
-
 {- |
 Unsafe. -}
 fromListL :: [a] -> DS a