Make crytal walls destructible by shatterGun

src/Dodge/Block.hs

@@ -34,6 +34,7 @@ matSplintSound :: BlockMaterial -> Point2 -> World -> World
 matSplintSound mat = case mat of
     GlassBlock -> mkSoundSplinterGlass
     StoneBlock -> mkSoundSplinterBlock
+    CrystalBlock -> mkSoundSplinterBlock
     DirtBlock  -> originIDsAt (BlockDegradeSound 1) [impact1S,impact3S]
     WoodBlock  -> originIDsAt (BlockDegradeSound 1) [impact1S,impact2S,impact3S]
     MetalBlock -> originIDsAt (BlockDegradeSound 1) [impact2S,impact3S]

src/Dodge/Block/Debris.hs

@@ -16,33 +16,38 @@ import qualified Quaternion as Q
 --import Data.List (zip4)
 
 makeBlockDebris :: Block -> World -> World
-makeBlockDebris bl = makeDebris (greyN 0.5) (_blMaterial bl) (_blPos bl)
+makeBlockDebris bl = makeDebris (_blMaterial bl) (_blPos bl)
 
-makeDebris :: Color -> BlockMaterial -> Point2 -> World -> World
+makeDebris :: BlockMaterial -> Point2 -> World -> World
 makeDebris = makeDebrisDirected 1 2 (2*pi) 0
-
 makeDebrisDirected :: Float -> Float 
-    -> Float -> Float -> Color -> BlockMaterial -> Point2 -> World -> World
+    -> Float -> Float -> BlockMaterial -> Point2 -> World -> World
-makeDebrisDirected mindist maxdist arcrad dir col bm p w = w
+makeDebrisDirected mindist maxdist arcrad dir bm p w = w
-    & flip (foldr (plNew props pjID)) thedebris
+        & flip (foldr (plNew props pjID)) thedebris
-    & randGen .~ newg
+        & randGen .~ newg
-    & matDesSound bm p
+        & matDesSound bm p
   where
+    someDebris = case bm of
+        StoneBlock -> stoneDebris
+        GlassBlock -> glassDebris
+        CrystalBlock -> crystalDebris
+        DirtBlock   -> dirtDebris
+        WoodBlock   -> stoneDebris
+        MetalBlock  -> stoneDebris
     (thedebris,newg) = runState (mapM f [35,55..95]) $ _randGen w
     f h = do
         v <- rotateV (dir - arcrad/2) <$> randInArcStrip mindist maxdist arcrad
         q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere
         return $ someDebris
             & prPos .~ p
-            & pjColor .~ col
             & pjVel .~ v
             & pjQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1)
             & pjQuat .~ q
             & pjVelZ .~ 0
             & pjPosZ .~ h
 
-someDebris :: Prop
+stoneDebris :: Prop
-someDebris = PropZ
+stoneDebris = PropZ
     {_prPos = 0
     ,_pjStartPos = 0
     ,_pjVel = 0
@@ -54,14 +59,40 @@ someDebris = PropZ
     ,_pjTimer = 20
     ,_pjQuat = Q.axisAngle (V3 1 0 0) 0
     ,_pjQuatSpin = Q.axisAngle (V3 1 1 0) 0.1
-    ,_pjColor = white
+    ,_pjColor = greyN 0.5
     }
