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

Add airlocks

Browse Source
This commit is contained in:
jgk
2021-05-02 21:09:25 +02:00
parent 9cdd3a9629
commit f336d7e3f6
27 changed files with 522 additions and 219 deletions
Download Patch File Download Diff File Expand all files Collapse all files
package.yaml
-1
View File
@@ -46,7 +46,6 @@ dependencies:
- aeson
- directory
- QuickCheck
- utility-ht
library:
source-dirs: src
src/Dodge/Base.hs
+1 -1
View File
@@ -735,7 +735,7 @@ nearestCrInFront p dir x w
{- | Test whether a creature is in a polygon.
-}
crInPolygon :: Creature -> [Point2] -> Bool
crInPolygon cr xs = errorPointInPolygon 3 (_crPos cr) xs
crInPolygon cr = errorPointInPolygon 3 (_crPos cr)
{- | Transform coordinates from world position to normalised screen coordinates.
-}
src/Dodge/Creature/Inanimate.hs
+9 -7
View File
@@ -67,13 +67,15 @@ explosiveBarrel :: Creature
explosiveBarrel = defaultInanimate
{ _crUpdate = updateExpBarrel
, _crHP = 400
, _crPict = \ _ -> onLayer CrLayer $ pictures [ color orange $ circleSolid 10
, color red $ circleSolid 8
]
, _crState = defaultState {_goals = [[Wait]]
,_faction = ChaseCritters
,_crSpState = Barrel []
}
, _crPict = \ _ -> onLayer CrLayer $ pictures
[ color red $ circleSolid 8
, color orange $ circleSolid 10
]
, _crState = defaultState
{_goals = [[Wait]]
,_faction = ChaseCritters
,_crSpState = Barrel []
}
, _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
,_crApplyDamage = \_ c -> (id, c)
}
src/Dodge/Creature/State.hs
+15 -12
View File
@@ -46,18 +46,20 @@ stateUpdate u w (f,g) cr =
$ crOrCorpse =<< maybeCr
)
where
crOrCorpse cr | cr ^. crHP > 0 = Just cr
| otherwise = Nothing
deathEff | cr ^.crHP > 0 = id
| otherwise = stopSoundFrom (CrWeaponSound (_crID cr))
. over decorations addCorpse
. dropByState cr
crOrCorpse cr
| cr ^. crHP > 0 = Just cr
| otherwise = Nothing
deathEff
| cr ^.crHP > 0 = id
| otherwise = stopSoundFrom (CrWeaponSound (_crID cr))
. over decorations addCorpse
. dropByState cr
crBeforeDeath = colCrWall w $ cr
addCorpse = insertNewKey $ uncurry translate (_crOldPos cr)
$ rotate (_crDir cr)
(_crCorpse cr)
-- | Drop items accoring to the creature state.
-- | Drop items according to the creature state.
dropByState :: Creature -> World -> World
dropByState cr w = foldr (copyItemToFloor cr) w is
where
@@ -81,11 +83,12 @@ crFriction cr vel = (0,0)
doDamage :: Creature -> Creature
doDamage cr = set (crState . crDamage) [] $ over (crState . crPastDamage) (+ hpLost)
damagedCr
where dams = _crDamage $ _crState cr
startHP = _crHP cr
damagedCr = snd $ (_crApplyDamage cr) dams cr
afterHP = _crHP damagedCr
hpLost = startHP - afterHP -- note this can be negative
where
dams = _crDamage $ _crState cr
startHP = _crHP cr
damagedCr = snd $ (_crApplyDamage cr) dams cr
afterHP = _crHP damagedCr
hpLost = startHP - afterHP -- note this can be negative
sumDamage :: Creature -> DamageType -> Int -> Int
sumDamage cr dm x = x + _dmAmount dm
src/Dodge/Creature/YourControl.hs
-2
View File
@@ -16,8 +16,6 @@ import qualified Data.Set as S
import qualified Data.IntMap.Strict as IM
import System.Random
yourControl :: World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature)
yourControl w (f,g) cr = ( (updateUsingInput . f, g)
, Just . crAutoReload . mouseActionsCr (_mouseButtons w) $ wasdWithAiming w speed strafeSpeed 0 cr
src/Dodge/Data.hs
+5 -5
View File
@@ -26,10 +26,12 @@ import Dodge.Data.DamageType
import Dodge.Config.Data
import Dodge.Config.KeyConfig
import Dodge.Item.Attachment.Data
import Dodge.World.Trigger.Data
import Preload.Data
import Picture.Data
import Geometry.Data
import Sound.Data
import qualified DoubleStack as DS
import Control.Lens
import Control.Monad.State
@@ -162,10 +164,6 @@ data WorldState
| CrNumAlive Int
deriving (Eq,Ord)
data WorldTrigger
= ResetLevel Int
deriving (Eq,Ord)
data Button = Button
{ _btPict :: Picture
, _btPos :: Point2
@@ -434,12 +432,14 @@ data Wall
, _wlIsSeeThrough :: Bool
}
| Door
{ _wlLine :: [Point2] , _wlID :: Int
{ _wlLine :: [Point2]
, _wlID :: Int
, _doorMech :: World -> World
, _wlColor :: Color
, _wlSeen :: Bool
, _wlIsSeeThrough :: Bool
, _doorPathable :: Bool
, _drPositions :: DS.DS [Point2]
}
| Block
{ _wlLine :: [Point2]
src/Dodge/Data.hs.orig
+1 -1
View File
@@ -616,7 +616,7 @@ data PSType = PutCrit Creature
| PutAutoDoor Point2 Point2
| PutBlock [Int] Color [Point2]
| PutLineBlock Wall Float Float Point2 Point2
| PutTriggerDoor Color (World -> Bool) Point2 Point2
| PutDoubleDoor Color (World -> Bool) Point2 Point2
| PutBtDoor Color Point2 Float Point2 Point2
| PutSwitchDoor Color Point2 Float Point2 Point2
| RandPS (State StdGen PSType)
src/Dodge/Default.hs
+3
View File
@@ -16,6 +16,7 @@ import Dodge.Config.Data
import Dodge.Config.KeyConfig
import Geometry
import Picture
import qualified DoubleStack as DS
import Control.Lens
import System.Random
@@ -44,6 +45,7 @@ defaultAutoDoor = Door
, _wlSeen = False
, _wlIsSeeThrough = False
, _doorPathable = True
, _drPositions = DS.singleton [(0,0),(50,0)]
}
{-
Non-pathable door.
@@ -56,6 +58,7 @@ defaultDoor = Door
, _wlSeen = False
, _wlIsSeeThrough = False
, _doorPathable = False
, _drPositions = DS.singleton [(0,0),(50,0)]
}
defaultCreature :: Creature
defaultCreature = Creature
src/Dodge/Floor.hs
+29 -23
View File
@@ -12,6 +12,7 @@ import Dodge.Room.Link
import Dodge.Room.Door
import Dodge.Room.Branch
import Dodge.Room.Boss
import Dodge.Room.Airlock
import Dodge.Base
import Dodge.Layout
import Dodge.Layout.Tree.Polymorphic
@@ -40,29 +41,34 @@ roomTreex = do
let struct = treeFromPost [[SpecificRoom $ fmap (pure . Right) testRoom]] [EndRoom]
let t' = padCorridors struct
t = treeFromTrunk
[[StartRoom]
,[DoorAno]
,[SpecificRoom $ fmap (pure . Right) $ randomiseAllLinks =<< centerVaultRoom 1 200 200 50]
,[SpecificRoom blockedCorridor]
,[OrAno [[DoorAno]
,[Corridor]
,[DoorNumAno 0,AirlockAno]]
]
,[FirstWeapon]
,[Corridor]
,[SpecificRoom $ fmap (pure . Right) testRoom]
,[Corridor]
,[OrAno [[SpecificRoom $ branchRectWith $ fmap (pure . Left) armouredChasers]
,[BossAno $ addArmour launcherCrit & crHP +~ 800
& crState . crDropsOnDeath .~ DropSpecific [0] ]
]
]
,[Corridor]
,[SpecificRoom $ fmap (pure . Right) armouredCorridor]
,[Corridor]
,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]]
]
t'
[[StartRoom]
,[Corridor]
,[SpecificRoom $ (pure . pure . Right) $ airlockCrystal 20]
,[Corridor]
,[DoorAno]
,[SpecificRoom $ fmap (pure . Right)
$ randomiseLinksBy shuffleTail =<< centerVaultRoom 1 200 200 50]
,[SpecificRoom blockedCorridor]
,[OrAno [[DoorAno]
,[Corridor]
,[DoorNumAno 0,AirlockAno]]
]
,[FirstWeapon]
,[Corridor]
,[SpecificRoom $ fmap (pure . Right) testRoom]
,[Corridor]
,[OrAno
[[SpecificRoom $ branchRectWith $ fmap (pure . Left) armouredChasers]
,[BossAno $ addArmour launcherCrit & crHP +~ 800
& crState . crDropsOnDeath .~ DropSpecific [0] ]
]
]
,[Corridor]
,[SpecificRoom $ fmap (pure . Right) armouredCorridor]
,[Corridor]
,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]]
]
t'
fmap (shiftExpandTree . expandTreeBy id) $ mapM annoToRoomTree t
levx :: RandomGen g => State g [Room]
src/Dodge/Layout/Tree/Annotate.hs
+2 -1
View File
@@ -15,6 +15,7 @@ import Dodge.Room.Boss
import Dodge.Room.Treasure
import Dodge.Room.Link
import Dodge.Room.Data
import Dodge.Room.Airlock
import Dodge.Room
import Dodge.Room.Teleport
@@ -71,7 +72,7 @@ annoToRoomTree [OrAno as] = do
annoToRoomTree a
annoToRoomTree [Corridor] = pure . Right <$> randomiseOutLinks corridor
annoToRoomTree [DoorAno] = roomThenCorridor door
annoToRoomTree [DoorNumAno i,AirlockAno] = roomThenCorridor (airlock i)
annoToRoomTree [DoorNumAno i,AirlockAno] = airlock i >>= roomThenCorridor
annoToRoomTree [FirstWeapon] = do
branchWP <- branchRectWith weaponRoom
blockedC <- longBlockedCorridor
src/Dodge/LevelGen.hs
+9 -3
View File
@@ -61,10 +61,16 @@ placeSpot ps w = case ps of
-> placePressPlate pp p rot w
PS {_psType = RandPS rgen}
-> placeSpot (set psType evaluatedType ps) (set randGen g w)
where (evaluatedType, g) = runState rgen (_randGen w)
where
(evaluatedType, g) = runState rgen (_randGen w)
PS {_psPos = p, _psRot = rot, _psType = PutTriggerDoor col f a b}
-> addTriggerDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
PS {_psPos = p, _psRot = rot, _psType = PutDoor col f pss}
-> putDoor col f (map (mapBoth $ shiftPointBy (p,rot)) pss) w
where
mapBoth fn (x,y) = (fn x, fn y)
PS {_psPos = p, _psRot = rot, _psType = PutDoubleDoor col f a b}
-> putDoubleDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
PS {_psPos = p, _psRot = rot, _psType = PutAutoDoor a b}
-> addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
src/Dodge/LevelGen/AutoDoor.hs
+2
View File
@@ -10,6 +10,7 @@ import Dodge.SoundLogic
import Dodge.Creature.Property
import Geometry
import Picture
import qualified DoubleStack as DS
import Data.List
import Data.Maybe
@@ -85,6 +86,7 @@ autoDoorPane (trigx,trigy) n closedPos openPos = Door
, _wlSeen = False
, _wlIsSeeThrough = False
, _doorPathable = True
, _drPositions = DS.singleton closedPos
}
where
a = closedPos !! 0
src/Dodge/LevelGen/Data.hs
+2 -1
View File
@@ -17,7 +17,8 @@ data PSType = PutCrit Creature
| PutAutoDoor Point2 Point2
| PutBlock [Int] Color [Point2]
| PutLineBlock Wall Float Float Point2 Point2
| PutTriggerDoor Color (World -> Bool) Point2 Point2
| PutDoubleDoor Color (World -> Bool) Point2 Point2
| PutDoor Color (World -> Bool) [(Point2,Point2)]
| PutBtDoor Color Point2 Float Point2 Point2
| PutSwitchDoor Color Point2 Float Point2 Point2
| RandPS (State StdGen PSType)
src/Dodge/LevelGen/TriggerDoor.hs
+89 -16
View File
@@ -6,17 +6,15 @@ import Dodge.Base
import Dodge.SoundLogic
import Dodge.LevelGen.Switch
import Dodge.LevelGen.Pathing
import Picture
import Geometry
import qualified DoubleStack as DS
import Data.List
import Data.Maybe
import qualified Data.IntMap.Strict as IM
import Control.Lens
import Control.DeepSeq (deepseq)
import Data.Graph.Inductive hiding ((&))
import Data.Graph.Inductive.NodeMap
@@ -26,7 +24,7 @@ addButtonDoor c btp btr a b w = over buttons (IM.insert bid bt)
$ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
$ set pathGraph newGraph
$ set pathGraph' newGraphPairs
$ addTriggerDoor c cond a b w
$ putDoubleDoor c cond a b w
where
bid = newKey $ _buttons w
cond w = BtNoLabel == _btState (_buttons w IM.! bid)
@@ -44,7 +42,7 @@ addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt)
$ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
$ set pathGraph newGraph
$ set pathGraph' newGraphPairs
$ addTriggerDoor c cond a b w
$ putDoubleDoor c cond a b w
where
bid = newKey $ _buttons w
cond w = BtOn == _btState (_buttons w IM.! bid)
@@ -59,17 +57,48 @@ addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt)
closeDoor w' = over pathGraph' (\\ removedPairs)
. over pathGraph (flip run_ $ delMapEdgesM removedPairs) $ w'
addTriggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> World -> World
addTriggerDoor c cond a b = over walls (triggerDoor c cond a b)
triggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
triggerDoor c cond a b wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoor c cond a b is
where
i = newKey wls
is = [i..]
putDoor
:: Color
-> (World -> Bool)
-> [(Point2,Point2)] -- ^ Door positions, closed to open.
-- Bumped out up and down by 9, not widened
-> World
-> World
putDoor c cond pss = over walls triggerDoor
where
triggerDoor wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoor c cond pss is
where
is = [newKey wls..]
mkTriggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> [Int] -> [Wall]
mkTriggerDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPane c cond)
putDoubleDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> World -> World
putDoubleDoor c cond a b = over walls triggerDoubleDoor
where
triggerDoubleDoor wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoubleDoor c cond a b is
where
is = [newKey wls..]
mkTriggerDoor
:: Color
-> (World -> Bool) -- ^ Opening condition
-> [(Point2,Point2)] -- ^ List of wall position pairs, closed to open
-> [Int] -- ^ Wall ids
-> [Wall]
mkTriggerDoor c cond ppairs is = zipWith (triggerDoorPane c cond) is $
transpose $ map toPanePoints ppairs
toPanePoints :: (Point2,Point2) -> [[Point2]]
toPanePoints (x,y) =
[ [y +.+ perp, y -.- perp]
, [y -.- perp, x -.- perp]
, [x -.- perp, x +.+ perp]
, [x +.+ perp, y +.+ perp]
]
where
perp = 9 *.* errorNormalizeV 49 ( vNormal (x -.- y))
mkTriggerDoubleDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> [Int] -> [Wall]
mkTriggerDoubleDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPaneLinear c cond)
xs
(leftDoor ++ rightDoor)
(map shiftLeft leftDoor ++ map shiftRight rightDoor)
@@ -106,8 +135,14 @@ mkTriggerDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPane c cond)
where
wp = _wlLine (_walls w IM.! head xs) !! 1
triggerDoorPane :: Color -> (World -> Bool) -> Int -> [Point2] -> [Point2] -> Wall
triggerDoorPane c cond n closedPos openPos = Door
triggerDoorPaneLinear
:: Color
-> (World -> Bool) -- ^ Opening condition
-> Int -- ^ Wall id
-> [Point2] -- ^ Closed position
-> [Point2] -- ^ Open position
-> Wall
triggerDoorPaneLinear c cond n closedPos openPos = Door
{ _wlLine = closedPos
, _wlID = n
, _doorMech = dm
@@ -115,6 +150,7 @@ triggerDoorPane c cond n closedPos openPos = Door
, _wlSeen = False
, _wlIsSeeThrough = False
, _doorPathable = False
, _drPositions = DS.singleton closedPos
}
where
a = closedPos !! 0
@@ -135,3 +171,40 @@ triggerDoorPane c cond n closedPos openPos = Door
= over wallsZone $ adjustIMZone openDoor x y n
changeZonedWall' (!x,!y)
= over wallsZone $ adjustIMZone closeDoor x y n
{- |
Zoning might be an issue here.
It is necessary in the current version, but I am not sure of its behaviour. -}
triggerDoorPane
:: Color
-> (World -> Bool) -- ^ Opening condition
-> Int -- ^ Wall id
-> [[Point2]] -- ^ List of positions: closed to open
-> Wall
triggerDoorPane c cond n poss = Door
{ _wlLine = head poss
, _wlID = n
, _doorMech = dm
, _wlColor = c
, _wlSeen = False
, _wlIsSeeThrough = False
, _doorPathable = False
, _drPositions = DS.fromListL poss
}
where
dm w | cond w = flip (foldr changeZonedWall) allZoneps
$ over walls (IM.adjust openDoor n) w -- . wlLine . ix 0) (mvPointToward a')
| otherwise = flip (foldr changeZonedWall') allZoneps
$ over walls (IM.adjust closeDoor n) w -- . wlLine . ix 0) (mvPointToward a)
openDoor = updatePos . (drPositions %~ DS.pushL)
closeDoor = updatePos . (drPositions %~ DS.pushR)
updatePos :: Wall -> Wall
updatePos d = d & wlLine %~ maybe id const (DS.head <$> (d ^? drPositions))
changeZonedWall (!x,!y)
= over wallsZone $ adjustIMZone openDoor x y n
changeZonedWall' (!x,!y)
= over wallsZone $ adjustIMZone closeDoor x y n
allZoneps = nub $ concatMap zoneps poss
zoneps [a,b]
| dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
| otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b
src/Dodge/RandomHelp.hs
+5 -1
View File
@@ -41,7 +41,7 @@ takeN :: RandomGen g => Int -> [a] -> State g [a]
takeN 0 xs = return []
takeN i xs = fmap fst $ takeNMore i ([],xs)
-- to randomly shuffle a list
-- | Randomly shuffle a list.
shuffle :: RandomGen g => [a] -> State g [a]
shuffle xs = do
let l = length xs
@@ -51,6 +51,10 @@ shuffle xs = do
let (_,zs) = mapAccumR f xs rands
return zs
-- | Randomly shuffle the tail of a list, not safe.
shuffleTail :: RandomGen g => [a] -> State g [a]
shuffleTail (x:xs) = (x :) <$> shuffle xs
randomSelectionFromList :: RandomGen g => Float -> [a] -> State g [a]
randomSelectionFromList p = filterM $ const $ randProb p
src/Dodge/Render.hs
+8 -15
View File
@@ -51,53 +51,43 @@ doDrawing pdata w = do
viewFroms@(viewFromx,viewFromy) = _cameraViewFrom w
pic = worldPictures w
wallPoints = map fst wallPointsCol
-- set the coordinate uniforms ready for drawing elements with using world coordinates
setCommonUniforms pdata rot zoom trans wins
depthFunc $= Just Less
pmat <- (newMatrix RowMajor $ perspectiveMatrix rot zoom trans wins viewFroms)
:: IO (GLmatrix GLfloat)
-- draw the lightmap. Probably changes the bound framebufferObject
createLightMap pdata (w ^. config . shadow_resolution) wallPoints lightPoints viewFroms pmat
-- draw the background. Assumes that depth testing is not enabled or that
-- the depth buffer is ready to be drawn on
blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
renderBackground pdata rot zoom trans wins
-- draw the walls
depthFunc $= Just Less
if w ^. config . wall_textured
then renderTextureWalls pdata wallPointsCol pmat
else renderBlankWalls pdata wallPointsCol pmat
-- I believe a more apt name would be setCeilingDepth: stops drawing of objects
-- at points that are behind the extension of walls to the screen edge
setWallDepth pdata wallPoints (viewFromx,viewFromy) pmat
-- draw the first layer of pictures
-- these will probably all be opaque
renderFoldable pdata $ picToLTree (Just 0) pic
-- reset blend so that light map doesn't apply
-- useful for drawing vivid projectiles
blendFuncSeparate $= ((SrcAlpha,OneMinusSrcAlpha) , (Zero,One))
depthFunc $= Just Lequal
renderFoldable pdata $ picToLTree (Just 1) pic
-- reset blend so that light map applies again
-- allows us to be certain these elements are drawn on top of those before,
-- in case we want transparency effects
blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
renderFoldable pdata $ picToLTree (Just 2) pic
depthMask $= Disabled
-- render transparent walls
-- the ordering between these and transparent clouds perhaps presents a challenge
renderBlankWalls pdata windowPoints pmat
depthMask $= Enabled
-- draw the fbo to the screen
-- allows for post-processing
-- first, bind the screen fbo
@@ -108,20 +98,23 @@ doDrawing pdata w = do
textureBinding Texture2D $= Just (snd $ _fbo2 pdata)
-- textureFilter Texture2D $= ((Linear',Just Linear') , Linear')
-- generateMipmap' Texture2D
bindShaderBuffers [_fullscreenShader pdata] [4]
drawShader (_fullscreenShader pdata) 4
if _crHP (you w) > 0
then do
bindShaderBuffers [_fullscreenShader pdata] [4]
drawShader (_fullscreenShader pdata) 4
else do
bindShaderBuffers [_grayscaleShader pdata] [4]
drawShader (_grayscaleShader pdata) 4
blend $= Enabled
-- reset the coordinate uniforms for pictures that are drawn wrt to window
-- coordinates
resetShaderUniforms (map extractProgAndUnis $ _pictureShaders pdata)
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
renderFoldable pdata (picToLTree Nothing $ fixedCoordPictures w)
eTicks <- SDL.ticks
return (eTicks - sTicks)
----------------------
--------------------------------------------------------------------------------
renderBlankWalls
:: RenderData
src/Dodge/Room.hs
+3 -48
View File
@@ -27,6 +27,7 @@ import Dodge.Room.Corridor
import Dodge.Room.Link
import Dodge.Room.Branch
import Dodge.Room.Door
import Dodge.Room.Airlock
import Geometry
import Picture
@@ -47,53 +48,6 @@ import Data.Graph.Inductive.NodeMap
import qualified Data.Map as M
import qualified Data.IntMap.Strict as IM
airlockOneWay :: Int -> Room
airlockOneWay n = Room
{ _rmPolys = [rectNSWE 90 0 0 40]
, _rmLinks = lnks
, _rmPath = []
, _rmPS = [PS (0,15) 0 $ PutTriggerDoor col (not . cond) (0,0) (0,40)
,PS (0,75) 0 $ PutTriggerDoor col (cond) (0,0) (0,40)
,PS (35,45) (pi/2) $ PutButton $ makeButton col (over worldState
(M.insert (DoorNumOpen n) True))
]
--, _rmBound = rectNSWE 90 30 (-30) 30
, _rmBound = rectNSWE 75 15 0 40
}
where lnks = [((0,85),0)
,((0, 5),pi)
]
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
col = dim $ dim $ bright red
airlock
:: Int -- ^ Door id
-> Room
airlock n = Room
{ _rmPolys =
[ rectNSWE 100 0 0 40
, rectNSWE 65 35 (-40) 20
]
, _rmLinks = lnks
, _rmPath = [((20,85),(20,45))
,((20,45),(20, 5))
]
, _rmPS =
[PS (0,20) 0 $ PutTriggerDoor col (not . cond) (1,0) (39,0)
,PS (0,80) 0 $ PutTriggerDoor col (cond) (1,0) (39,0)
,PS (35,50) (pi/2) $ PutButton $ makeSwitch col
(over worldState (M.insert (DoorNumOpen n) True))
(over worldState (M.insert (DoorNumOpen n) False))
,PS (-25, 50) 0 putLamp
]
, _rmBound = rectNSWE 75 15 0 40
}
where
lnks = [((20,85),0)
,((20, 5),pi)
]
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
col = dim $ dim $ bright red
roomC :: Float -> Float -> Room
roomC x y = Room
@@ -633,4 +587,5 @@ spawnerRoom = do
]
let f ((lx,_),_) = lx < x/2-5
roomWithSpawner <- (fmap connectRoom . randomiseOutLinks) =<< filterLinks f (set rmPS plmnts $ roomRect x y 2 2)
return $ treeFromTrunk [Left (airlock 0)] roomWithSpawner
aRoom <- airlock 0
return $ treeFromTrunk [Left aRoom] roomWithSpawner
src/Dodge/Room/Airlock.hs
+157
View File
@@ -0,0 +1,157 @@
{-# LANGUAGE TupleSections #-}
{-
Rooms that contain two doors and a switch alternating both. -}
module Dodge.Room.Airlock
where
import Dodge.Room.Data
import Dodge.Room.Placement
import Dodge.Data
import Dodge.LevelGen.Data
import Dodge.LevelGen.Switch
import Dodge.RandomHelp
import Geometry
import Picture
import qualified Data.Map as M
import System.Random
import Control.Monad.State
import Control.Lens
airlockOneWay :: Int -> Room
airlockOneWay n = Room
{ _rmPolys = [rectNSWE 90 0 0 40]
, _rmLinks = lnks
, _rmPath = []
, _rmPS = [PS (0,15) 0 $ PutDoubleDoor col (not . cond) (0,0) (0,40)
,PS (0,75) 0 $ PutDoubleDoor col (cond) (0,0) (0,40)
,PS (35,45) (pi/2) $ PutButton $ makeButton col (over worldState
(M.insert (DoorNumOpen n) True))
]
--, _rmBound = rectNSWE 90 30 (-30) 30
, _rmBound = rectNSWE 75 15 0 40
}
where lnks = [((0,85),0)
,((0, 5),pi)
]
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
col = dim $ dim $ bright red
{- |
A passage with a switch that opens forward access while closing backwards access. -}
airlock
:: RandomGen g
=> Int -- ^ Door id
-> State g Room
airlock n = takeOne [airlock0 n,airlock90 n,airlockCrystal n]
{- |
Straight airlock -}
airlock0
:: Int -- ^ Door id
-> Room
airlock0 n = Room
{ _rmPolys =
[ rectNSWE 100 0 0 40
, rectNSWE 65 35 (-40) 20
]
, _rmLinks = lnks
, _rmPath = [((20,95),(20,45))
,((20,45),(20, 5))
]
, _rmPS =
[PS (0,20) 0 $ PutDoubleDoor col (not . cond) (1,0) (39,0)
,PS (0,80) 0 $ PutDoubleDoor col (cond) (1,0) (39,0)
,PS (35,50) (pi/2) $ PutButton $ makeSwitch col
(over worldState (M.insert (DoorNumOpen n) True))
(over worldState (M.insert (DoorNumOpen n) False))
,PS (-25, 50) 0 putLamp
]
, _rmBound = rectNSWE 75 15 0 40
}
where
lnks = [((20,95),0)
,((20, 5),pi)
]
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
col = dim $ dim $ bright red
airlock90
:: Int -- ^ Door id
-> Room
airlock90 n = Room
{ _rmPolys =
[ rectNSWE 100 10 10 100
, rectNSWE 20 0 20 60
, rectNSWE 20 60 20 0
, [ (10,100)
, (100,150)
, (150,100)
, (100,10)
]
]
, _rmLinks =
[((0,40),pi/2)
,((40, 0),pi)
]
, _rmPath =
[((0,40),(40,0))
,((40,0),(0,40))
]
, _rmPS =
[PS (5,5) 0 $ PutDoor col (not . cond) pss
,PS (120,120) (3* pi/4) $ PutButton $ makeSwitch col
(over worldState (M.insert (DoorNumOpen n) True))
(over worldState (M.insert (DoorNumOpen n) False))
,PS (60, 60) 0 putLamp
]
, _rmBound =
[ (10,10)
, (10,100)
, (100,150)
, (150,100)
, (100,10)
]
}
where
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
col = dim $ dim $ bright red
pss = ((0,0) ,) <$> arcStepwise 3 (negate $ pi/2) (0,0) (0,55)
airlockCrystal
:: Int -- ^ Door id
-> Room
airlockCrystal n = Room
{ _rmPolys =
[ rectNSWE 140 0 0 40
, orderPolygon
[(39,20)
,(150,60)
,(150,80)
,(39,120)
]
]
, _rmLinks =
[((20,130),0)
,((20, 0),pi)
]
, _rmPath =
[
]
, _rmPS =
[PS (0,0) 0 $ PutDoor col (not . cond) pss
,PS (145,70) (pi/2) $ PutButton $ makeSwitch col
(over worldState (M.insert (DoorNumOpen n) True))
(over worldState (M.insert (DoorNumOpen n) False))
,crystalLine (0,70) (40,70)
,PS (20, 40) 0 putLamp
,PS (20, 100) 0 putLamp
]
, _rmBound =
[ ]
}
where
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
col = dim $ dim $ bright red
pss :: [(Point2,Point2)]
pss = reverse $ fmap ( (\x -> ((50,x),(50,x+50)) ) . fromIntegral)
[20,22..70]
src/Dodge/Room/Door.hs
+2
View File
@@ -22,3 +22,5 @@ door = Room
where lnks = [((20,35),0)
,((20, 5),pi)
]
src/Dodge/Room/Link.hs
+9
View File
@@ -30,6 +30,15 @@ randomiseAllLinks r = do
newLinks <- shuffle $ _rmLinks r
return $ r {_rmLinks = newLinks}
randomiseLinksBy
:: RandomGen g
=> ( [(Point2,Float)] -> State g [(Point2,Float)] )
-> Room
-> State g Room
randomiseLinksBy f r = do
newLinks <- f $ _rmLinks r
return $ r {_rmLinks = newLinks}
filterLinks :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room
filterLinks cond r = do
newLinks <- shuffle $ filter cond $ init $ _rmLinks r
src/Dodge/Room/Procedural.hs
+5 -1
View File
@@ -260,6 +260,10 @@ centerVaultRoom n w h d = do
,PS (w-5,5-h) 0 putLamp
,PS (5-w,h-5) 0 putLamp
,PS (5-w,5-h) 0 putLamp
,PS (0,h-5) 0 $ PutCrit explosiveBarrel
,PS (5,h-5) 0 $ PutCrit explosiveBarrel
,PS (0,h) 0 $ PutCrit explosiveBarrel
,PS (-4,h-5) 0 $ PutCrit explosiveBarrel
,PS (0,0) 0 $ PutCrit (cr & crState . crDropsOnDeath .~ DropAll)
]
++ concat (zipWith (\i r -> map (shiftPSBy ((0,0),r)) $ theDoor i)
@@ -269,7 +273,7 @@ centerVaultRoom n w h d = do
where
col = dim $ dim $ bright red
theDoor i =
[ PS (0,d-10) 0 $ PutTriggerDoor col (cond i) (-19,0) (19,0)
[ PS (0,d-10) 0 $ PutDoubleDoor col (cond i) (-19,0) (19,0)
, PS (35,d+4) 0 $ PutButton $ makeSwitch col
(over worldState (M.insert (DoorNumOpen i) True))
(over worldState (M.insert (DoorNumOpen i) False))
src/Dodge/Room/Teleport.hs
+1
View File
@@ -4,6 +4,7 @@ Specification of rooms that teleport (between levels).
module Dodge.Room.Teleport
where
import Dodge.Data
import Dodge.World.Trigger.Data
import Dodge.Base
import Dodge.Room.Data
import Dodge.Room.Procedural
src/Dodge/Update.hs
+91 -81
View File
@@ -7,6 +7,7 @@ module Dodge.Update
) where
import Dodge.Data
import Dodge.Data.Menu
import Dodge.World.Trigger.Data
import Dodge.Config.Data
import Dodge.Data.Menu
import Dodge.Base
@@ -35,35 +36,38 @@ pushSideEffects :: World -> World
pushSideEffects w = w
& sideEffects .~ []
& doneSideEffects .~ _sideEffects w
{- | The update step.
If '_menuLayers' is not empty, or the saving screen, this is the identity.
In such menus, the only way to change the world is using event handling.
-}
{- |
The update step.
For most menus the only way to change the world is using event handling. -}
update' :: World -> World
update' w = case _menuLayers w of
(WaitMessage _ : ls) -> w & menuLayers .~ ls
(_ : _) -> w
[] -> let w1 = updateParticles
. updateProjectiles
. updateLightSources
. zoneClouds
. updateClouds
. updateCreatures
. updateBlocks -- . zoning
. updateSeenWalls
. updateSoundQueue
$ updateCloseObjects w
in checkEndGame
. updateTriggers
. ppEvents
. updateCamera
. colCrsWalls
. simpleCrSprings
. zoneCreatures
. updateWalls
. set worldEvents id
$ _worldEvents w1 w1
(GameOverMenu : _) -> updateParticles
. updateProjectiles
. updateLightSources
$ updateClouds
w
(_ : _) -> w
[] -> checkEndGame
. updateTriggers
. ppEvents
. updateCamera
. colCrsWalls
. simpleCrSprings
. zoneCreatures
. updateWalls
. set worldEvents id
. doubleArgumentFor _worldEvents
. updateParticles
. updateProjectiles
. updateLightSources
. zoneClouds
. updateClouds
. updateCreatures
. updateBlocks
. updateSeenWalls
. updateSoundQueue
$ updateCloseObjects w
where
zoneCreatures = set creaturesZone (IM.foldr creatureInZone IM.empty (_creatures w))
creatureInZone cr = insertIMInZone x y cid cr
@@ -73,17 +77,18 @@ update' w = case _menuLayers w of
cloudInZone cr = insertIMInZone x y cid cr
where (x,y) = zoneOfPoint $ _clPos cr
cid = _clID cr
doubleArgumentFor f x = f x x
updateTriggers :: World -> World
updateTriggers w
| ResetLevel 1 `S.member` _worldTriggers w
= generateFromList levx
$ initialWorld
& randGen .~ _randGen w
& config .~ _config w
& menuLayers .~ []
& creatures . ix 0 . crPos .~ (0,0)
| ResetLevel 1 `S.member` _worldTriggers w = generateFromList levx $ initialWorld
& randGen .~ _randGen w
& config .~ _config w
& menuLayers .~ []
& creatures . ix 0 .~ cr
| otherwise = w
where
cr = _creatures w IM.! 0 & crPos .~ (0,0)
updateSoundQueue = set soundQueue [] . set sounds M.empty
@@ -93,10 +98,8 @@ updateLightSources w = set tempLightSources (catMaybes tlss) w'
(w',tlss) = mapAccumR (\a b -> _tlsUpdate b a b) w $ _tempLightSources w
updateProjectiles w = IM.foldr' _pjUpdate w $ _projectiles w
{-
Apply internal particle updates, delete 'Nothing's.
-}
Apply internal particle updates, delete 'Nothing's. -}
updateParticles :: World -> World
updateParticles w = set particles (catMaybes ps) w'
where
@@ -105,12 +108,11 @@ updateParticles w = set particles (catMaybes ps) w'
updateCreatures :: World -> World
updateCreatures w = f $ set randGen newG $ set creatures (IM.mapMaybe id crs) w
where
((f,newG),crs) = IM.mapAccum (\g' cr -> _crUpdate cr w g' cr) (id,_randGen w)
$ _creatures w
((f,newG),crs) =
IM.mapAccum (\g' cr -> _crUpdate cr w g' cr) (id,_randGen w) $ _creatures w
{- |
Apply door mechanisms.
-}
Apply door mechanisms. -}
updateWalls :: World -> World
updateWalls w = IM.foldr (maybe id id . (^? doorMech)) w (_walls w)
@@ -127,69 +129,75 @@ updateSeenWalls w = foldr markSeen w wallsToUpdate
setTestStringIO :: IO World -> IO World
setTestStringIO = fmap (\ w -> set testString (show $ s w) w)
where s w = (-.-) <$> (w ^? creatures . ix 0 . crPos) <*> (w ^? creatures . ix 0 . crOldPos)
where
s w = (-.-) <$> (w ^? creatures . ix 0 . crPos) <*> (w ^? creatures . ix 0 . crOldPos)
checkEndGame :: World -> World
checkEndGame w | _crHP (you w) < 1 = haltSound $ w {_menuLayers = [GameOverMenu]}
| otherwise = w
checkEndGame w
| _crHP (you w) < 1 = haltSound $ w {_menuLayers = [GameOverMenu]}
| otherwise = w
updateClouds :: World -> World
updateClouds w = IM.foldr' updateCloud w $ _clouds w
updateCloud :: Cloud -> World -> World
updateCloud c w | _clTimer c < 1 = w & clouds %~ IM.delete (_clID c)
| otherwise = moveCloud c w
updateCloud c w
| _clTimer c < 1 = w & clouds %~ IM.delete (_clID c)
| otherwise = moveCloud c w
moveCloud :: Cloud -> World -> World
moveCloud c w = _clEffect c c . theUpdate $ w
where newVel = 0.95 *.* springVels
springVels = IM.foldr' (clClSpringVel c w) (_clVel c) (cloudsNearPoint oldPos w)
oldPos = _clPos c
newPos = oldPos +.+ newVel
hitWl = collideCircWalls' oldPos newPos 5 $ wallsNearPoint newPos w
finalPos = fromMaybe newPos (fmap fst hitWl)
finalVel = fromMaybe newVel (fmap snd hitWl)
theUpdate w' = w' & clouds . ix (_clID c) . clTimer %~ (\t -> t - 1)
& clouds . ix (_clID c) . clVel .~ finalVel
& clouds . ix (_clID c) . clPos .~ finalPos
where
newVel = 0.95 *.* springVels
springVels = IM.foldr' (clClSpringVel c w) (_clVel c) (cloudsNearPoint oldPos w)
oldPos = _clPos c
newPos = oldPos +.+ newVel
hitWl = collideCircWalls' oldPos newPos 5 $ wallsNearPoint newPos w
finalPos = fromMaybe newPos (fmap fst hitWl)
finalVel = fromMaybe newVel (fmap snd hitWl)
theUpdate w' = w'
& clouds . ix (_clID c) . clTimer %~ (\t -> t - 1)
& clouds . ix (_clID c) . clVel .~ finalVel
& clouds . ix (_clID c) . clPos .~ finalPos
clClSpringVel :: Cloud -> World -> Cloud -> Point2 -> Point2
clClSpringVel a w b v
| ida == idb = v
| dist pa pb < radDist = v +.+ 0.1 *.* (safeNormalizeV (pa -.- pb))
| otherwise = v
where ida = _clID a
idb = _clID b
pa = _clPos a
pb = _clPos b
radDist = (_clRad a + _clRad b) / 2
where
ida = _clID a
idb = _clID b
pa = _clPos a
pb = _clPos b
radDist = (_clRad a + _clRad b) / 2
simpleCrSprings :: World -> World
simpleCrSprings w = IM.foldr' crSpring w $ _creatures w
crSpring :: Creature -> World -> World
crSpring c w = IM.foldr' (crCrSpring c) w $ cs
where cs = creaturesNearPoint (_crPos c) w
where
cs = creaturesNearPoint (_crPos c) w
crCrSpring :: Creature -> Creature -> World -> World
crCrSpring c1 c2 w
| id1 == id2 = w
| vec == (0,0) = w
| diff < comRad = over (creatures . ix id1 . crPos) (+.+ overlap1)
$ over (creatures . ix id2 . crPos) (-.- overlap2) w
| otherwise = w
where id1 = _crID c1
id2 = _crID c2
vec = _crPos c1 -.- _crPos c2
diff = magV $ vec
comRad = _crRad c1 + _crRad c2
overlap1 = ((comRad - diff) * _crMass c2 * 0.5 / massT) *.* errorNormalizeV 55 vec
overlap2 = ((comRad - diff) * _crMass c1 * 0.5 / massT) *.* errorNormalizeV 56 vec
massT = _crMass c1 + _crMass c2
| id1 == id2 = w
| vec == (0,0) = w
| diff < comRad = over (creatures . ix id1 . crPos) (+.+ overlap1)
$ over (creatures . ix id2 . crPos) (-.- overlap2) w
| otherwise = w
where
id1 = _crID c1
id2 = _crID c2
vec = _crPos c1 -.- _crPos c2
diff = magV $ vec
comRad = _crRad c1 + _crRad c2
overlap1 = ((comRad - diff) * _crMass c2 * 0.5 / massT) *.* errorNormalizeV 55 vec
overlap2 = ((comRad - diff) * _crMass c1 * 0.5 / massT) *.* errorNormalizeV 56 vec
massT = _crMass c1 + _crMass c2
{-
Finds the IDs of visible walls from a point to another point.
-}
Finds the IDs of visible walls from a point to another point. -}
visibleWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Int]
visibleWalls p1 p2 ws
= map fst
@@ -201,8 +209,10 @@ visibleWalls p1 p2 ws
$ IM.toList ws
where
f (i,wl) = (intersectSegSeg' (_wlLine wl !! 0) (_wlLine wl !! 1) p1 p2, (i,wl))
takeUntil h xs = let (ys,zs) = span h xs
in ys ++ tf zs
where tf (x:_) = [x]
tf _ = []
takeUntil h xs =
let (ys,zs) = span h xs
in ys ++ tf zs
where
tf (x:_) = [x]
tf _ = []
src/Dodge/World.hs
+6
View File
@@ -0,0 +1,6 @@
{- |
Placeholder... not sure of its purpose, but might deal with pure world change functions.
The world datatype itself is very intertwined with the creature, weapon, etc datatypes.
-}
module Dodge.World
where
src/Dodge/World/Trigger/Data.hs
+12
View File
@@ -0,0 +1,12 @@
{- |
World triggers are intended to help me handle global events,
such as new levels, game overs, etc, that disrupt the typical flow of the game.
They should probably be used sparingly.
-}
module Dodge.World.Trigger.Data
where
data WorldTrigger
= ResetLevel Int
| GameOver
deriving (Eq,Ord)
src/DoubleStack.hs
+33
View File
@@ -0,0 +1,33 @@
module DoubleStack
where
newtype DS a = DS (a,[a],[a])
deriving (Eq, Ord, Read, Show)
{- |
Unsafe. -}
fromListL :: [a] -> DS a
fromListL (x:xs) = DS (x,xs,[])
singleton :: a -> DS a
singleton x = DS (x,[],[])
head (DS (x,_,_)) = x
left (DS (_,l,_)) = l
right (DS (_,_,r)) = r
pushL :: DS a -> DS a
pushL (DS (x,xs,(y:ys))) = DS (y,(x:xs),ys)
pushL ds = ds
pushR :: DS a -> DS a
pushR (DS (y,(x:xs),ys)) = DS (x,xs,(y:ys))
pushR ds = ds
cycleL :: DS a -> Maybe (DS a)
cycleL (DS (x,xs,(y:ys))) = Just $ DS (y,(x:xs),ys)
cycleL _ = Nothing
cycleR :: DS a -> Maybe (DS a)
cycleR (DS (y,(x:xs),ys)) = Just $ DS (x,xs,(y:ys))
cycleR _ = Nothing
src/Geometry.hs
+23
View File
@@ -461,6 +461,29 @@ divideCircle x cen rad = map (cen +.+) $ nRaysRad n rad
where
n = ceiling $ rad * 2 * pi / x
arcStepwise
:: Float -- ^ Maximum distance between points
-> Float -- ^ Angle to travel
-> Point2 -- ^ Center
-> Point2 -- ^ Start vector from center
-> [Point2]
arcStepwise ssize a c v
| a < 0 = reverse $ arcStepwisePositive ssize (negate a) c (rotateV a v)
| otherwise = arcStepwisePositive ssize a c v
arcStepwisePositive
:: Float -- ^ Maximum distance between points
-> Float -- ^ Angle to travel, assumed to be positive
-> Point2 -- ^ Center
-> Point2 -- ^ Start vector from center
-> [Point2]
arcStepwisePositive ssize a cen v = ((cen +.+) . (\rot -> rotateV rot v) ) <$> rots
where
rots :: [Float]
rots = map ((a*) . (/ fromIntegral n ) . fromIntegral) [0 .. n]
n :: Int
n = ceiling (a * magV v / ssize)
--nPointsOnCirc :: Int -> Float -> [Point2]
--nPointsOnCirc n rad = take n $ iterate (rotateV (2*pi/fromIntegral n)) (rad,0)