Unify block wall types
This commit is contained in:
@@ -11,90 +11,14 @@ import Dodge.Zone
|
||||
--import Dodge.SoundLogic.LoadSound
|
||||
--import Dodge.WorldEvent.Sound
|
||||
import Dodge.LevelGen.Pathing
|
||||
import Dodge.Default.Wall
|
||||
--import Dodge.RandomHelp
|
||||
import Geometry
|
||||
import qualified IntMapHelp as IM
|
||||
import Color
|
||||
|
||||
import Control.Lens
|
||||
--import Control.Monad.State
|
||||
import Data.List
|
||||
--import Data.Maybe
|
||||
--import Data.Function
|
||||
--import System.Random
|
||||
|
||||
--updateBlocks :: World -> World
|
||||
--updateBlocks w
|
||||
-- = w --(\w' -> seq (_wallsZone w') w')
|
||||
-- $ flip (foldl' $ flip removeFromZone) deadPanes
|
||||
-- $ over walls (\wls -> wls `seq` IM.filter (not . blockIsDead) wls) degradeBlocks
|
||||
-- where
|
||||
-- --degradeBlocks = deadBlocks `seq` foldl' (flip killBlock) w deadBlocks
|
||||
-- removeFromZone :: Wall -> World -> World
|
||||
-- removeFromZone bl = over (wallsZone . znObjects . ix x . ix y) (IM.delete (_wlID bl))
|
||||
-- where
|
||||
-- (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine bl)
|
||||
-- deadPanes w' = filter (blockIsDead w') (IM.elems $ _walls w)
|
||||
-- --deadBlocks = nubBy ((==) `on` _blIDs) deadPanes
|
||||
-- blockIsDead w' wl = case IM.lookup (_wlBlockID wl) $ _blocks w of
|
||||
-- Just x -> x <= 0
|
||||
-- Nothing -> False
|
||||
|
||||
{- | Destroy a block.
|
||||
Plays destruction sound and sets to be displayed other walls that were shadowed by this wall. -}
|
||||
--killBlock :: Wall -> World -> World
|
||||
--killBlock bl w = f bl . flip (foldl' $ flip unshadow) (_blShadows bl) $ w
|
||||
-- where
|
||||
-- f :: Wall -> World -> World
|
||||
-- f bl'
|
||||
-- | isJust (bl ^? blDegrades . ix 0) = degradeBlock bl' . breakHitSound bl
|
||||
-- | otherwise = hitSound' bl'
|
||||
-- pos = fst $ _wlLine bl
|
||||
-- breakHitSound bl'
|
||||
-- | _wlIsSeeThrough bl' = mkSoundBreakGlass pos
|
||||
-- | otherwise = soundMultiFrom sos (fst $ _wlLine bl') impactSound Nothing
|
||||
-- hitSound' bl'
|
||||
-- | _wlIsSeeThrough bl' = mkSoundSplinterGlass pos
|
||||
-- | otherwise = soundMultiFrom sos (fst $ _wlLine bl') impactSound Nothing
|
||||
-- sos = [BlockDegradeSound 0,BlockDegradeSound 1]
|
||||
-- impactSound = evalState (takeOne [impact1S,impact2S,impact3S,impact4S]) $ _randGen w
|
||||
-- unshadow :: Int -> World -> World
|
||||
-- unshadow bid w' = case w' ^? walls . ix bid of
|
||||
-- Just b ->
|
||||
-- let (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine b)
|
||||
-- in w & wallsZone . znObjects . ix x . ix y . ix bid . blVisible %~ const True
|
||||
-- & walls . ix bid . blVisible %~ const True
|
||||
-- Nothing -> w
|
||||
|
||||
--degradeBlock :: Wall -> World -> World
|
||||
--degradeBlock bl w =
|
||||
-- let blid = _wlID bl
|
||||
-- bls = map (\i -> _walls w IM.! i) (_blIDs $ _walls w IM.! blid)
|
||||
-- ps = reverse $ orderPolygon $ nub $ concatMap ((\(a,b) -> [a,b]) . _wlLine) bls
|
||||
-- (newPs,g) = runState (shrinkPolygon 0.5 ps) $ _randGen w
|
||||
-- (x:xs) = _blDegrades bl
|
||||
-- in addBlock newPs (x + _blHP bl) (_wlColor bl) (_wlIsSeeThrough bl) xs $ set randGen g w
|
||||
|
||||
{-
|
||||
This does not have clear behaviour in my mind, and should probably be replaced with something more obvious...
|
||||
-}
|
||||
--pushPointTowardsBy
|
||||
-- :: RandomGen g
|
||||
-- => Float
|
||||
-- -> Point2
|
||||
-- -> [Point2]
|
||||
-- -> State g Point2
|
||||
--pushPointTowardsBy x p ps = do
|
||||
-- xs <- replicateM (length ps) $ state $ randomR (0, x / fromIntegral (length ps))
|
||||
-- let toAdd p' y = y *.* (p' -.- p)
|
||||
-- return $ p +.+ foldl1' (+.+) (zipWith toAdd ps xs)
|
||||
|
||||
--shrinkPolygon
|
||||
-- :: RandomGen g
|
||||
-- => Float -- ^ Shrink parameter
|
||||
-- -> [Point2]
|
||||
-- -> State g [Point2]
|
||||
--shrinkPolygon x ps = mapM (flip (pushPointTowardsBy x) ps) ps
|
||||
|
||||
addBlock
|
||||
:: [Point2] -- ^ Block polygon
|
||||
@@ -110,25 +34,19 @@ addBlock (p:ps) hp col isSeeThrough hps w
|
||||
| otherwise = w
|
||||
& wallsZone . znObjects %~ flip (IM.foldl' $ flip wallInZone) panes
|
||||
& walls %~ IM.union panes
|
||||
& blocks %~ IM.insert blid (Block' {_blID = blid,_blWallIDs = is, _blHPs = hp:hps, _blShadows'=[]})
|
||||
& blocks %~ IM.insert blid (Block {_blID = blid,_blWallIDs = is, _blHPs = hp:hps, _blShadows=[]})
|
||||
where
|
||||
blid = IM.newKey $ _blocks w
|
||||
lns = zip (p:ps) (ps ++ [p])
|
||||
i = IM.newKey $ _walls w
|
||||
is = [i.. i + length lns-1]
|
||||
panes = IM.fromList $ zip is $ zipWith
|
||||
(\j (a,b) -> Block
|
||||
(\j (a,b) -> defaultWall
|
||||
{ _wlLine = (a,b)
|
||||
, _wlID = j
|
||||
, _wlColor = col
|
||||
, _wlSeen = False
|
||||
, _blIDs = is
|
||||
, _wlIsSeeThrough = isSeeThrough
|
||||
, _blVisible = True
|
||||
, _blShadows = []
|
||||
, _wlDraw = True
|
||||
, _wlRotateTo = True
|
||||
, _wlBlockID = blid
|
||||
, _wlBlockID = Just blid
|
||||
}
|
||||
) is lns
|
||||
wallInZone wl
|
||||
|
||||
@@ -18,8 +18,7 @@ putLineBlock
|
||||
-> Point2 -- ^ End point (symmetric)
|
||||
-> World
|
||||
-> (Int, World)
|
||||
putLineBlock basePane blockWidth depth a b w
|
||||
= (,) 0
|
||||
putLineBlock basePane blockWidth depth a b w = (,) 0
|
||||
$ removePathsCrossing a b $ foldr insertBlock (insertBlocks' w) listBlocks
|
||||
where
|
||||
d = dist a b
|
||||
@@ -29,17 +28,13 @@ putLineBlock basePane blockWidth depth a b w
|
||||
blockCenPs = snd $ evenOddSplit psOnLine
|
||||
numBlocks = length blockCenPs
|
||||
is = [0.. numBlocks - 1]
|
||||
cornerPoints = map toV2
|
||||
[(-halfBlockWidth,-depth) -- goes anticlockwise around the block
|
||||
,(-halfBlockWidth, depth)
|
||||
,( halfBlockWidth, depth)
|
||||
,( halfBlockWidth,-depth)
|
||||
]
|
||||
cornerPoints = reverse $ rectWH halfBlockWidth depth -- goes clockwise around the block
|
||||
cornersAt p = fmap ( (p +.+) . rotateV rot) cornerPoints
|
||||
linesAt p = makeLoopPairs $ cornersAt p
|
||||
k = IM.newKey $ _walls w
|
||||
blid = IM.newKey $ _blocks w
|
||||
insertBlock' i = over blocks $ IM.insert (i+blid) Block' {_blID = i + blid, _blWallIDs = ksAtI i, _blHPs = [5,5], _blShadows' = shadowsAt i}
|
||||
insertBlock' i = over blocks
|
||||
$ IM.insert (i+blid) Block {_blID = i + blid, _blWallIDs = ksAtI i, _blHPs = [5,5], _blShadows = shadowsAt i}
|
||||
insertBlocks' = flip (foldr insertBlock') is
|
||||
ksAtI i = map ( + (k + i*4) ) [0,1,2,3]
|
||||
visibilityAt i
|
||||
@@ -54,11 +49,9 @@ putLineBlock basePane blockWidth depth a b w
|
||||
makeBlockAt p i = zipWith3 (makePane i) (visibilityAt i) (ksAtI i) (linesAt p)
|
||||
makePane i visStatus k' ps = basePane
|
||||
{_wlID = k'
|
||||
,_wlBlockID = i + blid
|
||||
,_wlBlockID = Just $ i + blid
|
||||
,_wlLine = ps
|
||||
,_blIDs = ksAtI i
|
||||
,_blShadows = shadowsAt i
|
||||
,_blVisible = visStatus
|
||||
,_wlDraw = visStatus
|
||||
}
|
||||
listBlocks = concat $ zipWith makeBlockAt blockCenPs is
|
||||
insertBlock :: Wall -> World -> World
|
||||
|
||||
Reference in New Issue
Block a user