justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Refactor level/room generation modules

Browse Source
This commit is contained in:
jgk
2021-03-11 22:08:35 +01:00
parent 2d995339b9
commit e8e3dd8f50
17 changed files with 546 additions and 436 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Critters.hs
+1
View File
@@ -365,6 +365,7 @@ startCr = basicCreature
,latchkey 0
,frontArmour
,miniGun
,medkit 50
]
++ repeat NoItem))
-- startInv
src/Dodge/Floor.hs
+92
View File
@@ -0,0 +1,92 @@
module Dodge.Floor
( lev1
, generateLevel
)
where
import Geometry
import Picture
import Dodge.Data
import Dodge.Rooms
import Dodge.Base
import Dodge.Layout
import Dodge.Critters
import Dodge.SoundLogic
import Dodge.RandomHelp
import Dodge.LightSources
import Data.Tree
import Control.Lens
import Control.Monad.State
import Control.Monad.Loops
import System.Random
lev1 :: RandomGen g => State g (Tree Room)
lev1 = do
firstWeapon <- takeOne $ [[branchRectWith weaponRoom,blockedCorridor]] ++ replicate 5 [weaponRoom]
iterateWhile boundClip $ fmap (shiftRoomTree . expandTreeBy id)
$ sequence $ treePost
(
[return $ return $ Right deadEndRoom
]
++ [return $ connectRoom corridor
,return $ connectRoom door]
++ firstWeapon
++ [return $ connectRoom corridor
,return $ connectRoom door]
++ [randomiseLinks =<< pistolerRoom]
++ [return $ connectRoom door]
++ [randomiseLinks =<< shooterRoom]
++ (replicate 3 $ randomiseLinks corridor)
++ [return $ connectRoom (set rmPS [PS (20,40) 0 basicLS] corridor)]
++ [return $ connectRoom corridor]
++ (replicate 3 $ randomiseLinks corridor)
++ [return $ connectRoom corridor]
++[return $ connectRoom corridor,return $ connectRoom door]
++ [shootingRange]
++ (replicate 3 $ randomiseLinks corridor)
++[roomMiniIntro]
++ (replicate 3 $ randomiseLinks corridor)
++ [return $ connectRoom corridor
,return $ connectRoom door
,slowDoorRoom]
++ [return $ connectRoom corridor
,spawnerRoom
,return $ connectRoom corridor
]
)
$ randomiseLinks corridor
roomToLevel2 :: RandomGen g => State g (Tree (Either Room Room))
roomToLevel2 = join $ takeOne
[ portalRoom1
]
portalRoom1 :: RandomGen g => State g (Tree (Either Room Room))
portalRoom1 = return $ connectRoom $ (roomRect 300 300) { _rmPS = plmnts}
where plmnts = [PS (0,0) (0-pi/2) $ PutPressPlate (levelPortalAt (200,120) 1)
,PS (60,100) pi $ PutCrit autoCrit
]
generateLevel :: Int -> World -> World
generateLevel i w =
do haltSound $ ((generateFromTree $ levelTree i) w)
levelTree :: Int -> State StdGen (Tree Room)
levelTree 1 = lev1
levelPortalAt :: Point2 -> Int -> PressPlate
levelPortalAt p x
= PressPlate
{ _ppPict = onLayer PressPlateLayer $ color blue $ circle 10
, _ppPos = p
, _ppRot = 0
, _ppEvent = \pp w -> if dist (_crPos (you w)) (_ppPos pp) < 10
then generateLevel x w
else w
, _ppID = -1
, _ppText = "Portal to level "++ show x
}
src/Dodge/Layout.hs
+11 -41
View File
@@ -1,23 +1,20 @@
module Dodge.Layout where
module Dodge.Layout
( module Dodge.Layout
, module Dodge.Layout.Tree
)
where
-- imports {{{
import Dodge.Data
import Dodge.Weapons
import Dodge.Critters
import Dodge.LevelGen
import Dodge.Base
import Dodge.RandomHelp
import Dodge.Prototypes
import Dodge.Path
import Dodge.Layout.Tree
import Geometry
--
--import Graphics.Gloss
--import Graphics.Gloss.Data.Vector
--import Graphics.Gloss.Geometry.Line
--import Graphics.Gloss.Geometry.Angle
--
import Control.Monad.State
--import Control.Monad.Loops
import Control.Lens
import System.Random
@@ -35,11 +32,10 @@ import Data.Graph.Inductive.NodeMap
import qualified Data.IntMap.Strict as IM
-- }}}
-- connects a collection (tree) of rooms together
generateFromTree :: State StdGen (Tree Room) -> World -> World
generateFromTree t w = zoning $ placeSpots plmnts
$ w {_walls = wallsFromTree tr, _randGen = g
-- ,_loadedSounds = lSounds
,_pathGraph = path
,_pathGraph' = pairGraph
,_pathPoints = foldr insertPoint IM.empty (labNodes path)
@@ -47,7 +43,6 @@ generateFromTree t w = zoning $ placeSpots plmnts
where tr = evalState t $ _randGen w
plmnts = concatMap _rmPS $ flatten tr
g = _randGen w
-- lSounds = _loadedSounds w
path = pairsToGraph dist pairGraph
pairGraph = makePath tr
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
@@ -66,8 +61,6 @@ makePath = concat . map _rmPath . flatten
wallsFromTree :: Tree Room -> IM.IntMap Wall
wallsFromTree t = createInnerWalls $ nubWalls $ divideWalls $ foldr cutWalls IM.empty (concatMap _rmPolys $ flatten t)
--wallsFromTree t = checkWalls $ nubWalls $ divideWalls $ foldr cutWalls IM.empty (concatMap _rmPolys $ flatten t)
--wallsFromTree t = divideWalls $ foldr cutWalls IM.empty (concatMap _rmPolys $ flatten t)
divideWall :: Wall -> [Wall]
divideWall wl
@@ -85,26 +78,11 @@ divideWallIn wl wls =
divideWalls :: IM.IntMap Wall -> IM.IntMap Wall
divideWalls wls = IM.foldr divideWallIn wls wls
collapseTree :: Tree (Tree (Either Room Room)) -> Tree (Either Room Room)
collapseTree = g . expandTreeBy f
where f (Node (Right x) xs) = Node (Right (Right x)) $ map f xs
f (Node (Left x) xs) = Node (Left (Left x)) $ map f xs
g (Node (Right x) []) = Node (Right x) []
g (Node (Right x) xs) = Node (Left x) $ map g xs
g (Node y ys) = Node y $ map g ys
insertInZone :: Int -> Int -> a -> IM.IntMap (IM.IntMap a) -> IM.IntMap (IM.IntMap a)
insertInZone x y obj = IM.insertWith f x $ IM.singleton y obj
where f _ = IM.insert y obj
allPairs :: Eq a => [a] -> [(a,a)]
allPairs xs = [(x,y) | x <- xs, y <- xs, x /= y]
treePost :: [a] -> a -> Tree a
treePost [] y = Node y []
treePost (x:xs) y = Node x [treePost xs y]
randomiseLinks :: RandomGen g => Room -> State g (Tree (Either Room Room))
randomiseLinks r = do
@@ -135,16 +113,9 @@ composeTreeWith f (Node x xs) = paste xs $ f x
where paste xs (Node (Right y) _) = Node (Left y) (map (composeTreeWith f) xs)
paste xs (Node (Left y) ys) = Node (Left y) (map (paste xs) ys)
doPolysIntersect :: [Point2] -> [Point2] -> Bool
doPolysIntersect (p:ps) (q:qs)
= any isJust $ (\(a,b) (c,d) -> intersectSegSeg' a b c d) <$> pair1s <*> pair2s
where pair1s = zip (p:ps) (ps++[p])
pair2s = zip (q:qs) (qs++[q])
doPolysIntersect [] _ = False
doPolysIntersect _ [] = False
-- the old version of this used a version of polysIntersect with intersectSegSeg'
boundClip :: Tree Room -> Bool
boundClip t = or $ map (uncurry doPolysIntersect) [(x,y) | x<- xs, y<-xs, x>y]
boundClip t = or $ map (uncurry polysIntersect) [(x,y) | x<- xs, y<-xs, x>y]
++ map f [(ps,qs) | ps <- xs, qs <-xs, ps/=qs]
where xs = map _rmBound $ flatten t
f ([],qs) = False
@@ -186,4 +157,3 @@ shiftPSBy (pos,rot) ps = case ps of
$ over psRot (+rot)
ps
src/Dodge/Layout/Tree.hs
+46
View File
@@ -0,0 +1,46 @@
module Dodge.Layout.Tree
where
import Data.Tree
import Control.Monad.State
import System.Random
-- Left elements get new children, Right elements inherit the children from the
-- mapped over node
expandTreeBy :: (a -> Tree (Either b b)) -> Tree a -> Tree b
expandTreeBy f (Node x []) = fmap removeEither (f x)
where removeEither (Left y) = y
removeEither (Right y) = y
expandTreeBy f (Node x xs) = appendAndRemove $ f x
where appendAndRemove (Node (Left y) ys) = Node y (map appendAndRemove ys)
appendAndRemove (Node (Right y) _ ) = Node y (map (expandTreeBy f) xs)
expandTreeRand :: RandomGen g =>
(a -> State g (Tree (Either b b))) -> Tree a -> State g (Tree b)
expandTreeRand f (Node x []) = fmap (fmap removeEither) (f x)
where removeEither (Left y) = y
removeEither (Right y) = y
expandTreeRand f (Node x xs) = do
root <- f x
branches <- sequence $ map (expandTreeRand f) xs
return (appendAndRemove branches root)
where appendAndRemove :: [Tree a] -> Tree (Either a a) -> Tree a
appendAndRemove bran (Node (Left y) ys) = Node y (map (appendAndRemove bran) ys)
appendAndRemove bran (Node (Right y) _) = Node y bran
collapseTree :: Tree (Tree (Either a a)) -> Tree (Either a a)
collapseTree = g . expandTreeBy f
where f (Node (Right x) xs) = Node (Right (Right x)) $ map f xs
f (Node (Left x) xs) = Node (Left (Left x)) $ map f xs
g (Node (Right x) []) = Node (Right x) []
g (Node (Right x) xs) = Node (Left x) $ map g xs
g (Node y ys) = Node y $ map g ys
treePost :: [a] -> a -> Tree a
treePost [] y = Node y []
treePost (x:xs) y = Node x [treePost xs y]
treeTrunk :: [a] -> Tree a -> Tree a
treeTrunk [] t = t
treeTrunk (x:xs) t = Node x [treeTrunk xs t]
applyToRoot :: (a -> a) -> Tree a -> Tree a
applyToRoot f (Node x xs) = Node (f x) xs
src/Dodge/LevelGen.hs
+3 -44
View File
@@ -14,8 +14,6 @@ module Dodge.LevelGen
import Dodge.Data
import Dodge.Base
import Dodge.SoundLogic
import Dodge.Prototypes
import Dodge.LevelGen.Block
import Dodge.LevelGen.Pathing
@@ -29,7 +27,6 @@ import Picture
import System.Random
import Control.Monad.State
import Data.List
import Data.Function
@@ -40,16 +37,7 @@ import qualified Data.IntMap.Strict as IM
import qualified Data.Set as S
import qualified Data.Map as M
import Data.Graph.Inductive hiding ((&))
import Data.Graph.Inductive.NodeMap
import Data.Tree
treeTrunk :: [a] -> Tree a -> Tree a
treeTrunk [] t = t
treeTrunk (x:xs) t = Node x [treeTrunk xs t]
applyToRoot :: (a -> a) -> Tree a -> Tree a
applyToRoot f (Node x xs) = Node (f x) xs
-- deals with placement of objects within the world
placeSpots :: [PlacementSpot] -> World -> World
placeSpots pss w = foldr placeSpot w basicPlacements
@@ -101,7 +89,8 @@ placeSpot ps w = case ps of
PS {_psPos = p, _psRot = rot, _psType = PutWindow { _pwPoly = ps, _pwColor = c }}
-> rmCrossPaths $ over walls (addWindow (q:qs) c) w
where (q:qs) = translateS p $ rotateS rot ps
-- where (q:qs) = translateS p $ rotateS rot ps
where (q:qs) = map (shiftPointBy (p,rot)) ps
rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ zip (q:qs) (qs++[q])
_ -> w
@@ -130,11 +119,6 @@ instance Shiftable PlacementSpot where
translateS p' (PS p r x) = PS (p +.+ p') r x
rotateS r' (PS p r x) = PS (rotateV r' p) (r + r') x
putWindowBlock :: Point2 -> Point2 -> World -> World
putWindowBlock a b w = removePathsCrossing a b $ foldr makeBlockAt w $ zip ps ns
where d = dist a b
@@ -201,8 +185,6 @@ putWindowBlock a b w = removePathsCrossing a b $ foldr makeBlockAt w $ zip ps ns
}
f = IM.insert k0 l . IM.insert k1 t . IM.insert k2 r . IM.insert k3 b
in over walls f w
shiftPointBy (pos,rot) p = pos +.+ rotateV rot p
@@ -228,29 +210,6 @@ placeFlIt fi p rot w = over floorItems addFI w
placePressPlate pp p rot w = over pressPlates addPP w
where addPP pps = IM.insert (newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps
-- Left elements get new children, Right elements inherit the children from the
-- mapped over node
expandTreeBy :: (a -> Tree (Either b b)) -> Tree a -> Tree b
expandTreeBy f (Node x []) = fmap removeEither (f x)
where removeEither (Left y) = y
removeEither (Right y) = y
expandTreeBy f (Node x xs) = appendAndRemove $ f x
where appendAndRemove (Node (Left y) ys) = Node y (map appendAndRemove ys)
appendAndRemove (Node (Right y) _ ) = Node y (map (expandTreeBy f) xs)
expandTreeRand :: RandomGen g =>
(a -> State g (Tree (Either b b))) -> Tree a -> State g (Tree b)
expandTreeRand f (Node x []) = fmap (fmap removeEither) (f x)
where removeEither (Left y) = y
removeEither (Right y) = y
expandTreeRand f (Node x xs) = do
root <- f x
branches <- sequence $ map (expandTreeRand f) xs
return (appendAndRemove branches root)
where appendAndRemove :: [Tree a] -> Tree (Either a a) -> Tree a
appendAndRemove bran (Node (Left y) ys) = Node y (map (appendAndRemove bran) ys)
appendAndRemove bran (Node (Right y) _) = Node y bran
placeCr :: Creature -> Point2 -> Float -> World -> World
placeCr crF p rot w = over creatures addCr w
where addCr crs = IM.insert (newKey crs)
src/Dodge/Menu.hs
+1
View File
@@ -2,6 +2,7 @@ module Dodge.Menu where
-- imports {{{
import Dodge.Data
import Dodge.Rooms
import Dodge.Floor
import Dodge.Initialisation
import Dodge.SoundLogic
src/Dodge/RandomHelp.hs
+1
View File
@@ -23,6 +23,7 @@ takeOneWeighted ws xs = state (randomR (0, sum ws))
i y _ = 0
takeOneMore :: RandomGen g => ([a],[a]) -> State g ([a],[a])
takeOneMore (xs,[]) = error "trying to takeOneMore from empty list"
takeOneMore (xs,ys) = do
i <- state $ randomR (0,length ys - 1)
let (zs, w:ws) = splitAt i ys
src/Dodge/Rooms.hs
+4 -119
View File
@@ -36,78 +36,7 @@ import Data.Graph.Inductive.NodeMap
import qualified Data.IntMap.Strict as IM
-- }}}
lev1 :: RandomGen g => State g (Tree Room)
lev1 = do
firstWeapon <- takeOne $ [[branchRectWith weaponRoom,blockedCorridor]] ++ replicate 5 [weaponRoom]
iterateWhile boundClip $ fmap (shiftRoomTree . expandTreeBy id)
$ sequence $ treePost
(
-- [randomiseLinks =<< pistolerRoom]
[return $ return $ Right deadEndRoom
]
++ [slowDoorRoom]
++ [return $ connectRoom corridor
,return $ connectRoom door]
-- ++ [randomiseLinks =<< longRoom]
++ [randomiseLinks =<< pistolerRoom]
-- ++ [randomiseLinks =<< shooterRoom]
++ [return $ connectRoom door]
-- ++ [return $ connectRoom $ set rmPS [PS (100,100) 0 $ PutCrit explosiveBarrel
-- ,PS (105,110) 0 $ PutCrit explosiveBarrel
-- ,PS (115,110) 0 $ PutCrit autoCrit
-- ,PS (135,110) 0 $ PutCrit explosiveBarrel
-- ,PS (105,140) 0 $ PutCrit explosiveBarrel
-- ]
-- $ roomRect 300 300]
++ [randomiseLinks =<< shooterRoom]
++ (replicate 3 $ randomiseLinks corridor)
++ [return $ connectRoom (set rmPS [PS (20,40) 0 basicLS] corridor)]
-- ++ [randomiseLinks =<< longRoom]
++ [return $ connectRoom corridor]
++ firstWeapon
++ (replicate 3 $ randomiseLinks corridor)
++ [return $ connectRoom corridor]
++[return $ connectRoom corridor,return $ connectRoom door]
++ [shootingRange]
++ (replicate 3 $ randomiseLinks corridor)
++[roomMiniIntro]
++ (replicate 3 $ randomiseLinks corridor)
++ [return $ connectRoom corridor
,return $ connectRoom door
,slowDoorRoom]
++ [return $ connectRoom corridor
,spawnerRoom
,return $ connectRoom corridor
]
)
$ randomiseLinks corridor
generateLevel :: Int -> World -> World
generateLevel i w =
do haltSound $ ((generateFromTree $ levelTree i) w)
levelTree :: Int -> State StdGen (Tree Room)
levelTree 1 = lev1
levelPortalAt :: Point2 -> Int -> PressPlate
levelPortalAt p x
= PressPlate
{ _ppPict = onLayer PressPlateLayer $ color blue $ circle 10
, _ppPos = p
, _ppRot = 0
, _ppEvent = \pp w -> if dist (_crPos (you w)) (_ppPos pp) < 10
then generateLevel x w
else w
, _ppID = -1
, _ppText = "Portal to level "++ show x
}
-- definition of individual rooms
airlockOneWay :: Int -> Room
airlockOneWay n = Room
{ _rmPolys = [rectNSWE 90 0 0 40]
@@ -497,6 +426,8 @@ roomOctogon = Room
,((-35,55),3*pi/4)
,( (0,40),pi)
]
allPairs :: Eq a => [a] -> [(a,a)]
allPairs xs = [(x,y) | x <- xs, y <- xs, x /= y]
randomCorridorFrom :: RandomGen g => [a] -> State g (Tree (Either a a))
randomCorridorFrom xs = do
@@ -504,13 +435,6 @@ randomCorridorFrom xs = do
return $ treeTrunk (map Left $ init rooms) (Node (Right (last rooms)) [])
--splitWall :: Float -> Wall -> [[Point]]
--splitWall x wl =
sWalls g = wallsFromTree $ evalState (iterateWhile boundClip lev1) $ g
randFirstWeapon :: State StdGen PSType
randFirstWeapon = do
r <- state $ randomR (-pi,pi)
@@ -599,22 +523,6 @@ blockedCorridor = do
sequence $ treePost (replicate n $ fmap Left $ randLinks corridor)
$ fmap Right $ return $ set rmPS plmnts corridor
-- weaponBehindV :: RandomGen g => State g (Tree (Either Room Room))
-- weaponBehindV = do
-- wpPos <- takeOne [(x,y) | x <- [70,-70], y <- [90,230]]
-- (ps,_) <- takeNMore 2 ([], [(x,y) | x <- [60,-60], y <- [100,220]])
-- r <- state $ randomR (0,pi)
-- let crPos1 = ps !! 0
-- let crPos2 = ps !! 1
-- let d p = argV $ (0,160) -.- p
-- let plmnts = [PS wpPos 0 $ RandPS randFirstWeapon
-- ,PS crPos1 (d crPos1) $ randC1
-- ,PS crPos2 (d crPos2) $ randC1
-- ,PS (0,295) r $ PutBlock [5,5,5] (makeColorI 150 75 0 250)
-- $ reverse $ rectNSWE 10 (-10) (-10) 10
-- ]
-- return $ connectRoom $ set rmPS plmnts $ roomVs
weaponLongCorridor :: RandomGen g => State g (Tree (Either Room Room))
weaponLongCorridor = do
root <- takeOne $ [tEast, tWest]
@@ -662,28 +570,6 @@ roomCCrits = do
$ zipWith (+.+) [(x,y) | x<-[110,130,150,170,190], y<- [70,90,110,130,150]] ps
return $ connectRoom $ over rmPS (++plmnts) $ roomC 200 200
--
-- roomSwarm :: RandomGen g => State g (Tree (Either Room Room))
-- roomSwarm = do
-- ps <- sequence $ replicate 25 $ randInCirc 200
-- let plmnts = map (\p -> PS ((500,500) +.+ p) 0 $ PutCrit swarmCrit) ps
-- return $ connectRoom $ set rmPS plmnts $ roomRect 1000 1000
--
roomToLevel2 :: RandomGen g => State g (Tree (Either Room Room))
roomToLevel2 = join $ takeOne
[ portalRoom1
]
portalRoom1 :: RandomGen g => State g (Tree (Either Room Room))
portalRoom1 = return $ connectRoom $ (roomRect 300 300) { _rmPS = plmnts}
where plmnts = [PS (0,0) (0-pi/2) $ PutPressPlate (levelPortalAt (200,120) 1)
,PS (60,100) pi $ PutCrit autoCrit
]
branchRectWith :: RandomGen g => State g (Tree (Either Room Room)) -> State g (Tree (Either Room Room))
branchRectWith t = do
x <- state $ randomR (100,200)
@@ -838,7 +724,7 @@ pistolerRoom = do
f <- takeOne [f2]
h <- state $ randomR (400,800)
let w = h
i <- takeOne [2,4,6,8]
i <- takeOne [4,6,8]
let j = fromIntegral (i+1)
-- the 20+etc here is to correct for the pathfinding grid, which matches up to
-- edges based on the size of doors (i.e. the line next to the wall is 20
@@ -887,7 +773,6 @@ shootingRange = do
,Left $ roomPadCut (rectNSWE 20 (-20) (-80) 80) (0,20)
]
(Right rm3)
spawnerRoom :: RandomGen g => State g (Tree (Either Room Room))
spawnerRoom = do
src/Dodge/TransparencyEffects.hs
+4
View File
@@ -0,0 +1,4 @@
module Dodge.TransparencyEffects
where
src/Dodge/Weapons.hs
+3 -181
View File
@@ -18,9 +18,6 @@ import Data.List
import Data.Char
import Data.Maybe
import Data.Function
--import Data.Graph.Inductive.Graph
--import Data.Graph.Inductive.PatriciaTree
--import Codec.BMP
import qualified Data.ByteString as B
import Control.Lens
import Control.Applicative
@@ -2020,11 +2017,6 @@ drawWeapon p cr posInInv
| _crInvSel cr == posInInv = onLayer PtLayer drawnWep
| otherwise = blank
where drawnWep = uncurry translate (_crRad cr,0) p
--drawWeapon :: Picture -> Creature -> Int -> Maybe (Picture, [Int])
--drawWeapon p cr posInInv
-- | _crInvSel cr == posInInv = Just (drawnWep, [levLayer PtLayer])
-- | otherwise = Nothing
-- where drawnWep = uncurry translate (_crRad cr,0) p
medkit :: Int -> Item
medkit i = basicConsumable
@@ -2157,110 +2149,6 @@ crOrWall p dir w = fromMaybe (E3x3 $ p +.+ rotateV dir (arcLen,0))
g (E3x1 cr1) = dist p $ _crPos cr1
(arcLen,_) = randomR (25,50) $ _randGen w
-- grapFire :: Int -> World -> World
-- grapFire n w | fireCondition = set (creatures . ix n . crInv . ix itRef . wpFireState)
-- (_wpFireRate (_crInv cr IM.! itRef))
-- $ over (creatures . ix n . crInv . ix itRef . wpLoadedAmmo)
-- (\x -> x - 1)
-- $ set randGen g
-- $ over particles (IM.insert i (makeGrapFrom i n pos dir)) w
-- | reloadCondition = let remAmmo = _crAmmo cr M.! _wpAmmoType item
-- (newA,newTotalA) = moveInt (_wpMaxAmmo item) remAmmo
-- in set (pointerToItem . wpReloadState) rTime
-- $ set (pointerToItem . wpLoadedAmmo) newA
-- $ over (creatures . ix n . crAmmo )
-- (M.insert (_wpAmmoType item) newTotalA) w
-- | emptyCondition = soundOnce 1 w
-- | otherwise = w
-- where i = newParticleKey w
-- cr = (_creatures w IM.! n)
-- pos = _crPos cr +.+ ((_crRad cr +1) *.* unitVectorAtAngle dir)
-- dir = _crDir cr -- + a
-- (a,g) = randomR (-0.2,0.2::Float) (_randGen w)
-- itRef = _crInvSel cr
-- item = _crInv cr IM.! itRef
-- pointerToItem = creatures . ix n . crInv . ix itRef
-- rTime = _wpReloadTime (_crInv cr IM.! itRef)
-- fireCondition = _wpReloadState (_crInv cr IM.! itRef) == 0
-- && _wpFireState (_crInv cr IM.! itRef) == 0
-- && _wpLoadedAmmo (_crInv cr IM.! itRef) > 0
-- reloadCondition = _wpReloadState (_crInv cr IM.! itRef) == 0
-- && _wpLoadedAmmo (_crInv cr IM.! itRef) == 0
-- && someJust (_crAmmo cr M.!? PistolBullet)
-- emptyCondition = _wpLoadedAmmo (_crInv cr IM.! itRef) == 0
--
-- makeGrapFrom :: Int -> Int -> Point -> Float -> Particle
-- makeGrapFrom i ci pos dir = Particle
-- { _ptPos = pos
-- , _ptStartPos = pos
-- , _ptVel = rotateV dir (10,0)
-- , _ptPict = Line [(0,0)]
-- , _ptID = i
-- , _ptUpdate = moveGrap 50 [pos] ci i
-- }
--
-- moveGrap :: Int -> [Point] -> Int -> Int -> World -> World
-- moveGrap x ls ci i w --
-- | x < 0 || lineCollide = windGrap' (zipWith (-.-) ls ls5) ci i w
-- | otherwise = case tHit of
-- Just (Left (p,crID)) -> set (particles . ix i . ptUpdate) (windGrap'' i crID ci
-- (_crPos (_creatures w IM.! crID))
-- sCrP)
-- w
-- Just (Right (p,sv)) -> set (particles . ix i . ptUpdate)
-- (windGrap sCrP (zipWith (-.-) ls ls5 ++[p]) ci i)
-- w
-- _ -> set (particles . ix i . ptUpdate) (moveGrap (x-1) ls1 ci i)
-- $ set (particles . ix i. ptPos) pNewPos
-- $ set (particles . ix i. ptPict) pic
-- w
-- where sCr = _creatures w IM.! ci
-- sCrP = _crPos sCr
-- pic = thickLine ls1
-- pOldPos = _ptPos (_particles w IM.! i)
-- vel = _ptVel (_particles w IM.! i)
-- ls1 = zipWith (+.+) ls2 $ zipWith f [1,1-step..] ls ++ [pNewPos]
-- step = 1/ (51 - fromIntegral x)
-- f y p = p +.+ (y) *.* crMv
-- pNewPos = pOldPos +.+ vel
-- crMv = sCrP -.- _crOldPos sCr
-- ls3 = (:) (0,0) $ drop x $ take 48 $ cycle $
-- [lineWidth *.* vNormal vel
-- ,(0,0)
-- ,(-lineWidth) *.* vNormal vel
-- ,(-lineWidth) *.* vNormal vel
-- ,(0,0)
-- ,lineWidth *.* vNormal vel
-- ]
-- lineWidth = 1
-- lineWidth2 = 0.5
-- ls2 = ls3 ++ repeat (0,0)
-- ls5 = (:) (0,0) $ drop (x+z) $ take (48+z) $ cycle $
-- [lineWidth *.* vNormal vel
-- ,(0,0)
-- ,(-lineWidth) *.* vNormal vel
-- ,(-lineWidth) *.* vNormal vel
-- ,(0,0)
-- ,lineWidth *.* vNormal vel
-- ]
-- where z = 2
-- ls6 = (:) (0,0) $ drop (x+z) $ take (48+z) $ cycle $
-- [lineWidth2 *.* vNormal vel
-- ,(0,0)
-- ,(-lineWidth2) *.* vNormal vel
-- ,(-lineWidth2) *.* vNormal vel
-- ,(0,0)
-- ,lineWidth2 *.* vNormal vel
-- ]
-- where z = 2
-- hitCr = collidePointCrsPoint pOldPos pNewPos w
-- hitWl = collidePointWalls pOldPos pNewPos $ wallsNearPoint pNewPos w
-- tHit = thingHit' pOldPos hitCr hitWl
-- lineCollide = foldr (||) False $ zipWith
-- (\a b -> isJust $ collidePointWalls a b
-- $ wallsNearPoint b w)
-- ls (tail ls)
thingHit' :: Point2 -> Maybe (Point2,a) -> Maybe (Point2,c) -> Maybe (Either (Point2,a) (Point2,c))
thingHit' p Nothing Nothing = Nothing
thingHit' p (Just x) Nothing = Just (Left x)
@@ -2269,74 +2157,10 @@ thingHit' p (Just x@(p1,_)) (Just y@(p2,_))
| magV (p -.- p1) > magV (p -.- p2) = Just (Right y)
| otherwise = Just (Left x)
-- windGrap :: Point -> [Point] -> Int -> Int -> World -> World
-- windGrap cp (x:y:xs) ci i w
-- | dist (_crPos cr) cp < 5
-- = set (particles . ix i . ptUpdate) (windGrap cNewPos (y:xs) ci i)
-- $ set (particles . ix i . ptPict) (thickLine (y:xs))
-- $ set (creatures . ix ci . crPos) cNewPos
-- w
-- | otherwise = windGrap' (x:y:xs) ci i w
-- where cr = _creatures w IM.! ci
-- cNewPos = y -.- d
-- d = _crRad cr *.* errorNormalizeV 31 (y -.- x)
-- windGrap _ _ _ i w
-- = over particles (IM.delete i) w
--
-- windGrap' :: [Point] -> Int -> Int -> World -> World
-- windGrap' (x:[]) _ i w
-- = over particles (IM.delete i) w
-- windGrap' (x:xs) ci i w
-- = set (particles . ix i . ptUpdate) (windGrap' ys ci i)
-- $ set (particles . ix i . ptPict) (thickLine ys)
-- w
-- where ys = init $ zipWith f [1,1-step..] (x:xs)
-- crMv = sCrP -.- _crOldPos sCr
-- sCr = _creatures w IM.! ci
-- sCrP = _crPos sCr
-- f y p = p +.+ (y) *.* crMv
-- step = 1/ (fromIntegral (length xs) + 1)
--
-- windGrap'' :: Int -> Int -> Int -> Point -> Point -> World -> World
-- windGrap'' pti ci1 ci2 p1 p2 w
-- | dist cp1 cp2 < r1 + r2 + 1
-- = over particles (IM.delete pti) w
-- | dist cp1 p1 > 5 || dist cp2 p2 > 5
-- = over particles (IM.delete pti) w
-- | otherwise
-- = set (creatures . ix ci1 . crPos) cpn1
-- $ set (creatures . ix ci2 . crPos) cpn2
-- $ set (particles . ix pti . ptPict) (thickLine [ cp1, cp2])
-- $ set (particles . ix pti . ptUpdate) (windGrap'' pti ci1 ci2 cpn1 cpn2)
-- w
-- where cr1 = _creatures w IM.! ci1
-- cr2 = _creatures w IM.! ci2
-- cp1 = _crPos cr1
-- cp2 = _crPos cr2
-- r1 = _crRad cr1
-- r2 = _crRad cr2
-- m1 = _crMass cr1
-- m2 = _crMass cr2
-- v = errorNormalizeV 32 $ cp2 -.- cp1
-- v1 = 10 * m2 / (m1 + m2) *.* v
-- v2 = (-10 * m1 / (m1 + m2)) *.* v
-- cpn1 = cp1 +.+ v1
-- cpn2 = cp2 +.+ v2
spreadGunSpread,autogunSpread :: Float
spreadGunSpread = 0.5
autogunSpread = 0.07
medkit25,pipe,magShield :: Item
medkit25 = basicConsumable
{ _itIdentity = Medkit25
, _itName = "MEDKIT25"
, _itMaxStack = 3
, _itAmount = 2
, _cnEffect = heal25
, _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
, _itEquipPict = \cr _ -> blank
}
pipe = Craftable
{ _itIdentity = Generic
, _itName = "PIPE"
@@ -2426,13 +2250,11 @@ latchkeyPic = color yellow $
-- }}}
heal25 :: Int -> World -> Maybe World
heal25 n w | _crHP (_creatures w IM.! n) >= 200 = Nothing
| otherwise = Just $ soundOnce healSound
$ over (creatures . ix n . crHP) ((\x-> min x 100). (+ 25) ) w
heal25 = heal 25
heal :: Int -> Int -> World -> Maybe World
heal hp n w | _crHP (_creatures w IM.! n) >= 1000 = Nothing
heal hp n w | _crHP (_creatures w IM.! n) >= 10000 = Nothing
| otherwise = Just $ soundOnce healSound
$ over (creatures . ix n . crHP) ((\x-> min x 1000). (+ hp) ) w
$ over (creatures . ix n . crHP) ((\x-> min x 10000). (+ hp) ) w
forceFieldFire :: Int -> World -> World
forceFieldFire cid w = w