+dirtDebris :: Prop
+dirtDebris = stoneDebris
+    & pjColor .~ dirtColor
+    & pjUpdate .~ fallSmallBounce
+dirtColor :: Color
+dirtColor = V4 (150/256) ( 75/256)  0 ( 250/256)
+
+glassDebris :: Prop
+glassDebris = PropZ
+    {_prPos = 0
+    ,_pjStartPos = 0
+    ,_pjVel = 0
+    ,_prDraw = \pr -> drawMovingShape pr (debrisShape 2 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
 debrisShape :: Float -> Prop -> Shape
 debrisShape size pr = colorSH (_pjColor pr) . translateSHz (-size) $ upperPrismPoly 8 $ square size
 
 matDesSound :: BlockMaterial -> Point2 -> World -> World
 matDesSound mat = case mat of
     GlassBlock -> mkSoundBreakGlass
+    CrystalBlock -> mkSoundBreakGlass -- this should be more crunchy
     StoneBlock -> mkSoundSplinterBlock
     DirtBlock  -> originIDsAt (BlockDegradeSound 1) [impact1S,impact3S]
     WoodBlock  -> originIDsAt (BlockDegradeSound 1) [impact1S,impact2S,impact3S]

src/Dodge/Data.hs

@@ -929,6 +929,7 @@ data Block = Block
     , _blDeath      :: Block -> World -> World
     }
 data BlockMaterial = WoodBlock | DirtBlock | StoneBlock | GlassBlock | MetalBlock
+    | CrystalBlock
 data TerminalStatus = TerminalOff | TerminalBusy | TerminalReady
   deriving (Eq,Ord,Show)
 data TerminalInput = TerminalInput
@@ -1016,21 +1017,22 @@ data Door = Door
 data DoorStatus = DoorOpen | DoorClosed | DoorHalfway | DoorInt Int
   deriving (Eq, Ord, Show)
 data Wall = Wall 
-    { _wlLine       :: (Point2,Point2) 
+    { _wlLine           :: (Point2,Point2) 
-    , _wlID         :: Int 
+    , _wlID             :: Int
-    , _wlColor      :: Color
+    , _wlColor          :: Color
-    , _wlSeen       :: Bool
+    , _wlSeen           :: Bool
-    , _wlOpacity    :: Opacity
+    , _wlOpacity        :: Opacity
-    , _wlPathable   :: Bool
+    , _wlPathable       :: Bool
-    , _wlWalkable   :: Bool
+    , _wlWalkable       :: Bool
-    , _wlTouchThrough :: Bool
+    , _wlTouchThrough   :: Bool
-    , _wlFireThrough :: Bool
+    , _wlFireThrough    :: Bool
-    , _wlReflect    :: Bool
+    , _wlReflect        :: Bool
-    , _wlDraw       :: Bool
+    , _wlDraw           :: Bool
-    , _wlRotateTo   :: Bool
+    , _wlRotateTo       :: Bool
-    , _wlStructure  :: WallStructure
+    , _wlStructure      :: WallStructure
-    , _wlHeight     :: Float
+    , _wlHeight         :: Float
-    , _wlDamageEff  :: Damage -> Wall -> World -> World
+    , _wlDamageEff      :: Damage -> Wall -> World -> World
+    , _wlMaterial       :: BlockMaterial
     }
 data Opacity
     = SeeThrough
@@ -1039,9 +1041,9 @@ data Opacity
     | Opaque
 data WallStructure 
     = StandaloneWall
-    | DoorPart    { _wlStDoor    :: Int }
+    | DoorPart    { _wsDoor    :: Int }
-    | MachinePart { _wlStMachine :: Int }
+    | MachinePart { _wsMachine :: Int }
-    | BlockPart   { _wlStBlock   :: Int }
+    | BlockPart   { _wsBlock   :: Int }
     | CreaturePart 
         { _wlStCreature :: Int 
         , _wlStDamCreature :: Damage -> Wall -> Int -> World -> World

src/Dodge/Default/Wall.hs

@@ -1,6 +1,7 @@
 module Dodge.Default.Wall
     where
 import Dodge.Data
+import Dodge.Block.Debris -- this dependency is (directly) for dirtColor
 import Dodge.Wall.DamageEffect
 import Picture
 import Geometry.Data
@@ -22,12 +23,14 @@ defaultWall = Wall
     , _wlWalkable = False
     , _wlHeight = 100
     , _wlDamageEff = defaultWallDamage
+    , _wlMaterial = StoneBlock
     }
 {- Indestructible see-through wall.  -}
 defaultCrystalWall :: Wall
 defaultCrystalWall = defaultWall 
     { _wlColor = withAlpha 0.5 aquamarine
     , _wlOpacity = SeeThrough
+    , _wlMaterial = CrystalBlock
     }
 defaultMachineWall :: Wall
 defaultMachineWall = defaultWall
@@ -35,4 +38,29 @@ defaultMachineWall = defaultWall
     , _wlDraw = False
     , _wlRotateTo = False
     , _wlStructure = MachinePart 0
+    , _wlMaterial  = MetalBlock
+    }
+defaultDirtWall :: Wall
+defaultDirtWall = defaultWall
+    { _wlLine = (V2 0 0,V2 50 0)
+    , _wlID = 0
+    , _wlColor = dirtColor
+    , _wlSeen = False
+    , _wlOpacity = Opaque
+    , _wlRotateTo = False
+    , _wlDraw = True
+    , _wlFireThrough = True
+    , _wlMaterial    = DirtBlock
+    }
+defaultWindow :: Wall
+defaultWindow = defaultWall
+    { _wlLine = (V2 0 0,V2 50 0)
+    , _wlDamageEff = windowWallDamage
+    , _wlID = 0
+    , _wlColor = withAlpha 0.5 cyan
+    , _wlSeen = False
+    , _wlOpacity = SeeThrough
+    , _wlDraw = True
+    , _wlFireThrough = True
+    , _wlMaterial    = GlassBlock
     }

src/Dodge/Item/Weapon/Shatter.hs

@@ -53,6 +53,7 @@ shootShatter it cr w = maybe w (uncurry $ shatterWall w sp ep) $ collidePointWal
   where
     canshatter wl = case _wlOpacity wl of
         Opaque -> True
+        SeeThrough -> True
         _ -> False
     sp = _crPos cr +.+ aimingMuzzlePos cr it *.* unitVectorAtAngle dir
     dir = _crDir cr
@@ -60,6 +61,6 @@ shootShatter it cr w = maybe w (uncurry $ shatterWall w sp ep) $ collidePointWal
 
 shatterWall :: World -> Point2 -> Point2 -> Point2 -> Wall -> World
 shatterWall w sp ep p wl = w 
-    & makeDebris (_wlColor wl) StoneBlock p
+    & makeDebris (_wlMaterial wl) p
-    & makeDebrisDirected 1 2 (pi/2) (argV $ vNormal $ uncurry (-.-) $ _wlLine wl) (_wlColor wl) StoneBlock p
+    & makeDebrisDirected 1 2 (pi/2) (argV $ vNormal $ uncurry (-.-) $ _wlLine wl) (_wlMaterial wl) p
     & damageWall (Damage SHATTERING 1000 sp p ep NoDamageEffect) wl

src/Dodge/Placement/Instance/Wall.hs

@@ -3,6 +3,7 @@ module Dodge.Placement.Instance.Wall
 import Dodge.Data
 import Dodge.LevelGen.Data
 import Dodge.Default.Wall
+--import Dodge.Wall.DamageEffect
 import Geometry
 import Shape
 import Color
@@ -71,22 +72,23 @@ Places an breakable window between two points.
 Width 8, also extends out from each point by 8.
  -}
 windowLine :: Point2 -> Point2 -> Placement
