Add submodules of levelgen

2021-03-05 20:25:25 +01:00
parent 37822c3ad2
commit 079f4deecf
2 changed files with 304 additions and 0 deletions
@@ -0,0 +1,105 @@
+{-# LANGUAGE BangPatterns #-}
+module Dodge.LevelGen.Block where
+import Dodge.Data
+import Dodge.Base
+import Dodge.SoundLogic
+
+import Geometry
+import Picture.Data
+
+import Control.Lens
+
+import Data.List
+
+import Data.Function
+import qualified Data.IntMap.Strict as IM
+import System.Random
+import Control.Monad.State
+
+updateBlocks :: World -> World
+updateBlocks w = (\w' -> seq (_wallsZone w') w') $ flip (foldr removeFromZone) deadPanes 
+                    $ over walls (\wls -> wls `seq` IM.filter (not . blockIsDead) wls)
+                 degradeBlocks 
+--                    w                
+   where  degradeBlocks = deadBlocks `seq` foldr killBlock w deadBlocks
+          removeFromZone :: Wall -> World -> World
+          removeFromZone bl = over (wallsZone . ix x . ix y) (IM.delete (_wlID bl))
+            where (x,y) = zoneOfPoint $ pHalf (_wlLine bl !! 0) (_wlLine bl !! 1)
+          deadPanes = filter blockIsDead (IM.elems $ _walls w)
+          deadBlocks = nubBy ((==) `on` _blIDs) deadPanes
+          blockIsDead wl = case wl ^? blHP of Just x  -> x <= 0
+                                              Nothing -> False
+
+killBlock :: Wall -> World -> World
+killBlock bl w =  f bl .
+                  flip (foldr unshadow)
+--                  flip (foldr (\i -> set (walls . ix i . blVisible) (True)))
+                         (_blShadows bl)
+                        $ w
+    where
+        f bl@(Block {_blDegrades = (x:xs)}) = degradeBlock bl . hitSound bl
+        f bl          = hitSound' bl
+        hitSound bl | _wlIsSeeThrough bl = soundMultiFrom sos (soundid+8) 25 0 
+                    | otherwise = soundMultiFrom sos soundid 25 0 
+        hitSound' bl | _wlIsSeeThrough bl = soundMultiFrom sos (soundid+4) 25 0 
+                     | otherwise = soundMultiFrom sos soundid 25 0 
+        sos = [BlockDegradeSound 0,BlockDegradeSound 1]
+        (soundid,_) = randomR (29,32) $ _randGen w
+        unshadow :: Int -> World -> World
+        unshadow bid w = case w ^? walls . ix bid of 
+                            Just b  -> let (x,y) = zoneOfPoint $ pHalf (_wlLine b !! 0) (_wlLine b !! 1)
+                                       in  w & wallsZone . ix x . ix y . ix bid . blVisible %~ \_ -> 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 _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
+
+pushPointTowardsBy :: RandomGen g => Float -> Point2 -> [Point2] -> State g Point2
+pushPointTowardsBy x p ps = do
+    xs <- sequence $ take (length ps) $ repeat $ state $ randomR (0, x / (fromIntegral $ length ps))
+    let toAdd p' y = y *.* (p' -.- p)
+    return $ p +.+ foldr1 (+.+) (zipWith toAdd ps xs)
+
+shrinkPolygon :: RandomGen g => Float -> [Point2] -> State g [Point2]
+shrinkPolygon x ps = sequence $ map (flip (pushPointTowardsBy x) ps) ps
+
+
+addBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World
+addBlock (p:ps) hp col isSeeThrough degradability w 
+    | hp <= 0 && degradability == [] = w
+    | hp <= 0 = addBlock (p:ps) (head degradability + hp) col isSeeThrough (tail degradability) w
+    | otherwise = over wallsZone (flip (IM.foldr wallInZone) blocks)
+      $ over walls (IM.union blocks) w
+--addBlock (p:p':ps) w = over walls (IM.insert i b) w
+    where 
+        lines = zip (p:ps) (ps ++ [p])
+        i = newKey $ _walls w
+        is = [i.. i + length lines-1]
+        blocks = IM.fromList $ zip is 
+                  $ zipWith (\j (a,b) -> Block { _wlLine = [a,b]
+                                               , _wlID = j
+                                            --   , _wlColor = greyN 0.5
+                                               , _wlColor = col
+                                               , _wlDraw = Nothing
+                                               , _wlSeen = False
+                                               , _blIDs = is
+                                               , _blHP = hp
+                                               , _wlIsSeeThrough = isSeeThrough
+                                               , _blVisible = True
+                                               , _blShadows = []
+                                               , _blDegrades = degradability
+                                               , _wlCastShadow = False
+                                               }
+                             ) is lines
+        wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize 
+                          = insertIMInZone x y wlid wl
+                      | otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips
+          where (x,y) = zoneOfPoint $ (pHalf (_wlLine wl !! 0) (_wlLine wl !! 1))
+                wlid  = _wlID wl
+                ips = map zoneOfPoint $ divideLine (2*zoneSize) (_wlLine wl !! 0) (_wlLine wl !! 1)
+