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

Cleanup

Browse Source
This commit is contained in:
justin
2024-10-22 11:22:38 +01:00
parent 65f05b93f8
commit 9e3d8ae6b0
8 changed files with 425 additions and 407 deletions
Download Patch File Download Diff File Expand all files Collapse all files
data/dodge.config.json
+1 -1
View File
@@ -14,7 +14,7 @@
"_graphics_num_shadow_casters": "NumShadowCasters20",
"_graphics_shadow_rendering": "GeoObjShads",
"_graphics_shadow_size": "Typical",
"_graphics_world_resolution": "QuarterRes",
"_graphics_world_resolution": "HalfRes",
"_volume_master": 1,
"_volume_music": 0,
"_volume_sound": 1,
ghcidOutput
+1 -1
View File
@@ -1 +1 @@
All good (596 modules, at 10:48:32)
All good (596 modules, at 11:08:10)
src/Dodge/Block.hs
+15 -10
View File
@@ -1,15 +1,19 @@
module Dodge.Block where
module Dodge.Block (
splinterBlock,
destroyBlock,
destroyDoor,
) where
import Control.Monad
import Data.Set (Set)
import Dodge.Data.MountedObject
import Control.Lens
import Control.Monad
import Data.Foldable
import qualified Data.Graph.Inductive as FGL
import qualified Data.IntSet as IS
import Data.Maybe
import Data.Set (Set)
import Dodge.Base.Collide
import Dodge.Block.Debris
import Dodge.Data.MountedObject
import Dodge.Data.World
import Dodge.DrWdWd
import Dodge.LightSource
@@ -44,10 +48,10 @@ unshadowBlock w wlid = case w ^? cWorld . lWorld . walls . ix wlid of
& insertWallInZones (wl & wlUnshadowed .~ True)
Nothing -> w
checkBlockHP :: Block -> World -> World
checkBlockHP bl
| _blHP bl < 1 = destroyBlock bl
| otherwise = id
--checkBlockHP :: Block -> World -> World
--checkBlockHP bl
-- | _blHP bl < 1 = destroyBlock bl
-- | otherwise = id
destroyBlock :: Block -> World -> World
destroyBlock bl w =
@@ -74,8 +78,9 @@ maybeClearPath :: World -> PathEdgeNodes -> World
maybeClearPath w (PathEdgeNodes x y pe)
| not . null $ overlapSegWalls (_peStart pe) (_peEnd pe) $ wlsNearSeg (_peStart pe) (_peEnd pe) w =
w
| otherwise = w
& cWorld . pathGraph %~ FGL.insEdge (x, y, pe & peObstacles .~ mempty) . FGL.delEdge (x, y)
| otherwise =
w
& cWorld . pathGraph %~ FGL.insEdge (x, y, pe & peObstacles .~ mempty) . FGL.delEdge (x, y)
destroyDoor :: Door -> World -> World
destroyDoor dr w =
src/Dodge/Prop/Gib.hs
+11 -11
View File
@@ -1,7 +1,9 @@
module Dodge.Prop.Gib where
module Dodge.Prop.Gib (
addCrGibs,
) where
import Control.Monad
import Color
import Control.Monad
import Data.Foldable
import Data.List (zip4)
import Dodge.Base
@@ -30,17 +32,15 @@ aGib =
}
addCrGibs :: Creature -> World -> World
addCrGibs cr w = case damageDirection $ _csDamage $ _crState cr of
addCrGibs cr = case damageDirection $ _csDamage $ _crState cr of
Nothing ->
w
& addGibAt 25 (_skinHead skin) cpos
& addGibsAt 3 7 (_skinLower skin) cpos
& addGibsAt 13 20 (_skinUpper skin) cpos
addGibAt 25 (_skinHead skin) cpos
. addGibsAt 3 7 (_skinLower skin) cpos
. addGibsAt 13 20 (_skinUpper skin) cpos
Just d ->
w
& addGibsAtDir d 3 7 (_skinLower skin) cpos
& addGibsAtDir d 13 20 (_skinUpper skin) cpos
& addGibAtDir d 25 (_skinHead skin) cpos
addGibsAtDir d 3 7 (_skinLower skin) cpos
. addGibsAtDir d 13 20 (_skinUpper skin) cpos
. addGibAtDir d 25 (_skinHead skin) cpos
where
skin = _crType cr -- this should be cleaned up
cpos = _crPos cr
src/Dodge/Tree/GenerateStructure.hs
+25 -21
View File
@@ -3,43 +3,47 @@ Procedural generation of tree structures.
A /trunk/ refers to the successive first nodes in lists of children.
-}
module Dodge.Tree.GenerateStructure
where
import RandomHelp
import Control.Monad
module Dodge.Tree.GenerateStructure where
import Control.Monad
import Data.Tree
import RandomHelp
{- Single branched tree (a trunk). -}
treePath :: Int -> Tree ()
treePath 0 = Node () []
treePath x = Node () [treePath (x-1)]
treePath x = Node () [treePath (x -1)]
{- Adds a branch at a certain point down a trunk. -}
addBranchAt
:: Int -- ^ Depth to add branch at
-> Tree () -- ^ Branch to add
-> Tree () -- ^ Starting tree
-> Tree ()
addBranchAt ::
-- | Depth to add branch at
Int ->
-- | Branch to add
Tree () ->
-- | Starting tree
Tree () ->
Tree ()
addBranchAt 0 b (Node () xs) = Node () (xs ++ [b])
addBranchAt i b (Node () (x:xs))
= Node () (addBranchAt (i-1) b x : xs)
addBranchAt i b (Node () (x : xs)) =
Node () (addBranchAt (i -1) b x : xs)
addBranchAt _ _ _ = error "Trying to add a branch too far along a tree"
{- Randomly generate a tree containing a maximum of three nodes. -}
smallBranch :: RandomGen g => State g (Tree ())
smallBranch = takeOne
[ treePath 0
, treePath 1
, treePath 2
, addBranchAt 0 (treePath 0) (treePath 1)
]
smallBranch =
takeOne
[ treePath 0
, treePath 1
, treePath 2
, addBranchAt 0 (treePath 0) (treePath 1)
]
{- Randomly generate a small tree. -}
aTreeStrut :: RandomGen g => State g (Tree ())
aTreeStrut = do
d <- state $ randomR (9,11:: Int)
nbs <- state $ randomR (2,4)
d <- state $ randomR (9, 11 :: Int)
nbs <- state $ randomR (2, 4)
bds <- takeN nbs [1 .. d - 1]
bs <- replicateM nbs smallBranch
bs <- replicateM nbs smallBranch
let trunk = treePath d
return $ foldr (uncurry addBranchAt) trunk $ zip bds bs
src/Dodge/Update.hs
+77 -61
View File
@@ -6,41 +6,32 @@ Description : Simulation update
-}
module Dodge.Update (updateUniverse) where
import Dodge.Inventory
import Dodge.ListDisplayParams
import Dodge.SelectionSections
import Data.Monoid
import NewInt
import Control.Monad
import Dodge.Update.Input.InGame
import Dodge.Update.Input.ScreenLayer
import Dodge.Debug
import Dodge.SmoothScroll
import Color
--import Control.Applicative
import Control.Monad
import Data.List
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Monoid
import Dodge.Base
--import Dodge.Beam
import Dodge.Bullet
import Dodge.CrGroupUpdate
import Dodge.Creature.Update
--import Dodge.Data.SelectionList
import Dodge.Data.Universe
import Dodge.Debug
import Dodge.DisplayInventory
import Dodge.Distortion
import Dodge.DrWdWd
import Dodge.EnergyBall
import Dodge.Flame
import Dodge.Inventory
import Dodge.Item.Location
import Dodge.Laser.Update
import Dodge.LightSource.Update
import Dodge.LinearShockwave.Update
import Dodge.ListDisplayParams
import Dodge.Machine.Update
import Dodge.Magnet.Update
import Dodge.Menu
--import Dodge.Menu.Option
import Dodge.ModificationEffect
import Dodge.PosEvent
import Dodge.PressPlate
@@ -49,7 +40,9 @@ import Dodge.Prop.Update
import Dodge.RadarBlip
import Dodge.RadarSweep
import Dodge.ScrollValue
import Dodge.SelectionSections
import Dodge.Shockwave.Update
import Dodge.SmoothScroll
import Dodge.SoundLogic
import Dodge.Spark
import Dodge.Tesla.Arc
@@ -57,6 +50,8 @@ import Dodge.TmTm
import Dodge.TractorBeam.Update
import Dodge.Update.Camera
import Dodge.Update.Cloud
import Dodge.Update.Input.InGame
import Dodge.Update.Input.ScreenLayer
import Dodge.Update.Scroll
import Dodge.Update.WallDamage
import Dodge.WallCreatureCollisions
@@ -66,6 +61,7 @@ import Dodge.Zoning.Creature
import Geometry
import qualified IntMapHelp as IM
import LensHelp
import NewInt
import SDL
import Sound.Data
import StrictHelp
@@ -92,22 +88,23 @@ updateUniverseFirst u =
updateDebugMessageOffset :: Universe -> Universe
updateDebugMessageOffset u
| SDL.ScancodeRShift `M.member` (u ^. uvWorld . input . pressedKeys)
= u & uvDebugMessageOffset %~ (max 0 . subtract (u ^. uvWorld . input . scrollAmount))
| SDL.ScancodeRShift `M.member` (u ^. uvWorld . input . pressedKeys) =
u & uvDebugMessageOffset %~ (max 0 . subtract (u ^. uvWorld . input . scrollAmount))
| otherwise = u
setClickWorldPos :: Universe -> M.Map MouseButton Point2
setClickWorldPos u = fmap
(const (screenToWorldPos (u ^. uvWorld . wCam) (u ^. uvWorld . input . mousePos)))
(M.filter (== 0) $ u ^. uvWorld . input . mouseButtons)
setClickWorldPos u =
fmap
(const (screenToWorldPos (u ^. uvWorld . wCam) (u ^. uvWorld . input . mousePos)))
(M.filter (== 0) $ u ^. uvWorld . input . mouseButtons)
updateWorldEventFlags :: Universe -> Universe
updateWorldEventFlags u =
(uvWorld . worldEventFlags .~ mempty)
-- for now update inventory positioning every tick
. updateInventoryPositioning
-- the question is how often to update the close objects section, and if
-- this can be done independently of the other sections
(uvWorld . worldEventFlags .~ mempty)
-- for now update inventory positioning every tick
. updateInventoryPositioning
-- the question is how often to update the close objects section, and if
-- this can be done independently of the other sections
$ foldr updateWorldEventFlag u (u ^. uvWorld . worldEventFlags)
updateWorldEventFlag :: WorldEventFlag -> Universe -> Universe
@@ -136,8 +133,10 @@ updateUniverseLast u =
& uvWorld . input . pressedKeys . each %~ f
& uvWorld . input . mouseMoving .~ False
& uvWorld . input . mouseButtons . each +~ 1
& uvWorld . input . heldPos %~ M.union (fmap (const mp) (u ^. uvWorld . input . mouseButtons))
& uvWorld . input . heldWorldPos %~ M.union (fmap (const mwp) (u ^. uvWorld . input . mouseButtons))
& uvWorld . input . heldPos
%~ M.union (fmap (const mp) (u ^. uvWorld . input . mouseButtons))
& uvWorld . input . heldWorldPos
%~ M.union (fmap (const mwp) (u ^. uvWorld . input . mouseButtons))
where
mp = u ^. uvWorld . input . mousePos
mwp = screenToWorldPos (u ^. uvWorld . wCam) mp
@@ -165,10 +164,10 @@ timeFlowUpdate :: Universe -> Universe
timeFlowUpdate u = case u ^. uvWorld . timeFlow of
NormalTimeFlow -> functionalUpdate u
ItemScrollTimeFlow smoothing _ _ _ -> over uvWorld (doItemTimeScroll smoothing) u
CameraScrollTimeFlow smoothing _ _
| SDL.ScancodeLShift `M.member` (u ^. uvWorld . input . pressedKeys)
-> over uvWorld (doTimeScroll smoothing) u
CameraScrollTimeFlow {} -> u
CameraScrollTimeFlow smoothing _ _
| SDL.ScancodeLShift `M.member` (u ^. uvWorld . input . pressedKeys) ->
over uvWorld (doTimeScroll smoothing) u
CameraScrollTimeFlow{} -> u
RewindLeftClick 0 _ -> u & uvWorld . timeFlow .~ NormalTimeFlow
RewindLeftClick _ _ -> over uvWorld scrollTimeBack u -- & uvWorld . cWorld . timeFlow .~ NormalTimeFlow
DeathTime{} -> u
@@ -214,8 +213,9 @@ scrollTimeBack w = case w ^? pastWorlds . _head of
mupdateitem x = fromMaybe id $ do
i <- w ^? timeFlow . scrollItemID . unNInt
let pointituse = pointerToItemLocation (w ^?! cWorld . lWorld . itemLocations . ix i) . itUse
return $ (pointituse . leftConsumption . wpCharge .~ (x -1))
. ( pointituse . leftHammer .~ HammerDown)
return $
(pointituse . leftConsumption . wpCharge .~ (x -1))
. (pointituse . leftHammer .~ HammerDown)
scrollTimeForward :: World -> World
scrollTimeForward w = case w ^? timeFlow . futureWorlds . _head of
@@ -225,7 +225,7 @@ scrollTimeForward w = case w ^? timeFlow . futureWorlds . _head of
& pastWorlds .:~ (w ^. cWorld . lWorld)
& cWorld . lWorld .~ lw
& timeFlow . reverseAmount .~ ramount
& mupdateitem
& mupdateitem
where
ramount = (w ^?! timeFlow . reverseAmount) + 1
mupdateitem = fromMaybe id $ do
@@ -254,7 +254,7 @@ functionalUpdate u =
. over uvWorld updateEnergyBalls
. over uvWorld updateBullets
. over uvWorld updateRadarBlips
-- . over uvWorld updateBeams
-- . over uvWorld updateBeams
. over uvWorld updateLasers
. over uvWorld updateTeslaArcs
. over uvWorld updateTractorBeams
@@ -278,7 +278,7 @@ functionalUpdate u =
. over uvWorld updateRBList
. over uvWorld updateCloseObjects
. over uvWorld updateWheelEvents
. over uvWorld (updateMouseInventorySelection (u ^. uvConfig))
. over uvWorld (updateMouseInventorySelection (u ^. uvConfig))
. over uvWorld (updateMouseOverInventory (u ^. uvConfig))
. over uvWorld zoneClouds
. over uvWorld zoneCreatures
@@ -308,26 +308,34 @@ updateMouseInventorySelection' sss cfig w
return $ w & hud . hudElement . subInventory . nsSelected .~ MouseInvSelect ysel Nothing
Just p -> w & hud . hudElement . subInventory . nsSelected %~ startdrag p
| leftclickheld = case w ^? hud . hudElement . subInventory . nsSelected of
Just MouseInvSelect{} -> w
& hud . hudElement . subInventory . nsSelected . misMaybeEnd .~ msel
Just MouseInvSelect{} ->
w
& hud . hudElement . subInventory . nsSelected . misMaybeEnd .~ msel
Just (MouseInvChosen ssel esel)
| maybe False (<ssel) $ inverseSelBoundaryUp cfig ldp sss mpos -> w
& shiftInvItemsUp ssel esel (inverseSelBoundaryUp cfig ldp sss mpos)
| maybe False (< ssel) $ inverseSelBoundaryUp cfig ldp sss mpos ->
w
& shiftInvItemsUp ssel esel (inverseSelBoundaryUp cfig ldp sss mpos)
Just (MouseInvChosen ssel esel)
| maybe False (>esel) $ inverseSelBoundaryDown cfig ldp sss mpos -> w
& shiftInvItemsDown ssel esel (inverseSelBoundaryDown cfig ldp sss mpos)
| maybe False (> esel) $ inverseSelBoundaryDown cfig ldp sss mpos ->
w
& shiftInvItemsDown ssel esel (inverseSelBoundaryDown cfig ldp sss mpos)
Just (MouseInvChosen{}) -> w
_ -> w
& hud . hudElement . subInventory . nsSelected .~ NoMouseSel
_ ->
w
& hud . hudElement . subInventory . nsSelected .~ NoMouseSel
| otherwise = case w ^? hud . hudElement . subInventory . nsSelected of
Just (MouseInvSelect ssel (Just esel)) -> w
& hud . hudElement . subInventory . nsSelected .~ MouseInvChosen (min ssel esel)
(max ssel esel)
Just (MouseInvSelect _ Nothing) -> w
& hud . hudElement . subInventory . nsSelected .~ NoMouseSel
Just (MouseInvSelect ssel (Just esel)) ->
w
& hud . hudElement . subInventory . nsSelected
.~ MouseInvChosen
(min ssel esel)
(max ssel esel)
Just (MouseInvSelect _ Nothing) ->
w
& hud . hudElement . subInventory . nsSelected .~ NoMouseSel
_ -> w
where
startdrag p (MouseInvChosen s e) | s <= p && p <= e = MouseInvChosen s e
startdrag p (MouseInvChosen s e) | s <= p && p <= e = MouseInvChosen s e
startdrag p _ = MouseInvChosen p p
leftclickstart = w ^? input . mouseButtons . ix ButtonLeft == Just 0 && nobuttonright
leftclickheld = ButtonLeft `M.member` (w ^. input . mouseButtons) && nobuttonright
@@ -337,21 +345,23 @@ updateMouseInventorySelection' sss cfig w
msel = inverseSelNumPos cfig ldp sss (w ^. input . mousePos)
mysel = inverseSelSecYint (posSelSecYint cfig ldp (mpos ^. _y)) sss
shiftInvItemsUp :: (Int,Int) -> (Int,Int) -> Maybe (Int,Int) -> World -> World
shiftInvItemsUp (_,i) (_,j) Just{} w = w
& flip (foldl' f) [i..j]
& hud . hudElement . subInventory . nsSelected . misChosenStart . _2 -~ 1
& hud . hudElement . subInventory . nsSelected . misChosenEnd . _2 -~ 1
shiftInvItemsUp :: (Int, Int) -> (Int, Int) -> Maybe (Int, Int) -> World -> World
shiftInvItemsUp (_, i) (_, j) Just{} w =
w
& flip (foldl' f) [i .. j]
& hud . hudElement . subInventory . nsSelected . misChosenStart . _2 -~ 1
& hud . hudElement . subInventory . nsSelected . misChosenEnd . _2 -~ 1
where
f w' i' = swapInvItems g i' w'
g i' m = fmap fst $ IM.cycleLT i' m
shiftInvItemsUp _ _ Nothing w = w
shiftInvItemsDown :: (Int,Int) -> (Int,Int) -> Maybe (Int,Int) -> World -> World
shiftInvItemsDown (_,i) (_,j) Just{} w = w
& flip (foldl' f) (reverse [i..j])
& hud . hudElement . subInventory . nsSelected . misChosenStart . _2 +~ 1
& hud . hudElement . subInventory . nsSelected . misChosenEnd . _2 +~ 1
shiftInvItemsDown :: (Int, Int) -> (Int, Int) -> Maybe (Int, Int) -> World -> World
shiftInvItemsDown (_, i) (_, j) Just{} w =
w
& flip (foldl' f) (reverse [i .. j])
& hud . hudElement . subInventory . nsSelected . misChosenStart . _2 +~ 1
& hud . hudElement . subInventory . nsSelected . misChosenEnd . _2 +~ 1
where
f w' i' = swapInvItems g i' w'
g i' m = fmap fst $ IM.cycleGT i' m
@@ -360,8 +370,9 @@ shiftInvItemsDown _ _ Nothing w = w
updateMouseOverInventory :: Configuration -> World -> World
updateMouseOverInventory cfig w = fromMaybe w $ do
sss <- w ^? hud . hudElement . diSections
return $ w & hud . hudElement . subInventory . nsMouseOver .~
inverseSelNumPos cfig ldp sss (w ^. input . mousePos)
return $
w & hud . hudElement . subInventory . nsMouseOver
.~ inverseSelNumPos cfig ldp sss (w ^. input . mousePos)
where
ldp = invDisplayParams w
@@ -380,6 +391,7 @@ advanceScrollAmount u =
updatePastWorlds :: World -> World
updatePastWorlds w = w & pastWorlds %~ (forceFoldable . take 100 . ((w ^. cWorld . lWorld) :))
--updatePastWorlds w = w & pastWorlds %~ (forceFoldable . take 600 . ((w ^. cWorld . lWorld) :))
doWorldEvents :: World -> World
@@ -462,10 +474,12 @@ updateCreatureSoundPositions w =
--updateIMr fim fup w = foldr (dbArg fup) w (fim w)
updateIMl :: (World -> IM.IntMap a) -> (a -> a -> World -> World) -> World -> World
updateIMl fim fup w = alaf Endo foldMap (dbArg fup) (fim w) w
--updateIMl fim fup w = foldl' (flip $ dbArg fup) w (fim w)
updateIMl' :: (World -> IM.IntMap a) -> (a -> World -> World) -> World -> World
updateIMl' fim fup w = alaf Endo foldMap fup (fim w) w
--updateIMl' fim fup w = foldl' (flip fup) w (fim w)
updateCreatureGroups :: World -> World
@@ -638,10 +652,12 @@ ppEvents w = IM.foldl' (flip $ \pp -> doPressPlateEvent (_ppEvent pp) pp) w $ w
updateSeenWalls :: World -> World
updateSeenWalls w = alaf Endo foldMap (markWallSeen . _wlID . snd) (allVisibleWalls w) w
--updateSeenWalls w = foldl' markWallSeen w (map (_wlID . snd) $ allVisibleWalls w)
markWallSeen :: Int -> World -> World
markWallSeen i = cWorld . seenWalls . at i ?~ ()
--markWallSeen :: World -> Int -> World
--markWallSeen w i = w & cWorld . seenWalls . at i ?~ ()
src/Dodge/WorldEvent/Explosion.hs
-7
View File
@@ -8,10 +8,6 @@ module Dodge.WorldEvent.Explosion (
makeTeslaExplosionAt,
) where
--import Dodge.WorldEvent.Flash
--import Geometry.Vector3D
import Control.Monad
import Data.List
import Dodge.Base.Collide
@@ -27,8 +23,6 @@ import LensHelp
import Picture
import RandomHelp
--import Data.Maybe
makePoisonExplosionAt ::
-- | Position
Point2 ->
@@ -97,7 +91,6 @@ makeExplosionAt p w =
inversePushOut v = (15 - magV v) * 0.01 *.* v
fVs' = zipWith (+.+) fVs $ map inversePushOut fPs'
sizes = randomRs (2, 9) $ _randGen w
--times = randomRs (20,25) $ _randGen w
times = randomRs (15, 20) $ _randGen w
mF q z v size time = makeFlamelet q z v size time
newFs = zipWith5 mF fPs zs (fmap (3 *.*) fVs') sizes times
tags
+295 -295
View File
File diff suppressed because it is too large Load Diff