Allow for door destruction

src/Dodge/Base/Collide.hs

@@ -366,15 +366,18 @@ collidePointAnyWallsReflect p1 p2
 -- If found, gives collision point
 -- If not found, returns point
 collidePointWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
+{-# INLINE collidePointWalls #-}
 collidePointWalls p1 p2 = foldr findPoint p2 . fmap _wlLine
   where
     findPoint (x,y) p = fromMaybe p $ intersectSegSeg p1 p x y
 collidePointWalls' :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
+{-# INLINE collidePointWalls' #-}
 collidePointWalls' p1 p2 = foldl' findPoint p2 . fmap _wlLine
   where
     findPoint p = fromMaybe p . uncurry (intersectSegSeg p1 p)
 
 collidePointWallsFilt' :: (Wall -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> Point2
+{-# INLINE collidePointWallsFilt' #-}
 collidePointWallsFilt' t p1 p2 = collidePointWalls p1 p2 . IM.filter t
 
 -- | Looks for first collision of a circle with walls.

src/Dodge/Block.hs

@@ -62,3 +62,15 @@ destroyBlock bl w = w
     awl = _walls w IM.! IS.findMin wlids
     pos = fst . _wlLine $ _walls w IM.! IS.findMin wlids
     ps = replicateM 25 (randInCirc 20) & evalState $ _randGen w
+
+destroyDoor :: Door -> World -> World
+destroyDoor dr w = w
+    & _drDeath dr dr
+    & deleteWallIDs wlids
+    & doors %~ IM.delete (_drID dr)
+    & flip (foldr (wlDustAt awl)) (map (pos +.+) ps)
+  where
+    wlids = _drWallIDs dr
+    awl = _walls w IM.! IS.findMin wlids
+    pos = fst . _wlLine $ _walls w IM.! IS.findMin wlids
+    ps = replicateM 25 (randInCirc 20) & evalState $ _randGen w

src/Dodge/Block/Debris.hs

@@ -75,26 +75,16 @@ dirtColor :: Color
 dirtColor = V4 (150/256) ( 75/256)  0 ( 250/256)
 
 glassDebris :: Prop
-glassDebris = PropZ
+glassDebris = stoneDebris
-    {_prPos = 0
+    & prDraw    .~ (\pr -> drawMovingShape pr (shardShape 4 pr))
-    ,_pjStartPos = 0
+    & pjUpdate  .~ fallSmallBounce
-    ,_pjVel = 0
+    & pjColor   .~ withAlpha 0.5 cyan
-    ,_prDraw = \pr -> drawMovingShape pr (shardShape 4 pr)
-    ,_pjID = 0
-    ,_pjUpdate = fallSmallBounce
-    ,_pjPosZ = 10
-    ,_pjVelZ = 5
-    ,_pjTimer = 20
-    ,_pjQuat = Q.axisAngle (V3 1 0 0) 0
-    ,_pjQuatSpin = Q.axisAngle (V3 1 1 0) 0.1
-    ,_pjColor = withAlpha 0.5 cyan
-    }
 crystalDebris :: Prop
 crystalDebris = glassDebris
     & pjColor .~ withAlpha 0.5 aquamarine
 
 shardShape :: Float -> Prop -> Shape
-shardShape size pr = colorSH (_pjColor pr) . translateSHz (-size) $ upperPrismPoly size $ 
+shardShape size pr = colorSH (_pjColor pr) . translateSHz (-size) $ upperPrismPoly size
     [V2 size 0
     ,V2 (-size) 1
     ,V2 (-size) (-1)

src/Dodge/Creature/Action.hs

@@ -318,4 +318,5 @@ pickUpItemID cid flid w = pickUpItem cid (_floorItems w IM.! flid) w
 {- | Pick up a specific item. -}
 pickUpItem :: Int -> FloorItem -> World -> World
 pickUpItem cid flit w = maybe w (soundStart (CrSound cid) (_flItPos flit) pickUpS Nothing)
+    . fmap snd
     $ tryPutItemInInv cid flit w

src/Dodge/CullBox.hs

@@ -15,7 +15,7 @@ cullBox :: Configuration -> World -> [Point2]
 --cullBox cfig w = farWallPoints cp w
 cullBox cfig w' 
     | debugOn Bound_box_screen cfig = screenPolygon cfig w'
-    | otherwise = let (n,s,e,w) = farWallDistDirection (_cameraCenter w') cfig w'
+    | otherwise = let (n,s,e,w) = farWallDistDirection (_cameraCenter w') w'
             in map ((+.+ _cameraCenter w') . rotateV (_cameraRot w') ) $ rectNSWE n (negate s) (negate w) e
 --    --mapMaybe (fmap (fst . _wlLine . snd) . f) $ screenPolygon cfig w
 --  where

src/Dodge/Data.hs

@@ -1012,6 +1012,8 @@ data Door = Door
     , _drPos :: (Point2,Point2)
     , _drOpenPos :: (Point2,Point2)
     , _drClosePos :: (Point2,Point2)
+    , _drHP     :: Int
+    , _drDeath  :: Door -> World -> World
     }
 data DoorStatus = DoorOpen | DoorClosed | DoorHalfway | DoorInt Int
   deriving (Eq, Ord, Show)

src/Dodge/Debug/Terminal.hs

@@ -62,7 +62,7 @@ applyTerminalCommandArguments :: String -> [String] -> Universe -> Universe
 applyTerminalCommandArguments command args u = case command of
     "ITEM" -> fromMaybe u $ do
         ibt <- safeHead args >>= readMaybe 
-        return $ u & uvWorld %~ createPutItem (itemFromBase ibt)
+        return $ u & uvWorld %~ (snd . createPutItem (itemFromBase ibt))
     _ -> u
 
 showTerminalError :: String -> String -> Universe -> Universe

src/Dodge/Default/Door.hs

@@ -0,0 +1,17 @@
+module Dodge.Default.Door where
+import Dodge.Data
+
+defaultDoor :: Door
+defaultDoor = Door
+    { _drID = 0
+    , _drWallIDs = mempty
+    , _drStatus = DoorClosed
+    , _drTrigger = const False
+    , _drMech   = const id
+    , _drPos = (0,0)
+    , _drOpenPos = (0,0)
+    , _drClosePos = (0,0)
+    , _drHP     = 10000
+    , _drDeath  = const id
+    }
+

src/Dodge/Event.hs

@@ -101,21 +101,26 @@ handlePressedMouseButton but w = case (_hudElement (_hud w), but) of
         | inTermFocus w -> doTerminalEffectLB (w ^?! terminals . ix tmid) w
         | otherwise -> w & terminals . ix tmid . tmInput . tiFocus %~ const True
     ( DisplayInventory (CombineInventory mi) , ButtonLeft)
-                -> maybe (hud . hudElement .~ DisplayInventory NoSubInventory) doCombine mi w
+                -> maybeexitcombine $ maybe id doCombine mi w
     _ -> w
+  where
+    maybeexitcombine
+        | ButtonRight `S.member` _mouseButtons w = id
+        | otherwise = hud . hudElement .~ DisplayInventory NoSubInventory
 
 -- note "sort" on the inventory indices; otherwise
 -- lower items may be shifted up and items below these removed instead
 doCombine :: Int -> World -> World
 doCombine i w = case combineItemListYou w !? i of
     Nothing -> w
-    Just (is,it) -> enterCombineInv
+    Just (is,it) -> -- set (hud . hudElement) (DisplayInventory NoSubInventory)
+        selectinv --enterCombineInv
         . createPutItem it
---        . uncurry (putItemInInvID yid)
---        . copyItemToFloorID (_crPos $ you w) (applyModules it)
         $ foldr (rmInvItem yid) w (sort is)
   where
     yid = _yourID w
+    selectinv (Just i', w') = w' & creatures . ix yid . crInvSel .~ i'
+    selectinv (Nothing, w') = w'
 
 
 handleMouseWheelEvent :: MouseWheelEventData -> Universe -> Maybe Universe

src/Dodge/Inventory/Add.hs

@@ -9,21 +9,23 @@ import Data.Maybe
 import Control.Lens
 import qualified Data.IntMap.Strict as IM
 
-putItemInInvID :: Int -> Int -> World -> World
+putItemInInvID :: Int -> Int -> World -> (Maybe Int,World)
-putItemInInvID cid flid w = fromMaybe w
+putItemInInvID cid flid w = fromMaybe (Nothing,w) $ do
-    $ tryPutItemInInv cid (_floorItems w IM.! flid) w
+    (i,w') <- tryPutItemInInv cid (_floorItems w IM.! flid) w
+    return (Just i,w')
 
 putItemInInvSlot :: Int -> Item -> IM.IntMap Item -> IM.IntMap Item
 putItemInInvSlot = IM.insertWith (const $ itConsumption . icAmount +~ 1)
 
 {- | Pick up a specific item. -}
-tryPutItemInInv :: Int -> FloorItem -> World -> Maybe World
+tryPutItemInInv :: Int -> FloorItem -> World -> Maybe (Int,World)
 tryPutItemInInv cid flit w = case maybeInvSlot of
     Nothing -> Nothing
-    Just i  -> Just $ w
+    Just i  -> Just (i, w
         & updateItLocation i
         & floorItems %~ IM.delete (_flItID flit)
         & creatures . ix cid . crInv %~ putItemInInvSlot i it
+        )
   where 
     it = _flIt flit
     maybeInvSlot = checkInvSlotsYou it w
@@ -45,6 +47,6 @@ tryPutItemInInv cid flit w = case maybeInvSlot of
 --    updateItLocation invid w' = case _itID it of 
 --        Nothing -> w'
 --        Just j  -> w' & itemPositions . ix j .~ InInv cid invid
-createPutItem :: Item -> World -> World
+createPutItem :: Item -> World -> (Maybe Int, World)
 createPutItem it w = uncurry (putItemInInvID (_yourID w))
     $ copyItemToFloorID (_crPos $ you w) (applyModules it) w

src/Dodge/Placement/PlaceSpot/TriggerDoor.hs

@@ -5,6 +5,7 @@ module Dodge.Placement.PlaceSpot.TriggerDoor
     ) where
 import Dodge.Data
 import Dodge.Default.Wall
+import Dodge.Default.Door
 import Dodge.Wall.Move
 import Dodge.LevelGen.DoorPane
 import Picture
@@ -26,7 +27,7 @@ plDoor :: Color
 plDoor col cond pss gw = (drid, addWalls gw & doors %~ addDoor)
   where
     drid = IM.newKey $ _doors gw
-    addDoor = IM.insert drid $ Door
+    addDoor = IM.insert drid $ defaultDoor
         { _drID = drid
         , _drWallIDs = IS.fromList wlids
         , _drStatus = DoorInt 0
@@ -39,16 +40,15 @@ plDoor col cond pss gw = (drid, addWalls gw & doors %~ addDoor)
     nsteps = length pss - 1
     wlids = take 4 [IM.newKey $ _walls gw ..]
     wlps' = uncurry (rectanglePairs 9) $ head pss
-    addWalls w' = foldl' (addDoorWall col False) w' $ zip wlids wlps'
+    addWalls w' = foldl' (addDoorWall drid col False) w' $ zip wlids wlps'
 
-addDoorWall :: Color -> Bool -> World -> (Int,(Point2,Point2)) -> World
+addDoorWall :: Int -> Color -> Bool -> World -> (Int,(Point2,Point2)) -> World
-addDoorWall col pathableStatus w (wlid,wlps) = w & walls %~ IM.insert wlid defaultWall
+addDoorWall drid col pathableStatus w (wlid,wlps) = w & walls %~ IM.insert wlid defaultWall
     { _wlLine = wlps
     , _wlID = wlid
     , _wlColor = col
-    , _wlSeen = False
-    , _wlOpacity = Opaque
     , _wlPathable = pathableStatus
+    , _wlStructure = DoorPart drid
     }
 -- TODO use vector instead of list, perhaps also memoisation of rectanglePairs
 -- TODO update _drPos
@@ -108,10 +108,10 @@ plSlideDoor
     -> World
     -> (Int, World)
 plSlideDoor isPathable col cond shiftOffset a b speed gw 
-    = (drid, addWalls gw & doors %~ addDoor)
+    = (drid, addDoorWalls gw & doors %~ addDoor)
   where
     drid = IM.newKey $ _doors gw
-    addDoor = IM.insert drid $ Door
+    addDoor = IM.insert drid $ defaultDoor
         { _drID = drid
         , _drWallIDs = IS.fromList wlids
         , _drStatus = DoorClosed
@@ -121,7 +121,7 @@ plSlideDoor isPathable col cond shiftOffset a b speed gw
         , _drOpenPos = (shiftLeft a,shiftLeft b)
         , _drClosePos = (a,b)
         }
-    addWalls w' = foldl' (addDoorWall col isPathable) w' $ zip wlids pairs
+    addDoorWalls w' = foldl' (addDoorWall drid col isPathable) w' $ zip wlids pairs
     pairs = rectanglePairs 9 a b
     shiftedPairs = map (bimap shiftLeft shiftLeft) pairs
     shiftLeft  = (+.+ (a -.- b +.+ shiftOffset *.* normalizeV (b -.- a)))

src/Dodge/Update/Camera.hs

@@ -18,6 +18,7 @@ import LensHelp
 
 --import qualified Data.List.NonEmpty as NEL
 --import Control.Applicative
+import Data.Foldable
 import Data.Maybe
 import Control.Monad
 import qualified Data.Set as S
@@ -206,16 +207,16 @@ farWallDist p cfig w = (winFac /)
     wos = wallsOnScreen cfig w
     distFromEqmnt = foldr max 1 $ IM.mapMaybe (_eqViewDist . _eqEq. _itUse) $ getCrEquipment $ you w
 
-farWallDistDirection :: Point2 -> Configuration -> World -> (Float,Float,Float,Float)
+farWallDistDirection :: Point2 -> World -> (Float,Float,Float,Float)
---farWallDist p cfig w = (winFac /) . min maxViewDistance $ ssfold (> maxViewDistance) findMax 1 vps
+farWallDistDirection p w = foldl' (flip (m . f)) (0,0,0,0) vps
-farWallDistDirection p cfig w = foldr (m . f) (0,0,0,0) vps
   where
-    f q = g $ rotateV (negate $ _cameraRot w) $ collidePointWallsFilt' wlIsOpaque p q wos -.- p
+    --f q = g $ rotateV (negate $ _cameraRot w) $ collidePointWallsFilt' wlIsOpaque p q wos -.- p
+    f q = g $ rotateV (negate $ _cameraRot w) 
+        $ collidePointWallsFilt' wlIsOpaque p q (wallsAlongLine p q w) -.- p
     g (V2 x y) = (y, negate y, x, negate x)
     m (a,b,c,d) (x,y,z,w') = (max a x, max b y, max c z, max d w')
     vps = concatMap _grViewpoints grs ++ extendedViewPoints p grs
     grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w)
-    wos = wallsOnScreen cfig w
 
 extendedViewPoints :: Point2 -> [GameRoom] -> [Point2]
 extendedViewPoints p grs = map extend 

src/Dodge/Wall/Damage.hs

@@ -16,6 +16,8 @@ damageWall dt wl w = case _wlStructure wl of
         & machines . ix mcid . mcDamage .:~ dt
     BlockPart blid   -> let (w',x) = defaultWallDamage dt wl w
         in w' & blocks . ix blid . blHP -~ x & maybeDestroyBlock blid
+    DoorPart drid   -> let (w',x) = defaultWallDamage dt wl w
+        in w' & doors . ix drid . drHP -~ x & maybeDestroyDoor drid
     _   -> fst $ defaultWallDamage dt wl w
 
 -- block destruction is convoluted...
@@ -24,6 +26,11 @@ maybeDestroyBlock blid w = case w ^? blocks . ix blid of
     Just bl | _blHP bl < 1 -> destroyBlock bl w 
     _ -> w
 
+maybeDestroyDoor :: Int -> World -> World
+maybeDestroyDoor drid w = case w ^? doors . ix drid of
+    Just dr | _drHP dr < 1 -> destroyDoor dr w 
+    _ -> w
+
 damageBlocksBy :: Int -> Wall -> World -> World
 damageBlocksBy x wl = case wl ^? wlStructure . wsBlock of
     Just blid -> blocks . ix blid . blHP -~ x

src/Picture.hs

@@ -55,7 +55,7 @@ polygonWire :: [Point2] -> Picture
 {-# INLINE polygonWire #-}
 polygonWire ps = line (ps ++ [head ps])
 
--- need to check the winding!
+-- | Expects clockwise input.
 polygon :: [Point2] -> Picture
 {-# INLINE polygon #-}
 polygon = map f . polyToTris