-windowLine a b = sps0 $ PutLineBlock baseWindowPane GlassBlock 8 8 a b
+windowLine a b = sps0 $ PutLineBlock defaultWindow GlassBlock 8 8 a b
 {-
 Places an unbreakable window between two points.
 Width 7, also extends out from each point by 7.
  -}
 crystalLine :: Point2 -> Point2 -> Placement
-crystalLine a b = sps0 $ PutWall ps defaultCrystalWall
+crystalLine a b = sps0 $ PutLineBlock defaultCrystalWall CrystalBlock 7 7 a b
-  where
+--crystalLine a b = sps0 $ PutWall ps defaultCrystalWall
-    ps = 
+--  where
-        [ a +.+ left +.+ up
+--    ps = 
-        , (a +.+ left) -.- up
+--        [ a +.+ left +.+ up
-        , (b -.- left) -.- up
+--        , (a +.+ left) -.- up
-        , (b -.- left) +.+ up
+--        , (b -.- left) -.- up
-        ]
+--        , (b -.- left) +.+ up
-    left = 7 *.* normalizeV (a-.-b)
+--        ]
-    up   = vNormal left
+--    left = 7 *.* normalizeV (a-.-b)
+--    up   = vNormal left
 {- Places an unbreakable wall between two points.
 Depth 15, does not extend wider than points.
  -}
@@ -102,7 +104,7 @@ wallLine a b = sps0 $ PutWall ps defaultWall
     up   = vNormal left
 
 windowLineType :: Point2 -> Point2 -> PSType
-windowLineType = PutLineBlock baseWindowPane GlassBlock 8 8
+windowLineType = PutLineBlock defaultWindow GlassBlock 8 8
 
 baseBlockPane :: Wall
 baseBlockPane = defaultWall
@@ -114,27 +116,6 @@ baseBlockPane = defaultWall
     , _wlDraw = True
     , _wlFireThrough = True
     }
-dirtWall :: Wall
-dirtWall = defaultWall
-    { _wlLine = (V2 0 0,V2 50 0)
-    , _wlID = 0
-    , _wlColor = V4 (150/256) ( 75/256)  0 ( 250/256)
-    , _wlSeen = False
-    , _wlOpacity = Opaque
-    , _wlRotateTo = False
-    , _wlDraw = True
-    , _wlFireThrough = True
-    }
-baseWindowPane :: Wall
-baseWindowPane = defaultWall
-    { _wlLine = (V2 0 0,V2 50 0)
-    , _wlID = 0
-    , _wlColor = cyan
-    , _wlSeen = False
-    , _wlOpacity = SeeThrough
-    , _wlDraw = True
-    , _wlFireThrough = True
-    }
 -- TODO find home for this
 {- Replaces instances of a given 'PutID' with 'PSType's drawn from a list.  -}
 replacePutID 

