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

Add IntMapHelper, locate wall cutting bug

Browse Source
This commit is contained in:
jgk
2021-05-22 15:14:21 +02:00
parent 26f0ca4ab5
commit 9c2bcbec10
35 changed files with 221 additions and 139 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base.hs
+3 -13
View File
@@ -16,15 +16,14 @@ import Dodge.Base.Window
import Dodge.Base.Collide
import Geometry
import Picture
import qualified IntMapHelp as IM
import Control.Lens
--import Control.Monad.State
import Data.List
--import Data.Function
import Data.Maybe
--import Data.Bifunctor
import qualified Data.IntMap.Strict as IM
--import qualified Data.IntSet as IS
--import qualified Data.Set as S
@@ -177,21 +176,12 @@ adjustIMZone f x y n = IM.adjust f' x
where
f' = IM.adjust f'' y
f'' = IM.adjust f n
{- | Find a key value one higher than any key in the map, or zero if the map is
- empty -}
newKey :: IM.IntMap a -> Int
newKey = maybe 0 ((+ 1) . fst) . IM.lookupMax
{- | Finds unused projectile key. -}
newProjectileKey :: World -> Int
newProjectileKey = newKey . _projectiles
newProjectileKey = IM.newKey . _projectiles
{- | Finds unused creature key. -}
newCrKey :: World -> Int
newCrKey = newKey . _creatures
{- | Insert an element with some new key. -}
insertNewKey :: a -> IM.IntMap a -> IM.IntMap a
insertNewKey x m = case IM.lookupMax m of
Nothing -> IM.singleton 0 x
Just (k,_) -> IM.insert (k+1) x m
newCrKey = IM.newKey . _creatures
{- | TODO: determine precisely what this does. -}
reflectPointCreature :: Point2 -> Point2 -> Creature -> Maybe (Point2, Point2, Int)
reflectPointCreature p1 p2 cr = case collidePointCirc p1 p2 (_crRad cr) (_crPos cr) of
src/Dodge/Creature.hs
+4 -4
View File
@@ -28,7 +28,6 @@ import Dodge.Creature.ChaseCrit
import Dodge.Creature.ArmourChase
import Dodge.Data
import Dodge.Default
import Dodge.Base
import Dodge.Item.Weapon
import Dodge.Item.Equipment
import Dodge.Item.Consumable
@@ -43,6 +42,7 @@ import Dodge.Creature.Rationality
import Dodge.Picture.Layer
import Picture
--import Geometry
import qualified IntMapHelp as IM
--import Data.List
--import Data.Char
@@ -52,7 +52,6 @@ import Control.Lens
--import Control.Monad.Reader
--import System.Random
--import qualified Data.Set as S
import qualified Data.IntMap.Strict as IM
--import qualified Data.Map as M
spawnerCrit :: Creature
@@ -133,7 +132,7 @@ multGunCrit = defaultCreature
addArmour :: Creature -> Creature
addArmour = over crInv insarmour
where
insarmour xs = IM.insert (newKey xs) frontArmour xs
insarmour xs = IM.insert (IM.newKey xs) frontArmour xs
{- | The creature you control.
ID 0. -}
startCr :: Creature
@@ -156,7 +155,8 @@ startCr = defaultCreature
startInventory :: IM.IntMap Item
startInventory = IM.fromList (zip [0..20]
(
[bezierGun
[blinkGun
,bezierGun
,multGun
,hvAutoGun
,remoteLauncher
src/Dodge/Creature/Action.hs
+2 -2
View File
@@ -19,6 +19,7 @@ import Dodge.Inventory
--import Dodge.LightSources
import Geometry
import Picture
import qualified IntMapHelp as IM
import Control.Lens
--import Control.Monad
@@ -26,7 +27,6 @@ import Control.Lens
import Data.Maybe
--import Data.List
import System.Random
import qualified Data.IntMap.Strict as IM
--import qualified Data.Map as M
startReloadingWeapon
@@ -107,7 +107,7 @@ copyItemToFloor cr i w = case _crInv cr IM.! i of
updateLocation w' = case it ^? itID of
Just (Just i') -> w' & itemPositions . ix i' .~ OnFloor flid
_ -> w'
flid = newKey $ _floorItems w
flid = IM.newKey $ _floorItems w
theflit = FlIt
{_flIt = it
,_flItPos = offset +.+ _crPos cr
src/Dodge/Creature/ArmourChase.hs
+4 -3
View File
@@ -22,16 +22,17 @@ armourChaseCrit = defaultCreature
{ _crUpdate = stateUpdate $ impulsiveAIR $
doStrategyActionsR >=>
performActionsR >=>
overrideMeleeCloseTargetR >=>
chaseTargetR targetYouLOS >=>
basicPerceptionUpdateR [0] >=>
targetYouWhenCognizantR >=>
return . (crMeleeCooldown . _Just %~ (max 0 . subtract 1))
targetYouWhenCognizantR >=>
overrideMeleeCloseTargetR >=>
return . (crMeleeCooldown . _Just %~ max 0 . subtract 1)
, _crHP = 300
, _crPict = basicCrPict green
, _crInv = IM.fromList
[(0,frontArmour)
,(1,medkit 200)
]
, _crMeleeCooldown = Just 0
, _crGroup = ShieldGroup
}
src/Dodge/Creature/ChaseCrit.hs
+1 -1
View File
@@ -41,7 +41,7 @@ chaseCrit = defaultCreature
chaseTargetR targetYouLOS >=>
basicPerceptionUpdateR [0] >=>
targetYouWhenCognizantR >=>
return . (crMeleeCooldown . _Just %~ (max 0 . subtract 1))
return . (crMeleeCooldown . _Just %~ max 0 . subtract 1)
, _crHP = 300
, _crPict = basicCrPict green
, _crInv = IM.fromList [(0,medkit 200)]
src/Dodge/Creature/ImpulseRat.hs
-13
View File
@@ -20,19 +20,6 @@ chaseTarget targFunc w cr = case targFunc cr w of
Nothing -> cr
Just crTarg -> cr & crActionPlan . crImpulse .~ chaseTarg cr crTarg
overrideMeleeCloseTarget :: World -> Creature -> Creature
overrideMeleeCloseTarget _ cr = case _crTarget cr of
Nothing -> cr
Just tcr
| _crMeleeCooldown cr == Just 0
&& dist (_crPos tcr) cpos < _crRad cr + _crRad tcr + 5
&& abs (_crDir cr - argV (_crPos tcr -.- cpos)) < pi/4
-> cr & crActionPlan . crAction .~ [DoImpulses [Melee (_crID tcr)]]
| otherwise -> cr
where
cpos = _crPos cr
meleeHeadingMove
:: Float -- ^ max turn speed
-> Float -- ^ min turn speed
src/Dodge/Creature/Inanimate.hs
+2 -3
View File
@@ -6,7 +6,6 @@ module Dodge.Creature.Inanimate
import Dodge.Data
--import Dodge.Creature.Stance.Data
import Dodge.Creature.State.Data
import Dodge.Base
import Dodge.Picture.Layer
import Dodge.Default
import Dodge.Creature.State
@@ -15,8 +14,8 @@ import Dodge.WorldEvent.Flash
import Dodge.WorldEvent.Sound
import Dodge.Creature.Update hiding (CRUpdate)
import Picture
import qualified IntMapHelp as IM
import qualified Data.IntMap.Strict as IM
import Control.Lens
defaultInanimate :: Creature
@@ -34,7 +33,7 @@ lamp = defaultInanimate
initialiseLamp :: CRUpdate
initialiseLamp w (f,g) cr = ( (addLS . f , g), Just $ cr & crUpdate .~ updateLamp i)
where
i = newKey $ _lightSources $ f w -- to give different lights different keys
i = IM.newKey $ _lightSources $ f w -- to give different lights different keys
addLS = over lightSources (IM.insert i (lightAt (_crPos cr) i))
updateLamp :: Int -> CRUpdate
src/Dodge/Creature/Rationality.hs
+1 -1
View File
@@ -69,7 +69,7 @@ followImpulse cr w imp = case imp of
ChangePosture post -> (id, cr & crStance . posture .~ post)
UseItem -> (crUseItem cr, cr)
SwitchToItem i -> (id, cr & crInvSel .~ i)
Melee cid ->
Melee cid ->
(hitCr cid
, crMvBy (10 *.* normalizeV (posFromID cid -.- cpos)) $ cr & crMeleeCooldown ?~ 20) -- randomise cooldown?
RandomTurn a -> (id, creatureTurn (rr a) cr)
src/Dodge/Creature/ReaderUpdate.hs
+6 -5
View File
@@ -22,14 +22,15 @@ tryMeleeAttack cr tcr
| _crMeleeCooldown cr == Just 0
&& dist (_crPos tcr) cpos < _crRad cr + _crRad tcr + 5
&& abs (_crDir cr - argV (_crPos tcr -.- cpos)) < pi/4
= cr & crActionPlan . crStrategy .~ StrategyActions MeleeStrike meleeActions
-- = cr & crActionPlan . crStrategy .~ StrategyActions MeleeStrike meleeActions
= cr & crActionPlan . crImpulse .~ [Melee $ _crID tcr]
| otherwise = cr
where
cpos = _crPos cr
meleeActions =
[DoImpulses [Melee (_crID tcr)]
`DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]
]
--meleeActions =
-- [DoImpulses [Melee (_crID tcr)]
-- `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]
-- ]
chaseTargetR
:: (Creature -> World -> Maybe Creature) -- ^ Function for determining target
src/Dodge/Creature/State.hs
+4 -5
View File
@@ -11,6 +11,7 @@ import Dodge.WorldEvent
import Dodge.Creature.Action
import Geometry
import Picture
import qualified IntMapHelp as IM
import Data.List
--import Data.Char
@@ -24,7 +25,6 @@ import Control.Monad.State
--import qualified SDL.Mixer as Mix
import System.Random
--import qualified Data.Set as S
import qualified Data.IntMap.Strict as IM
--import qualified Data.Map as M
type CRUpdate = World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature)
@@ -53,7 +53,7 @@ stateUpdate u w (f,g) cr =
. over decorations addCorpse
. dropByState cr
--crBeforeDeath = colCrWall w cr
addCorpse = insertNewKey
addCorpse = IM.insertNewKey
$ uncurry translate (_crOldPos cr)
$ rotate (_crDir cr)
(_crCorpse cr)
@@ -210,9 +210,8 @@ updateExpBarrel _ (f,g) cr
--perforate (Piercing amount sp int ep) cr = over (crState . crSpState . piercedPoints)
-- ((:) $ int -.- _crPos cr) cr
--perforate _ cr = cr
applyFuseDamage cr' = over crHP (subtract $ length (_piercedPoints
$ _crSpState $ _crState cr'))
cr'
applyFuseDamage cr' = cr' & crHP %~
subtract (length . _piercedPoints . _crSpState $ _crState cr')
hiss | null poss = id
| otherwise = soundMultiFrom [BarrelHiss 0,BarrelHiss 1] 41 50 1
stopSounds = stopSoundFrom (BarrelHiss 0) . stopSoundFrom (BarrelHiss 1)
src/Dodge/Creature/SwarmCrit.hs
+1 -1
View File
@@ -32,7 +32,7 @@ swarmCrit :: Creature
swarmCrit = defaultCreature
{ _crUpdate = stateUpdate $ impulsiveAIR $
flockToPointUsing (encircleDistP (100)) (meleeHeadingMove 0.1 0.1 (pi/4) 3.9)
>=> return . (crMeleeCooldown . _Just %~ (max 0 . subtract 1))
>=> return . (crMeleeCooldown . _Just %~ max 0 . subtract 1)
>=> basicPerceptionUpdateR [0]
>=> doStrategyActionsR
>=> targetYouWhenCognizantR
src/Dodge/Debug.hs
+5 -5
View File
@@ -1,13 +1,12 @@
module Dodge.Debug where
import Dodge.Data
import Dodge.Base
import Dodge.Picture
import Dodge.Picture.Layer
--import Geometry.Data
import Picture
import qualified IntMapHelp as IM
import Control.Lens
import qualified Data.IntMap.Strict as IM
drawCircleAtFor :: Point2 -> Int -> World -> World
drawCircleAtFor p t w = w & projectiles %~
@@ -20,7 +19,7 @@ drawCircleAtFor p t w = w & projectiles %~
, _pjUpdate = pjTimer t k
}
where
k = newKey $ _projectiles w
k = IM.newKey $ _projectiles w
drawCircleAtForCol :: Point2 -> Int -> Color -> World -> World
drawCircleAtForCol p t col w = w & projectiles %~
IM.insert k Projectile
@@ -32,7 +31,7 @@ drawCircleAtForCol p t col w = w & projectiles %~
, _pjUpdate = pjTimer t k
}
where
k = newKey $ _projectiles w
k = IM.newKey $ _projectiles w
drawLineForCol :: [Point2] -> Int -> Color -> World -> World
drawLineForCol ps t col w = w & projectiles %~
IM.insert k Projectile
@@ -44,8 +43,9 @@ drawLineForCol ps t col w = w & projectiles %~
, _pjUpdate = pjTimer t k
}
where
k = newKey $ _projectiles w
k = IM.newKey $ _projectiles w
pjTimer :: Int -> Int -> World -> World
pjTimer 0 i = projectiles %~ IM.delete i
pjTimer time i = projectiles . ix i . pjUpdate .~ pjTimer (time - 1) i
src/Dodge/Debug/LinkDecoration.hs
+34
View File
@@ -0,0 +1,34 @@
module Dodge.Debug.LinkDecoration
( addRoomLinkDecorations
, addRoomPolyDecorations
) where
import Dodge.Data
--import Dodge.Base
import Dodge.Room.Data
import Dodge.Picture.Layer
import Picture
import qualified IntMapHelp as IM
import Geometry.Vector
import Control.Lens
addRoomPolyDecorations :: [Room] -> World -> World
addRoomPolyDecorations rms w = w & decorations %~
IM.insertWithNewKeys (map roomPolyDecorations rms)
addRoomLinkDecorations :: [Room] -> World -> World
addRoomLinkDecorations rms w = w & decorations %~
IM.insertWithNewKeys (map roomLinkDecorations rms)
roomLinkDecorations :: Room -> Picture
roomLinkDecorations rm = pictures . map linkDecoration $ _rmLinks rm
linkDecoration :: (Point2,Float) -> Picture
linkDecoration (p,a) = setLayer 1 . onLayer DebugLayer . color red $ line [p, p +.+ 20 *.* unitVectorAtAngle (a - pi/2)]
roomPolyDecorations :: Room -> Picture
roomPolyDecorations rm = pictures . map polyWireFrame $ _rmPolys rm
polyWireFrame :: [Point2] -> Picture
polyWireFrame (x:xs) = setLayer 1 . onLayer DebugLayer . color green $ line $ (x:xs) ++ [x]
polyWireFrame _ = undefined
src/Dodge/Event/Menu.hs
+1 -1
View File
@@ -69,7 +69,7 @@ handlePressedKeyInMenu mState scode w = case mState of
& menuLayers .~ [WaitMessage "GENERATING..." 1]
& worldEvents .~ const aNewGame
aNewGame :: World
aNewGame = updateFramebufferSize $ generateFromList levx $ initialWorld
aNewGame = updateFramebufferSize $ generateLevelFromRoomList levx $ initialWorld
& randGen .~ _randGen w
& config .~ _config w
src/Dodge/Floor.hs
+1 -3
View File
@@ -75,7 +75,7 @@ roomTreex = do
,[DoorNumAno 0,AirlockAno]]
]
,[FirstWeapon]
,[Corridor]
,[CorridorDebug]
,[SpecificRoom $ fmap (pure . Right) randomFourCornerRoom]
,[Corridor]
,[OrAno
@@ -93,7 +93,5 @@ roomTreex = do
shiftExpandTree . expandTreeBy id <$> mapM annoToRoomTree t
--swarmTestRoom ::
levx :: RandomGen g => State g [Room]
levx = untilJust roomTreex
src/Dodge/Initialisation.hs
+1 -1
View File
@@ -20,7 +20,7 @@ firstWorld = do
-- i <- randomRIO (0,5000)
let i = 2
putStrLn $ "Seed for level generation: " ++ show ( i :: Int)
return $ generateFromList levx $ initialWorld {_randGen = mkStdGen i}
return $ generateLevelFromRoomList levx $ initialWorld {_randGen = mkStdGen i}
initialWorld :: World
initialWorld = defaultWorld
src/Dodge/Item/Weapon.hs
+5 -5
View File
@@ -24,6 +24,7 @@ import Dodge.Item.Attachment.Data
import Dodge.Item.Attachment
import Geometry
import Picture
import qualified IntMapHelp as IM
--import Data.List
--import Data.Char
@@ -38,7 +39,6 @@ import Control.Monad.State
import qualified SDL
import System.Random
import qualified Data.Set as S
import qualified Data.IntMap.Strict as IM
--import qualified Data.Map as M
pistol
@@ -930,7 +930,7 @@ fireRemoteLauncher cid w = setLocation
$ soundOnce (fromIntegral launcherSound)
$ over projectiles remRocket w
where
i = newKey $ _projectiles w
i = IM.newKey $ _projectiles w
cr = _creatures w IM.! cid
dir = _crDir cr
pos = _crPos cr +.+ rotateV dir (_crRad cr + 1,0)
@@ -943,7 +943,7 @@ fireRemoteLauncher cid w = setLocation
, _pjUpdate = moveRemoteShell 50 i cid itid dir
}
j = _crInvSel $ _creatures w IM.! cid
newitid = newKey $ _itemPositions w
newitid = IM.newKey $ _itemPositions w
maybeitid = w ^? creatures . ix cid . crInv . ix j . itID . _Just
resetFire = set (creatures . ix cid . crInv . ix j . wpFire)
$ hammerCheck $ explodeRemoteRocket itid i
@@ -1083,7 +1083,7 @@ throwRemoteBomb n w = setLocation $ removePict $ resetFire
Nothing -> w' & creatures . ix n . crInv . ix j . itID ?~ newitid
& itemPositions %~ IM.insert newitid (InInv n j)
_ -> w'
newitid = newKey $ _itemPositions w
newitid = IM.newKey $ _itemPositions w
itid = fromMaybe newitid maybeitid
explodeRemoteBomb :: Int -> Int -> Int -> World -> World
@@ -1223,7 +1223,7 @@ spawnCrNextTo
-> World
spawnCrNextTo cr i w = w & creatures %~ IM.insert k newCr
where
k = newKey $ _creatures w
k = IM.newKey $ _creatures w
sCr = _creatures w IM.! i
newCr = cr
& crID .~ k
src/Dodge/Layout.hs
+7 -4
View File
@@ -12,6 +12,8 @@ import Dodge.Room.Data
import Dodge.Default
import Geometry
import Dodge.Room.Link
import qualified IntMapHelp as IM
import Dodge.Debug.LinkDecoration
import Control.Monad.State
import Control.Lens
@@ -21,11 +23,12 @@ import System.Random
import Data.Tree
import Data.Graph.Inductive.Graph (labNodes)
import qualified Data.Map as M
import qualified Data.IntMap.Strict as IM
generateFromList :: State StdGen [Room] -> World -> World
generateFromList gr w = updateWallZoning
generateLevelFromRoomList :: State StdGen [Room] -> World -> World
generateLevelFromRoomList gr w = updateWallZoning
. placeSpots plmnts
. addRoomPolyDecorations rs
. addRoomLinkDecorations rs
$ w { _walls = wallsFromRooms rs
}
where
@@ -95,7 +98,7 @@ divideWall wl
divideWallIn :: Wall -> IM.IntMap Wall -> IM.IntMap Wall
divideWallIn wl wls =
let (wl':newWls) = divideWall wl
k = newKey wls
k = IM.newKey wls
newWls' = zipWith (\i w -> w {_wlID = i}) [k..] newWls
in foldr (\w -> IM.insert (_wlID w) w) wls (wl':newWls')
src/Dodge/Layout/Tree/Annotate.hs
+2
View File
@@ -27,6 +27,7 @@ data Annotation g
= Lock Int
| Key Int
| Corridor
| CorridorDebug
| DoorAno
| SwitchDoorAno
| DoorNumAno Int
@@ -71,6 +72,7 @@ annoToRoomTree [OrAno as] = do
a <- takeOne as
annoToRoomTree a
annoToRoomTree [Corridor] = pure . Right <$> randomiseOutLinks corridor
annoToRoomTree [CorridorDebug] = pure . Right <$> randomiseOutLinks corridorDebug
annoToRoomTree [DoorAno] = roomThenCorridor door
annoToRoomTree [DoorNumAno i,AirlockAno] = airlock i >>= roomThenCorridor
annoToRoomTree [FirstWeapon] = do
src/Dodge/LevelGen.hs
+13 -14
View File
@@ -9,7 +9,6 @@ module Dodge.LevelGen
, makeSwitch
) where
import Dodge.Data
import Dodge.Base
--import Dodge.Room.Data
import Dodge.LevelGen.Block
import Dodge.LevelGen.LineBlock
@@ -21,6 +20,7 @@ import Dodge.LevelGen.Switch
import Dodge.LevelGen.Data
import Geometry
import Picture
import qualified IntMapHelp as IM
--import System.Random
import Control.Monad.State
@@ -29,7 +29,6 @@ import Control.Lens
import Data.List.Extra
--import Data.Function
--import Data.Maybe
import qualified Data.IntMap.Strict as IM
--import qualified Data.Set as S
--import qualified Data.Map as M
@@ -128,9 +127,9 @@ addWalls qs wl wls = foldr (addPane wl) wls pairs
pairs = zip (ps ++ [p]) (p:ps)
addPane :: Wall -> (Point2,Point2) -> IM.IntMap Wall -> IM.IntMap Wall
addPane wl (p0,p1) wls = IM.insert (newKey wls) (wl
addPane wl (p0,p1) wls = IM.insert (IM.newKey wls) (wl
{ _wlLine = (p0,p1)
, _wlID = newKey wls
, _wlID = IM.newKey wls
})
wls
@@ -142,7 +141,7 @@ placeBt
-> World
placeBt bt p rot = over buttons addBT
where
addBT bts = IM.insert (newKey bts) (bt {_btPos = p, _btRot = rot, _btID = newKey bts}) bts
addBT bts = IM.insert (IM.newKey bts) (bt {_btPos = p, _btRot = rot, _btID = IM.newKey bts}) bts
{- Creates a floor item at a given point.
Assigns an id correctly. -}
placeFlIt
@@ -152,11 +151,11 @@ placeFlIt
-> World
-> World
placeFlIt itm p rot = floorItems %~
\ fis -> IM.insert (newKey fis)
\ fis -> IM.insert (IM.newKey fis)
(FlIt
{ _flItPos = p
, _flItRot = rot
, _flItID = newKey fis
, _flItID = IM.newKey fis
, _flIt = itm
}
) fis
@@ -169,30 +168,30 @@ placePressPlate
-> World
placePressPlate pp p rot = over pressPlates addPP
where
addPP pps = IM.insert (newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps
addPP pps = IM.insert (IM.newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps
placeUpdateCr :: Creature -> Point2 -> Float -> World -> (World, PSType)
placeUpdateCr scr p rot w = (w & creatures %~ IM.insert cid cr, PutCrit cr)
where
cid = newKey (_creatures w)
cid = IM.newKey (_creatures w)
cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid}
placeCr :: Creature -> Point2 -> Float -> World -> World
placeCr crF p rot = over creatures addCr
where
addCr crs = IM.insert
(newKey crs)
(crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = newKey crs})
(IM.newKey crs)
(crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = IM.newKey crs})
crs
placeLS :: LightSource -> Picture -> Point2 -> Float -> World -> World
placeLS ls dec p rot w = over lightSources addLS $ over decorations addDec w
where
addLS lss = IM.insert
(newKey lss)
(ls {_lsPos = p,_lsDir = rot,_lsID = newKey lss})
(IM.newKey lss)
(ls {_lsPos = p,_lsDir = rot,_lsID = IM.newKey lss})
lss
addDec decs = IM.insert
(newKey decs)
(IM.newKey decs)
(uncurry translate p $ rotate (negate rot) dec)
decs
src/Dodge/LevelGen/AutoDoor.hs
+2 -2
View File
@@ -12,10 +12,10 @@ import Dodge.Creature.Property
import Geometry
import Picture
import qualified DoubleStack as DS
import qualified IntMapHelp as IM
--import Data.List
--import Data.Maybe
import qualified Data.IntMap.Strict as IM
import Control.Lens
--import Control.DeepSeq (deepseq)
@@ -33,7 +33,7 @@ autoDoorAt
-> IM.IntMap Wall
autoDoorAt a b wls = IM.union wls $ IM.fromList $ zip is $ mkAutoDoor a b is
where
i = newKey wls
i = IM.newKey wls
is = [i..]
mkAutoDoor
src/Dodge/LevelGen/Block.hs
+2 -2
View File
@@ -7,13 +7,13 @@ import Dodge.WorldEvent.Sound
import Dodge.LevelGen.Pathing
import Geometry
import Picture.Data
import qualified IntMapHelp as IM
import Control.Lens
import Control.Monad.State
import Data.List
import Data.Maybe
import Data.Function
import qualified Data.IntMap.Strict as IM
import System.Random
updateBlocks :: World -> World
@@ -103,7 +103,7 @@ addBlock (p:ps) hp col isSeeThrough degradability w
& walls %~ IM.union panes
where
lns = zip (p:ps) (ps ++ [p])
i = newKey $ _walls w
i = IM.newKey $ _walls w
is = [i.. i + length lns-1]
panes = IM.fromList $ zip is $ zipWith
(\j (a,b) -> Block
src/Dodge/LevelGen/LineBlock.hs
+2 -2
View File
@@ -8,9 +8,9 @@ import Dodge.Base
import Dodge.LevelGen.Pathing
--import Picture
import Geometry
import qualified IntMapHelp as IM
import Control.Lens
import qualified Data.IntMap as IM
putLineBlock
:: Wall -- ^ Base pane
@@ -37,7 +37,7 @@ putLineBlock basePane blockWidth depth a b w = removePathsCrossing a b $ foldr i
]
cornersAt p = fmap ( (p +.+) . rotateV rot) cornerPoints
linesAt p = makeLoopPairs $ cornersAt p
k = newKey $ _walls w
k = IM.newKey $ _walls w
ksAtI i = map ( + (k + i*4) ) [0,1,2,3]
visibilityAt i
| i == 0 = [ True,True,False,True]
src/Dodge/LevelGen/StaticWalls.hs
+48 -16
View File
@@ -38,24 +38,29 @@ removeInverseWalls ((a,b):ps)
removeInverseWalls ps = ps
-- | Cut out a polygon from a set of walls, and check for errors in the
-- created walls.
-- If created walls are not consistent, rotate and expand poly and retry.
-- If created walls are not consistent, retry, rotating and expanding poly.
cutWalls :: [Point2] -> [WallP] -> [WallP]
cutWalls ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
[] -> newWalls
-- _ -> cutWalls (expandPolyBy 100 ps) wls
-- _ -> cutWalls (expandPolyBy 0.01 ps) wls
_ -> cutWalls (map (rotateV 0.001) $ expandPolyBy 0.01 ps) wls
_ -> cutWallsRetry 0 ps wls
-- _ -> wls
-- _ -> error $ show ps
where
newWalls = cutWalls' ps wls
-- | As 'cutWalls', but rotate in the other direction.
cutWallsL :: [Point2] -> [WallP] -> [WallP]
cutWallsL ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
newWalls = cutPoly ps wls
cutWallsRetry :: Int -> [Point2] -> [WallP] -> [WallP]
--cutWallsRetry 200 ps wls = error $ show ps ++ show wls
cutWallsRetry i ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
[] -> newWalls
-- _ -> cutWalls (expandPolyBy 100 ps) wls
-- _ -> cutWalls (expandPolyBy 0.01 ps) wls
_ -> cutWalls (map (rotateV (-0.001)) $ expandPolyBy 0.01 ps) wls
_ -> cutWallsRetry (i+1) ps wls
-- _ -> wls
-- _ -> error $ show ps
where
newWalls = cutWalls' ps wls
newWalls = cutPoly ps' wls
--ps' = map (rotateV a) $ expandPolyBy 0.1 ps
ps' = map (rotateV a) $ expandPolyBy x ps
x = fromIntegral i / 100
a | even i = 0.001
| otherwise = negate 0.001
-- | Cut out a polygon from a set of walls, and check for errors in the
-- created walls.
-- Give error if created walls are not consistent.
@@ -72,7 +77,7 @@ cutWalls'' ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
++ "\nWalls after cut:\n"
++ unlines (map show newWalls)
where
newWalls = cutWalls' ps wls
newWalls = cutPoly ps wls
errsL = mapMaybe (`checkWallLeft` newWalls) newWalls
-- | Given a specific wall and list of walls, checks that the number of walls leaving the
-- second point is the same as the number of walls entering the second point of
@@ -109,10 +114,10 @@ checkWallLeft (x,y) wls
-- 5. remove any walls that ended up zero length after fusing
-- 6. remove any duplicate walls
-- Unclear behaviour if a line in the polygon is colinear with a wall.
cutWalls' :: [Point2] -> [WallP] -> [WallP]
cutWalls' qs wls =
cutPoly :: [Point2] -> [WallP] -> [WallP]
cutPoly qs wls =
nub
. filter (not.wallIsZeroLength)
. filter (not . wallIsZeroLength)
. fuseWallsWith zs
. addPolyWalls rs
-- . removeWallsInPolygon ps
@@ -131,6 +136,7 @@ expandPolyBy x ps = map f ps
where
cp = 1/fromIntegral (length ps) *.* foldr (+.+) (0,0) ps
f p = p +.+ x *.* (p -.- cp)
--f p = p +.+ x *.* normalizeV (p -.- cp)
-- | Given a polygon expressed as a list of points and a collection of walls,
-- returns:
-- fst: points of the polygon's intersection with walls
@@ -223,3 +229,29 @@ removeWallsInPolygon :: [Point2] -> [WallP] -> [WallP]
removeWallsInPolygon ps = filter (not . cond)
where
cond wall = pointInOrOnPolygon (0.5 *.* uncurry (+.+) wall) ps
brokenWalls :: [(Point2,Point2)]
brokenWalls =
[((330.12192,3032.2456),(190.52365,2995.8352)),((190.52365,2995.8352),(203.94716,2945.9377)),((214.33855,2907.311),(230.12193,2859.0405)),((230.12193,2859.0405),(366.7245,2895.643)),((366.7245,2895.643),(330.12192,3032.2456)),((366.7245,2895.643),(230.12193,2859.0405)),((230.12193,2859.0405),(266.7245,2722.438)),((266.7245,2722.438),(403.32703,2759.0405)),((403.32703,2759.0405),(503.32703,2932.2456)),((466.72446,3068.8481),(330.12192,3032.2456)),((330.12192,3032.2456),(366.7245,2895.643)),((503.32703,2932.2456),(466.72446,3068.8481)),((203.94716,2945.9377),(145.99155,2930.4084)),((156.38292,2891.7817),(214.33855,2907.311)),((107.47222,2920.979),(34.06077,2901.2295)),((34.06077,2901.2295),(52.571453,2832.4224)),((70.17772,2796.55),(174.45558,2824.6025)),((174.45558,2824.6025),(156.38292,2891.7817)),((100.76944,2955.4202),(107.47222,2920.979)),((145.99155,2930.4084),(140.79587,2949.722)),((52.571453,2832.4224),(35.882084,2827.9504)),((31.745949,2785.4312),(70.17772,2796.55)),((88.14497,3002.5354),(100.76944,2955.4202)),((140.79587,2949.722),(120.21855,3027.0303)),((35.882084,2827.9504),(-22.07344,2812.4214)),((-31.039248,2768.608),(31.745949,2785.4312)),((-261.32483,3408.5737),(-303.9881,3451.237)),((-303.9881,3451.237),(-332.27234,3422.9526)),((-332.27234,3422.9526),(-289.84595,3380.5264)),((-261.56174,3352.242),(88.14497,3002.5354)),((120.21855,3027.0303),(-233.27742,3380.5264)),((-289.84595,3380.5264),(-332.2724,3338.0999)),((-332.2724,3338.0999),(-303.9881,3309.8157)),((-303.9881,3309.8157),(-261.56174,3352.242)),((-22.07344,2812.4214),(-89.68823,2794.304)),((-79.335526,2755.667),(-31.039248,2768.608)),((-210.16953,3456.4133),(-261.32483,3408.5737)),((-233.27742,3380.5264),(-194.64026,3419.1633)),((-128.32533,2783.9514),(-200.79468,3054.4106)),((-200.79468,3054.4106),(-780.35016,2899.1191)),((-780.35016,2899.1191),(-625.05865,2319.5635)),((-625.05865,2319.5635),(-45.503174,2474.855)),((-45.503174,2474.855),(-117.97253,2745.3142)),((-89.68823,2794.304),(-128.32533,2783.9514)),((-117.97253,2745.3142),(-79.335526,2755.667)),((-178.49438,3590.2566),(-241.50847,3573.372)),((-241.50847,3573.372),(-210.16953,3456.4133)),((-194.64026,3419.1633),(-136.80266,3434.6611)),((-98.165634,3445.014),(-139.85736,3600.6094)),((-92.98925,3425.6953),(-98.165634,3445.014)),((-136.80266,3434.6611),(-127.74397,3400.8535)),((-187.553,3624.064),(-178.49438,3590.2566)),((-139.85736,3600.6094),(-148.91603,3634.4167)),((-127.74397,3400.8535),(-111.20285,3339.121)),((-78.55679,3371.8325),(-92.98925,3425.6953)),((-349.5008,4383.0093),(-388.13782,4372.6563)),((-388.13782,4372.6563),(-485.18823,3653.0168)),((-485.18823,3653.0168),(-477.42368,3624.039)),((-477.42368,3624.039),(-206.96445,3696.5085)),((-168.32744,3706.861),(102.131805,3779.3306)),((102.131805,3779.3306),(94.36725,3808.308)),((94.36725,3808.308),(-349.5008,4383.0093)),((-206.96445,3696.5085),(-187.553,3624.064)),((-148.91603,3634.4167),(-168.32744,3706.861)),((299.35522,3346.2668),(97.2383,3547.9797)),((97.2383,3547.9797),(-78.55679,3371.8325)),((-111.20285,3339.121),(116.74672,3110.6904)),((116.74672,3110.6904),(320.08704,3314.438)),((352.084,3395.578),(299.35522,3346.2668)),((320.08704,3314.438),(367.6133,3358.328)),((495.06226,3666.979),(293.8115,3613.054)),((293.8115,3613.054),(352.084,3395.578)),((367.6133,3358.328),(563.6875,3410.866)),((563.6875,3410.866),(495.06226,3666.979))]
intersectingBrokenWalls :: [(Point2,Point2)]
intersectingBrokenWalls = filter (\(a,b) -> test a b) brokenWalls
where
polyPairs = zip brokenPoly (tail brokenPoly ++ [head brokenPoly])
test a b = any (isJust . uncurry (myIntersectSegSeg a b)) polyPairs
brokenPoly :: [Point2]
brokenPoly = [(434.66675,2833.3225),(503.9488,2793.3225),(523.9488,2827.9636),(454.66675,2867.9636)]
iBWall :: (Point2,Point2)
iBWall = ((403.32703,2759.0405),(503.32703,2932.2456))
expandToSquare :: (Point2,Point2) -> [(Point2,Point2)]
expandToSquare (a,b) = [(a,b),(b,c),(c,d),(d,a)]
where
v = a -.- b
c = b +.+ vNormal v
d = a +.+ vNormal v
minWalls :: [(Point2,Point2)]
minWalls = expandToSquare iBWall
src/Dodge/LevelGen/SwarmPlacement.hs
+3 -4
View File
@@ -3,14 +3,13 @@ module Dodge.LevelGen.SwarmPlacement
)
where
import Dodge.Data
import Dodge.Base
import Dodge.LevelGen.Data
import Dodge.Creature.State.Data
import Geometry
import qualified IntMapHelp as IM
import Data.List
import qualified Data.IntSet as IS
import qualified Data.IntMap as IM
import Control.Lens
swarmPS :: Int -> Point2 -> Float -> Creature -> Placement
@@ -26,7 +25,7 @@ setSwarm w ps = updateCrs w' & creatureGroups %~ IM.insert gid theGroupParams
(w', crs) = mapAccumR updateCrit w ps
is = IS.fromList $ map _crID crs
cpos = centroid $ map _crPos crs
gid = newKey (_creatureGroups w')
gid = IM.newKey (_creatureGroups w')
theGroupParams = CrGroupParams
{ _crGroupParamID = gid
, _crGroupIDs = is
@@ -52,5 +51,5 @@ updateCrit w pl = (w & creatures %~ IM.insert cid cr
p = _psPos $ _placementSpot pl
rot = _psRot $ _placementSpot pl
scr = _unPutCrit $ _psType $ _placementSpot pl
cid = newKey (_creatures w)
cid = IM.newKey (_creatures w)
cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid}
src/Dodge/LevelGen/TriggerDoor.hs
+5 -5
View File
@@ -9,10 +9,10 @@ import Dodge.LevelGen.Pathing
import Picture
import Geometry
import qualified DoubleStack as DS
import qualified IntMapHelp as IM
import Data.List
import Data.Maybe
import qualified Data.IntMap.Strict as IM
import Control.Lens
import Data.Graph.Inductive hiding ((&))
@@ -24,7 +24,7 @@ addButtonDoor c btp btr a b w = over buttons (IM.insert bid bt)
$ set pathGraph' newGraphPairs
$ putDoubleDoor c cond a b w
where
bid = newKey $ _buttons w
bid = IM.newKey $ _buttons w
cond w' = BtNoLabel == _btState (_buttons w' IM.! bid)
bt = (makeButton c eff) {_btPos = btp, _btRot = btr, _btID = bid}
(newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg' a b))
@@ -42,7 +42,7 @@ addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt)
$ set pathGraph' newGraphPairs
$ putDoubleDoor c cond a b w
where
bid = newKey $ _buttons w
bid = IM.newKey $ _buttons w
cond w' = BtOn == _btState (_buttons w' IM.! bid)
bt = (makeSwitch c openDoor closeDoor) {_btPos = btp, _btRot = btr, _btID = bid}
(newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg' a b))
@@ -67,14 +67,14 @@ 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..]
is = [IM.newKey wls..]
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..]
is = [IM.newKey wls..]
mkTriggerDoor
:: Color
src/Dodge/Picture/Layer.hs
+6 -11
View File
@@ -8,21 +8,15 @@ module Dodge.Picture.Layer
) where
import Dodge.Picture.Layer.Data
import Picture
{- | Uses a layer to set the depth.
-}
{- | Uses a layer to set the depth. -}
onLayer :: Layer -> Picture -> Picture
onLayer l = setDepth $ 1 - fromIntegral (levLayer l) / 100
onLayer l = setDepth $ 1 - fromIntegral (levLayer l) / 100
{- | Set a depth according to a list of numbers.
Lists are lexicographically ordered if input values are always less than 100.
Higher numbers will get placed on top of lower numbers.
-}
Higher numbers will get placed on top of lower numbers. -}
onLayerL :: [Int] -> Picture -> Picture
onLayerL is = setDepth (1 - sum (zipWith (/) (map fromIntegral is) $ map (100 **) [1..]))
{- | For depth testing, set layer values.
-}
onLayerL is = setDepth (1 - sum (zipWith (/) (map fromIntegral is) $ map (100 **) [1..]))
{- | For depth testing, set layer values. -}
levLayer :: Layer -> Int
levLayer BgLayer = 20
levLayer PressPlateLayer = 45
@@ -38,3 +32,4 @@ levLayer ShadowLayer = 75
levLayer LabelLayer = 80
levLayer InvLayer = 85
levLayer MenuDepth = 90
levLayer DebugLayer = 99
src/Dodge/Picture/Layer/Data.hs
+1
View File
@@ -16,3 +16,4 @@ data Layer
| UPtLayer
| HPtLayer
| GloomLayer
| DebugLayer
src/Dodge/Room.hs
+4 -1
View File
@@ -309,9 +309,12 @@ weaponBetweenPillars = do
,sPS crPos1 (d crPos1) randC1
,sPS crPos2 (d crPos2) randC1
]
(fmap connectRoom . randomiseOutLinks) =<< filterLinks f (over rmPS (++plmnts) roomPillars)
theRoom = roomPillars & rmPS %~ (++ plmnts)
-- & rmPolys %~ (rectNSWE 300 0 0 300 :)
(fmap connectRoom . randomiseOutLinks) =<< filterLinks f theRoom
where
f (_,a) = a == 0
--f (_,_) = True -- this is probably preferable...
weaponLongCorridor :: RandomGen g => State g (Tree (Either Room Room))
weaponLongCorridor = do
src/Dodge/Room/Corridor.hs
+23 -4
View File
@@ -2,13 +2,12 @@ module Dodge.Room.Corridor
where
import Dodge.Room.Data
import Geometry
{- First exit due north, two other exits at angles next to this.
Entrance from south.
-}
{- | First exit due north, two other exits at angles next to this.
Entrance from south. -}
corridor :: Room
corridor = Room
{ _rmPolys = [rectNSWE 80 0 0 40
--{ _rmPolys = [rectNSWE 90 (-10) 0 40
-- ,[(0,80), (0,80) +.+ rotateV (pi/3) (40,0),(40,80)]
-- ,[(40,0), (0,0) +.+ rotateV (0-pi/3) (40,0),( 0, 0)]
]
@@ -24,6 +23,26 @@ corridor = Room
,((20,70), negate $ pi/6)
,((20,10) ,pi)
]
{- | Debug drop-in copy of corridor -}
corridorDebug :: Room
corridorDebug = Room
{ _rmPolys =
[ rectNSWE 80 0 0 40
--, [ (0,0), (0,200) , (200,100)]
--, [ (0,0), (0,20) , (20,10)]
]
, _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (20,60) . fst) lnks
, _rmPS = []
, _rmBound = [ rectNSWE 50 30 0 40 ]
}
where
lnks =
[((20,70) ,0)
,((20,70), pi/6)
,((20,70), negate $ pi/6)
,((20,10) ,pi)
]
corridorN :: Room
corridorN = Room
{ _rmPolys = [rectNSWE 80 0 0 40
src/Dodge/Update.hs
+1 -1
View File
@@ -91,7 +91,7 @@ updateCreatureGroups w = w & creatureGroups %~
updateTriggers :: World -> World
updateTriggers w
| ResetLevel 1 `S.member` _worldTriggers w = generateFromList levx $ initialWorld
| ResetLevel 1 `S.member` _worldTriggers w = generateLevelFromRoomList levx $ initialWorld
& randGen .~ _randGen w
& config .~ _config w
& menuLayers .~ []
src/Dodge/WallCreatureCollisions.hs
+2 -3
View File
@@ -1,6 +1,4 @@
{- |
Deals with moving creature wall collisions.
-}
{- | Deals with moving creature wall collisions. -}
module Dodge.WallCreatureCollisions where
import Dodge.Data
import Dodge.Creature.State.Data
@@ -18,6 +16,7 @@ colCrsWalls w = over creatures (fmap (colCrWall w)) w
colCrWall :: World -> Creature -> Creature
colCrWall w c
| _crID c == 0 = c -- for noclip
| p1 == p2 = pushOrCrush ls c
| otherwise = c & crPos %~
collideCorners rad wallPoints
src/Dodge/WorldEvent/Cloud.hs
+2 -2
View File
@@ -5,14 +5,14 @@ import Dodge.Data
import Dodge.Base
--import Geometry
import Picture
import qualified IntMapHelp as IM
import Control.Lens
import qualified Data.IntMap as IM
makeCloudAt :: Float -> Int -> (Cloud -> Picture) -> Point2 -> World -> World
makeCloudAt rad t drawFunc p w
= w & clouds %~ IM.insert i theCloud
where i = newKey $ _clouds w
where i = IM.newKey $ _clouds w
theCloud = Cloud { _clID = i
, _clPos = p
, _clVel = (0,0)
src/Dodge/WorldEvent/SpawnParticle.hs
+2 -2
View File
@@ -19,9 +19,9 @@ import Dodge.RandomHelp
import Dodge.Debug
import Picture
import Geometry
import qualified IntMapHelp as IM
import Control.Lens
import qualified Data.IntMap.Strict as IM
import System.Random
import Control.Monad.State
import Data.Function (on)
@@ -228,7 +228,7 @@ makeGasCloud pos vel w = w
& clouds %~ IM.insert i theCloud
& randGen .~ g
where
i = newKey $ _clouds w
i = IM.newKey $ _clouds w
theCloud = Cloud { _clID = i
, _clPos = pos
, _clVel = vel
src/IntMapHelp.hs
+21
View File
@@ -0,0 +1,21 @@
module IntMapHelp
( module Data.IntMap.Strict
, newKey
, insertNewKey
, insertWithNewKeys
)
where
--import Data.List hiding (foldr,insert)
import Data.IntMap.Strict
{- | Find a key value one higher than any key in the map, or zero if the map is
- empty -}
newKey :: IntMap a -> Int
newKey = maybe 0 ((+ 1) . fst) . lookupMax
{- | Insert an element with some new key. -}
insertNewKey :: a -> IntMap a -> IntMap a
insertNewKey x m = case lookupMax m of
Nothing -> singleton 0 x
Just (k,_) -> insert (k+1) x m
{- | Insert a list of values with new keys -}
insertWithNewKeys :: [a] -> IntMap a -> IntMap a
insertWithNewKeys xs m = union m $ fromList $ zip [newKey m..] xs