src/Dodge/Placement/PlaceSpot.hs

@@ -191,7 +191,7 @@ placeMachineWalls col poly mcid wlid = flip (foldr f) $ zip [wlid..] $ loopPairs
     f (wid,l) = IM.insert wid baseWall{_wlID = wid, _wlLine = l}
     baseWall = defaultMachineWall 
         & wlColor .~ col
-        & wlStructure . wlStMachine .~ mcid
+        & wlStructure . wsMachine .~ mcid
         & wlTouchThrough .~ True
 
 mvLS :: Point3 -> Float -> LightSource -> LightSource

src/Dodge/Room/RoadBlock.hs

@@ -1,5 +1,6 @@
 {- Connecting rooms designed with a pass-through technique in mind.  -}
 module Dodge.Room.RoadBlock where
+import Dodge.Default.Wall
 import Dodge.Cleat
 import Dodge.Data
 import Dodge.RoomLink
@@ -66,7 +67,7 @@ blockedCorridor :: RandomGen g => State g (Tree Room)
 blockedCorridor = longBlockedCorridor 0
 
 dirtPoly :: [Point2] -> PSType
-dirtPoly = PutBlock DirtBlock 1 dirtWall . reverse
+dirtPoly = PutBlock DirtBlock 1 defaultDirtWall . reverse
 
 -- | A single corridor with a destructible block blocking it.
 blockedCorridorCloseBlocks :: RandomGen g => State g Room

src/Dodge/Wall/Damage.hs

@@ -36,6 +36,6 @@ damageBlockWith dm = case _dmType dm of
     dam = _dmAmount dm
 
 damageBlocksBy :: Int -> Wall -> World -> World
-damageBlocksBy x wl = case wl ^? wlStructure . wlStBlock of
+damageBlocksBy x wl = case wl ^? wlStructure . wsBlock of
     Just blid -> blocks . ix blid . blHP -~ x
     Nothing   -> id

src/Dodge/Wall/DamageEffect.hs

@@ -4,10 +4,12 @@ import Dodge.Particle.Spark
 import Dodge.Particle.Bullet.Spawn
 import Dodge.Wall.Reflect
 import Dodge.Wall.Dust
+import Dodge.Block
 import Geometry
 import LensHelp
 
 import Control.Monad.State
+import Data.Maybe
 
 defaultWallDamage :: Damage -> Wall -> World -> World
 defaultWallDamage dm wl = wallDamageEffect dm wl . case _dmType dm of
@@ -33,6 +35,36 @@ defaultWallDamage dm wl = wallDamageEffect dm wl . case _dmType dm of
     pSparkCol = V4 5 1 0.5 2
     lSparkCol = V4 20 (-5) 0 1
 
+windowWallDamage :: Damage -> Wall -> World -> World
+windowWallDamage dm wl = wallDamageEffect dm wl . case _dmType dm of
+    LASERING    -> colSparkRandDir 0.2 8 lSparkCol outTo (reflDirWall sp p wl)
+    PIERCING    -> dosplint . colSparkRandDir 0.2 8 pSparkCol outTo (reflDirWall sp p wl) . wlDustAt wl outTo
+    BLUNT       -> dosplint . wlDustAt wl outTo
+    SHATTERING  -> dosplint . muchWlDustAt wl outTo
+    CRUSHING    -> dosplint . id
+    EXPLOSIVE   -> dosplint . id
+    CUTTING     -> dosplint . id
+    SPARKING    -> id
+    FLAMING     -> id
+    ELECTRICAL  -> id
+    CONCUSSIVE  -> dosplint . id
+    TORQUEDAM   -> id
+    PUSHDAM     -> id
+    POISONDAM   -> id
+    ENTERREMENT -> id
+  where
+    dosplint w = fromMaybe w $ do
+        blid <- wl ^? wlStructure . wsBlock
+        bl   <- w ^? blocks . ix blid
+        return $ splinterBlock bl w
+            & blocks . ix blid . blHP %~ min 1
+    sp = _dmFrom dm
+    p = _dmAt dm
+    outTo = p +.+ squashNormalizeV (sp -.- p)
+    pSparkCol = V4 5 1 0.5 2
+    lSparkCol = V4 20 (-5) 0 1
+
+
 wallDamageEffect :: Damage -> Wall -> World -> World
 wallDamageEffect dm wl w = case _dmEffect dm of
     BounceBullet bt -> w & instantParticles .:~ thebouncer