From 69f915a8941147034274ed27a2c53d3ff668d01d Mon Sep 17 00:00:00 2001 From: jgk Date: Mon, 17 May 2021 22:39:18 +0200 Subject: [PATCH] Cleanup warnings --- src/Dodge/Base.hs | 51 +++++-- src/Dodge/Base/Collide.hs | 9 +- src/Dodge/Base/Window.hs | 3 +- src/Dodge/Config/Data.hs | 6 +- src/Dodge/Config/KeyConfig.hs | 167 +++++++++++----------- src/Dodge/Config/Update.hs | 3 +- src/Dodge/Creature.hs | 70 +++------ src/Dodge/Creature/Action.hs | 24 ++-- src/Dodge/Creature/Action/Flee.hs | 2 +- src/Dodge/Creature/ActionRat.hs | 86 +++++++---- src/Dodge/Creature/AutoCrit.hs | 52 +++++++ src/Dodge/Creature/ImpulseRat.hs | 28 ++-- src/Dodge/Creature/Inanimate.hs | 3 +- src/Dodge/Creature/LauncherCrit.hs | 8 +- src/Dodge/Creature/LtAutoCrit.hs | 15 +- src/Dodge/Creature/Picture.hs | 19 +-- src/Dodge/Creature/PistolCrit.hs | 32 ++--- src/Dodge/Creature/Rationality.hs | 55 +++---- src/Dodge/Creature/SetTarget.hs | 7 + src/Dodge/Creature/SpreadGunCrit.hs | 50 ++++--- src/Dodge/Creature/State.hs | 52 +++---- src/Dodge/Creature/State/Data.hs | 2 +- src/Dodge/Creature/SwarmCrit.hs | 20 ++- src/Dodge/Creature/Update.hs | 2 +- src/Dodge/Creature/YourControl.hs | 14 +- src/Dodge/Data.hs | 16 +-- src/Dodge/Debug.hs | 3 +- src/Dodge/Default.hs | 32 +++-- src/Dodge/Event.hs | 43 +++--- src/Dodge/Event/Keyboard.hs | 7 +- src/Dodge/Event/Menu.hs | 9 +- src/Dodge/Event/Test.hs | 17 ++- src/Dodge/Floor.hs | 44 +++--- src/Dodge/Graph.hs | 1 - src/Dodge/Initialisation.hs | 7 +- src/Dodge/Inventory.hs | 21 +-- src/Dodge/Item.hs | 9 +- src/Dodge/Item/Attachment.hs | 26 ++-- src/Dodge/Item/Equipment.hs | 60 ++++++++ src/Dodge/Item/Weapon.hs | 144 ++++++++----------- src/Dodge/Item/Weapon/Bullet.hs | 68 +++------ src/Dodge/Item/Weapon/Decoration.hs | 2 +- src/Dodge/Item/Weapon/ExtraEffect.hs | 18 ++- src/Dodge/Item/Weapon/Grenade.hs | 14 +- src/Dodge/Item/Weapon/InventoryDisplay.hs | 11 +- src/Dodge/Item/Weapon/Laser.hs | 17 +-- src/Dodge/Item/Weapon/TriggerType.hs | 11 +- src/Dodge/Item/Weapon/UseEffect.hs | 16 +-- src/Dodge/Layout.hs | 20 +-- src/Dodge/Layout/Generate.hs | 6 +- src/Dodge/Layout/Tree.hs | 6 +- src/Dodge/Layout/Tree/Either.hs | 3 +- src/Dodge/Layout/Tree/Shift.hs | 4 +- src/Dodge/LevelGen.hs | 37 +++-- src/Dodge/LevelGen/AutoDoor.hs | 20 +-- src/Dodge/LevelGen/Block.hs | 34 +++-- src/Dodge/LevelGen/InnerWalls.hs | 12 +- src/Dodge/LevelGen/LineBlock.hs | 21 ++- src/Dodge/LevelGen/Pathing.hs | 20 ++- src/Dodge/LevelGen/StaticWalls.hs | 47 +++--- src/Dodge/LevelGen/Switch.hs | 2 + src/Dodge/LevelGen/TriggerDoor.hs | 9 +- src/Dodge/LightSources.hs | 20 ++- src/Dodge/LoadSound.hs | 6 - src/Dodge/Path.hs | 67 +++++---- src/Dodge/Render.hs | 44 +++--- src/Dodge/Render/HUD.hs | 26 ++-- src/Dodge/Render/MenuScreen.hs | 8 +- src/Dodge/Render/Picture.hs | 26 ++-- src/Dodge/Room.hs | 55 +++---- src/Dodge/Room/Airlock.hs | 2 +- src/Dodge/Room/Branch.hs | 4 +- src/Dodge/Room/Link.hs | 20 ++- src/Dodge/Room/LongDoor.hs | 11 +- src/Dodge/Room/NoNeedWeapon.hs | 4 +- src/Dodge/Room/Placement.hs | 35 ++++- src/Dodge/Room/Procedural.hs | 56 ++++---- src/Dodge/Room/RoadBlock.hs | 2 +- src/Dodge/Room/Teleport.hs | 3 +- src/Dodge/Room/Treasure.hs | 4 +- src/Dodge/SoundLogic.hs | 22 --- src/Dodge/SoundLogic/Synonyms.hs | 3 +- src/Dodge/Update.hs | 31 ++-- src/Dodge/Update/Camera.hs | 52 ++++--- src/Dodge/WallCreatureCollisions.hs | 39 +++-- src/Dodge/WorldEvent.hs | 18 +-- src/Dodge/WorldEvent/Bullet.hs | 18 +-- src/Dodge/WorldEvent/Cloud.hs | 4 +- src/Dodge/WorldEvent/DamageBlock.hs | 16 +++ src/Dodge/WorldEvent/Explosion.hs | 5 +- src/Dodge/WorldEvent/Flash.hs | 13 +- src/Dodge/WorldEvent/HelperParticle.hs | 11 +- src/Dodge/WorldEvent/HitEffect.hs | 78 ++++++---- src/Dodge/WorldEvent/Shockwave.hs | 19 +-- src/Dodge/WorldEvent/Sound.hs | 2 - src/Dodge/WorldEvent/SpawnParticle.hs | 30 ++-- src/Dodge/WorldEvent/ThingsHit.hs | 11 +- src/DoubleStack.hs | 3 + src/Geometry/Data.hs | 6 +- src/Picture/Preload.hs | 13 +- src/Picture/Render.hs | 18 +-- src/Preload.hs | 6 +- 102 files changed, 1243 insertions(+), 1185 deletions(-) create mode 100644 src/Dodge/Creature/AutoCrit.hs create mode 100644 src/Dodge/Item/Equipment.hs create mode 100644 src/Dodge/WorldEvent/DamageBlock.hs diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index 39507f215..1d4c13ba5 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -14,19 +14,19 @@ import Dodge.Data import Dodge.Base.Zone import Dodge.Base.Window import Dodge.Base.Collide -import Dodge.Config.Data +--import Dodge.Config.Data import Geometry import Picture import Control.Lens -import Control.Monad.State +--import Control.Monad.State import Data.List -import Data.Function +--import Data.Function import Data.Maybe -import Data.Bifunctor +--import Data.Bifunctor import qualified Data.IntMap.Strict as IM -import qualified Data.IntSet as IS -import qualified Data.Set as S +--import qualified Data.IntSet as IS +--import qualified Data.Set as S leftPad :: Int -> a -> [a] -> [a] leftPad i x xs = reverse $ take i $ reverse (take i xs) ++ repeat x @@ -44,10 +44,11 @@ midPadL i x xs ys = take j (xs ++ repeat x) ++ ys where j = i - length ys +{- | Implementation copied from + - https://hackage.haskell.org/package/utility-ht-0.0.16/docs/src/Data.List.HT.Private.html#takeUntil + -} takeUntil :: (a -> Bool) -> [a] -> [a] -takeUntil f ps = case break f ps of - (xs,[]) -> xs - (xs, y:_ ) -> xs ++ [y] +takeUntil p = foldr (\x xs -> x : if p x then [] else xs) [] you :: World -> Creature you w = _creatures w IM.! _yourID w @@ -63,6 +64,12 @@ crItem w cid = _crInv cr IM.! _crInvSel cr where cr = _creatures w IM.! cid +yourItemRef + :: Applicative f + => World + -> (Item -> f Item) + -> World + -> f World yourItemRef w = creatures . ix (_yourID w) . crInv . ix (_crInvSel (you w)) wallNormal :: Wall -> Point2 @@ -189,7 +196,7 @@ insertNewKey x m = case IM.lookupMax m of reflectPointCreature :: Point2 -> Point2 -> Creature -> Maybe (Point2, Point2, Int) reflectPointCreature p1 p2 cr = case collidePointCirc p1 p2 (_crRad cr) (_crPos cr) of Nothing -> Nothing - Just p3 -> Just + Just _ -> Just ( p1 , errorNormalizeV 35 (ssaTriPoint p2 (_crPos cr) p1 (_crRad cr) -.- _crPos cr) +.+ (_crPos cr -.- _crOldPos cr) @@ -212,7 +219,7 @@ reflectCircCreature -> Maybe (Point2, Point2, Int) reflectCircCreature rad p1 p2 cr = case collidePointCirc p1 p2 (rad + _crRad cr) (_crPos cr) of Nothing -> Nothing - Just p3 -> Just + Just _ -> Just ( p1 , errorNormalizeV 37 (ssaTriPoint p2 (_crPos cr) p1 (_crRad cr) -.- _crPos cr) +.+ (_crPos cr -.- _crOldPos cr) @@ -234,7 +241,9 @@ reflectCircCreatures rad p1 p2 cs f (a,_,_) = magV (a -.- p1) -- | collides a point with forcefields -- if found, returns point of collision, deflection if required, and the id +collidePointFFs :: a collidePointFFs = undefined +collidePointFF :: a collidePointFF = undefined -- --collidePointFFs :: Point2 -> Point2 -> StdGen -> IM.IntMap ForceField @@ -380,11 +389,16 @@ circOnSomeWall p rad w . IM.elems $ wallsNearPoint p w {- | Test whether there is a creature of weight 4 or greater near a line. -} -isHeavyCrNearLine :: Float -> [Point2] -> World -> Bool +isHeavyCrNearLine + :: Float + -> [Point2] + -> World + -> Bool isHeavyCrNearLine d (p1:p2:_) w = any (\c -> circOnSeg p1 p2 (_crPos c) (d + _crRad c)) . IM.filter (\cr -> _crMass cr > 4) $ _creatures w +isHeavyCrNearLine _ _ _ = error "Testing whether creature is near empty line" {- | Adds the distance to the creature radius, tests whether the center is in the circle of this size centered at the point -} crsNearPoint :: Float -> Point2 -> World -> Bool @@ -505,7 +519,8 @@ isAnimate cr = case _crActionPlan cr of Inanimate -> False _ -> True -sigmoid x = x/sqrt(1+x^2) +sigmoid :: Floating a => a -> a +sigmoid x = x/sqrt(1+x^(2::Int)) {- | In order to force a list, apply with seq. -} forceSpine :: [a] -> () @@ -514,3 +529,13 @@ forceSpine = foldr (const id) () forceList :: [a] -> [a] forceList l = seq (forceSpine l) l +normalizeAnglePi :: Float -> Float +normalizeAnglePi angle + | normalizeAngle angle > pi = normalizeAngle angle - 2*pi + | otherwise = normalizeAngle angle + +-- | Taken from online, splits a list into its even and odd elements +evenOddSplit :: [a] -> ([a],[a]) +evenOddSplit = foldr f ([],[]) + where + f a (ls,rs) = (rs, a : ls) diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs index cd47c8344..17ba87eee 100644 --- a/src/Dodge/Base/Collide.hs +++ b/src/Dodge/Base/Collide.hs @@ -103,21 +103,19 @@ hasLOSIndirect p1 p2 w = case collidePointIndirect p1 p2 $ wallsAlongLine p1 p2 Nothing -> True isWalkable :: Point2 -> Point2 -> World -> Bool -isWalkable p1 p2 w = not $ collidePointWalkable p1 p2 nearbyWalls - where - nearbyWalls = wallsAlongLine p1 p2 w +isWalkable p1 p2 w = not + $ collidePointWalkable p1 p2 + $ wallsAlongLine p1 p2 w canSee :: Int -> Int -> World -> Bool canSee i j w = hasLOS p1 p2 w where p1 = _crPos (_creatures w IM.! i) p2 = _crPos (_creatures w IM.! j) - nearbyWalls = wallsAlongLine p1 p2 w canSeePoint :: Int -> Point2 -> World -> Bool canSeePoint i p w = hasLOS p1 p w where - nearbyWalls = wallsAlongLine p1 p w p1 = _crPos (_creatures w IM.! i) pathToPointFireable :: Int -> Point2 -> World -> Bool @@ -133,7 +131,6 @@ canSeePointAll i targPos w = all (flip (canSeePoint i) w . (\p -> targPos +.+ radius *.* p)) [(1,0),(0,1),(-1,0),(0,-1)] where cr = _creatures w IM.! i - cpos = _crPos cr radius = _crRad cr canSeeAny :: Int -> Int -> World -> Bool diff --git a/src/Dodge/Base/Window.hs b/src/Dodge/Base/Window.hs index b347dbae7..483b05710 100644 --- a/src/Dodge/Base/Window.hs +++ b/src/Dodge/Base/Window.hs @@ -10,6 +10,7 @@ screenPolygon w = [tr,tl,bl,br] where scRot = rotateV (_cameraRot w) scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p + | otherwise = p scTran p = p +.+ _cameraCenter w tr = scTran $ scRot $ scZoom ( halfWidth w, halfHeight w) tl = scTran $ scRot $ scZoom (-halfWidth w, halfHeight w) @@ -19,6 +20,6 @@ screenPolygon w = [tr,tl,bl,br] halfWidth,halfHeight :: World -> Float halfWidth w = getWindowX w / 2 halfHeight w = getWindowY w / 2 - +getWindowX ,getWindowY :: World -> Float getWindowX = _windowX . _config getWindowY = _windowY . _config diff --git a/src/Dodge/Config/Data.hs b/src/Dodge/Config/Data.hs index eb99fcf0e..3bc10d12f 100644 --- a/src/Dodge/Config/Data.hs +++ b/src/Dodge/Config/Data.hs @@ -14,11 +14,8 @@ module Dodge.Config.Data ( ) where import Data.Aeson -import Foreign.C.Types import GHC.Generics -import qualified GHC.Int -import qualified SDL -import System.Directory +--import System.Directory import Control.Lens data Configuration = Configuration @@ -39,6 +36,7 @@ instance ToJSON Configuration where instance FromJSON Configuration +defaultConfig :: Configuration defaultConfig = Configuration { _volume_master = 1 , _volume_sound = 1 diff --git a/src/Dodge/Config/KeyConfig.hs b/src/Dodge/Config/KeyConfig.hs index 6b8736a4b..ed7162c3f 100644 --- a/src/Dodge/Config/KeyConfig.hs +++ b/src/Dodge/Config/KeyConfig.hs @@ -2,14 +2,13 @@ {-# LANGUAGE OverloadedStrings #-} module Dodge.Config.KeyConfig where -import Data.Aeson -import Foreign.C.Types +--import Data.Aeson +--import Foreign.C.Types import GHC.Generics -import qualified GHC.Int +--import qualified GHC.Int import qualified SDL -import qualified SDL.Internal.Numbered - -import System.Directory +--import qualified SDL.Internal.Numbered +--import System.Directory data KeyConfig = KeyConfig { moveUpBinding :: Int, @@ -51,6 +50,7 @@ data KeyConfigSDL = KeyConfigSDL } deriving (Generic, Show) +defaultKeyConfigSDL :: KeyConfigSDL defaultKeyConfigSDL = KeyConfigSDL { moveUpKey = SDL.ScancodeW, @@ -71,82 +71,85 @@ defaultKeyConfigSDL = newKey = SDL.ScancodeN } -instance ToJSON KeyConfig where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON KeyConfig where - parseJSON = withObject "KeyConfig" $ \o -> do - moveUpBinding <- o .:? "moveUp" .!= 119 - moveDownBinding <- o .:? "moveDown" .!= 115 - moveLeftBinding <- o .:? "moveLeft" .!= 97 - moveRightBinding <- o .:? "moveRight" .!= 100 - pauseBinding <- o .:? "pause" .!= 112 - escapeBinding <- o .:? "escape" .!= 27 - dropItemBinding <- o .:? "dropItem" .!= 102 - toggleMapBinding <- o .:? "toggleMap" .!= 109 - reloadBinding <- o .:? "reload" .!= 114 - testEventBinding <- o .:? "testEvent" .!= 116 - spaceActionBinding <- o .:? "spaceAction" .!= 32 - rotateCameraPlusBinding <- o .:? "rotateCameraPlus" .!= 113 - rotateCameraMinusBinding <- o .:? "rotateCameraMinus" .!= 101 - zoomInBinding <- o .:? "zoomIn" .!= 106 - zoomOutBinding <- o .:? "zoomOut" .!= 107 - newBinding <- o .:? "new" .!= 110 - return - KeyConfig - { moveUpBinding = moveUpBinding, - moveDownBinding = moveDownBinding, - moveLeftBinding = moveLeftBinding, - moveRightBinding = moveRightBinding, - pauseBinding = pauseBinding, - escapeBinding = escapeBinding, - dropItemBinding = dropItemBinding, - toggleMapBinding = toggleMapBinding, - reloadBinding = reloadBinding, - testEventBinding = testEventBinding, - spaceActionBinding = spaceActionBinding, - rotateCameraPlusBinding = rotateCameraPlusBinding, - rotateCameraMinusBinding = rotateCameraMinusBinding, - zoomInBinding = zoomInBinding, - zoomOutBinding = zoomOutBinding, - newBinding = newBinding - } +--instance ToJSON KeyConfig where +-- toEncoding = genericToEncoding defaultOptions +-- +--instance FromJSON KeyConfig where +-- parseJSON = withObject "KeyConfig" $ \o -> do +-- moveUpBinding <- o .:? "moveUp" .!= 119 +-- moveDownBinding <- o .:? "moveDown" .!= 115 +-- moveLeftBinding <- o .:? "moveLeft" .!= 97 +-- moveRightBinding <- o .:? "moveRight" .!= 100 +-- pauseBinding <- o .:? "pause" .!= 112 +-- escapeBinding <- o .:? "escape" .!= 27 +-- dropItemBinding <- o .:? "dropItem" .!= 102 +-- toggleMapBinding <- o .:? "toggleMap" .!= 109 +-- reloadBinding <- o .:? "reload" .!= 114 +-- testEventBinding <- o .:? "testEvent" .!= 116 +-- spaceActionBinding <- o .:? "spaceAction" .!= 32 +-- rotateCameraPlusBinding <- o .:? "rotateCameraPlus" .!= 113 +-- rotateCameraMinusBinding <- o .:? "rotateCameraMinus" .!= 101 +-- zoomInBinding <- o .:? "zoomIn" .!= 106 +-- zoomOutBinding <- o .:? "zoomOut" .!= 107 +-- newBinding <- o .:? "new" .!= 110 +-- return +-- KeyConfig +-- { moveUpBinding = moveUpBinding, +-- moveDownBinding = moveDownBinding, +-- moveLeftBinding = moveLeftBinding, +-- moveRightBinding = moveRightBinding, +-- pauseBinding = pauseBinding, +-- escapeBinding = escapeBinding, +-- dropItemBinding = dropItemBinding, +-- toggleMapBinding = toggleMapBinding, +-- reloadBinding = reloadBinding, +-- testEventBinding = testEventBinding, +-- spaceActionBinding = spaceActionBinding, +-- rotateCameraPlusBinding = rotateCameraPlusBinding, +-- rotateCameraMinusBinding = rotateCameraMinusBinding, +-- zoomInBinding = zoomInBinding, +-- zoomOutBinding = zoomOutBinding, +-- newBinding = newBinding +-- } loadKeyConfig :: IO KeyConfigSDL -loadKeyConfig = do - fExists <- doesFileExist "keys.json" - if fExists - then do - mayConfig <- decodeFileStrict "keys.json" - print mayConfig - case mayConfig of - Just config -> - return - KeyConfigSDL - { moveUpKey = getSdlScancode $ moveUpBinding config, - moveDownKey = getSdlScancode $ moveDownBinding config, - moveLeftKey = getSdlScancode $ moveLeftBinding config, - moveRightKey = getSdlScancode $ moveRightBinding config, - pauseKey = getSdlScancode $ pauseBinding config, - escapeKey = getSdlScancode $ escapeBinding config, - dropItemKey = getSdlScancode $ dropItemBinding config, - toggleMapKey = getSdlScancode $ toggleMapBinding config, - reloadKey = getSdlScancode $ reloadBinding config, - testEventKey = getSdlScancode $ testEventBinding config, - spaceActionKey = getSdlScancode $ spaceActionBinding config, - rotateCameraPlusKey = getSdlScancode $ rotateCameraPlusBinding config, - rotateCameraMinusKey = getSdlScancode $ rotateCameraMinusBinding config, - zoomInKey = getSdlScancode $ zoomInBinding config, - zoomOutKey = getSdlScancode $ zoomOutBinding config, - newKey = getSdlScancode $ newBinding config - } - Nothing -> do - putStrLn "invalid keys.json, loading default config" - -- This is duplicated but not sure how to reduce - return defaultKeyConfigSDL - else do - putStrLn "No keys.json found, loading default config" - return defaultKeyConfigSDL +loadKeyConfig = return defaultKeyConfigSDL -getSdlScancode :: Int -> SDL.Scancode -getSdlScancode x = SDL.Internal.Numbered.fromNumber (fromIntegral x) :: SDL.Scancode +--loadKeyConfig' :: IO KeyConfigSDL +--loadKeyConfig' = do +-- fExists <- doesFileExist "keys.json" +-- if fExists +-- then do +-- mayConfig <- decodeFileStrict "keys.json" +-- print mayConfig +-- case mayConfig of +-- Just config -> +-- return +-- KeyConfigSDL +-- { moveUpKey = getSdlScancode $ moveUpBinding config, +-- moveDownKey = getSdlScancode $ moveDownBinding config, +-- moveLeftKey = getSdlScancode $ moveLeftBinding config, +-- moveRightKey = getSdlScancode $ moveRightBinding config, +-- pauseKey = getSdlScancode $ pauseBinding config, +-- escapeKey = getSdlScancode $ escapeBinding config, +-- dropItemKey = getSdlScancode $ dropItemBinding config, +-- toggleMapKey = getSdlScancode $ toggleMapBinding config, +-- reloadKey = getSdlScancode $ reloadBinding config, +-- testEventKey = getSdlScancode $ testEventBinding config, +-- spaceActionKey = getSdlScancode $ spaceActionBinding config, +-- rotateCameraPlusKey = getSdlScancode $ rotateCameraPlusBinding config, +-- rotateCameraMinusKey = getSdlScancode $ rotateCameraMinusBinding config, +-- zoomInKey = getSdlScancode $ zoomInBinding config, +-- zoomOutKey = getSdlScancode $ zoomOutBinding config, +-- newKey = getSdlScancode $ newBinding config +-- } +-- Nothing -> do +-- putStrLn "invalid keys.json, loading default config" +-- -- This is duplicated but not sure how to reduce +-- return defaultKeyConfigSDL +-- else do +-- putStrLn "No keys.json found, loading default config" +-- return defaultKeyConfigSDL +-- +--getSdlScancode :: Int -> SDL.Scancode +--getSdlScancode x = SDL.Internal.Numbered.fromNumber (fromIntegral x) :: SDL.Scancode diff --git a/src/Dodge/Config/Update.hs b/src/Dodge/Config/Update.hs index 6c9c91ce1..cac6c61c9 100644 --- a/src/Dodge/Config/Update.hs +++ b/src/Dodge/Config/Update.hs @@ -10,8 +10,7 @@ import Preload.Data import Preload.Update import Data.Aeson (encodeFile) -import Control.Monad (when) - +--import Control.Monad (when) {- | Write the current world configuration to disk as a json file. -} diff --git a/src/Dodge/Creature.hs b/src/Dodge/Creature.hs index e584cb71d..b43aade0e 100644 --- a/src/Dodge/Creature.hs +++ b/src/Dodge/Creature.hs @@ -5,9 +5,10 @@ module Dodge.Creature , pistolCrit , ltAutoCrit , spreadGunCrit + , autoCrit ) where -import Dodge.Creature.Stance.Data +--import Dodge.Creature.Stance.Data import Dodge.Creature.State.Data import Dodge.Creature.ImpulseRat import Dodge.Creature.ActionRat @@ -18,10 +19,12 @@ import Dodge.Creature.LauncherCrit import Dodge.Creature.PistolCrit import Dodge.Creature.LtAutoCrit import Dodge.Creature.SpreadGunCrit +import Dodge.Creature.AutoCrit import Dodge.Data import Dodge.Default import Dodge.Base import Dodge.Item.Weapon +import Dodge.Item.Equipment import Dodge.Item.Consumable import Dodge.WorldEvent.Cloud import Dodge.Creature.YourControl @@ -30,29 +33,21 @@ import Dodge.Creature.State import Dodge.Creature.Picture import Dodge.Creature.Rationality import Dodge.Creature.ChooseTarget -import Dodge.Item +--import Dodge.Item import Dodge.Picture.Layer import Picture -import Geometry +--import Geometry -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 Data.List +--import Data.Char +--import Data.Maybe +--import Data.Function import Control.Lens -import Control.Applicative import Control.Monad.State -import Control.Monad -import System.Random -import qualified Data.Set as S +--import System.Random +--import qualified Data.Set as S import qualified Data.IntMap.Strict as IM -import qualified Data.Map as M -import Foreign.ForeignPtr -import Control.Concurrent +--import qualified Data.Map as M spawnerCrit :: Creature spawnerCrit = defaultCreature @@ -74,9 +69,12 @@ smallChaseCrit = defaultCreature chaseCrit :: Creature chaseCrit = defaultCreature { _crUpdate = stateUpdate $ impulsiveAIR $ - chaseTargetR targetYouLOS <=< - overrideMeleeCloseTargetR <=< - basicPerceptionUpdateR [0] <=< + doStrategyActionsR >=> + performActionsR >=> + overrideMeleeCloseTargetR >=> + chaseTargetR targetYouLOS >=> + basicPerceptionUpdateR [0] >=> + targetYouWhenCognizantR >=> return . (crMeleeCooldown . _Just %~ (max 0 . subtract 1)) , _crHP = 300 , _crPict = basicCrPict green @@ -165,33 +163,6 @@ multGunCrit = defaultCreature , _crGoal = [] } } -autoCrit :: Creature -autoCrit = defaultCreature - { _crPict = basicCrPict red - , _crUpdate = stateUpdate $ impulsiveAI $ composeInternalAIs - [ performActions - , watchUpdateStrat - [ (crHasTargetLOS, shootAdvanceStrat 0) - , (crAwayFromPost, goToPostStrat) - ] - , basicPerceptionUpdate [0] - , doStrategyActions - , reloadOverride - , targetYouWhenCognizant - , overrideInternal (onBoth (&&) crHasTarget (crStratConMatches (GetTo (0,0)))) - $ \ _ -> crActionPlan . crStrategy .~ WatchAndWait - ] - , _crActionPlan = ActionPlan - { _crImpulse = [] - , _crAction = [] - , _crStrategy = StrategyActions WatchAndWait [StartSentinelPost] - , _crGoal = [] - } - , _crInv = IM.fromList [(0,autoGun),(1,medkit 100)] - , _crInvSel = 0 - , _crRad = 10 - , _crHP = 300 - } addArmour :: Creature -> Creature addArmour = over crInv insarmour where @@ -215,6 +186,7 @@ startCr = defaultCreature , _crFaction = PlayerFaction } {- | Items you start with. -} +startInventory :: IM.IntMap Item startInventory = IM.fromList (zip [0..20] ( [bezierGun @@ -241,6 +213,6 @@ startInventory = IM.fromList (zip [0..20] ] ++ repeat NoItem)) - +smokeGenGun :: Item smokeGenGun = effectGun "smoke" $ const spawnSmokeAtCursor diff --git a/src/Dodge/Creature/Action.hs b/src/Dodge/Creature/Action.hs index 3fa07cf05..f97e212a9 100644 --- a/src/Dodge/Creature/Action.hs +++ b/src/Dodge/Creature/Action.hs @@ -9,25 +9,25 @@ module Dodge.Creature.Action import Dodge.Creature.Action.UseItem import Dodge.Creature.Action.Movement import Dodge.Creature.Stance.Data -import Dodge.Creature.State.Data +--import Dodge.Creature.State.Data import Dodge.WorldEvent.Shockwave -import Dodge.Data hiding (carriage) +import Dodge.Data import Dodge.Base import Dodge.SoundLogic -import Dodge.WorldEvent +--import Dodge.WorldEvent import Dodge.Inventory -import Dodge.LightSources +--import Dodge.LightSources import Geometry import Picture import Control.Lens -import Control.Monad -import Control.Applicative +--import Control.Monad +--import Control.Applicative import Data.Maybe -import Data.List +--import Data.List import System.Random import qualified Data.IntMap.Strict as IM -import qualified Data.Map as M +--import qualified Data.Map as M crStrafeLeft :: Float -- ^ Speed @@ -271,7 +271,7 @@ turnBy a n = over (creatures . ix n . crDir) (+ a) youDropItem :: World -> World youDropItem w = case yourItem w of NoItem -> w - it -> rmSelectedInvItem (_yourID w) + _ -> rmSelectedInvItem (_yourID w) . copyItemToFloor (you w) (_crInvSel $ you w) $ soundOnce putDownSound w @@ -287,9 +287,9 @@ copyItemToFloor cr i w = case _crInv cr IM.! i of where (rot, g) = randomR (-pi,pi) $ _randGen w offset = (_crRad cr + 2) *.* unitVectorAtAngle rot - updateLocation w = case it ^? itID of - Just (Just i) -> w & itemPositions . ix i .~ OnFloor flid - _ -> w + updateLocation w' = case it ^? itID of + Just (Just i') -> w' & itemPositions . ix i' .~ OnFloor flid + _ -> w' flid = newKey $ _floorItems w theflit = FlIt {_flIt = it diff --git a/src/Dodge/Creature/Action/Flee.hs b/src/Dodge/Creature/Action/Flee.hs index b176c8705..8587efdb2 100644 --- a/src/Dodge/Creature/Action/Flee.hs +++ b/src/Dodge/Creature/Action/Flee.hs @@ -8,7 +8,7 @@ import Data.Maybe retreatPointForFrom :: Float -> World -> Creature -> Point2 -> Maybe Point2 -retreatPointForFrom d w cr p +retreatPointForFrom d _ cr p = listToMaybe . sortOn (dist cpos) $ divideCircle 10 p d diff --git a/src/Dodge/Creature/ActionRat.hs b/src/Dodge/Creature/ActionRat.hs index 4a6121382..6e06f7cf8 100644 --- a/src/Dodge/Creature/ActionRat.hs +++ b/src/Dodge/Creature/ActionRat.hs @@ -6,27 +6,32 @@ module Dodge.Creature.ActionRat , shootAdvance , shootFirstMiss , doStrategyActions + , doStrategyActionsR , reloadOverride + , reloadOverrideR , reloadOverrideNoHolster , shootAdvanceStrat , shootMoveStrat , watchUpdateStrat + , watchUpdateStratR , goToPostStrat , overrideInternal + , overrideInternalR , fleeTime ) where import Dodge.Data import Dodge.Base -import Dodge.Base.Collide -import Dodge.Creature.ChooseTarget +--import Dodge.Base.Collide +--import Dodge.Creature.ChooseTarget import Dodge.Creature.Stance.Data import Dodge.Creature.Test -import Geometry +--import Geometry import Data.List -import qualified Data.IntMap.Strict as IM +--import qualified Data.IntMap.Strict as IM import Control.Lens +import Control.Monad.Reader shootTargetWithStrat :: (Creature -> World -> Maybe Creature) -- ^ Function for determining target @@ -65,8 +70,9 @@ suppress w cr tcr as ] | otherwise = as +-- This should be decomposed properly shootFirstMiss :: Int -> World -> Creature -> Strategy -shootFirstMiss tcid w cr = StrategyActions (ShootAt tcid) acs +shootFirstMiss tcid _ _ = StrategyActions (ShootAt tcid) acs where acs = [ DoActionIfElse NoAction crIsAiming (DoActionThen DrawWeapon (WaitThen 50 NoAction)) @@ -88,7 +94,7 @@ shootFirstMiss tcid w cr = StrategyActions (ShootAt tcid) acs advanceShoot = ImpulsesList [[UseItem, MoveForward 3]] fleeTime :: Int -> World -> Creature -> Strategy -fleeTime t w cr = StrategyActions Flee +fleeTime t _ _ = StrategyActions Flee [ t `DoReplicate` UseTargetCID FleeFrom `DoActionThen` @@ -110,9 +116,6 @@ aimThenShootStrat tcid _ _ = StrategyActions (ShootAt tcid) , _slowAimAngle = pi/8 } ] - where - lostest (w,cr') = canSee (_crID cr') tcid w - advanceShoot = ImpulsesList [[UseItem, MoveForward 3]] shootMoveStrat :: Point2 -> Int -> World -> Creature -> Strategy shootMoveStrat moveV tcid _ _ = StrategyActions (ShootAt tcid) @@ -165,7 +168,7 @@ goToPostStrat w cr = case find sentinelGoal $ _crGoal $ _crActionPlan cr of ] _ -> WatchAndWait where - sentinelGoal (SentinelAt p dir) = True + sentinelGoal (SentinelAt _ _) = True sentinelGoal _ = False holsterIfAiming | crIsAiming (w,cr) = HolsterWeapon @@ -181,6 +184,16 @@ overrideInternal test update w cr | test (w,cr) = update w cr | otherwise = cr +overrideInternalR + :: ((World , Creature) -> Bool) + -> (World -> Creature -> Creature) + -> Creature + -> Reader World Creature +overrideInternalR test update cr = reader $ \w -> + if test (w,cr) + then update w cr + else cr + shootAdvance :: World -> Creature -> Creature -> [Action] -> [Action] shootAdvance w cr tcr as | lostest (w,cr) && cr ^. crStance . posture /= Aiming @@ -205,33 +218,25 @@ shootAdvance w cr tcr as = [ HolsterWeapon ] | otherwise = as where - lostest (w,cr') = canSee (_crID cr) (_crID tcr) w + lostest (w',cr') = canSee (_crID cr') (_crID tcr) w' advanceShoot = ImpulsesList [[UseItem, MoveForward 3]] -applyNewStrategies - :: World - -> Creature - -> Creature -applyNewStrategies w cr = case cr ^? crActionPlan . crStrategy of - Just (StrategyActions strat acs) -> cr & crActionPlan . crAction .~ acs - & crActionPlan . crStrategy .~ strat - _ -> cr - doStrategyActions :: World -> Creature -> Creature -doStrategyActions w cr = case cr ^? crActionPlan . crStrategy of +doStrategyActions _ cr = case cr ^? crActionPlan . crStrategy of Just (StrategyActions strat acs) -> cr & crActionPlan . crAction .~ acs & crActionPlan . crStrategy .~ strat _ -> cr -updateShoot - :: World - -> Creature - -> Creature -updateShoot w cr = case _crStrategy $ _crActionPlan cr of - WatchAndWait -> undefined +doStrategyActionsR + :: Creature + -> Reader World Creature +doStrategyActionsR cr = return $ case cr ^? crActionPlan . crStrategy of + Just (StrategyActions strat acs) -> cr & crActionPlan . crAction .~ acs + & crActionPlan . crStrategy .~ strat + _ -> cr reloadOverride :: World @@ -245,7 +250,21 @@ reloadOverride _ cr where reloadActions = [ HolsterWeapon - , WaitThen 1 $ DoActionWhileThen NoAction crIsReloading (DoImpulses [ChangeStrategy WatchAndWait]) + , WaitThen 1 $ DoActionWhileInterrupt NoAction crIsReloading (DoImpulses [ChangeStrategy WatchAndWait]) + ] + +reloadOverrideR + :: Creature + -> Reader World Creature +reloadOverrideR cr + | cr ^? crInv . ix (_crInvSel cr) . wpLoadedAmmo == Just 0 + && cr ^. crStance . posture == Aiming + = return $ cr & crActionPlan . crStrategy .~ StrategyActions Reload reloadActions + | otherwise = return $ cr + where + reloadActions = + [ HolsterWeapon + , WaitThen 1 $ DoActionWhileInterrupt NoAction crIsReloading (DoImpulses [ChangeStrategy WatchAndWait]) ] reloadOverrideNoHolster @@ -259,7 +278,7 @@ reloadOverrideNoHolster _ cr | otherwise = cr where reloadActions = - [ DoActionWhileThen NoAction crIsReloading (DoImpulses [ChangeStrategy WatchAndWait]) + [ DoActionWhileInterrupt NoAction crIsReloading (DoImpulses [ChangeStrategy WatchAndWait]) ] watchUpdateStrat @@ -272,6 +291,15 @@ watchUpdateStrat fs w cr = case cr ^? crActionPlan . crStrategy of & crActionPlan . crStrategy .~ listGuard (fs, \_ _ -> WatchAndWait) (w, cr) w cr _ -> cr +watchUpdateStratR + :: [ ((World, Creature) -> Bool, World -> Creature -> Strategy) ] + -> Creature + -> Reader World Creature +watchUpdateStratR fs cr = reader $ \w -> case cr ^? crActionPlan . crStrategy of + Just WatchAndWait -> cr + & crActionPlan . crStrategy .~ listGuard (fs, \_ _ -> WatchAndWait) (w, cr) w cr + _ -> cr + listGuard :: ([(a -> Bool, b)] , b) -> a -> b listGuard ( (test,y):ps, z ) x | test x = y diff --git a/src/Dodge/Creature/AutoCrit.hs b/src/Dodge/Creature/AutoCrit.hs new file mode 100644 index 000000000..17be01d5d --- /dev/null +++ b/src/Dodge/Creature/AutoCrit.hs @@ -0,0 +1,52 @@ +module Dodge.Creature.AutoCrit + ( autoCrit + ) where +import Dodge.Data +import Dodge.Default +import Dodge.Creature.Picture +import Dodge.Creature.Test +import Dodge.Creature.ActionRat +--import Dodge.Creature.ChooseTarget +import Dodge.Creature.SetTarget +import Dodge.Creature.Rationality +import Dodge.Creature.AlertLevel +import Dodge.Creature.State +--import Dodge.Creature.State.Data +import Dodge.Item.Weapon +import Dodge.Item.Consumable +--import Geometry +import Picture +--import Dodge.RandomHelp + +--import Data.Maybe +import qualified Data.IntMap.Strict as IM +import Control.Lens +import Control.Monad +--import System.Random + +autoCrit :: Creature +autoCrit = defaultCreature + { _crPict = basicCrPict red + , _crUpdate = stateUpdate $ impulsiveAIR $ + performActionsR + >=> watchUpdateStratR + [ (crHasTargetLOS, shootAdvanceStrat 0) + , (crAwayFromPost, goToPostStrat) + ] + >=> basicPerceptionUpdateR [0] + >=> doStrategyActionsR + >=> reloadOverrideR + >=> targetYouWhenCognizantR + >=> (overrideInternalR (onBoth (&&) crHasTarget (crStratConMatches (GetTo (0,0)))) + $ \ _ -> crActionPlan . crStrategy .~ WatchAndWait) + , _crActionPlan = ActionPlan + { _crImpulse = [] + , _crAction = [] + , _crStrategy = StrategyActions WatchAndWait [StartSentinelPost] + , _crGoal = [] + } + , _crInv = IM.fromList [(0,autoGun),(1,medkit 100)] + , _crInvSel = 0 + , _crRad = 10 + , _crHP = 300 + } diff --git a/src/Dodge/Creature/ImpulseRat.hs b/src/Dodge/Creature/ImpulseRat.hs index 90307c65c..32c307c3b 100644 --- a/src/Dodge/Creature/ImpulseRat.hs +++ b/src/Dodge/Creature/ImpulseRat.hs @@ -2,7 +2,7 @@ module Dodge.Creature.ImpulseRat where import Dodge.Data import Dodge.Base -import Dodge.Creature.ChooseTarget +--import Dodge.Creature.ChooseTarget import Dodge.Creature.State.Data import Geometry @@ -120,15 +120,14 @@ chaseTargetR targFunc cr = reader $ \w -> case targFunc cr w of Nothing -> cr Just crTarg -> cr & crActionPlan . crImpulse .~ chaseTarg cr crTarg - overrideMeleeCloseTarget :: World -> Creature -> Creature -overrideMeleeCloseTarget w cr = case _crTarget cr of +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 . crStrategy .~ StrategyActions MeleeStrike [DoImpulses [Melee (_crID tcr)]] + -> cr & crActionPlan . crAction .~ [DoImpulses [Melee (_crID tcr)]] | otherwise -> cr where cpos = _crPos cr @@ -136,16 +135,21 @@ overrideMeleeCloseTarget w cr = case _crTarget cr of overrideMeleeCloseTargetR :: Creature -> Reader World Creature -overrideMeleeCloseTargetR cr = reader $ \w -> 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 . crStrategy .~ StrategyActions MeleeStrike [DoImpulses [Melee (_crID tcr)]] - | otherwise -> cr +overrideMeleeCloseTargetR cr = return $ maybe cr (tryMeleeAttack cr) (_crTarget cr) + +tryMeleeAttack :: Creature -> Creature -> Creature +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 + | otherwise = cr where cpos = _crPos cr + meleeActions = + [DoImpulses [Melee (_crID tcr)] + `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait] + ] chaseTarg' :: Point2 -> Creature -> Creature -> [Impulse] chaseTarg' p cr crT diff --git a/src/Dodge/Creature/Inanimate.hs b/src/Dodge/Creature/Inanimate.hs index 452f35c5f..e806ab0ad 100644 --- a/src/Dodge/Creature/Inanimate.hs +++ b/src/Dodge/Creature/Inanimate.hs @@ -4,7 +4,7 @@ Inanimate objects such as lamps, barrels, etc module Dodge.Creature.Inanimate where import Dodge.Data -import Dodge.Creature.Stance.Data +--import Dodge.Creature.Stance.Data import Dodge.Creature.State.Data import Dodge.Base import Dodge.Picture.Layer @@ -19,6 +19,7 @@ import Picture import qualified Data.IntMap.Strict as IM import Control.Lens +defaultInanimate :: Creature defaultInanimate = defaultCreature & crActionPlan .~ Inanimate lamp :: Creature diff --git a/src/Dodge/Creature/LauncherCrit.hs b/src/Dodge/Creature/LauncherCrit.hs index 8c08f05ac..402f4ab58 100644 --- a/src/Dodge/Creature/LauncherCrit.hs +++ b/src/Dodge/Creature/LauncherCrit.hs @@ -7,15 +7,15 @@ import Dodge.Default import Dodge.Creature.Picture import Dodge.Creature.Test import Dodge.Creature.ActionRat -import Dodge.Creature.ChooseTarget +--import Dodge.Creature.ChooseTarget import Dodge.Creature.SetTarget import Dodge.Creature.Rationality import Dodge.Creature.AlertLevel import Dodge.Creature.State -import Dodge.Creature.State.Data +--import Dodge.Creature.State.Data import Dodge.Item.Weapon -import Dodge.Item.Consumable -import Geometry +--import Dodge.Item.Consumable +--import Geometry import Picture import qualified Data.IntMap.Strict as IM diff --git a/src/Dodge/Creature/LtAutoCrit.hs b/src/Dodge/Creature/LtAutoCrit.hs index a66eb87be..5528048f0 100644 --- a/src/Dodge/Creature/LtAutoCrit.hs +++ b/src/Dodge/Creature/LtAutoCrit.hs @@ -6,24 +6,23 @@ import Dodge.Default import Dodge.Creature.Picture import Dodge.Creature.Test import Dodge.Creature.ActionRat -import Dodge.Creature.ChooseTarget +--import Dodge.Creature.ChooseTarget import Dodge.Creature.SetTarget import Dodge.Creature.Rationality import Dodge.Creature.AlertLevel import Dodge.Creature.State -import Dodge.Creature.State.Data +--import Dodge.Creature.State.Data import Dodge.Item.Weapon import Dodge.Item.Consumable import Geometry import Picture -import Dodge.RandomHelp +--import Dodge.RandomHelp -import Data.Maybe +--import Data.Maybe import qualified Data.IntMap.Strict as IM import Control.Lens -import Control.Monad.State -import System.Random - +--import Control.Monad.State +--import System.Random ltAutoCrit :: Creature ltAutoCrit = defaultCreature @@ -31,7 +30,7 @@ ltAutoCrit = defaultCreature , _crUpdate = stateUpdate $ impulsiveAI $ composeInternalAIs [ performActions , watchUpdateStrat - [ (crHasTargetLOS, \w cr -> StrategyActions (ShootAt 0) + [ (crHasTargetLOS, \_ _ -> StrategyActions (ShootAt 0) [DoActionIf (not . crIsAiming) DrawWeapon ,DoActionThen (DoActionWhile crHasTargetLOS $ ArbitraryAction chooseMovement) diff --git a/src/Dodge/Creature/Picture.hs b/src/Dodge/Creature/Picture.hs index f356a20a2..c30eb1e98 100644 --- a/src/Dodge/Creature/Picture.hs +++ b/src/Dodge/Creature/Picture.hs @@ -8,7 +8,7 @@ module Dodge.Creature.Picture import Dodge.Data import Dodge.Creature.Stance.Data import Dodge.Creature.State.Data -import Dodge.Creature.AlertLevel.Data +--import Dodge.Creature.AlertLevel.Data import Dodge.Picture.Layer import Picture import Geometry @@ -52,14 +52,14 @@ basicCrPict col cr = pictures Nothing -> False Just x -> x > 5 -drawAwakeLevel - :: Creature - -> Picture -drawAwakeLevel cr = case cr ^? crAttentionDir of - Just (AttentiveTo [0]) -> setPos . color red $ circleSolid 5 - _ -> setPos . color blue $ circleSolid 5 - where - setPos = translate 0 (_crRad cr) +--drawAwakeLevel +-- :: Creature +-- -> Picture +--drawAwakeLevel cr = case cr ^? crAttentionDir of +-- Just (AttentiveTo [0]) -> setPos . color red $ circleSolid 5 +-- _ -> setPos . color blue $ circleSolid 5 +-- where +-- setPos = translate 0 (_crRad cr) drawEquipment :: Creature @@ -70,4 +70,5 @@ drawEquipment cr = pictures $ map f $ IM.toList (_crInv cr) Just g | (cr ^? crStance . posture) == Just Aiming -> g cr i _ -> blank +circLine :: Float -> Picture circLine x = line [(0,0),(x,0)] diff --git a/src/Dodge/Creature/PistolCrit.hs b/src/Dodge/Creature/PistolCrit.hs index 819365f87..5c5e32775 100644 --- a/src/Dodge/Creature/PistolCrit.hs +++ b/src/Dodge/Creature/PistolCrit.hs @@ -6,12 +6,12 @@ import Dodge.Default import Dodge.Creature.Picture import Dodge.Creature.Test import Dodge.Creature.ActionRat -import Dodge.Creature.ChooseTarget +--import Dodge.Creature.ChooseTarget import Dodge.Creature.SetTarget import Dodge.Creature.Rationality import Dodge.Creature.AlertLevel import Dodge.Creature.State -import Dodge.Creature.State.Data +--import Dodge.Creature.State.Data import Dodge.Item.Weapon import Dodge.Item.Consumable import Geometry @@ -22,24 +22,24 @@ import Data.Maybe import qualified Data.IntMap.Strict as IM import Control.Lens import Control.Monad.State -import System.Random +--import System.Random pistolCrit :: Creature pistolCrit = defaultCreature { _crPict = basicCrPict red - , _crUpdate = stateUpdate $ impulsiveAI $ composeInternalAIs - [ performActions - , watchUpdateStrat - [ (crHasTargetLOS, \w cr -> StrategyActions (ShootAt 0) [DoActionIf (not . crIsAiming) DrawWeapon,chooseMovement cr w]) - , (crAwayFromPost, goToPostStrat) - ] - , basicPerceptionUpdate [0] - , doStrategyActions - , reloadOverride - , targetYouWhenCognizant - , overrideInternal (onBoth (&&) crHasTarget (crStratConMatches (GetTo (0,0)))) - $ \ _ -> crActionPlan . crStrategy .~ WatchAndWait - ] + , _crUpdate = stateUpdate $ impulsiveAIR $ + performActionsR + >=> watchUpdateStratR + [ (crHasTargetLOS, \w cr -> StrategyActions (ShootAt 0) + [DoActionIf (not . crIsAiming) DrawWeapon,chooseMovement cr w]) + , (crAwayFromPost, goToPostStrat) + ] + >=> basicPerceptionUpdateR [0] + >=> doStrategyActionsR + >=> reloadOverrideR + >=> targetYouWhenCognizantR + >=> overrideInternalR (onBoth (&&) crHasTarget (crStratConMatches (GetTo (0,0)))) + ( \ _ -> crActionPlan . crStrategy .~ WatchAndWait ) , _crActionPlan = ActionPlan { _crImpulse = [] , _crAction = [] diff --git a/src/Dodge/Creature/Rationality.hs b/src/Dodge/Creature/Rationality.hs index b6e370ad8..b230aa03d 100644 --- a/src/Dodge/Creature/Rationality.hs +++ b/src/Dodge/Creature/Rationality.hs @@ -3,7 +3,7 @@ module Dodge.Creature.Rationality import Dodge.Data import Dodge.Base.Collide import Dodge.Creature.Action -import Dodge.Creature.Action.UseItem +--import Dodge.Creature.Action.UseItem import Dodge.Creature.State.Data import Dodge.Creature.Stance.Data import Dodge.SoundLogic @@ -15,8 +15,6 @@ import System.Random import Control.Lens import Control.Monad.Reader --- Alternatives would probably be a very good fit for actions... - composeInternalAIs :: [World -> Creature -> Creature] -> World @@ -40,13 +38,14 @@ impulsiveAI -> ((World -> World,StdGen), Maybe Creature) impulsiveAI impF w (f,g) = followImpulses w (f,g) . impF w +-- needs cleanup followImpulses :: World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) followImpulses w (f,g) cr - = (\(f''' ,cr) -> ((f''',g'),Just cr)) + = (\(f''' ,cr') -> ((f''',g'),Just cr')) $ foldr (\imp (f' , cr') -> let (f'', cr'') = followImpulse cr' w imp in (f'' . f', cr'')) (f, cr) @@ -68,9 +67,9 @@ 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 crID -> - (hitCr crID - , crMvBy (10 *.* normalizeV (posFromID crID -.- cpos)) $ cr & crMeleeCooldown ?~ 20) -- randomise cooldown? + Melee cid -> + (hitCr cid + , crMvBy (10 *.* normalizeV (posFromID cid -.- cpos)) $ cr & crMeleeCooldown ?~ 20) -- randomise cooldown? RandomTurn a -> (id, creatureTurn (rr a) cr) MakeSound sid -> ( soundOnceOrigin sid (CrSound (_crID cr)) (_crPos cr) , cr ) DropItem -> undefined @@ -101,18 +100,6 @@ actionUpdateAI -> Creature actionUpdateAI actF w c = performActions w $ actF w c -performActionR :: Creature -> Reader World Creature -performActionR cr = reader $ \w -> performActions w cr - -watchUpdateStratR - :: [ ((World, Creature) -> Bool, World -> Creature -> Strategy) ] - -> Creature - -> Reader World Creature -watchUpdateStratR fs cr = case cr ^? crActionPlan . crStrategy of - Just WatchAndWait -> reader $ \w -> cr - & crActionPlan . crStrategy .~ listGuard (fs, \_ _ -> WatchAndWait) (w, cr) w cr - _ -> reader $ \_ -> cr - listGuard :: ([(a -> Bool, b)] , b) -> a -> b listGuard ( (test,y):ps, z ) x | test x = y @@ -126,6 +113,10 @@ performActions w cr = cr where (iss, mayas) = unzip $ map (performAction cr w) $ cr ^. crActionPlan . crAction +performActionsR :: Creature -> Reader World Creature +performActionsR cr = reader $ \w -> performActions w cr + + {- | Performing an action means that a creature has some impulses for a frame, and updates or deletes the action itself. -} performAction @@ -154,24 +145,24 @@ performAction cr w ac = case ac of DoImpulses imps -> (imps, Nothing) DrawWeapon -> ([ChangePosture Aiming, MakeSound pickUpSound] , Nothing) HolsterWeapon -> ([ChangePosture AtEase, MakeSound putDownSound] , Nothing) - DoActionThen ac ac' -> case performAction cr w ac of - (imps , Just ac'') -> (imps, Just (DoActionThen ac'' ac')) - (imps , Nothing ) -> (imps, Just ac') - DoActionWhile f ac -> performAction cr w $ DoActionWhilePartial ac f ac + DoActionThen fsta afta -> case performAction cr w fsta of + (imps , Just nxta) -> (imps, Just (DoActionThen nxta afta)) + (imps , Nothing ) -> (imps, Just afta) + DoActionWhile f repa -> performAction cr w $ DoActionWhilePartial repa f repa DoActionWhilePartial partAc f resetAc | f (w,cr) -> case performAction cr w partAc of - (imps, Just ac) -> (imps, Just $ DoActionWhilePartial ac f resetAc) + (imps, Just nxta) -> (imps, Just $ DoActionWhilePartial nxta f resetAc) (imps, _) -> (imps, Just $ DoActionWhilePartial resetAc f resetAc) | otherwise -> performAction cr w partAc - DoActionIf f ac - | f (w,cr) -> performAction cr w ac + DoActionIf f ifa + | f (w,cr) -> performAction cr w ifa | otherwise -> ([],Nothing) - DoActionIfElse ac f ac' - | f (w,cr) -> performAction cr w ac - | otherwise -> performAction cr w ac' - DoActionWhileThen ac f ac' - | f (w,cr) -> (fst $ performAction cr w ac, Just $ DoActionWhileThen ac f ac') - | otherwise -> performAction cr w ac' + DoActionIfElse ifa f elsea + | f (w,cr) -> performAction cr w ifa + | otherwise -> performAction cr w elsea + DoActionWhileInterrupt repa f afta + | f (w,cr) -> (fst $ performAction cr w repa, Just $ DoActionWhileInterrupt repa f afta) + | otherwise -> performAction cr w afta DoActions [] -> ([], Nothing) DoActions acs -> let (imps, newAcs) = unzip $ map (performAction cr w) acs diff --git a/src/Dodge/Creature/SetTarget.hs b/src/Dodge/Creature/SetTarget.hs index 04c595a20..6f96b4c66 100644 --- a/src/Dodge/Creature/SetTarget.hs +++ b/src/Dodge/Creature/SetTarget.hs @@ -7,6 +7,7 @@ import Dodge.Data import Dodge.Creature.AlertLevel.Data import Control.Lens +import Control.Monad.Reader import qualified Data.IntMap.Strict as IM {- | Assumes that you are id 0: if creature is cognizant of you, sets you as target -} targetYouWhenCognizant @@ -16,3 +17,9 @@ targetYouWhenCognizant targetYouWhenCognizant w cr = case cr ^? crAwarenessLevel . ix 0 of Just (Cognizant _) -> cr & crTarget ?~ _creatures w IM.! 0 _ -> cr & crTarget .~ Nothing + +targetYouWhenCognizantR :: Creature -> Reader World Creature +targetYouWhenCognizantR cr = reader $ \w -> case cr ^? crAwarenessLevel . ix 0 of +-- Just (Cognizant _) -> cr & crTarget ?~ _creatures w IM.! 0 + Just (Cognizant _) -> cr {_crTarget = Just $! _creatures w IM.! 0} + _ -> cr & crTarget .~ Nothing diff --git a/src/Dodge/Creature/SpreadGunCrit.hs b/src/Dodge/Creature/SpreadGunCrit.hs index 1a58495c1..51a6cc720 100644 --- a/src/Dodge/Creature/SpreadGunCrit.hs +++ b/src/Dodge/Creature/SpreadGunCrit.hs @@ -6,47 +6,45 @@ import Dodge.Default import Dodge.Creature.Picture import Dodge.Creature.Test import Dodge.Creature.ActionRat -import Dodge.Creature.ChooseTarget +--import Dodge.Creature.ChooseTarget import Dodge.Creature.SetTarget import Dodge.Creature.Rationality import Dodge.Creature.AlertLevel import Dodge.Creature.State -import Dodge.Creature.State.Data +--import Dodge.Creature.State.Data import Dodge.Item.Weapon import Dodge.Item.Consumable import Geometry import Picture -import Dodge.RandomHelp +--import Dodge.RandomHelp -import Data.Maybe +--import Data.Maybe import qualified Data.IntMap.Strict as IM import Control.Lens -import Control.Monad.State -import System.Random - +import Control.Monad +--import System.Random spreadGunCrit :: Creature spreadGunCrit = defaultCreature { _crPict = basicCrPict red - , _crUpdate = stateUpdate $ impulsiveAI $ composeInternalAIs - [ performActions - , watchUpdateStrat - [ (crHasTargetLOS, \w cr -> StrategyActions (ShootAt 0) - [DoActionIf (not . crIsAiming) DrawWeapon - ,DoActionThen - (DoActionWhile crHasTargetLOS $ ArbitraryAction chooseMovement) - (DoImpulses [ChangeStrategy WatchAndWait]) - ] - ) - , (crAwayFromPost, goToPostStrat) - ] - , basicPerceptionUpdate [0] - , doStrategyActions - , reloadOverride - , targetYouWhenCognizant - , overrideInternal (onBoth (&&) crHasTarget (crStratConMatches (GetTo (0,0)))) - $ \ _ -> crActionPlan . crStrategy .~ WatchAndWait - ] + , _crUpdate = stateUpdate $ impulsiveAIR $ + performActionsR + >=> watchUpdateStratR + [ (crHasTargetLOS, \_ _ -> StrategyActions (ShootAt 0) + [DoActionIf (not . crIsAiming) DrawWeapon + ,DoActionThen + (DoActionWhile crHasTargetLOS $ ArbitraryAction chooseMovement) + (DoImpulses [ChangeStrategy WatchAndWait]) + ] + ) + , (crAwayFromPost, goToPostStrat) + ] + >=> basicPerceptionUpdateR [0] + >=> doStrategyActionsR + >=> reloadOverrideR + >=> targetYouWhenCognizantR + >=> (overrideInternalR (onBoth (&&) crHasTarget (crStratConMatches (GetTo (0,0)))) + $ \ _ -> crActionPlan . crStrategy .~ WatchAndWait) , _crActionPlan = ActionPlan { _crImpulse = [] , _crAction = [] diff --git a/src/Dodge/Creature/State.hs b/src/Dodge/Creature/State.hs index fb49dc107..7f6d6bde2 100644 --- a/src/Dodge/Creature/State.hs +++ b/src/Dodge/Creature/State.hs @@ -6,27 +6,25 @@ import Dodge.Base import Dodge.SoundLogic import Dodge.RandomHelp import Dodge.WorldEvent -import Dodge.WallCreatureCollisions +--import Dodge.WallCreatureCollisions import Dodge.Creature.Action import Geometry import Picture import Data.List -import Data.Char -import Data.Maybe +--import Data.Char +--import Data.Maybe import Data.Function import Control.Lens -import Control.Applicative +--import Control.Applicative import Control.Monad.State -import Control.Monad -import qualified SDL -import qualified SDL.Mixer as Mix +--import Control.Monad +--import qualified SDL +--import qualified SDL.Mixer as Mix import System.Random -import qualified Data.Set as S +--import qualified Data.Set as S import qualified Data.IntMap.Strict as IM -import qualified Data.Map as M -import Foreign.ForeignPtr -import Control.Concurrent +--import qualified Data.Map as M type CRUpdate = World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) @@ -45,15 +43,15 @@ stateUpdate u w (f,g) cr = , fmap (updateReloadCounter . doDamage . crAutoReload) $ crOrCorpse =<< maybeCr ) where - crOrCorpse cr - | cr ^. crHP > 0 = Just 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 + --crBeforeDeath = colCrWall w cr addCorpse = insertNewKey $ uncurry translate (_crOldPos cr) $ rotate (_crDir cr) @@ -75,7 +73,7 @@ Given a creature and a velocity, applies friction to that creature and evaluates velocity to carry across frames. -} crFriction :: Creature -> Point2 -> Point2 -crFriction cr vel = (0,0) +crFriction _ _ = (0,0) doDamage :: Creature -> Creature doDamage cr = set (crState . crDamage) [] @@ -84,9 +82,6 @@ doDamage cr = set (crState . crDamage) [] dams = _crDamage $ _crState cr damagedCr = snd $ _crApplyDamage cr dams cr -sumDamage :: Creature -> DamageType -> Int -> Int -sumDamage cr dm x = x + _dmAmount dm - movementSideEff :: Creature -> World -> World movementSideEff cr w | hasJetPack @@ -178,18 +173,17 @@ updateBarrel -> (World -> World,StdGen) -> Creature -> ((World -> World , StdGen), Maybe Creature) -updateBarrel w (f,g) cr +updateBarrel _ (f,g) cr | _crHP cr > 0 = ((f, g), newCr) | otherwise = ((f, g), Nothing) where - damages = _crDamage $ _crState cr newCr = Just $ doDamage cr -- it is easy to leave off the "f" here -- should find some better way of doing all this that is less prone to error updateExpBarrel :: World -> (World -> World,StdGen) -> Creature -> ((World -> World , StdGen), Maybe Creature) -updateExpBarrel w (f,g) cr +updateExpBarrel _ (f,g) cr | _crHP cr > 0 = ((f . foldr (.) id pierceSparks . hiss, g'), newCr) | otherwise = ((f . makeExplosionAt (_crPos cr) . stopSounds , g'), Nothing) where @@ -205,13 +199,13 @@ updateExpBarrel w (f,g) cr poss = _piercedPoints $ _crSpState $ _crState cr --newCr = Just $ doDamage $ applyFuseDamage cr -- $ foldr perforate cr damages newCr = Just $ applyFuseDamage $ set (crState . crDamage) [] $ damToExpBarrel damages cr - perforate :: DamageType -> Creature -> Creature - perforate (Piercing amount sp int ep) cr = over (crState . crSpState . piercedPoints) - ((:) $ int -.- _crPos cr) cr - perforate _ cr = cr - applyFuseDamage cr = over crHP (\hp -> hp - length (_piercedPoints - $ _crSpState $ _crState cr)) - cr + --perforate :: DamageType -> Creature -> Creature + --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' hiss | null poss = id | otherwise = soundMultiFrom [BarrelHiss 0,BarrelHiss 1] 41 50 1 stopSounds = stopSoundFrom (BarrelHiss 0) . stopSoundFrom (BarrelHiss 1) @@ -224,7 +218,7 @@ damToExpBarrel ds cr = foldr damToExpBarrel' (foldr damToExpBarrel' cr pierceDam isPierce _ = False damToExpBarrel' :: DamageType -> Creature -> Creature -damToExpBarrel' (Piercing amount sp int ep) cr +damToExpBarrel' (Piercing amount _ int _) cr = over (crState . crSpState . piercedPoints) ((:) $ int -.- _crPos cr) $ over crHP (\hp -> hp - div amount 200) cr damToExpBarrel' PoisonDam {} cr = cr diff --git a/src/Dodge/Creature/State/Data.hs b/src/Dodge/Creature/State/Data.hs index c2bd726f7..3c77978da 100644 --- a/src/Dodge/Creature/State/Data.hs +++ b/src/Dodge/Creature/State/Data.hs @@ -4,7 +4,7 @@ module Dodge.Creature.State.Data where import Geometry import Dodge.Data.DamageType -import Dodge.Creature.Stance.Data +--import Dodge.Creature.Stance.Data import Picture.Data import Control.Lens diff --git a/src/Dodge/Creature/SwarmCrit.hs b/src/Dodge/Creature/SwarmCrit.hs index 1a60ff0ee..b5a0350c9 100644 --- a/src/Dodge/Creature/SwarmCrit.hs +++ b/src/Dodge/Creature/SwarmCrit.hs @@ -5,27 +5,25 @@ module Dodge.Creature.SwarmCrit import Dodge.Data import Dodge.Default import Dodge.Creature.Picture -import Dodge.Creature.Test -import Dodge.Creature.ActionRat +--import Dodge.Creature.Test +--import Dodge.Creature.ActionRat import Dodge.Creature.ImpulseRat import Dodge.Creature.ChooseTarget -import Dodge.Creature.SetTarget +--import Dodge.Creature.SetTarget import Dodge.Creature.Rationality import Dodge.Creature.AlertLevel import Dodge.Creature.State import Dodge.Creature.State.Data -import Dodge.Item.Weapon -import Dodge.Item.Consumable import Dodge.Picture.Layer -import Geometry +--import Geometry import Picture -import Dodge.RandomHelp +--import Dodge.RandomHelp -import Data.Maybe -import qualified Data.IntMap.Strict as IM +--import Data.Maybe +--import qualified Data.IntMap.Strict as IM import Control.Lens -import Control.Monad.State -import System.Random +--import Control.Monad.State +--import System.Random swarmCrit :: Creature swarmCrit = defaultCreature diff --git a/src/Dodge/Creature/Update.hs b/src/Dodge/Creature/Update.hs index 7afceb4ae..65419ca8c 100644 --- a/src/Dodge/Creature/Update.hs +++ b/src/Dodge/Creature/Update.hs @@ -12,4 +12,4 @@ unrandUpdate -> (Creature -> Maybe Creature) -> CRUpdate {-# INLINE unrandUpdate #-} -unrandUpdate h cF w (f,g) cr = ( ( h cr . f , g) , cF cr ) +unrandUpdate h cF _ (f,g) cr = ( ( h cr . f , g) , cF cr ) diff --git a/src/Dodge/Creature/YourControl.hs b/src/Dodge/Creature/YourControl.hs index 25898aac1..cf27b689c 100644 --- a/src/Dodge/Creature/YourControl.hs +++ b/src/Dodge/Creature/YourControl.hs @@ -1,10 +1,10 @@ module Dodge.Creature.YourControl where import Dodge.Data -import Dodge.Base +--import Dodge.Base import Dodge.Creature.Action -import Dodge.Creature.State -import Dodge.Creature.State.Data +--import Dodge.Creature.State +--import Dodge.Creature.State.Data import Dodge.Creature.Stance.Data import Dodge.Update.UsingInput import Dodge.Config.KeyConfig @@ -43,7 +43,7 @@ wasdWithAiming w speed i cr mov = rotateV (negate $ _crDir cr - _cameraRot w) mov' isAiming = _posture (_crStance cr) == Aiming isMoving = mov' /= (0,0) - mouseDir = case w ^? creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) + mouseDir = case w ^? creatures . ix i . crInv . ix (_crInvSel (_creatures w IM.! i)) . itAttachment of Just (Just ItScope{_scopePos = p}) -> normalizeAngle $ argV $ p +.+ 2 / _cameraZoom w @@ -67,9 +67,9 @@ wasdComp ks w = f $ foldr ( (+.+) . wasdM w ) (0,0) ks {- | Set posture according to mouse presses. -} mouseActionsCr :: S.Set SDL.MouseButton -> Creature -> Creature -mouseActionsCr keys +mouseActionsCr pkeys | rbPressed = crStance . posture .~ Aiming | otherwise = crStance . posture .~ AtEase where - lbPressed = SDL.ButtonLeft `S.member` keys - rbPressed = SDL.ButtonRight `S.member` keys + --lbPressed = SDL.ButtonLeft `S.member` pkeys + rbPressed = SDL.ButtonRight `S.member` pkeys diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 221077bbc..f8d3fb328 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -1,4 +1,4 @@ -{- +{- | Contains base datatypes that cannot be seperated into different modules because they are interdependent; circular imports are probably not a good idea. @@ -11,11 +11,10 @@ module Dodge.Data ( module Dodge.Data , module Dodge.Data.DamageType , module Dodge.Data.SoundOrigin - , Point2 (..) + , Point2 , Sound (..) , soundTime ) where -import Dodge.Picture.Layer.Data import Dodge.Creature.State.Data import Dodge.Creature.Stance.Data import Dodge.Creature.AlertLevel.Data @@ -34,20 +33,14 @@ import qualified DoubleStack as DS import GHC.Generics import Control.Lens -import Control.Monad.State import System.Random -import Data.Data import Data.Graph.Inductive import Data.Int (Int16) import qualified Data.Set as S import qualified Data.IntSet as IS import qualified Data.IntMap.Strict as IM import qualified Data.Map as M -import qualified Data.DList as DL import SDL (Scancode, MouseButton) -import qualified SDL.Mixer as Mix -import Graphics.Rendering.OpenGL (PrimitiveMode (..),GLfloat,Program,VertexArrayObject,BufferObject) -import Codec.Picture (Image,PixelRGBA8) data World = World { _keys :: !(S.Set Scancode) , _mouseButtons :: !(S.Set MouseButton) @@ -562,7 +555,7 @@ data Action ,_doActionIfElseCondition :: (World, Creature) -> Bool ,_doActionIfElseElseAction :: Action } - | DoActionWhileThen + | DoActionWhileInterrupt {_doActionWhileThenDo :: Action ,_doActionWhileThenCondition :: (World, Creature) -> Bool ,_doActionWhileThenThen :: Action @@ -667,4 +660,5 @@ numColor 8 = (0,0.5,1,1) numColor 9 = (0,1,0.5,1) numColor 10 = (0.5,1,0,1) numColor 11 = (1,0.5,0,1) -numColor 12 = (1,1,1,1) +numColor 12 = (1,1,1,1) +numColor _ = (1,1,1,1) diff --git a/src/Dodge/Debug.hs b/src/Dodge/Debug.hs index a76ab8cce..b058bf48b 100644 --- a/src/Dodge/Debug.hs +++ b/src/Dodge/Debug.hs @@ -1,10 +1,9 @@ module Dodge.Debug where - import Dodge.Data import Dodge.Base import Dodge.Picture import Dodge.Picture.Layer -import Geometry.Data +--import Geometry.Data import Picture import Control.Lens diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index 120adefc9..6cbb387a4 100644 --- a/src/Dodge/Default.hs +++ b/src/Dodge/Default.hs @@ -28,6 +28,7 @@ import qualified Data.Set as S import Data.Graph.Inductive.Graph hiding ((&)) import Data.List {- Indestructible wall. -} +defaultWall :: Wall defaultWall = Wall { _wlLine = ((0,0),(50,0)) , _wlID = 0 @@ -36,6 +37,7 @@ defaultWall = Wall , _wlIsSeeThrough = False } {- Indestructible see-through wall. -} +defaultCrystalWall :: Wall defaultCrystalWall = Wall { _wlLine = ((0,0),(50,0)) , _wlID = 0 @@ -45,6 +47,7 @@ defaultCrystalWall = Wall } {- Door that opens on approach. Pathable. -} +defaultAutoDoor :: Wall defaultAutoDoor = Door { _wlLine = ((0,0),(50,0)) , _wlID = 0 @@ -58,6 +61,7 @@ defaultAutoDoor = Door {- Non-pathable door. -} +defaultDoor :: Wall defaultDoor = Door { _wlLine = ((0,0),(50,0)) , _wlID = 0 @@ -76,7 +80,7 @@ defaultCreature = Creature , _crDir = 0 , _crID = 1 , _crPict = const $ onLayer CrLayer $ circleSolid 10 - , _crUpdate = \ w f cr -> (f , Just cr) + , _crUpdate = \ _ f cr -> (f , Just cr) , _crRad = 10 , _crMass = 10 , _crHP = 100 @@ -96,19 +100,21 @@ defaultCreature = Creature , _crTarget = Nothing , _crGroup = LoneWolf } +defaultState :: CreatureState defaultState = CrSt { _crDamage = [] , _crPastDamage = [] , _crSpState = GenCr , _crDropsOnDeath = DropAmount 1 } +defaultEquipment :: Item defaultEquipment = Equipment { _itIdentity = Generic , _itName = "genericEquipment" , _itMaxStack = 1 , _itAmount = 1 , _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)] - , _itEquipPict = \cr _ -> blank + , _itEquipPict = \_ _ -> blank , _itEffect = NoItEffect , _itHammer = HammerUp , _itID = Nothing @@ -118,6 +124,7 @@ defaultEquipment = Equipment , _itInvColor = yellow , _itInvDisplay = _itName } +defaultItZoom :: ItZoom defaultItZoom = ItZoom 20 0.2 1 20 0.2 1 defaultConsumable :: Item defaultConsumable = Consumable @@ -144,16 +151,16 @@ defaultApplyDamage ds cr = (id, doPoisonDam $ foldr (\d c -> snd $ applyIndividu doPoisonDam = over crHP (\hp -> hp - poisonDam) applyIndividualDamage :: DamageType -> Creature -> (World -> World, Creature) -applyIndividualDamage (Concussive amount from push pushexp pushRad) cr +applyIndividualDamage (Concussive amount fromDir push pushexp pushRad) cr = ( id , over crHP (\hp -> hp - amount) - $ over crPos (+.+ (pushAmount *.* safeNormalizeV (_crPos cr -.- from))) + $ over crPos (+.+ (pushAmount *.* safeNormalizeV (_crPos cr -.- fromDir))) cr ) - where pushAmount | dist (_crPos cr) from == 0 - = 0 - | otherwise = min 5 $ - (push*5*pushRad / (dist (_crPos cr) from * _crMass cr))**pushexp + where + pushAmount + | dist (_crPos cr) fromDir == 0 = 0 + | otherwise = min 5 $ (push*5*pushRad / (dist (_crPos cr) fromDir * _crMass cr))**pushexp applyIndividualDamage (TorqueDam amount rot) cr = ( id , over crHP (\hp -> hp - amount) $ over crDir (+ rot) cr) @@ -163,7 +170,9 @@ applyIndividualDamage (PushDam amount pback) cr ) applyIndividualDamage dt cr = ( id , over crHP (\hp -> hp - _dmAmount dt) cr ) +defaultFlIt :: FloorItem defaultFlIt = FlIt {_flItRot=0,_flIt = defaultIt, _flItPos = (0,0), _flItID = 0} +defaultIt :: Item defaultIt = Consumable { _itIdentity = Medkit25 , _itName = "defaultIt" @@ -171,13 +180,14 @@ defaultIt = Consumable , _itAmount = 2 , _cnEffect = const return , _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)] - , _itEquipPict = \cr _ -> blank + , _itEquipPict = \_ _ -> blank , _itID = Nothing , _itInvDisplay = _itName , _itInvColor = blue , _itEffect = NoItEffect , _itHammer = HammerUp } +defaultButton :: Button defaultButton = Button { _btPict = onLayer WlLayer $ color red $ polygon $ rectNSEW 5 (-5) 10 (-10) , _btPos = (0,0) @@ -190,6 +200,7 @@ defaultButton = Button , _btText = "Button" , _btState = BtOff } +defaultPT :: Projectile defaultPT = Projectile { _pjPos = (0,0) , _pjStartPos = (0,0) @@ -198,6 +209,7 @@ defaultPT = Projectile , _pjID = 0 , _pjUpdate = id } +defaultPP :: PressPlate defaultPP = PressPlate { _ppPict = onLayer PressPlateLayer $ color (dim $ dim $ bright blue) $ circleSolid 5 , _ppPos = (0,0) @@ -206,6 +218,7 @@ defaultPP = PressPlate , _ppID = -1 , _ppText = "Pressure plate" } +defaultWorld :: World defaultWorld = World { _keys = S.empty , _mouseButtons = S.empty @@ -266,6 +279,7 @@ defaultWorld = World , _sideEffects = [] , _doneSideEffects = [] } +youLight :: TempLightSource youLight = TLS { _tlsPos = (0,0) ,_tlsRad = 300 diff --git a/src/Dodge/Event.hs b/src/Dodge/Event.hs index 9e7ba354d..872511123 100644 --- a/src/Dodge/Event.hs +++ b/src/Dodge/Event.hs @@ -14,21 +14,21 @@ module Dodge.Event ( handleEvent ) where import Dodge.Event.Keyboard -import Dodge.Event.Menu +--import Dodge.Event.Menu import Dodge.Data import Dodge.Base -import Dodge.Creature.Action +--import Dodge.Creature.Action import Dodge.SoundLogic import Dodge.Inventory import Dodge.Config.Data -import Geometry +--import Geometry import Preload.Update import Control.Lens import Data.Maybe -import Data.Char -import Data.List -import Data.Function (on) +--import Data.Char +--import Data.List +--import Data.Function (on) import qualified Data.Set as S import qualified Data.IntMap.Strict as IM import SDL @@ -61,11 +61,12 @@ handleMouseButtonEvent mbev w = case mouseButtonEventMotion mbev of handleMouseWheelEvent :: MouseWheelEventData -> World -> Maybe World handleMouseWheelEvent mwev w = case _menuLayers w of - [] -> case mouseWheelEventPos mwev of - V2 x y | y > 0 -> Just (wheelUpEvent w) - | y < 0 -> Just (wheelDownEvent w) - | otherwise -> Just w - _ -> Just w + [] -> case mouseWheelEventPos mwev of + V2 _ y + | y > 0 -> Just (wheelUpEvent w) + | y < 0 -> Just (wheelDownEvent w) + | otherwise -> Just w + _ -> Just w {- | Resets the world window size, and resizes the fbo that gets the light map drawn into it. @@ -123,20 +124,12 @@ wheelDownEvent w = case _carteDisplay w of numLocs = (fst . IM.findMax $ _seenLocations w) + 1 upInvPos :: World -> World -upInvPos w = stopSoundFrom (CrReloadSound 0) $ set (creatures . ix (_yourID w) . crInvSel) x w +upInvPos w = stopSoundFrom (CrReloadSound 0) $ w + & creatures . ix (_yourID w) . crInvSel %~ (`mod` n) . (subtract 1) where - is = IM.keys $ _crInv $ _creatures w IM.! _yourID w - isis = is ++ is - x = before (_crInvSel (you w)) isis + n = length $ IM.keys $ _crInv $ _creatures w IM.! _yourID w downInvPos :: World -> World -downInvPos w = stopSoundFrom (CrReloadSound 0) $ set (creatures . ix (_yourID w) . crInvSel) x w +downInvPos w = stopSoundFrom (CrReloadSound 0) $ w + & creatures . ix (_yourID w) . crInvSel %~ (`mod` n) . (+ 1) where - is = IM.keys $ _crInv $ _creatures w IM.! _yourID w - isis = is ++ is - x = after (_crInvSel (you w)) isis - --- these are incomplete: should put in error case here! -before y (x:z:ys) | y == z = x - | otherwise = before y (z:ys) -after y (x:z:ys) | y == x = z - | otherwise = after y (z:ys) + n = length $ IM.keys $ _crInv $ _creatures w IM.! _yourID w diff --git a/src/Dodge/Event/Keyboard.hs b/src/Dodge/Event/Keyboard.hs index 8b32332fb..8628a801a 100644 --- a/src/Dodge/Event/Keyboard.hs +++ b/src/Dodge/Event/Keyboard.hs @@ -11,7 +11,7 @@ import Dodge.Picture.Layer import Dodge.Base import Dodge.Creature.Action import Dodge.Config.KeyConfig -import Dodge.Room.Placement +--import Dodge.Room.Placement import Dodge.LightSources import Dodge.LevelGen import Dodge.Creature.Inanimate @@ -77,18 +77,19 @@ spaceAction w = if _carteDisplay w Nothing -> w where theLoc = fst (_seenLocations w IM.! _selLocation w) w - updateTopCloseObject i w = w & closeActiveObjects %~ ( Right (_buttons w IM.! i) : ) . tail + updateTopCloseObject i = closeActiveObjects %~ ( Right (_buttons w IM.! i) : ) . tail pauseGame :: World -> World pauseGame w = w {_menuLayers = [PauseMenu]} +toggleMap :: World -> World toggleMap w = w & carteDisplay %~ not +escapeMap :: World -> World escapeMap w = w & carteDisplay .~ False dropLight :: World -> World dropLight w = placeLS ls dec pos 0 w where --(rot, g) = randomR (-pi,pi) $ _randGen w - i = newCrKey w -- to give different lights different keys pos = _crPos(you w) ls = lightAt pos 0 dec = onLayer PtLayer $ color white $ circleSolid 8 diff --git a/src/Dodge/Event/Menu.hs b/src/Dodge/Event/Menu.hs index feaaa14d7..06e76234b 100644 --- a/src/Dodge/Event/Menu.hs +++ b/src/Dodge/Event/Menu.hs @@ -13,7 +13,7 @@ import Dodge.Layout import Preload.Update import Data.Maybe -import qualified Data.Set as S +--import qualified Data.Set as S import Control.Lens import SDL @@ -62,8 +62,8 @@ handlePressedKeyInMenu mState scode w = case mState of startLevel = unpause . storeLevel dec x = max 0 (x - 0.1) inc x = min 1 (x + 0.1) - pushMenu ml w = Just $ w & menuLayers %~ (ml :) - popMenu w = Just $ w & menuLayers %~ tail + pushMenu ml w' = Just $ w' & menuLayers %~ (ml :) + popMenu w' = Just $ w' & menuLayers %~ tail sw = w & sideEffects %~ (setVol (_config w) : ) startNewGame = Just $ w & menuLayers .~ [WaitMessage "GENERATING..." 1] @@ -80,9 +80,12 @@ updateFramebufferSize w = w & sideEffects (x,y) = (round $ getWindowX w, round $ getWindowY w) divRes = w ^. config . shadow_resolution + +cycleResolution :: (Eq a, Num a, Num p) => a -> p cycleResolution 1 = 2 cycleResolution 2 = 4 cycleResolution 4 = 1 +cycleResolution _ = 1 storeLevel :: World -> World storeLevel w = case _storedLevel w of diff --git a/src/Dodge/Event/Test.hs b/src/Dodge/Event/Test.hs index add2714dd..51657f522 100644 --- a/src/Dodge/Event/Test.hs +++ b/src/Dodge/Event/Test.hs @@ -3,15 +3,14 @@ module Dodge.Event.Test ) where import Dodge.Data -import Dodge.Base -import Dodge.Default - -import Picture -import Geometry - -import qualified Data.IntMap as IM -import Control.Lens - +--import Dodge.Base +--import Dodge.Default +--import Picture +--import Geometry +-- +--import qualified Data.IntMap as IM +--import Control.Lens +testEvent :: World -> World testEvent w = w --testEvent :: World -> World diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index f6553534d..d3d55d06a 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -3,39 +3,39 @@ The tree of rooms that make up a level. -} module Dodge.Floor ( levx ) where -import Geometry -import Picture +--import Geometry +--import Picture import Dodge.Data -import Dodge.Room +--import Dodge.Room import Dodge.Creature.State.Data -import Dodge.Creature.SwarmCrit +--import Dodge.Creature.SwarmCrit import Dodge.Room.Procedural import Dodge.Room.RoadBlock import Dodge.Room.Data -import Dodge.Room.Link -import Dodge.Room.Door +--import Dodge.Room.Link +--import Dodge.Room.Door import Dodge.Room.Branch import Dodge.Room.Boss -import Dodge.Room.Airlock +--import Dodge.Room.Airlock import Dodge.Room.LongDoor import Dodge.Room.NoNeedWeapon -import Dodge.Base -import Dodge.Layout +--import Dodge.Base +--import Dodge.Layout import Dodge.Layout.Tree.Polymorphic import Dodge.Layout.Tree.Either -import Dodge.Layout.Tree.GenerateStructure +--import Dodge.Layout.Tree.GenerateStructure import Dodge.Layout.Tree.Annotate import Dodge.Layout.Tree.Shift import Dodge.Creature -import Dodge.SoundLogic -import Dodge.RandomHelp -import Dodge.LightSources +--import Dodge.SoundLogic +--import Dodge.RandomHelp +--import Dodge.LightSources import Dodge.LevelGen.Data -import Dodge.LevelGen.SwarmPlacement +--import Dodge.LevelGen.SwarmPlacement import Dodge.Item.Weapon -import Data.Tree -import Data.Maybe (fromJust,isNothing) +--import Data.Tree +--import Data.Maybe (fromJust,isNothing) import Control.Lens import Control.Monad.State import Control.Monad.Loops @@ -43,7 +43,7 @@ import System.Random {- | A test level tree. -} roomTreex :: RandomGen g => State g (Maybe [Room]) roomTreex = do - struct' <- aTreeStrut + --struct' <- aTreeStrut -- let struct = treeFromPost [[SpecificRoom $ fmap (pure . Right) pistolerRoom]] [EndRoom] let struct = treeFromPost [[Corridor,SpecificRoom $ fmap (pure . Right) randomFourCornerRoom]] [EndRoom] let t' = padCorridors struct @@ -51,12 +51,12 @@ roomTreex = do [[StartRoom] ,[Corridor] ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 - & rmPS %~ ([sPS (0,50) 0 $ PutCrit chaseCrit ]++) - ] - ,[Corridor] - ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 - & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200] ]++) + & rmPS %~ ([sPS (0,50) 0 $ PutCrit pistolCrit ]++) ] +-- ,[Corridor] +-- ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 +-- & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200] ]++) +-- ] ,[Corridor] ,[Corridor] ,[SpecificRoom $ pure . Right <$> twinSlowDoorChasers 30] diff --git a/src/Dodge/Graph.hs b/src/Dodge/Graph.hs index 7f4de0f4d..4c8efee7e 100644 --- a/src/Dodge/Graph.hs +++ b/src/Dodge/Graph.hs @@ -1,6 +1,5 @@ module Dodge.Graph where -import Data.Function (on) import Data.List.Extra import Data.Bifunctor (first) diff --git a/src/Dodge/Initialisation.hs b/src/Dodge/Initialisation.hs index ffb7b45fc..61a2fe755 100644 --- a/src/Dodge/Initialisation.hs +++ b/src/Dodge/Initialisation.hs @@ -1,10 +1,9 @@ module Dodge.Initialisation where --- imports {{{ import Dodge.Default import Dodge.Data import Dodge.Data.Menu import Dodge.Creature -import Dodge.Base +--import Dodge.Base import Dodge.Floor import Dodge.Layout @@ -13,10 +12,6 @@ import qualified Data.Set as S import qualified Data.IntMap.Strict as IM import qualified Data.Map as M -import Foreign.ForeignPtr -import Control.Concurrent -import Data.Tree - initializeWorld :: World -> World initializeWorld w = w diff --git a/src/Dodge/Inventory.hs b/src/Dodge/Inventory.hs index 688de89f2..e837ce1a8 100644 --- a/src/Dodge/Inventory.hs +++ b/src/Dodge/Inventory.hs @@ -6,9 +6,8 @@ import Geometry import Data.Maybe import Data.List -import Data.Function (on) import qualified Data.IntMap.Strict as IM -import System.Random +--import System.Random import Control.Lens checkInvSlotsYou' :: Maybe Item -> World -> Maybe Int @@ -39,7 +38,7 @@ checkInvSlots it its = fmap fst $ find cond $ IM.toList its addItem :: Item -> Item -> Item addItem it NoItem = it -addItem it it' = it' & itAmount +~ 1 +addItem _ it' = it' & itAmount +~ 1 numInventorySlots :: Int numInventorySlots = 9 @@ -52,19 +51,9 @@ rmInvItem -> Int -- ^ Inventory position -> World -> World -rmInvItem n i w = - let item = _crInv (_creatures w IM.! n) IM.! i - itRef = creatures . ix n . crInv . ix i - in case item of - Consumable {_itAmount = 1} -> set itRef NoItem w - Craftable {_itAmount = 1} -> set itRef NoItem w - Equipment {_itAmount = 1} -> set itRef NoItem w - Throwable {_itAmount = 1} -> set itRef NoItem w - Consumable {_itAmount = x} -> over (itRef . itAmount) (\y-> y-1) w - Craftable {_itAmount = x} -> over (itRef . itAmount) (\y-> y-1) w - Equipment {_itAmount = x} -> over (itRef . itAmount) (\y-> y-1) w - Throwable {_itAmount = x} -> over (itRef . itAmount) (\y-> y-1) w - _ -> set itRef NoItem w +rmInvItem cid itid w = case w ^? creatures . ix cid . crInv . ix itid . itAmount of + Just x | x > 1 -> w & creatures . ix cid . crInv . ix itid . itAmount %~ subtract 1 + _ -> w & creatures . ix cid . crInv . ix itid .~ NoItem {- Delete a creature's selected item, the item will no longer exist. -} rmSelectedInvItem :: Int -- ^ Creature id diff --git a/src/Dodge/Item.hs b/src/Dodge/Item.hs index 38428b019..a3c047514 100644 --- a/src/Dodge/Item.hs +++ b/src/Dodge/Item.hs @@ -1,8 +1,7 @@ module Dodge.Item where - import Dodge.Data -import Dodge.Base +--import Dodge.Base import Dodge.Default import Dodge.Picture import Picture @@ -14,7 +13,7 @@ keyToken n = defaultEquipment , _itMaxStack = 5 , _itAmount = 1 , _itFloorPict = setDepth 0.5 keyPic - , _itEquipPict = \cr _ -> setDepth 0 $ translate (-5) (-5) $ rotate (pi/2.5) keyPic + , _itEquipPict = \_ _ -> setDepth 0 $ translate (-5) (-5) $ rotate (pi/2.5) keyPic , _itEffect = NoItEffect , _itHammer = HammerUp , _itID = Nothing @@ -24,6 +23,7 @@ keyToken n = defaultEquipment , _itInvColor = yellow , _itInvDisplay = _itName } +keyPic :: Picture keyPic = color green $ pictures [translate (-4) 0 $ thickCircle 4 2 ,lineOfThickness 2 [(0,0),(8,0),(8,-4)] @@ -37,7 +37,7 @@ latchkey n = defaultEquipment , _itMaxStack = 1 , _itAmount = 1 , _itFloorPict = setDepth 0.5 latchkeyPic - , _itEquipPict = \cr _ -> setDepth 0 $ translate (-5) (-5) $ rotate (pi/2.5) latchkeyPic + , _itEquipPict = \_ _ -> setDepth 0 $ translate (-5) (-5) $ rotate (pi/2.5) latchkeyPic , _itEffect = NoItEffect , _itHammer = HammerUp , _itID = Nothing @@ -47,6 +47,7 @@ latchkey n = defaultEquipment , _itInvColor = yellow , _itInvDisplay = _itName } +latchkeyPic :: Picture latchkeyPic = color yellow $ pictures [translate (-4) 0 $ thickCircle 4 2 ,lineOfThickness 2 [(0,0),(8,0),(8,-4)] diff --git a/src/Dodge/Item/Attachment.hs b/src/Dodge/Item/Attachment.hs index a5c24b6ea..d37dbe0b2 100644 --- a/src/Dodge/Item/Attachment.hs +++ b/src/Dodge/Item/Attachment.hs @@ -39,19 +39,19 @@ charFiringStrat charFiringStrat strats cid w = case w ^? creatures . ix cid . crInv . ix (_crInvSel $ _creatures w IM.! cid) . itAttachment . _Just . itCharMode of Just (c :<| _) -> fromJust (Prelude.lookup c strats) cid w - Nothing -> w + _ -> w increaseFuse :: Int -- ^ Old fuse time -> Int -- ^ Inventory item reference (I believe) -> World -> World -increaseFuse fuse itID w = w - & creatures . ix 0 . crInv . ix itID . itScrollUp .~ decreaseFuse newTime - & creatures . ix 0 . crInv . ix itID . itScrollDown .~ increaseFuse newTime - & creatures . ix 0 . crInv . ix itID . itAttachment ?~ ItFuse newTime - & creatures . ix 0 . crInv . ix itID . itZoom - .~ (defaultItZoom {_itAimZoomMax = zm, _itAimZoomMin = zm}) +increaseFuse fuse itid w = w + & creatures . ix 0 . crInv . ix itid %~ + ( itScrollUp .~ decreaseFuse newTime ) + . (itScrollDown .~ increaseFuse newTime ) + . ( itAttachment ?~ ItFuse newTime ) + . ( itZoom .~ defaultItZoom{_itAimZoomMax = zm, _itAimZoomMin = zm} ) where newTime = min (fuse + 5) 90 zm = 50 / fromIntegral newTime @@ -60,12 +60,12 @@ decreaseFuse :: Int -- ^ Old fuse time -> Int -- ^ Inventory item reference (I believe) -> World -> World -decreaseFuse fuse itID w = w - & creatures . ix 0 . crInv . ix itID . itScrollUp .~ decreaseFuse newTime - & creatures . ix 0 . crInv . ix itID . itScrollDown .~ increaseFuse newTime - & creatures . ix 0 . crInv . ix itID . itAttachment ?~ ItFuse newTime - & creatures . ix 0 . crInv . ix itID . itZoom - .~ (defaultItZoom {_itAimZoomMax = zm, _itAimZoomMin = zm}) +decreaseFuse fuse itid w = w + & creatures . ix 0 . crInv . ix itid %~ + ( itScrollUp .~ decreaseFuse newTime ) + . ( itScrollDown .~ increaseFuse newTime ) + . ( itAttachment ?~ ItFuse newTime ) + . ( itZoom .~ defaultItZoom {_itAimZoomMax = zm, _itAimZoomMin = zm} ) where newTime = max (fuse - 5) 20 zm = 50 / fromIntegral newTime diff --git a/src/Dodge/Item/Equipment.hs b/src/Dodge/Item/Equipment.hs new file mode 100644 index 000000000..f0e9609dd --- /dev/null +++ b/src/Dodge/Item/Equipment.hs @@ -0,0 +1,60 @@ +module Dodge.Item.Equipment + where +import Dodge.Data +import Dodge.Default +import Dodge.Picture.Layer +import Picture +import Geometry + +magShield :: Item +magShield = defaultEquipment + { _itIdentity = MagShield + , _itName = "MAGSHIELD" + , _itMaxStack = 1 + , _itAmount = 1 + , _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)] + , _itEquipPict = \_ _ -> blank + , _itID = Nothing + } +flameShield, frontArmour :: Item +flameShield = defaultEquipment + { _itIdentity = FlameShield + , _itName = "FLAMESHIELD" + , _itMaxStack = 1 + , _itAmount = 1 + , _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)] + , _itEquipPict = \cr _ -> onLayer CrLayer $ pictures [color cyan $ circle (_crRad cr+2)] + , _itID = Nothing + } +{- | +Slows you down, blocks forward projectiles. -} +frontArmour = defaultEquipment + { _itIdentity = FrontArmour + , _itName = "FARMOUR" + , _itMaxStack = 1 + , _itAmount = 1 + , _itFloorPict = onLayer FlItLayer $ translate 0 (-5) $ pictures + [color (greyN 0.1) $ thickArc 0 (pi/2) 10 5 + ,color (greyN 0.1) $ thickArc (3*pi/2) (2*pi) 10 5 + ] + , _itEquipPict = \_ _ -> onLayer CrLayer $ pictures + [color (greyN 0.1) $ thickArc 0 (pi/2) 10 5 + ,color (greyN 0.1) $ thickArc (3*pi/2) (2*pi) 10 5 + ] + , _itEffect = NoItEffect + , _itID = Nothing + } +{- | +Increases speed, reduces friction, cannot only move forwards. -} +jetPack :: Item +jetPack = defaultEquipment + { _itIdentity = JetPack + , _itName = "JETPACK" + , _itMaxStack = 1 + , _itAmount = 1 + , _itFloorPict = onLayer FlItLayer $ color yellow $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)] + , _itEquipPict = \_ _ -> onLayer CrLayer + $ pictures [color yellow $ polygon $ rectNSEW 5 (-5) (-3) (-11) ] + , _itEffect = NoItEffect + , _itID = Nothing + } diff --git a/src/Dodge/Item/Weapon.hs b/src/Dodge/Item/Weapon.hs index 3428c3167..6a4bb929e 100644 --- a/src/Dodge/Item/Weapon.hs +++ b/src/Dodge/Item/Weapon.hs @@ -1,8 +1,6 @@ {- | Definitions of weapons. In progress: move out effects into other modules. -} module Dodge.Item.Weapon - ( module Dodge.Item.Weapon - ) where import Dodge.Data import Dodge.Base @@ -14,7 +12,7 @@ import Dodge.WorldEvent import Dodge.Default import Dodge.Item.Draw import Dodge.Item.Weapon.Bullet -import Dodge.Item.Weapon.Decoration +--import Dodge.Item.Weapon.Decoration import Dodge.Item.Weapon.InventoryDisplay import Dodge.Item.Weapon.TriggerType import Dodge.Item.Weapon.ExtraEffect @@ -26,27 +24,43 @@ import Dodge.Item.Attachment import Geometry import Picture -import Data.List -import Data.Char +--import Data.List +--import Data.Char import Data.Maybe import Data.Function -import qualified Data.ByteString as B +--import qualified Data.ByteString as B import qualified Data.Sequence as Seq import Control.Lens import Control.Applicative import Control.Monad.State -import Control.Monad +--import Control.Monad 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 -import Foreign.ForeignPtr +--import qualified Data.Map as M -pistol,lasGun,tractorGun,launcher,autoGun +pistol + ,lasGun + ,tractorGun + ,launcher + ,autoGun + ,ltAutoGun + ,hvAutoGun + ,miniGun ,teslaGun ,spreadGun ,multGun + ,defaultGun + ,defaultAutoGun + ,rezGun + ,flameLauncher + ,poisonLauncher + ,teslaLauncher + ,remoteLauncher + ,bezierGun + ,poisonSprayer + ,defaultThrowable -- ,shatterGun ,longGun,flamer,blinkGun,forceFieldGun :: Item pistol = Weapon @@ -130,6 +144,7 @@ autoGun = defaultGun , _itScrollDown = decCharMode , _itInvDisplay = basicWeaponDisplay } +autoFireMode, singleFireMode, autoGunNonTwistEff :: Int -> World -> World autoFireMode = shootWithSound (fromIntegral autoGunSound) . torqueBefore 0.05 $ autoGunNonTwistEff @@ -714,10 +729,7 @@ moveShell time i cid rot accel w smokeGen = makeSmokeCloudAt (oldPos +.+ r1 +.+ 30 *.* normalizeV (oldPos -.- newPos)) rot' = rot * 0.995 -normalizeAnglePi angle - | normalizeAngle angle > pi = normalizeAngle angle - 2*pi - | otherwise = normalizeAngle angle - +shellPic :: Picture shellPic = color black $ polygon [(-6,4),(-6,-4),(6,-4),(8,0),(6,4)] remoteShellPic :: Int -> Picture remoteShellPic i @@ -730,6 +742,7 @@ remoteShellPic i col | i > (-99) = green | otherwise = red +shellExplosionAt :: Point2 -> World -> World shellExplosionAt = makeExplosionAt aGasCloud :: Int -> World -> World @@ -739,8 +752,8 @@ aGasCloud cid w = insertCloud $ set randGen g w cr = _creatures w IM.! cid dir = _crDir cr + a pos = _crPos cr +.+ ((_crRad cr + 2.9) *.* unitVectorAtAngle (_crDir cr)) - pos2 = (0.5 *.* vel) +.+ - _crPos cr +.+ ((_crRad cr + 2.9) *.* unitVectorAtAngle (_crDir cr)) + --pos2 = (0.5 *.* vel) +.+ + -- _crPos cr +.+ ((_crRad cr + 2.9) *.* unitVectorAtAngle (_crDir cr)) vel = (_crPos cr -.- _crOldPos cr) +.+ 10 *.* unitVectorAtAngle dir insertCloud = makeGasCloud pos vel -- . makeFlame pos2 vel (Just cid) @@ -761,6 +774,8 @@ reflect :: Float -> Float -> Float reflect a b = a + 2*(a-b) +pointToItem :: Applicative f => + ItemPos -> (Item -> f Item) -> World -> f World pointToItem (InInv cid invid) = creatures . ix cid . crInv . ix invid pointToItem (OnFloor flid) = floorItems . ix flid . flIt @@ -880,8 +895,8 @@ flameGrenade = grenade { , _twFire = throwGrenade makeFlameExplosionAt } where - fuseTime = 50 - f x = 50 / fromIntegral x + fuseTime = 50 :: Int + --f x = 50 / fromIntegral x teslaGrenade :: Item teslaGrenade = grenade { @@ -889,8 +904,8 @@ teslaGrenade = grenade { , _twFire = throwGrenade makeTeslaExplosionAt } where - fuseTime = 50 - f x = 50 / fromIntegral x + fuseTime = 50 :: Int + --f x = 50 / fromIntegral x defaultThrowable = grenade remoteBomb = defaultThrowable @@ -941,7 +956,7 @@ fireRemoteLauncher cid w = setLocation itid = fromMaybe newitid maybeitid moveRemoteShell :: Int -> Int -> Int -> Int -> Float -> World -> World -moveRemoteShell time i cid itid dir w +moveRemoteShell time i cid itid _ w | time > 40 = if circOnSomeWall oldPos 4 w then doExplosion w else over (projectiles . ix i . pjPos) (+.+ vel) @@ -951,7 +966,7 @@ moveRemoteShell time i cid itid dir w $ setScope w | time >= 20 = case thingHit of - Just p -> doExplosion w + Just _ -> doExplosion w Nothing -> over (projectiles . ix i . pjPos) (+.+ vel) $ set (projectiles . ix i . pjPict) pic $ set (projectiles . ix i . pjUpdate) @@ -959,7 +974,7 @@ moveRemoteShell time i cid itid dir w $ setScope w | time > -99 = case thingHit of - Just p -> doExplosion + Just _ -> doExplosion $ stopSoundFrom (ShellSound i) w Nothing -> over (projectiles . ix i . pjPos) (+.+ vel) @@ -973,7 +988,7 @@ moveRemoteShell time i cid itid dir w $ setScope w | time > -200 = case thingHit of - Just p -> doExplosion + Just _ -> doExplosion $ stopSoundFrom (ShellSound i) w Nothing -> over (projectiles . ix i . pjPos) (+.+ vel) @@ -1011,18 +1026,18 @@ moveRemoteShell time i cid itid dir w smokeGen = makeSmokeCloudAt $ oldPos +.+ r1 +.+ 30 *.* normalizeV (oldPos -.- newPos) doExplosion = explodeRemoteRocket itid i cid setScope w' = case _itemPositions w' IM.! itid of - InInv cid invid - -> w' & creatures . ix cid . crInv . ix invid . itAttachment - . _Just . scopePos .~ (newPos -.- _crPos (_creatures w' IM.! cid)) - _ -> w' + InInv cid' invid + -> w' & creatures . ix cid' . crInv . ix invid . itAttachment + . _Just . scopePos .~ (newPos -.- _crPos (_creatures w' IM.! cid')) + _ -> w' explodeRemoteRocket :: Int -- ^ Item id -> Int -- ^ Projectile id - -> Int + -> Int -- ^ (Probably) firing creature id -> World -> World -explodeRemoteRocket itid pjid n w +explodeRemoteRocket itid pjid _ w = set (projectiles . ix pjid . pjUpdate) (retireRemoteRocket itid 30 pjid) $ set (projectiles . ix pjid . pjPict) blank $ set (itPoint . wpFire) (const id) @@ -1046,7 +1061,7 @@ throwRemoteBomb n w = setLocation $ removePict $ resetFire } i = newProjectileKey w -- fireDist = zoom *.* (rotateV (_cameraRot w) (_mousePos w) +.+ _cameraCenter w -.- yourPos) - d = argV $ _mousePos w + --d = argV $ _mousePos w --(l, _) = randomR (1 - grenadeAccL,1+grenadeAccL) (_randGen w) --(a, g) = randomR (-grenadeAccA,grenadeAccA) (_randGen w) v' = 0.02 / _cameraZoom w *.* rotateV (_cameraRot w) ( _mousePos w) @@ -1087,78 +1102,34 @@ explodeRemoteBomb itid pjid n w (drawWeapon remoteBombUnarmedPic) -- resetScope = creatures . ix n . crInv . ix j . itScope . _Just . scopePos .~ (0,0) j = _crInvSel $ _creatures w IM.! n -remoteBombPic :: Int -> Picture -remoteBombPic x = pictures +remoteBombPic + :: Int -- ^ time + -> Picture +remoteBombPic _ = pictures [ color (dark $ dark orange) $ circleSolid 5 ] + remoteBombUnarmedPic :: Picture remoteBombUnarmedPic = color (dark $ dark orange) $ circleSolid 5 spreadGunSpread,autogunSpread :: Float spreadGunSpread = 0.5 autogunSpread = 0.07 +pipe :: Item pipe = Craftable { _itIdentity = Generic , _itName = "PIPE" , _itMaxStack = 3 , _itAmount = 3 , _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)] - , _itEquipPict = \cr _ -> blank + , _itEquipPict = \_ _ -> blank , _itID = Nothing , _itInvDisplay = _itName , _itInvColor = green } -magShield = defaultEquipment - { _itIdentity = MagShield - , _itName = "MAGSHIELD" - , _itMaxStack = 1 - , _itAmount = 1 - , _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)] - , _itEquipPict = \cr _ -> blank - , _itID = Nothing - } -flameShield = defaultEquipment - { _itIdentity = FlameShield - , _itName = "FLAMESHIELD" - , _itMaxStack = 1 - , _itAmount = 1 - , _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)] - , _itEquipPict = \cr _ -> onLayer CrLayer $ pictures [color cyan $ circle (_crRad cr+2)] - , _itID = Nothing - } -{- | -Slows you down, blocks forward projectiles. -} -frontArmour = defaultEquipment - { _itIdentity = FrontArmour - , _itName = "FARMOUR" - , _itMaxStack = 1 - , _itAmount = 1 - , _itFloorPict = onLayer FlItLayer $ translate 0 (-5) $ pictures - [color (greyN 0.1) $ thickArc 0 (pi/2) 10 5 - ,color (greyN 0.1) $ thickArc (3*pi/2) (2*pi) 10 5 - ] - , _itEquipPict = \cr _ -> onLayer CrLayer $ pictures - [color (greyN 0.1) $ thickArc 0 (pi/2) 10 5 - ,color (greyN 0.1) $ thickArc (3*pi/2) (2*pi) 10 5 - ] - , _itEffect = NoItEffect - , _itID = Nothing - } -{- | -Increases speed, reduces friction, cannot only move forwards. -} -jetPack = defaultEquipment - { _itIdentity = JetPack - , _itName = "JETPACK" - , _itMaxStack = 1 - , _itAmount = 1 - , _itFloorPict = onLayer FlItLayer $ color yellow $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)] - , _itEquipPict = \_ _ -> onLayer CrLayer - $ pictures [color yellow $ polygon $ rectNSEW 5 (-5) (-3) (-11) ] - , _itEffect = NoItEffect - , _itID = Nothing - } {- | Sends out pulses that display walls. -} +radar :: Item radar = defaultGun { _itName = "RADAR" , _itIdentity = Generic @@ -1181,6 +1152,7 @@ radar = defaultGun } {- | Sends out pulses that display creatures. -} +sonar :: Item sonar = defaultGun { _itName = "SONAR" , _itIdentity = Generic @@ -1202,13 +1174,14 @@ sonar = defaultGun } {- | Automatically sends out pulses that display creatures. -} +autoSonar :: Item autoSonar = defaultEquipment { _itIdentity = Generic , _itName = "AUTOSONAR" , _itMaxStack = 1 , _itAmount = 1 , _itFloorPict = onLayer FlItLayer $ color yellow $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)] - , _itEquipPict = \cr _ -> blank + , _itEquipPict = \_ _ -> blank , _itEffect = autoSonarEffect , _itID = Nothing , _itAimingSpeed = 1 @@ -1217,13 +1190,14 @@ autoSonar = defaultEquipment } {- | Automatically sends out pulses that display walls. -} +autoRadar :: Item autoRadar = defaultEquipment { _itIdentity = Generic , _itName = "AUTORADAR" , _itMaxStack = 1 , _itAmount = 1 , _itFloorPict = onLayer FlItLayer $ color yellow $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)] - , _itEquipPict = \cr _ -> blank + , _itEquipPict = \_ _ -> blank , _itEffect = autoRadarEffect , _itID = Nothing , _itAimingSpeed = 1 diff --git a/src/Dodge/Item/Weapon/Bullet.hs b/src/Dodge/Item/Weapon/Bullet.hs index 06c5a6139..8d03856b8 100644 --- a/src/Dodge/Item/Weapon/Bullet.hs +++ b/src/Dodge/Item/Weapon/Bullet.hs @@ -4,8 +4,9 @@ Effects of bullets upon impact with walls or creatures, and possibly force field module Dodge.Item.Weapon.Bullet where import Dodge.Data -import Dodge.Base +--import Dodge.Base import Dodge.WorldEvent +import Dodge.WorldEvent.DamageBlock import Dodge.SoundLogic import Dodge.RandomHelp import Dodge.WorldEvent.Shockwave @@ -17,14 +18,14 @@ import Picture import System.Random import Control.Lens import Control.Monad.State -import qualified Data.IntMap.Strict as IM +--import Data.Maybe +--import qualified Data.IntMap.Strict as IM -- | Basic bullet hit creature effect. bulHitCr' :: Particle -> Point2 -> Creature -> World -> World bulHitCr' bt p cr w | crIsArmouredFrom p cr = createSpark 8 colID p1 (argV (p1 -.- p) + d1) Nothing . addDamageArmoured $ w - | otherwise - = addDamage . hitSound . flashEff $ w + | otherwise = addDamage . makeHitSound . flashEff $ w where sp = head $ _btTrail' bt bulVel = _btVel' bt @@ -32,19 +33,17 @@ bulHitCr' bt p cr w mvDams = [ PushDam 1 $ 2 *.* bulVel ] addDamage = creatures . ix cid . crState . crDamage %~ ((Piercing 100 sp p ep : mvDams) ++ ) addDamageArmoured = creatures . ix cid . crState . crDamage %~ (mvDams ++) - hitSound = soundMultiFrom [CrHitSound 0] 15 10 0 + makeHitSound = soundMultiFrom [CrHitSound 0] 15 10 0 flashEff = over worldEvents (bloodFlashAt p . ) cid = _crID cr - (d1,g) = randomR (-0.7,0.7) $ _randGen w + (d1,_) = randomR (-0.7,0.7) $ _randGen w (colID,_) = randomR (0,11) $ _randGen w p1 = p +.+ 2 *.* safeNormalizeV (p -.- _crPos cr) {- | Bounce off armoured creatures, otherwise do damage. -} bulBounceArmCr' :: Particle -> Point2 -> Creature -> World -> World bulBounceArmCr' bt p cr w - | crIsArmouredFrom p cr - = addBouncer . addDamageArmoured $ w - | otherwise - = addDamage . hitSound . flashEff $ w + | crIsArmouredFrom p cr = addBouncer . addDamageArmoured $ w + | otherwise = addDamage . makeHitSound . flashEff $ w where sp = head $ _btTrail' bt bulVel = _btVel' bt @@ -52,7 +51,7 @@ bulBounceArmCr' bt p cr w mvDams = [ PushDam 1 $ 2 *.* bulVel ] addDamage = creatures . ix cid . crState . crDamage %~ ((Piercing 100 sp p ep : mvDams) ++ ) addDamageArmoured = creatures . ix cid . crState . crDamage %~ (mvDams ++) - hitSound = soundMultiFrom [CrHitSound 0] 15 10 0 + makeHitSound = soundMultiFrom [CrHitSound 0] 15 10 0 flashEff = over worldEvents ((.) $ bloodFlashAt p) cid = _crID cr newDir = safeNormalizeV (p -.- _crPos cr) @@ -77,7 +76,7 @@ bulPenCr' bt p cr w $ over worldEvents (addPiercer . ) w where - (d1,g) = randomR (-0.7,0.7) $ _randGen w + (d1,_) = randomR (-0.7,0.7) $ _randGen w cid = _crID cr sp = head $ _btTrail' bt ep = sp +.+ _btVel' bt @@ -100,7 +99,7 @@ hvBulHitCr' bt p cr w $ soundMultiFrom [CrHitSound 0] 15 10 0 w where - (d1,g) = randomR (-0.7,0.7) $ _randGen w + (d1,_) = randomR (-0.7,0.7) $ _randGen w cid = _crID cr sp = head $ _btTrail' bt ep = sp +.+ _btVel' bt @@ -131,32 +130,24 @@ bulConCr' bt p cr w sp = head $ _btTrail' bt ep = sp +.+ _btVel' bt mkwave = over worldEvents $ (.) (makeShockwaveAt [] p 15 4 1 white) + {- | Hitting wall effects: create a spark, damage blocks. -} bulHitWall' :: Particle -> Point2 -> Wall -> World -> World -bulHitWall' bt p x w = damageBlocks x - $ createSpark 8 colID pOut (reflectDir x) Nothing +bulHitWall' bt p x w = damageBlocksBy 5 x + $ createSpark 8 12 pOut (reflectDir x) Nothing $ set randGen g w where sp = head $ _btTrail' bt pOut = p +.+ safeNormalizeV (sp -.- p) - (colID,g) = randomR (0,11) $ _randGen w - (a, _) = randomR (-0.1,0.1) $ _randGen w - spid = newKey $ _projectiles w + (a, g) = randomR (-0.2,0.2) $ _randGen w reflectDir wall = a + argV (reflectIn (uncurry (-.-) (_wlLine wall)) (p -.- sp) ) - damageBlocks wall w = case wall ^? blHP of - Just hp -> foldr (\j -> walls . ix j . blHP -~ 5) w (_blIDs wall) - _ -> w {- | Bounce off walls, do damage to blocks. -} bulBounceWall' :: Particle -> Point2 -> Wall -> World -> World -bulBounceWall' bt p wl w = damageBlocks wl $ over worldEvents addBouncer w +bulBounceWall' bt p wl w = damageBlocksBy 5 wl $ over worldEvents addBouncer w where sp = head $ _btTrail' bt pOut = p +.+ safeNormalizeV (sp -.- p) - damageBlocks wall w - = case wall ^? blHP of - Just hp -> foldr (\j -> walls . ix j . blHP -~ 5) w (_blIDs wall) - _ -> w bouncer = (aGenBulAt' Nothing (_btColor' bt) pOut reflectVel (_btHitEffect' bt) (_btWidth' bt) ) {_btTimer' = _btTimer' bt - 1} @@ -174,14 +165,10 @@ bulIncWall' -> Wall -> World -> World -bulIncWall' bt p wl w = damageBlocks wl $ incFlamelets w +bulIncWall' bt p wl w = damageBlocksBy 5 wl $ incFlamelets w where sp = head $ _btTrail' bt pOut = p +.+ safeNormalizeV (sp -.- p) - damageBlocks wall w - = case wall ^? blHP of - Just hp -> foldr (\j -> walls . ix j . blHP -~ 5) w (_blIDs wall) - _ -> w wallV = uncurry (-.-) (_wlLine wl) reflectVel = safeNormalizeV $ reflectIn wallV (_btVel' bt) incFlamelets = over worldEvents $ (.) (makeFlameletTimed pOut reflectVel Nothing 3 20) @@ -192,15 +179,8 @@ bulConWall' -> Wall -> World -> World -bulConWall' bt p wl w = damageBlocks wl $ mkwave w - where - sp = head $ _btTrail' bt - pOut = p +.+ safeNormalizeV (sp -.- p) - damageBlocks wall w - = case wall ^? blHP of - Just hp -> foldr (\j -> walls . ix j . blHP -~ 5) w (_blIDs wall) - _ -> w - mkwave = over worldEvents ( makeShockwaveAt [] p 15 4 1 white . ) +bulConWall' _ p wl = damageBlocksBy 1 wl . + over worldEvents ( makeShockwaveAt [] p 15 4 1 white . ) hvBulHitWall' :: Particle @@ -208,18 +188,14 @@ hvBulHitWall' -> Wall -> World -> World -hvBulHitWall' bt p x w = damageBlocks x $ set randGen g $ foldr ($) w (sparks pOut sv) +hvBulHitWall' bt p x w = damageBlocksBy 5 x $ set randGen g $ foldr ($) w (sparks pOut sv) where sp = head $ _btTrail' bt pOut = p +.+ safeNormalizeV (sp -.- p) - (a, g) = randomR (-0.1,0.1) $ _randGen w - spid = newKey $ _projectiles w + (a, g) = randomR (-0.2,0.2) $ _randGen w reflectDir wall = a + argV (reflectIn (uncurry (-.-) (_wlLine wall)) (p -.- sp) ) sv = unitVectorAtAngle $ reflectDir x - damageBlocks wall w = case wall ^? blHP of - Just hp -> foldr (\j -> walls . ix j . blHP -~ 20) w (_blIDs wall) - _ -> w cs = take 10 $ randomRs (0,11) $ _randGen w ds = randomRs (-0.7,0.7) $ _randGen w ts = randomRs (4,8) $ _randGen w diff --git a/src/Dodge/Item/Weapon/Decoration.hs b/src/Dodge/Item/Weapon/Decoration.hs index 3b638001c..7e1d170e2 100644 --- a/src/Dodge/Item/Weapon/Decoration.hs +++ b/src/Dodge/Item/Weapon/Decoration.hs @@ -6,7 +6,7 @@ module Dodge.Item.Weapon.Decoration import Dodge.Data import Dodge.Picture.Layer import Dodge.Picture -import Geometry.Data +--import Geometry.Data import Picture import Control.Lens diff --git a/src/Dodge/Item/Weapon/ExtraEffect.hs b/src/Dodge/Item/Weapon/ExtraEffect.hs index d04520661..e10a06185 100644 --- a/src/Dodge/Item/Weapon/ExtraEffect.hs +++ b/src/Dodge/Item/Weapon/ExtraEffect.hs @@ -28,6 +28,7 @@ wpRecock = ItInvEffect moveHammerUp HammerDown = HammerReleased moveHammerUp HammerReleased = HammerUp moveHammerUp HammerUp = HammerUp + moveHammerUp NoHammer = NoHammer fOnIt it = it & itHammer %~ moveHammerUp {- | Special recock for the bezier gun. @@ -64,10 +65,10 @@ itemLaserScopeEffect sp = p +.+ (r + 3) *.* unitVectorAtAngle d xp = sp +.+ 3000 *.* unitVectorAtAngle d ep = case listToMaybe $ thingsHitLongLine sp xp w of - Just (p,_) -> p + Just (pos,_) -> pos Nothing -> xp glowPoint = case listToMaybe $ thingsHitLongLine sp xp w of - Just (p,E3x2 wl) -> p +.+ 2 *.* wallNormal wl + Just (pos,E3x2 wl) -> pos +.+ 2 *.* wallNormal wl _ -> ep -.- 2 *.* unitVectorAtAngle d it = (cr ^. crInv) IM.! invid reloadFrac @@ -79,6 +80,7 @@ Automatically send out radar pulses that detect walls. -} autoRadarEffect :: ItEffect autoRadarEffect = ItInvEffect {_itInvEffect = f 50 ,_itEffectCounter = 0 } where + f :: Int -> Creature -> Int -> World -> World f 0 cr i w = aRadarPulse (_crID cr) w & creatures . ix (_crID cr) . crInv . ix i . itEffect . itInvEffect .~ f 100 @@ -89,8 +91,10 @@ autoRadarEffect = ItInvEffect {_itInvEffect = f 50 ,_itEffectCounter = 0 } Automatically send out sonar pulses that detect creatures. -} autoSonarEffect :: ItEffect autoSonarEffect = ItInvEffect {_itInvEffect = f 50 ,_itEffectCounter = 0 } - where f 0 cr i w = aSonarPulse (_crID cr) - w & creatures . ix (_crID cr) . crInv . ix i - . itEffect . itInvEffect .~ f 140 - f t cr i w = w & creatures . ix (_crID cr) . crInv . ix i - . itEffect . itInvEffect .~ f (t-1) + where + f :: Int -> Creature -> Int -> World -> World + f 0 cr i w = aSonarPulse (_crID cr) + w & creatures . ix (_crID cr) . crInv . ix i + . itEffect . itInvEffect .~ f 140 + f t cr i w = w & creatures . ix (_crID cr) . crInv . ix i + . itEffect . itInvEffect .~ f (t-1) diff --git a/src/Dodge/Item/Weapon/Grenade.hs b/src/Dodge/Item/Weapon/Grenade.hs index c3d78ad0b..e0efe9c13 100644 --- a/src/Dodge/Item/Weapon/Grenade.hs +++ b/src/Dodge/Item/Weapon/Grenade.hs @@ -6,14 +6,14 @@ import Dodge.Picture.Layer import Dodge.SoundLogic import Dodge.Item.Attachment.Data import Dodge.Item.Draw -import Dodge.Default +--import Dodge.Default import Picture import Geometry import Control.Lens import Data.Maybe (fromJust) import qualified Data.IntMap.Strict as IM -import System.Random +--import System.Random moveGrenade :: Int -- ^ Timer @@ -21,7 +21,7 @@ moveGrenade -> Int -- ^ Projectile id -> World -> World -moveGrenade 0 dir pID w = over projectiles (IM.delete pID) +moveGrenade 0 _ pID w = over projectiles (IM.delete pID) $ explosion (_pjPos (_projectiles w IM.! pID)) w where @@ -60,7 +60,7 @@ throwGrenade -> Int -- ^ Creature id -> World -> World -throwGrenade explosion n w = setWp $ removePict $ over projectiles addG $ set randGen g w +throwGrenade explosion n w = setWp $ removePict $ over projectiles addG $ w where addG = IM.insert i $ Shell { _pjPos = p @@ -75,8 +75,8 @@ throwGrenade explosion n w = setWp $ removePict $ over projectiles addG $ set ra j = _crInvSel cr removePict = set (creatures . ix n . crInv . ix j . itEquipPict) $ \ _ _ -> blank i = newProjectileKey w - (a, g) = randomR (-grenadeAccA,grenadeAccA::Float) (_randGen w) - (l, _) = randomR (1 - 2*grenadeAccL,1+grenadeAccL::Float) g + --(_, g) = randomR (-grenadeAccA,grenadeAccA::Float) (_randGen w) + --(_, _) = randomR (1 - 2*grenadeAccL,1+grenadeAccL::Float) g v' = 1 / (fromIntegral fuseTime * _cameraZoom w) *.* rotateV (_cameraRot w) ( _mousePos w) v | magV v' > 6 = 6 *.* normalizeV v' | otherwise = v' @@ -98,4 +98,4 @@ throwArmReset x = ItInvEffect {_itInvEffect = f ,_itEffectCounter = x } & itEquipPict .~ drawWeapon (grenadePic 50) | otherwise = it & itEffect . itEffectCounter -~ 1 -(grenadeAccL, grenadeAccA) = (0.1, 0.1) +--(grenadeAccL, grenadeAccA) = (0.1, 0.1) diff --git a/src/Dodge/Item/Weapon/InventoryDisplay.hs b/src/Dodge/Item/Weapon/InventoryDisplay.hs index 5ac93ca72..ca4141937 100644 --- a/src/Dodge/Item/Weapon/InventoryDisplay.hs +++ b/src/Dodge/Item/Weapon/InventoryDisplay.hs @@ -9,20 +9,15 @@ import Dodge.Item.Attachment.Data import Data.Sequence import Control.Lens -import Control.Monad - --- not sure if this is in the right place... - -{- | -Displays the item name, ammo if loaded, and any selected '_itCharMode'. - -} +--import Control.Monad +{- | Displays the item name, ammo if loaded, and any selected '_itCharMode'. -} basicWeaponDisplay :: Item -> String basicWeaponDisplay it = case it ^? itAttachment . _Just of Just ItCharMode {_itCharMode = (c :<| _)} -> midPadL 10 ' ' (_itName it) (' ' : aIfLoaded) ++ [' ',c] Just ItMode {_itMode = i} -> midPadL 10 ' ' (_itName it) (' ' : aIfLoaded) ++ show i _ -> midPadL 10 ' ' (_itName it) (' ' : aIfLoaded) where - availableAmmo = show $ _wpMaxAmmo it + --availableAmmo = show $ _wpMaxAmmo it aIfLoaded = case it ^? wpReloadState of Just 0 -> show $ _wpLoadedAmmo it Just x -> "R" ++ show x diff --git a/src/Dodge/Item/Weapon/Laser.hs b/src/Dodge/Item/Weapon/Laser.hs index 2af54a7fb..1369b9372 100644 --- a/src/Dodge/Item/Weapon/Laser.hs +++ b/src/Dodge/Item/Weapon/Laser.hs @@ -5,7 +5,7 @@ import Dodge.Data import Dodge.Picture import Dodge.Picture.Layer import Dodge.Item.Attachment.Data -import Dodge.Base +--import Dodge.Base import Dodge.SoundLogic import Dodge.WorldEvent.SpawnParticle import Dodge.WorldEvent.ThingsHit @@ -30,16 +30,17 @@ aLaser cid w = over particles (makeLaserAt phaseV pos dir (Just cid) : ) w where cr = _creatures w IM.! cid - i = newProjectileKey w pos = _crPos cr +.+ ((_crRad cr +3) *.* unitVectorAtAngle dir) dir = _crDir cr phaseV = charToPhaseV $ fromMaybe '/' $ Seq.lookup 0 =<< cr ^? crInv . ix j . itAttachment . _Just . itCharMode j = _crInvSel cr +charToPhaseV :: Fractional p => Char -> p charToPhaseV 'V' = 0.2 charToPhaseV '/' = 1 charToPhaseV 'Z' = 5 +charToPhaseV _ = error "Trying to set an undefined phaseV" makeLaserAt :: Float -> Point2 -> Float -> Maybe Int -> Particle makeLaserAt phaseV pos dir mcid = Particle @@ -55,7 +56,7 @@ moveLaser -> World -> Particle -> (World, Maybe Particle) -moveLaser phaseV pos dir mcid w pt +moveLaser phaseV pos dir _ w pt = ( set randGen g $ hitEffect w , Just pt {_ptDraw = const $ onLayer PtLayer pic ,_ptUpdate' = ptTimer' 0 } ) @@ -83,10 +84,10 @@ moveLaser phaseV pos dir mcid w pt angleRef | reflectExternal = angleInc | otherwise = asin $ sin angleInc / phaseV - piRange a - | a > pi = a - 2 * pi - | a > negate pi = a - | otherwise = a + 2 * pi + piRange a' + | a' > pi = a' - 2 * pi + | a' > negate pi = a' + | otherwise = a' + 2 * pi isEntering = not $ isLeftOf (x -.- y) (uncurry (-.-) (_wlLine wl)) wlNormal' = vNormal $ uncurry (-.-) (_wlLine wl) normalDist' = magV (p -.- y) *.* normalizeV wlNormal' @@ -97,7 +98,7 @@ moveLaser phaseV pos dir mcid w pt reflectInternal = 1 < abs (phaseV * sin angleInc') reflectExternal = 1 < abs (sin angleInc / phaseV) - h' ws (_,E3x2 wl) = not $ any (\w -> _wlID w == _wlID wl) ws + h' ws (_,E3x2 wl) = not $ any (\w' -> _wlID w' == _wlID wl) ws h' _ _ = True (thHit, ps) = f [] pos xp hitEffect diff --git a/src/Dodge/Item/Weapon/TriggerType.hs b/src/Dodge/Item/Weapon/TriggerType.hs index b5909e678..a64e6c86f 100644 --- a/src/Dodge/Item/Weapon/TriggerType.hs +++ b/src/Dodge/Item/Weapon/TriggerType.hs @@ -114,7 +114,6 @@ withWarmUp t f cid w item = _crInv cr IM.! itRef pointerToItem = creatures . ix cid . crInv . ix itRef fState = _itUseTime item - fRate = _itUseRate item reloadCondition = _wpLoadedAmmo item == 0 {- | Adds a sound to a creature based world effect. @@ -247,7 +246,6 @@ withMuzFlare withMuzFlare f cid w = tempLightForAt 3 pos . muzzleFlashAt pos2 $ f cid w where cr = _creatures w IM.! cid - dir = _crDir cr pos = _crPos cr +.+ _crRad cr *.* unitVectorAtAngle (_crDir cr) pos2 = _crPos cr +.+ (2 * _crRad cr) *.* unitVectorAtAngle (_crDir cr) {- | @@ -282,7 +280,6 @@ withVelWthHiteff vel width hiteff cid w (colid, g) = randomR (0,11) $ _randGen w dir = _crDir cr pos = _crPos cr +.+ _crRad cr *.* unitVectorAtAngle (_crDir cr) - pos2 = _crPos cr +.+ (2 * _crRad cr) *.* unitVectorAtAngle (_crDir cr) {- | Translate the creature sideways a random amount, apply the effect, translate back. -} withRandomOffset @@ -349,7 +346,7 @@ torqueAfter torque feff cid w | otherwise = set randGen g $ over (creatures . ix cid . crDir) (+rot) $ feff cid w where (rot, g) = randomR (-torque,torque) $ _randGen w - rotateScope w = w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) + rotateScope = creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) . itAttachment . _Just . scopePos %~ rotateV rot {- | Create multiple bullets with a given spread, a given amount, given velocity, given width and given 'HitEffect'. -} @@ -384,11 +381,11 @@ numVelWthHitEff -> Int -- ^ Creature id -> World -> World -numVelWthHitEff num vel wth eff cid w = over particles (newbuls ++) w +numVelWthHitEff num vel wth eff cid w = over particles (newbuls ++) w where cr = _creatures w IM.! cid newbuls = zipWith - (\pos colid -> aGenBulAt' (Just cid) (numColor colid) pos (rotateV d vel) eff wth) + (\p colid -> aGenBulAt' (Just cid) (numColor colid) p (rotateV d vel) eff wth) poss colids d = _crDir cr @@ -414,6 +411,6 @@ randWalkAngle ma aspeed f cid w = w & creatures . ix cid . crInv . ix i . wpSpread .~ newa where a = _wpSpread $ _crInv (_creatures w IM.! cid) IM.! i - (walka, g) = randomR (-aspeed,aspeed) (_randGen w) + (walka, _) = randomR (-aspeed,aspeed) (_randGen w) newa = min ma $ max (negate ma) (a + walka) i = _crInvSel $ _creatures w IM.! cid diff --git a/src/Dodge/Item/Weapon/UseEffect.hs b/src/Dodge/Item/Weapon/UseEffect.hs index 094a29d11..46eb892cd 100644 --- a/src/Dodge/Item/Weapon/UseEffect.hs +++ b/src/Dodge/Item/Weapon/UseEffect.hs @@ -6,10 +6,10 @@ module Dodge.Item.Weapon.UseEffect import Dodge.Data import Dodge.Base import Dodge.Picture.Layer -import Dodge.Item.Weapon.Decoration +--import Dodge.Item.Weapon.Decoration import Dodge.Item.Weapon.TriggerType -import Dodge.WorldEvent.Flash -import Dodge.WorldEvent.ThingsHit +--import Dodge.WorldEvent.Flash +--import Dodge.WorldEvent.ThingsHit import Picture import Geometry @@ -39,7 +39,7 @@ mvBlip :: Point2 -> Color -> Int -- ^ Max possible timer value -> Int -- ^ Current timer value -> World -> Particle -> (World, Maybe Particle) -mvBlip p col maxt 0 w pt = (w, Nothing) +mvBlip _ _ _ 0 w _ = (w, Nothing) mvBlip p col maxt t w pt = (w, Just $ pt & ptUpdate' .~ mvBlip p col maxt (t-1) & ptDraw .~ (const . setDepth (-0.5) @@ -73,7 +73,7 @@ mvSonar x p w pt = (w, Just $ pt {_ptDraw = const pic where crad = _crRad cr cpos = _crPos cr r = fromIntegral (500 - x*5) - sweepPics = [colHelper 0.05 $ uncurry translate p $ thickCircle r 5 ] + --sweepPics = [colHelper 0.05 $ uncurry translate p $ thickCircle r 5 ] globalAlpha | x > 10 = 1 | otherwise = fromIntegral x / 10 colHelper y = color (withAlpha (y * globalAlpha) green) @@ -97,7 +97,7 @@ mvRadar x p w pt = where pic = onLayerL [levLayer ShadowLayer, 1] $ pictures sweepPics putBlips = over worldEvents ( over particles (blips ++) . ) - blips = map (\p -> blipAt p (withAlpha (0.5*globalAlpha) red) 50) circPoints + blips = map (\bp -> blipAt bp (withAlpha (0.5*globalAlpha) red) 50) circPoints circPoints = mapMaybe (\wl -> uncurry collidePointCircCorrect (_wlLine wl) r p) $ map (over wlLine swp) (IM.elems $ wallsAlongCirc p r w) ++ IM.elems (wallsAlongCirc p r w) @@ -109,7 +109,7 @@ mvRadar x p w pt = ] globalAlpha | x > 10 = 1 | otherwise = fromIntegral x / 10 - colHelper y = color (withAlpha (y * globalAlpha) red) + --colHelper y = color (withAlpha (y * globalAlpha) red) aTractorBeam :: Int -- ^ Color id @@ -186,9 +186,7 @@ updateTractor colID time i w | x > -1 = x | x > -5 = -1 | otherwise = (x - 10) / 5 - d = errorNormalizeV 13 $ p' -.- p1 f x = g x / 50 - cID = fromIntegral colID / 10 col = mixColors 0.5 0.5 white blue px z = (fromIntegral time + 5) *.* z pz z = fromIntegral time * 10 *.* z diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index f3c8b727e..783c44cc6 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -1,16 +1,12 @@ module Dodge.Layout - ( module Dodge.Layout - , module Dodge.Layout.Tree - ) where import Dodge.Data import Dodge.LevelGen import Dodge.LevelGen.StaticWalls -import Dodge.LevelGen.Data +--import Dodge.LevelGen.Data import Dodge.Base -import Dodge.RandomHelp +--import Dodge.RandomHelp import Dodge.Graph -import Dodge.Layout.Tree import Dodge.Layout.Tree.Polymorphic (applyToRoot) import Dodge.Room.Data import Dodge.Default @@ -20,15 +16,10 @@ import Dodge.Room.Link import Control.Monad.State import Control.Lens import System.Random -import Data.List -import Data.Maybe +--import Data.List +--import Data.Maybe import Data.Tree -import Data.Either -import Data.Function -import Data.Graph.Inductive.Graph hiding ((&)) -import Data.Graph.Inductive.Basic -import Data.Graph.Inductive.PatriciaTree -import Data.Graph.Inductive.NodeMap +import Data.Graph.Inductive.Graph (labNodes) import qualified Data.Map as M import qualified Data.IntMap.Strict as IM @@ -86,7 +77,6 @@ wallsFromTree t = where assignKeys = IM.fromList . zip [0..] . zipWith f [0..] f i (x,y) = defaultWall {_wlLine = (x,y) , _wlID = i} - g (x,y) = (x-3855,y - 2613) wallsFromRooms :: [Room] -> IM.IntMap Wall wallsFromRooms = diff --git a/src/Dodge/Layout/Generate.hs b/src/Dodge/Layout/Generate.hs index f8937ec57..cfc65f96a 100644 --- a/src/Dodge/Layout/Generate.hs +++ b/src/Dodge/Layout/Generate.hs @@ -5,7 +5,7 @@ module Dodge.Layout.Generate where import Data.Tree import Control.Monad.State -import System.Random +--import System.Random generateLayout :: State g (Tree RoomProperties) generateLayout = undefined @@ -16,10 +16,10 @@ data RoomProperties = RProps } randomTreeStructure :: Int -> State g (Tree ()) -randomTreeStructure i = undefined +randomTreeStructure = undefined treeMaxDepthFromTrunk :: Int -> Int -> State g (Tree ()) -treeMaxDepthFromTrunk nNodes maxDepth = do +treeMaxDepthFromTrunk = do undefined diff --git a/src/Dodge/Layout/Tree.hs b/src/Dodge/Layout/Tree.hs index 7bb32cee5..8e38939b4 100644 --- a/src/Dodge/Layout/Tree.hs +++ b/src/Dodge/Layout/Tree.hs @@ -3,7 +3,7 @@ Combining and composing trees. -} module Dodge.Layout.Tree where -import Data.Tree -import Control.Monad.State -import System.Random +--import Data.Tree +--import Control.Monad.State +--import System.Random diff --git a/src/Dodge/Layout/Tree/Either.hs b/src/Dodge/Layout/Tree/Either.hs index 05bd73ebf..0611c0e91 100644 --- a/src/Dodge/Layout/Tree/Either.hs +++ b/src/Dodge/Layout/Tree/Either.hs @@ -30,8 +30,9 @@ appendEitherTree -> [Tree (Either a a)] -- ^ The forest to append -> Tree (Either a a) appendEitherTree (Node (Left x) ts) ts' = Node (Left x) $ map (`appendEitherTree` ts') ts -appendEitherTree (Node (Right x) ts) ts' = Node (Left x) ts' +appendEitherTree (Node (Right x) _) ts' = Node (Left x) ts' +removeEither :: Either p p -> p removeEither (Left y) = y removeEither (Right y) = y diff --git a/src/Dodge/Layout/Tree/Shift.hs b/src/Dodge/Layout/Tree/Shift.hs index 5cfbc89a6..e98d51dc5 100644 --- a/src/Dodge/Layout/Tree/Shift.hs +++ b/src/Dodge/Layout/Tree/Shift.hs @@ -26,11 +26,11 @@ shiftRoomTreeSearch shiftRoomTreeSearch _ Empty = Just [] shiftRoomTreeSearch bs (Node r ts :<| ts') | roomIsClipping = Nothing - | otherwise = fmap (r :) . shiftRoomTreeSearch newBounds $ ts' >< children + | otherwise = fmap (r :) . shiftRoomTreeSearch newBounds $ ts' >< chldren where roomIsClipping = or (polysIntersect <$> _rmBound r <*> bs) newBounds = _rmBound r ++ bs - children = fromList $ zipWith (applyToRoot . shiftRoomToLink) (_rmLinks r) ts + chldren = fromList $ zipWith (applyToRoot . shiftRoomToLink) (_rmLinks r) ts {- | All: Depth first search of trees of rooms, produces a list of lists of rooms that are not clipping. -} diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 4014eb6fe..e33583493 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -10,7 +10,7 @@ module Dodge.LevelGen ) where import Dodge.Data import Dodge.Base -import Dodge.Room.Data +--import Dodge.Room.Data import Dodge.LevelGen.Block import Dodge.LevelGen.LineBlock import Dodge.LevelGen.Pathing @@ -22,16 +22,16 @@ import Dodge.LevelGen.Data import Geometry import Picture -import System.Random +--import System.Random import Control.Monad.State -import Control.Applicative +--import Control.Applicative import Control.Lens import Data.List.Extra -import Data.Function -import Data.Maybe +--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 +--import qualified Data.Set as S +--import qualified Data.Map as M placeSpots :: [Placement] -> World -> World placeSpots pss w = foldr (placeSpot . _placementSpot) w' singlePlacements @@ -43,7 +43,7 @@ placeSpots pss w = foldr (placeSpot . _placementSpot) w' singlePlacements gplmnts = groupOn _groupPlacementID $ sortOn _groupPlacementID groupedPlacements w' = foldr putGroup w gplmnts putGroup :: [Placement] -> World -> World - putGroup gps w = (_groupUpdate $ head gps) w gps + putGroup gps w'' = (_groupUpdate $ head gps) w'' gps {- | OK, this is perhaps slightly impenetrable. - The idea is that for a list of collected group placements, we first update @@ -81,17 +81,17 @@ placeSpot ps w = case _psType ps of mapBoth fn (x,y) = (fn x, fn y) PutDoubleDoor col f a b -> putDoubleDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w PutAutoDoor a b -> addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w - PutBlock (hp:hps) col ps -> putBlock (map (shiftPointBy (p,rot)) ps) hp col False hps w + PutBlock (hp:hps) col ps' -> putBlock (map (shiftPointBy (p,rot)) ps') hp col False hps w PutBtDoor c bp f a b -> addButtonDoor c (shiftPointBy (p,rot) bp) (f + rot) (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w PutSwitchDoor c bp f a b -> addSwitchDoor c (shiftPointBy (p,rot) bp) (f + rot) (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w PutLineBlock wl width depth a b -> putLineBlock wl width depth (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w - PutWall { _pwPoly = ps, _pwWall = wl } -> rmCrossPaths $ over walls (addWalls (q:qs) wl) w + PutWall { _pwPoly = ps', _pwWall = wl } -> rmCrossPaths $ over walls (addWalls (q:qs) wl) w where - (q:qs) = map (shiftPointBy (p,rot)) ps - rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ zip (q:qs) (qs++[q]) + (q:qs) = map (shiftPointBy (p,rot)) ps' + rmCrossPaths w' = foldr (uncurry removePathsCrossing) w' $ zip (q:qs) (qs++[q]) _ -> w where p = _psPos ps @@ -118,6 +118,7 @@ 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 +shiftPointBy :: (Point2,Float) -> Point2 -> Point2 shiftPointBy (pos,rot) p = pos +.+ rotateV rot p addWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall @@ -133,6 +134,12 @@ addPane wl (p0,p1) wls = IM.insert (newKey wls) (wl }) wls +placeBt + :: Button + -> Point2 + -> Float -- ^ Rotation + -> World + -> World placeBt bt p rot = over buttons addBT where addBT bts = IM.insert (newKey bts) (bt {_btPos = p, _btRot = rot, _btID = newKey bts}) bts @@ -154,6 +161,12 @@ placeFlIt itm p rot = floorItems %~ } ) fis +placePressPlate + :: PressPlate + -> Point2 + -> Float -- ^ Rotation + -> World + -> World placePressPlate pp p rot = over pressPlates addPP where addPP pps = IM.insert (newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps diff --git a/src/Dodge/LevelGen/AutoDoor.hs b/src/Dodge/LevelGen/AutoDoor.hs index 1361416c8..76d904159 100644 --- a/src/Dodge/LevelGen/AutoDoor.hs +++ b/src/Dodge/LevelGen/AutoDoor.hs @@ -5,7 +5,7 @@ Creation of doors that open when creatures approach them. module Dodge.LevelGen.AutoDoor where import Dodge.Data -import Dodge.Creature.State.Data +--import Dodge.Creature.State.Data import Dodge.Base import Dodge.SoundLogic import Dodge.Creature.Property @@ -13,11 +13,11 @@ import Geometry import Picture import qualified DoubleStack as DS -import Data.List -import Data.Maybe +--import Data.List +--import Data.Maybe import qualified Data.IntMap.Strict as IM import Control.Lens -import Control.DeepSeq (deepseq) +--import Control.DeepSeq (deepseq) addAutoDoor :: Point2 -- ^ Left point @@ -41,10 +41,11 @@ mkAutoDoor -> Point2 -- ^ Right point (though the two points should be symmetric) -> [Int] -- ^ Wall ids -> [Wall] -mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane (pl,pr)) - xs - (lDoorClosed ++ rDoorClosed) - (map shiftL lDoorClosed ++ map shiftR rDoorClosed) +mkAutoDoor pl pr xs = addSound + $ zipWith3 (autoDoorPane (pl,pr)) + xs + (lDoorClosed ++ rDoorClosed) + (map shiftL lDoorClosed ++ map shiftR rDoorClosed) where lDoorClosed = [ (pld,hwd) , (hwd,hwu) @@ -67,7 +68,8 @@ mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane (pl,pr)) shiftR = h $ (-.- parallel) . (+.+ normalizeV parallel) h func (x,y) = (func x,func y) - addSound (x:xs) = f x : xs + addSound (x:ys) = f x : ys + addSound _ = error "Trying to add a sound to malformed auto door" f wl = over doorMech g wl g dm w | dist wp pld > 2 && dist wp hwd > 2 diff --git a/src/Dodge/LevelGen/Block.hs b/src/Dodge/LevelGen/Block.hs index 7969c22ce..36d09cf4d 100644 --- a/src/Dodge/LevelGen/Block.hs +++ b/src/Dodge/LevelGen/Block.hs @@ -1,6 +1,4 @@ -{- | -Creation, update and destruction of destructible walls. - -} +{- | Creation, update and destruction of destructible walls. -} module Dodge.LevelGen.Block where import Dodge.Data import Dodge.Base @@ -13,6 +11,7 @@ import Picture.Data 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 @@ -37,19 +36,21 @@ Plays destruction sound and sets to be displayed other walls that were shadowed killBlock :: Wall -> World -> World killBlock bl w = f bl . flip (foldr unshadow) (_blShadows bl) $ w where - f bl@Block{_blDegrades = (x:xs)} = degradeBlock bl . hitSound bl - f bl = hitSound' bl + f :: Wall -> World -> World + f bl' + | isJust (bl ^? blDegrades . ix 0) = degradeBlock bl' . breakHitSound bl + | otherwise = hitSound' bl' pos = fst $ _wlLine bl - hitSound bl - | _wlIsSeeThrough bl = mkSoundBreakGlass pos + breakHitSound bl' + | _wlIsSeeThrough bl' = mkSoundBreakGlass pos | otherwise = soundMultiFrom sos soundid 25 0 - hitSound' bl - | _wlIsSeeThrough bl = mkSoundSplinterGlass pos + hitSound' bl' + | _wlIsSeeThrough bl' = mkSoundSplinterGlass pos | otherwise = soundMultiFrom sos soundid 25 0 sos = [BlockDegradeSound 0,BlockDegradeSound 1] (soundid,_) = randomR (29,32) $ _randGen w unshadow :: Int -> World -> World - unshadow bid w = case w ^? walls . ix bid of + unshadow bid w' = case w' ^? walls . ix bid of Just b -> let (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine b) in w & wallsZone . ix x . ix y . ix bid . blVisible %~ const True @@ -101,9 +102,9 @@ addBlock (p:ps) hp col isSeeThrough degradability w & wallsZone %~ flip (IM.foldr wallInZone) panes & walls %~ IM.union panes where - lines = zip (p:ps) (ps ++ [p]) + lns = zip (p:ps) (ps ++ [p]) i = newKey $ _walls w - is = [i.. i + length lines-1] + is = [i.. i + length lns-1] panes = IM.fromList $ zip is $ zipWith (\j (a,b) -> Block { _wlLine = (a,b) @@ -117,7 +118,7 @@ addBlock (p:ps) hp col isSeeThrough degradability w , _blShadows = [] , _blDegrades = degradability } - ) is lines + ) is lns wallInZone wl | uncurry dist (_wlLine wl) <= 2*zoneSize = insertIMInZone x y wlid wl @@ -126,9 +127,12 @@ addBlock (p:ps) hp col isSeeThrough degradability w (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl) wlid = _wlID wl ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl) +addBlock _ _ _ _ _ _ = error "Trying to add a block with incomplete polygon" putBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World putBlock (p:ps) i c b is w = foldr (uncurry removePathsCrossing) wWithBlock pairs - where pairs = zip (p:ps) (ps ++ [p]) - wWithBlock = addBlock (p:ps) i c b is w + where + pairs = zip (p:ps) (ps ++ [p]) + wWithBlock = addBlock (p:ps) i c b is w +putBlock _ _ _ _ _ _ = error "Trying to put a block with incomplete polygon" diff --git a/src/Dodge/LevelGen/InnerWalls.hs b/src/Dodge/LevelGen/InnerWalls.hs index bcfce3f19..1b5ab1ee6 100644 --- a/src/Dodge/LevelGen/InnerWalls.hs +++ b/src/Dodge/LevelGen/InnerWalls.hs @@ -1,13 +1,11 @@ module Dodge.LevelGen.InnerWalls where -import Dodge.Data -import Dodge.Base - -import Geometry - -import Control.Lens -import qualified Data.IntMap as IM +--import Dodge.Data +--import Dodge.Base +--import Geometry +--import Control.Lens +--import qualified Data.IntMap as IM ------------------------------------------------------------------------------------ -- idea: create inner walls to draw and to cast shadows --createInnerWalls :: IM.IntMap Wall -> IM.IntMap Wall diff --git a/src/Dodge/LevelGen/LineBlock.hs b/src/Dodge/LevelGen/LineBlock.hs index d3fafa1b5..f8fba094e 100644 --- a/src/Dodge/LevelGen/LineBlock.hs +++ b/src/Dodge/LevelGen/LineBlock.hs @@ -6,14 +6,11 @@ module Dodge.LevelGen.LineBlock import Dodge.Data import Dodge.Base import Dodge.LevelGen.Pathing -import Picture +--import Picture import Geometry import Control.Lens import qualified Data.IntMap as IM --- | Taken from online, splits a list into its even and odd elements -evenOddSplit = foldr f ([],[]) - where f a (ls,rs) = (rs, a : ls) putLineBlock :: Wall -- ^ Base pane @@ -39,7 +36,7 @@ putLineBlock basePane blockWidth depth a b w = removePathsCrossing a b $ foldr i ,( halfBlockWidth,-depth) ] cornersAt p = fmap ( (p +.+) . rotateV rot) cornerPoints - linesAt p = map (\(a,b) -> (a,b)) $ makeLoopPairs $ cornersAt p + linesAt p = makeLoopPairs $ cornersAt p k = newKey $ _walls w ksAtI i = map ( + (k + i*4) ) [0,1,2,3] visibilityAt i @@ -52,13 +49,13 @@ putLineBlock basePane blockWidth depth a b w = removePathsCrossing a b $ foldr i | otherwise = ksAtI (i-1) ++ ksAtI (i+1) makeBlockAt :: Point2 -> Int -> [Wall] makeBlockAt p i = zipWith3 (makePane i) (visibilityAt i) (ksAtI i) (linesAt p) - makePane i visStatus k' ps - = basePane {_wlID = k' - ,_wlLine = ps - ,_blIDs = ksAtI i - ,_blShadows = shadowsAt i - ,_blVisible = visStatus - } + makePane i visStatus k' ps = basePane + {_wlID = k' + ,_wlLine = ps + ,_blIDs = ksAtI i + ,_blShadows = shadowsAt i + ,_blVisible = visStatus + } listBlocks = concat $ zipWith makeBlockAt blockCenPs is insertBlock :: Wall -> World -> World insertBlock wl = over walls $ IM.insert (_wlID wl) wl diff --git a/src/Dodge/LevelGen/Pathing.hs b/src/Dodge/LevelGen/Pathing.hs index d38fbe9c5..581b90852 100644 --- a/src/Dodge/LevelGen/Pathing.hs +++ b/src/Dodge/LevelGen/Pathing.hs @@ -1,28 +1,26 @@ module Dodge.LevelGen.Pathing where +import Dodge.Data +import Dodge.Base import Geometry import Control.Lens - -import Dodge.Data -import Dodge.Base - import Data.Maybe import Data.List - import qualified Data.IntMap as IM import Data.Graph.Inductive hiding ((&)) -import Data.Graph.Inductive.NodeMap +--import Data.Graph.Inductive.NodeMap pairsToGraph :: (Ord a, Eq a, Eq b) => (a -> a -> b) -> [(a,a)] -> Gr a b -pairsToGraph f pairs = let nodes = nub (map fst pairs ++ map snd pairs) - pairs' = map (\(x,y)->(x,y,f x y)) pairs - in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM nodes >> insMapEdgesM pairs' +pairsToGraph f pairs = + let nodes' = nub (map fst pairs ++ map snd pairs) + pairs' = map (\(x,y)->(x,y,f x y)) pairs + in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM nodes' >> insMapEdgesM pairs' removePathsCrossing :: Point2 -> Point2 -> World -> World removePathsCrossing a b w = set pathGraph newGraph $ set pathGraph' pg' - $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph)) - w + $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph)) + w where pg' = filter (isNothing . uncurry (intersectSegSeg' a b)) $ _pathGraph' w insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp] diff --git a/src/Dodge/LevelGen/StaticWalls.hs b/src/Dodge/LevelGen/StaticWalls.hs index 6abd72604..f13f8974c 100644 --- a/src/Dodge/LevelGen/StaticWalls.hs +++ b/src/Dodge/LevelGen/StaticWalls.hs @@ -5,17 +5,16 @@ Description : Concerns carving out of static walls to create the general room pl module Dodge.LevelGen.StaticWalls where import Dodge.Data -import Dodge.Base -import Dodge.Default +--import Dodge.Base +--import Dodge.Default import Geometry -import Control.Lens +--import Control.Lens import Data.Function (on) -import Data.Graph import Data.List import Data.Maybe -import qualified Data.IntMap as IM -import qualified Data.Set as S +--import qualified Data.IntMap as IM +--import qualified Data.Set as S -- | Describe a wall as two points. -- Order is important: the wall face is to the left as you move from 'fst' -- to 'snd'. @@ -48,7 +47,6 @@ cutWalls ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of _ -> cutWalls (map (rotateV 0.001) $ expandPolyBy 0.01 ps) wls where newWalls = cutWalls' ps wls - errsL = mapMaybe (`checkWallLeft` newWalls) newWalls -- | As 'cutWalls', but rotate in the other direction. cutWallsL :: [Point2] -> [WallP] -> [WallP] cutWallsL ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of @@ -58,7 +56,6 @@ cutWallsL ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of _ -> cutWalls (map (rotateV (-0.001)) $ expandPolyBy 0.01 ps) wls where newWalls = cutWalls' ps wls - errsL = mapMaybe (`checkWallLeft` newWalls) newWalls -- | 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. @@ -87,8 +84,8 @@ checkWallRight (x,y) wls | length ins == length outs = Nothing | otherwise = Just ((x,y), outs) where - ins = filter (\(a,b) -> b == y) wls - outs = filter (\(a,b) -> a == y) wls + ins = filter (\(_,b) -> b == y) wls + outs = filter (\(a,_) -> a == y) wls -- | Given a specific wall and list of walls, checks that the number of walls leaving the -- first point is the same as the number of walls entering the first point of -- the specific wall. @@ -99,8 +96,8 @@ checkWallLeft (x,y) wls | length ins == length outs = Nothing | otherwise = Just ((x,y), outs) where - ins = filter (\(a,b) -> a == x) wls - outs = filter (\(a,b) -> b == x) wls + ins = filter (\(a,_) -> a == x) wls + outs = filter (\(_,b) -> b == x) wls -- | Given a polygon of points and collection of walls, cuts out the polygon. -- Ie returns a new set of walls with a hole determined by anticlockwise ordering of the points. -- The overall procedure is: @@ -113,7 +110,7 @@ checkWallLeft (x,y) wls -- 6. remove any duplicate walls -- Unclear behaviour if a line in the polygon is colinear with a wall. cutWalls' :: [Point2] -> [WallP] -> [WallP] -cutWalls' qs walls = +cutWalls' qs wls = nub . filter (not.wallIsZeroLength) . fuseWallsWith zs @@ -124,7 +121,7 @@ cutWalls' qs walls = $ removeWallsInPolygon ps cwals where - (zs,cwals) = cutWallsWithPoints ps walls + (zs,cwals) = cutWallsWithPoints ps wls ps = orderPolygon qs rs = orderPolygon $ nub $ zs ++ qs -- | Given a value and a poly, pushes the poly points out from the center by the @@ -145,6 +142,7 @@ cutWallsWithPoints (p:ps) ws = foldr f ([],ws) (zip (p:ps) (ps++[p])) ( nub $ as ++ cutWallsPoints p1 p2 ws' , concatMap (cutWall p1 p2) ws' ) +cutWallsWithPoints _ _ = error "Trying to cut empty polygon" -- | List the points of intersection between a segment and collection of walls. cutWallsPoints :: Point2 -> Point2 -> [WallP] -> [Point2] --cutWallsPoints p1 p2 ws = mapMaybe (\(x:y:_) -> intersectExtendedSegSeg p1 p2 x y) @@ -154,11 +152,13 @@ cutWall :: Point2 -> Point2 -> WallP -> [WallP] cutWall p1 p2 (x,y) = case myIntersectSegSeg p1 p2 x y of Nothing -> [(x,y)] Just cp -> [(x,cp),(cp,y)] +-- | Add poly walls? addPolyWalls :: [Point2] -- ^ Multiple walls described as a polygon. -> [WallP] -> [WallP] -addPolyWalls (q:qs) walls = foldr addPolyWall walls (zip (q:qs) (qs++[q])) +addPolyWalls (q:qs) wls = foldr addPolyWall wls (zip (q:qs) (qs++[q])) +addPolyWalls _ _ = error "Trying to add empty poly walls" -- | Add a new wall to a list of walls only if either -- 1. no wall already exists on the normal line from the new wall -- 2. any of the first existing walls hit on the normal line from the new wall @@ -166,12 +166,12 @@ addPolyWalls (q:qs) walls = foldr addPolyWall walls (zip (q:qs) (qs++[q])) -- The normal line is the line from the center point of the new wall outwards -- along the clockwise normal of the new wall (currently 10000 units along) addPolyWall :: WallP -> [WallP] -> [WallP] -addPolyWall (p1,p2) walls = +addPolyWall (p1,p2) wls = case maybeWs of Just ws -> if all (\(x,y) -> isLHS x y p3) ws - then walls - else (p1,p2) : walls - Nothing -> (p1,p2) : walls + then wls + else (p1,p2) : wls + Nothing -> (p1,p2) : wls where p3 = 0.5 *.* (p1 +.+ p2) p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1) @@ -182,10 +182,10 @@ addPolyWall (p1,p2) walls = wlsP :: [(WallP, Point2)] wlsP = sortBy (compare `on` (dist p3 . snd)) . catMaybes - $ zipWith f walls maybes + $ zipWith f wls maybes f a (Just b) = Just (a,b) f _ Nothing = Nothing - maybes = map (uncurry $ myIntersectSegSeg p3 p4) walls + maybes = map (uncurry $ myIntersectSegSeg p3 p4) wls -- | Given a list of points and a point, returns a point in the list if any is close -- to the point. findClosePoint :: [Point2] -> Point2 -> Maybe Point2 @@ -212,10 +212,11 @@ fuseWall (ps, (x,y)) = ( nub (x':y':ps) , (x',y') ) fuseWallsWith :: [Point2] -> [WallP] -> [WallP] fuseWallsWith zs ws = snd $ foldr fuseWalls' (zs, []) ws where - fuseWalls' w (ps, ws) = + fuseWalls' w (ps, ws') = let (qs, w') = fuseWall (ps, w) - in (qs, w' : ws) + in (qs, w' : ws') -- | Test if fst p == snd p. +wallIsZeroLength :: Eq a => (a,a) -> Bool wallIsZeroLength (x,y) = x == y -- | Given a polygon and list of walls, removes walls inside the polygon. removeWallsInPolygon :: [Point2] -> [WallP] -> [WallP] diff --git a/src/Dodge/LevelGen/Switch.hs b/src/Dodge/LevelGen/Switch.hs index 548bca33a..3c411a39e 100644 --- a/src/Dodge/LevelGen/Switch.hs +++ b/src/Dodge/LevelGen/Switch.hs @@ -50,6 +50,7 @@ makeSwitch c effOn effOff = Button switchEffect b = case _btState b of BtOff -> effOn . over buttons (IM.adjust turnOn (_btID b)) BtOn -> effOff . over buttons (IM.adjust turnOff (_btID b)) + _ -> error "Trying to switch a button with no label" offPict = onLayer WlLayer $ color c $ pictures [--translate (-8) 4 $ circleSolid 5 polygon $ rectNSEW (-2) (-5) (-10) 10 ,polygon [(-2,-5),(-10,4),(-6,4),(2,-5)] @@ -70,3 +71,4 @@ makeSwitch c effOn effOff = Button , _btPict = offPict , _btText = "SWITCH/" } + diff --git a/src/Dodge/LevelGen/TriggerDoor.hs b/src/Dodge/LevelGen/TriggerDoor.hs index 9ad10124d..855b3320f 100644 --- a/src/Dodge/LevelGen/TriggerDoor.hs +++ b/src/Dodge/LevelGen/TriggerDoor.hs @@ -14,9 +14,7 @@ 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 -- probably don't have to rebuild the entire graph, oh well addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> World -> World @@ -27,7 +25,7 @@ addButtonDoor c btp btr a b w = over buttons (IM.insert bid bt) $ putDoubleDoor c cond a b w where bid = newKey $ _buttons w - cond w = BtNoLabel == _btState (_buttons w IM.! bid) + 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)) $ _pathGraph' w @@ -45,7 +43,7 @@ addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt) $ putDoubleDoor c cond a b w where bid = newKey $ _buttons w - cond w = BtOn == _btState (_buttons w IM.! bid) + 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)) $ _pathGraph' w @@ -127,7 +125,8 @@ mkTriggerDoubleDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPaneLinear prd = pr -.- norm hwu = hw +.+ norm hwd = hw -.- norm - addSound (x:xs) = f x : xs + addSound (x:ys) = f x : ys + addSound _ = error "When creating a trigger door, added a sound to nothing" f wl = over doorMech g wl g dm w | dist wp pld > 2 && dist wp hwd > 2 diff --git a/src/Dodge/LightSources.hs b/src/Dodge/LightSources.hs index 4829f4ac5..ebdd7e97a 100644 --- a/src/Dodge/LightSources.hs +++ b/src/Dodge/LightSources.hs @@ -1,13 +1,14 @@ module Dodge.LightSources where import Dodge.Data -import Dodge.Base +--import Dodge.Base import Dodge.Picture.Layer import Dodge.LevelGen.Data -import Geometry +--import Geometry import Picture -import qualified Data.IntMap.Strict as IM +--import qualified Data.IntMap.Strict as IM +lightAt :: Point2 -> Int -> LightSource lightAt p i = LS {_lsID = i ,_lsPos = p @@ -15,13 +16,12 @@ lightAt p i = ,_lsRad = 600 ,_lsIntensity = 0.75 } - +basicLS :: PSType basicLS = PutLS ls dec where ls = lightAt (0,0) 0 dec = onLayer PtLayer $ color white $ circleSolid 8 - tLightFade :: Int -> Float -> (Int -> Float) -> Point2 -> TempLightSource tLightFade 0 rmax intensityF p = TLS { _tlsPos = p @@ -36,8 +36,13 @@ tLightFade i rmax intensityF p = TLS , _tlsUpdate = \w _ -> (w, Just $ tLightFade (i-1) rmax intensityF p) } -tLightRad :: Int -> Float -> Float -> Point2 -> TempLightSource -tLightRad 0 rmax rmin p = TLS +tLightRad + :: Int + -> Float -- ^ maximal radius + -> Float -- ^ minimal radius (unused) + -> Point2 + -> TempLightSource +tLightRad 0 rmax _ p = TLS { _tlsPos = p , _tlsRad = rmax , _tlsIntensity = 0.5 @@ -50,4 +55,5 @@ tLightRad i rmax rmin p = TLS , _tlsUpdate = \w _ -> (w, Just $ tLightRad (i-1) rmax rmin p) } +tLightAt :: Int -> Point2 -> TempLightSource tLightAt i = tLightRad i 100 0 diff --git a/src/Dodge/LoadSound.hs b/src/Dodge/LoadSound.hs index d21881bb3..2304c2c4f 100644 --- a/src/Dodge/LoadSound.hs +++ b/src/Dodge/LoadSound.hs @@ -1,11 +1,5 @@ module Dodge.LoadSound where -import Dodge.Data - -import Data.Maybe import qualified Data.IntMap.Strict as IM -import qualified Data.Map as M -import Control.Monad -import Control.Lens import qualified SDL.Mixer as Mix loadSounds :: IO (IM.IntMap Mix.Chunk) diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs index e3132cc94..03d1dfd46 100644 --- a/src/Dodge/Path.hs +++ b/src/Dodge/Path.hs @@ -31,7 +31,7 @@ divideLineFixed x a b = fmap ( \i -> a +.+ i * x *.* normalizeV (b -.- a) ) ns where - numPoints = floor $ dist a b / x + numPoints = floor $ dist a b / x :: Int ns = map fromIntegral [1 .. numPoints] -- ok, astar or something like it @@ -40,25 +40,27 @@ type SearchedNodes = (HP.MinHeap (Float,(Float,[Point2])), [Point2]) stripRight :: Either a b -> b stripRight (Right x) = x +stripRight _ = error "Trying to strip Right where there is a Left" stepPath :: (Point2 -> [Point2]) -> Point2 -> SearchedNodes -> Either [Point2] SearchedNodes -stepPath f p (nextNodes, seenNodes) = case HP.view nextNodes of +stepPath h p (nextNodes, seenNodes) = case HP.view nextNodes of Nothing -> Left [] Just ((_,(cost,q:qs)), nextNodes') | q == p -> Left (q:qs) | otherwise -> - let rs' = f q + let rs' = h q rs = rs' \\ seenNodes - newNodes = map (\r -> (cost + dist q r + dist r p , (cost + dist q r , r:q:qs))) rs - in Right (foldr HP.insert nextNodes' newNodes , rs ++ seenNodes) + newNodes' = map (\r -> (cost + dist q r + dist r p , (cost + dist q r , r:q:qs))) rs + in Right (foldr HP.insert nextNodes' newNodes' , rs ++ seenNodes) + Just _ -> error "In step path" stepPath' :: (Point2 -> [Point2]) -> Point2 -> SearchedNodes -> [Point2] -stepPath' f p s = case stepPath f p s of +stepPath' h p s = case stepPath h p s of Left ps -> ps - Right s' -> stepPath' f p s' + Right s' -> stepPath' h p s' makePath' :: (Point2 -> [Point2]) -> Point2 -> Point2 -> [Point2] -makePath' f s e = stepPath' f e (HP.singleton (0,(0,[s])) , []) +makePath' h s e = stepPath' h e (HP.singleton (0,(0,[s])) , []) makeNode :: Point2 -> SearchedNodes makeNode e = (HP.singleton (0,(0,[e])) , []) @@ -69,18 +71,20 @@ tp1 = (0,1) tp2 = (0,20) tp3 = (30,40) +f :: Point2 -> [Point2] f = incidenceToFunction $ pairsToIncidence [(tp1,tp2) ,(tp2,tp3) ,(tp2,tp1) ,(tp1,tp3) ] -g = pairsToIncidence - [(tp1,tp2) - ,(tp2,tp3) - ,(tp2,tp1) - ,(tp1,tp3) - ] +--g :: [(Point2,[Point2])] +--g = pairsToIncidence +-- [(tp1,tp2) +-- ,(tp2,tp3) +-- ,(tp2,tp1) +-- ,(tp1,tp3) +-- ] pathBetween :: Point2 -> Point2 -> World -> Maybe [Point2] pathBetween a b w = (makePath' $ \p -> _pathInc w M.! p) <$> a' <*> b' @@ -92,46 +96,46 @@ pathBetween a b w = (makePath' $ \p -> _pathInc w M.! p) <$> a' <*> b' b' = find (flip (isWalkable b) w) nsb makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int] -makePathBetween a b w = join $ sp <$> fmap fst a' <*> fmap fst b' <*> return g +makePathBetween a b w = join $ sp <$> fmap fst a' <*> fmap fst b' <*> return g' where - g = _pathGraph w + g' = _pathGraph w nsa = concat $ lookLookups (zoneAroundPoint a) (_pathPoints w) nsb = concat $ lookLookups (zoneAroundPoint b) (_pathPoints w) a' = find (flip (isWalkable a) w . snd) nsa b' = find (flip (isWalkable b) w . snd) nsb ezipWith :: Monoid a => (b -> c -> d) -> Either a b -> Either a c -> Either a d -ezipWith f (Right x) (Right y) = Right (f x y) -ezipWith f (Left x) (Right _) = Left x -ezipWith f (Right _) (Left y) = Left y -ezipWith f (Left x) (Left y) = Left (mappend x y) +ezipWith f' (Right x) (Right y) = Right (f' x y) +ezipWith _ (Left x) (Right _) = Left x +ezipWith _ (Right _) (Left y) = Left y +ezipWith _ (Left x) (Left y) = Left (mappend x y) makePathBetween' :: Point2 -> Point2 -> World -> Either String [Int] makePathBetween' a b w = - let g = _pathGraph w - ns = labNodes g - nsa = _pathPoints w `ixNZ` a - nsb = _pathPoints w `ixNZ` b + let g' = _pathGraph w + ns = labNodes g' + --nsa = _pathPoints w `ixNZ` a + --nsb = _pathPoints w `ixNZ` b a' = case listToMaybe $ sortBy (compare `on` dist a . snd) $ filter (flip (isWalkable a) w . snd) ns of Just p -> Right $ fst p _ -> Left "FIRST POINT UNSEEN" b' = case listToMaybe $ sortBy (compare `on` dist b . snd) $ filter (flip (isWalkable b) w . snd) ns of Just p -> Right $ fst p _ -> Left $ "SECOND POINT UNSEEN" ++ show b - in case ezipWith (\x y -> sp x y g) a' b' of + in case ezipWith (\x y -> sp x y g') a' b' of Right (Just xs) -> Right xs Right Nothing -> Left $ "NO PATH" ++ show a ++ show b ++ show a' ++ show b' Left m -> Left m makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2] -makePathBetweenPs a b w = mapMaybe (lab g) <$> makePathBetween b a w +makePathBetweenPs a b w = mapMaybe (lab g') <$> makePathBetween b a w where - g = _pathGraph w + g' = _pathGraph w makePathBetweenPs' :: Point2 -> Point2 -> World -> Either String [Point2] -makePathBetweenPs' a b w = mapMaybe (lab g) <$> makePathBetween' a b w +makePathBetweenPs' a b w = mapMaybe (lab g') <$> makePathBetween' a b w where - g = _pathGraph w + g' = _pathGraph w pointTowardsImpulse :: Point2 -> Point2 -> World -> Maybe Point2 pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs a b w @@ -161,10 +165,11 @@ randomGraphStepRestricted n notns g = do ---- supposes that the list is non-empty randomGraphWalk :: RandomGen g => [Int] -> Gr a b -> State g [Int] randomGraphWalk (n:ns) g = do - next <- randomGraphStepRestricted n ns g - case next of + next' <- randomGraphStepRestricted n ns g + case next' of Nothing -> return (n:ns) Just n' -> randomGraphWalk (n':n:ns) g +randomGraphWalk _ _ = error "Trying to walk in an empty list" randomPointXStepsFrom :: Int -> Point2 -> World -> Point2 randomPointXStepsFrom i p w = diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index a241cf296..5ba8c1c47 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -8,29 +8,29 @@ module Dodge.Render import Dodge.Data import Dodge.Config.Data import Dodge.Base -import Dodge.Render.HUD -import Dodge.Render.MenuScreen +--import Dodge.Render.HUD +--import Dodge.Render.MenuScreen import Dodge.Render.Picture import Dodge.Render.PerspectiveMatrix import Geometry -import Picture +--import Picture import Picture.Render import Picture.Preload import Shader import Foreign (Word32) -import Control.Applicative -import Control.Monad.State +--import Control.Applicative +--import Control.Monad.State import Control.Lens import qualified Control.Foldl as F import Data.Tuple.Extra import Data.Maybe -import Data.List -import Data.Bifunctor -import Data.Function -import qualified Data.IntMap.Strict as IM -import qualified Data.Map as M -import qualified Data.Set as S +--import Data.List +--import Data.Bifunctor +--import Data.Function +--import qualified Data.IntMap.Strict as IM +--import qualified Data.Map as M +--import qualified Data.Set as S import Graphics.Rendering.OpenGL hiding (color,scale,translate,rotate) import qualified SDL @@ -43,9 +43,9 @@ doDrawing pdata w = do sTicks <- SDL.ticks clear [ColorBuffer,DepthBuffer] let rot = _cameraRot w - zoom = _cameraZoom w - trans@(tranx,trany) = _cameraCenter w - wins@(winx,winy) = (getWindowX w,getWindowY w) + camzoom = _cameraZoom w + trans = _cameraCenter w + wins = (getWindowX w,getWindowY w) wallPointsCol = wallsPointsAndCols w windowPoints = wallsWindows w lightPoints = lightsForGloom' w @@ -53,16 +53,16 @@ doDrawing pdata w = do 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 + setCommonUniforms pdata rot camzoom trans wins depthFunc $= Just Less - pmat <- (newMatrix RowMajor $ perspectiveMatrix rot zoom trans wins viewFroms) + pmat <- (newMatrix RowMajor $ perspectiveMatrix rot camzoom 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 + renderBackground pdata rot camzoom trans wins -- draw the walls depthFunc $= Just Less if w ^. config . wall_textured @@ -70,20 +70,20 @@ doDrawing pdata w = do 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 + _ <- setWallDepth pdata wallPoints (viewFromx,viewFromy) pmat -- draw the first layer of pictures -- these will probably all be opaque - renderFoldable pdata $ picToLTree (Just 0) pic + _ <- 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 + _ <- 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 + _ <- renderFoldable pdata $ picToLTree (Just 2) pic depthMask $= Disabled -- render transparent walls -- the ordering between these and transparent clouds perhaps presents a challenge @@ -111,7 +111,7 @@ doDrawing pdata w = do -- coordinates resetShaderUniforms (map extractProgAndUnis $ _pictureShaders pdata) blendFunc $= (SrcAlpha,OneMinusSrcAlpha) - renderFoldable pdata (picToLTree Nothing $ fixedCoordPictures w) + _ <- renderFoldable pdata (picToLTree Nothing $ fixedCoordPictures w) eTicks <- SDL.ticks return (eTicks - sTicks) diff --git a/src/Dodge/Render/HUD.hs b/src/Dodge/Render/HUD.hs index 35561be53..e9a2c1e68 100644 --- a/src/Dodge/Render/HUD.hs +++ b/src/Dodge/Render/HUD.hs @@ -1,16 +1,13 @@ module Dodge.Render.HUD where - import Dodge.Data import Dodge.Base import Dodge.Inventory - import Picture import Geometry import Data.Maybe import qualified Data.IntMap as IM - import Control.Lens hudDrawings :: World -> Picture @@ -40,7 +37,7 @@ displayListTopLeft :: [(String,Color)] -> World -> [Picture] displayListTopLeft scols w = map scaler $ zipWith (translate (15-halfWidth w)) - ( map (\x -> halfHeight w - (20 * (fromIntegral x+1))) [0..] ) + ( map (\x -> halfHeight w - (20 * (fromIntegral x+1))) ([0..]::[Int]) ) ( map (\(s,col) -> scale 0.1 0.1 . dShadCol col $ text s) scols ) where scaler = scale (2 / getWindowX w) (2 / getWindowY w) @@ -55,15 +52,15 @@ itemStringCol NoItem = ("----", greyN 0.5) itemStringCol itm = (_itInvDisplay itm itm, _itInvColor itm) drawLocations :: World -> [Picture] -drawLocations w = displayListTopLeft locs w - ++ zipWith bFunc (displayListEndCoords w locTexts) locPoss - ++ mapOverlay w - ++ [drawListCursor white iPos w] +drawLocations wrld = displayListTopLeft locs wrld + ++ zipWith bFunc (displayListEndCoords wrld locTexts) locPoss + ++ mapOverlay wrld + ++ [drawListCursor white iPos wrld] where - iPos = _selLocation w - locs = map (\(_,s) -> (s,white)) . IM.elems . _seenLocations $ w - locPoss = map (cartePosToScreen w . ($ w) . fst) . IM.elems . _seenLocations $ w - zoom = _carteZoom w + iPos = _selLocation wrld + locs = map (\(_,s) -> (s,white)) . IM.elems . _seenLocations $ wrld + locPoss = map (cartePosToScreen wrld . ($ wrld) . fst) . IM.elems . _seenLocations $ wrld + --cZoom = _carteZoom w locTexts = map fst locs bFunc (x,y) (z,w) = pictures [ bezierQuad (withAlpha 0.0 white) (withAlpha 0.2 white) 0.050 0.010 (x,y) (0,y) (z,w) @@ -72,7 +69,7 @@ drawLocations w = displayListTopLeft locs w ] --cheapo antialiasing displayListCoords :: World -> [Point2] -displayListCoords w = map (g . f) [1..] +displayListCoords w = map (g . f) [(1::Int)..] where f i = ( 15 - halfWidth w , halfHeight w - (20 * fromIntegral i) ) g (x,y) = (2*x / getWindowX w, 2*y / getWindowY w) @@ -106,7 +103,7 @@ mapWall w wl = {- | Pictures of popup text for items close to your position.-} closeObjectTexts :: World -> Picture -closeObjectTexts w = pictures $ zipWith renderList [0..] (map colAndText $ _closeActiveObjects w) +closeObjectTexts w = pictures $ zipWith renderList [(0::Int)..] (map colAndText $ _closeActiveObjects w) ++ maybeToList maybeLine where colAndText (Left x) = (_itInvColor $ _flIt x, _itName $ _flIt x) @@ -126,6 +123,7 @@ closeObjectTexts w = pictures $ zipWith renderList [0..] (map colAndText $ _clos maybeLeft (Left x) = Just x maybeLeft _ = Nothing pushout = 140 + xtran :: Int -> Float xtran 0 = case mayIt of Nothing -> 25 _ -> -25 xtran _ = 0 diff --git a/src/Dodge/Render/MenuScreen.hs b/src/Dodge/Render/MenuScreen.hs index dde93c2d1..e707d154a 100644 --- a/src/Dodge/Render/MenuScreen.hs +++ b/src/Dodge/Render/MenuScreen.hs @@ -6,9 +6,9 @@ module Dodge.Render.MenuScreen ) where import Dodge.Data.Menu -import Dodge.Config.Update +--import Dodge.Config.Update import Dodge.Config.Data -import Dodge.Base (halfWidth,halfHeight) +--import Dodge.Base (halfWidth,halfHeight) import Picture menuScreen @@ -18,7 +18,6 @@ menuScreen -> [MenuLayer] -> Picture menuScreen cfig hw hh mLays = case mLays of - [] -> blank (LevelMenu x:_) -> optionsList hw hh ("LEVEL"++show x) [] (PauseMenu:_) -> optionsList hw hh "PAUSED" ["N - NEW LEVEL" @@ -57,7 +56,7 @@ menuScreen cfig hw hh mLays = case mLays of mavol = f $ _volume_master cfig snvol = f $ _volume_sound cfig muvol = f $ _volume_music cfig - f x = show $ round $ 10 * x + f x = show $ (round $ 10 * x :: Int) showShadRes i = "1/"++ show i optionsList @@ -74,6 +73,7 @@ optionsList hw hh tit ops = pictures $ where placeString x y sc t = translate x y $ scale sc sc $ color white $ text t +controlsList :: Picture controlsList = pictures $ concat $ zipWith butAndEff [("wasd", "movement") ,("[rmb]", "aim") diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index 23fd9cd5a..03f20d9fe 100644 --- a/src/Dodge/Render/Picture.hs +++ b/src/Dodge/Render/Picture.hs @@ -64,7 +64,7 @@ clDraw c = uncurry translate (_clPos c) (_clPict c c) wallFloorsToDraw :: World -> [Wall] wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w where - onScreen wall = lineOnScreen w ((\(a,b) -> [a,b]) $ _wlLine wall) + onScreen wall = uncurry (lineOnScreen w) $ _wlLine wall isVisible wl | wl ^? blVisible == Just False = False | otherwise = onScreen wl @@ -98,12 +98,12 @@ outsideScreenPolygon w = [tr,tl,bl,br] where scRot = rotateV (_cameraRot w) scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p + | otherwise = error "Trying to set screen zoom to zero" scTran p = p +.+ _cameraCenter w tr = scTran $ scRot $ scZoom ( 3*halfWidth w , 3* halfHeight w) tl = scTran $ scRot $ scZoom (- (3*halfWidth w), 3* halfHeight w) br = scTran $ scRot $ scZoom ( 3*halfWidth w ,- (3* halfHeight w)) bl = scTran $ scRot $ scZoom (- (3*halfWidth w),- (3* halfHeight w)) - x = halfWidth w + halfHeight w wallShadowsToDraw :: World -> [Wall] wallShadowsToDraw w = filter (fromMaybe True . (^? blVisible)) @@ -112,8 +112,8 @@ wallShadowsToDraw w = filter (fromMaybe True . (^? blVisible)) -- cannot only test if walls are on screen, but also if they are on the cone -- towards the center of sight -lineOnScreenCone :: World -> [Point2] -> Bool -lineOnScreenCone w (p1:p2:_) = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9 p2 sp +lineOnScreenCone :: World -> Point2 -> Point2 -> Bool +lineOnScreenCone w p1 p2 = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9 p2 sp || any (isJust . uncurry (intersectSegSeg' p1 p2)) sps where sp' = screenPolygon w @@ -123,8 +123,8 @@ lineOnScreenCone w (p1:p2:_) = errorPointInPolygon 8 p1 sp || errorPointInPolygo sps = zip sp (tail sp ++ [head sp]) -lineOnScreen :: World -> [Point2] -> Bool -lineOnScreen w (p1:p2:_) = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9 p2 sp +lineOnScreen :: World -> Point2 -> Point2 -> Bool +lineOnScreen w p1 p2 = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9 p2 sp || any (isJust . uncurry (intersectSegSeg' p1 p2)) sps where sp = screenPolygon w @@ -156,17 +156,19 @@ extendConeToScreenEdge w c (x,y) = orderPolygon $ wallScreenIntersect ++ [x,y] + wallScreenIntersect = mapMaybe (uncurry $ intersectSegSeg' y ((2*.*y) -.- x)) . makeLoopPairs $ screenPolygon w +rectangleSolid :: Float -> Float -> Picture rectangleSolid x y = polygon [(x,y),(x,-y),(-x,-y),(-x,y)] drawItem :: FloorItem -> Picture -drawItem flIt = uncurry translate (_flItPos flIt) - $ rotate (_flItRot flIt) (_itFloorPict (_flIt flIt)) +drawItem flit = uncurry translate (_flItPos flit) + $ rotate (_flItRot flit) (_itFloorPict (_flIt flit)) ffToDraw :: World -> [ForceField] -ffToDraw w = filter (lineOnScreen w . _ffLine) $ - IM.elems $ over ffLine (map ( -.- _cameraCenter w)) <$> - _forceFields w +ffToDraw _ = [] +-- filter (lineOnScreen w . _ffLine) $ +-- IM.elems $ over ffLine (map ( -.- _cameraCenter w)) <$> +-- _forceFields w drawFF :: ForceField -> Picture drawFF FF{_ffLine = l, _ffColor = col} = pictures @@ -179,14 +181,12 @@ drawFFShadow w ff | youOnFF = [] | otherwise = map (rotate ( _cameraRot w) . pane) [0,0.05..0.25] where - p = rotateV (-_cameraRot w) ypShift x = rotateV (-_cameraRot w) x' y = rotateV (-_cameraRot w) y' yp = _crPos $ you w (x1:y1:_) = _ffLine ff (x':y':_) | isRHS x1 y1 yp = [y1,x1] | otherwise = [x1,y1] - fCol = color (_ffColor ff) col = _ffColor ff ypShift = yp -.- _cameraCenter w youOnFF = circOnSeg x' y' ypShift (_crRad $ you w) diff --git a/src/Dodge/Room.hs b/src/Dodge/Room.hs index f8272df77..a350032e1 100644 --- a/src/Dodge/Room.hs +++ b/src/Dodge/Room.hs @@ -8,47 +8,37 @@ module Dodge.Room import Dodge.Data import Dodge.Item.Weapon import Dodge.Creature -import Dodge.Creature.Inanimate -import Dodge.LevelGen +--import Dodge.Creature.Inanimate +--import Dodge.LevelGen import Dodge.LevelGen.Data -import Dodge.Base +--import Dodge.Base import Dodge.RandomHelp import Dodge.Default -import Dodge.Path -import Dodge.Layout +--import Dodge.Path +--import Dodge.Layout import Dodge.Layout.Tree.Polymorphic import Dodge.Layout.Tree.Either -import Dodge.LightSources -import Dodge.SoundLogic +--import Dodge.LightSources +--import Dodge.SoundLogic import Dodge.Room.Data import Dodge.Room.Placement import Dodge.Room.Procedural import Dodge.Room.Corridor import Dodge.Room.Link -import Dodge.Room.Branch +--import Dodge.Room.Branch import Dodge.Room.Door import Dodge.Room.Airlock import Dodge.Room.LongDoor import Geometry import Picture -import qualified SDL.Mixer as Mix import Control.Lens import Control.Monad.State import Control.Monad.Loops import System.Random -import Data.List -import Data.Maybe import Data.Tree -import Data.Either -import Data.Function -import Data.Graph.Inductive.Graph hiding ((&)) -import Data.Graph.Inductive.Basic -import Data.Graph.Inductive.PatriciaTree -import Data.Graph.Inductive.NodeMap -import qualified Data.Map as M -import qualified Data.IntMap.Strict as IM - +--import qualified Data.Map as M +--import qualified Data.IntMap.Strict as IM roomC :: Float -> Float -> Room roomC x y = Room @@ -144,7 +134,7 @@ miniRoom1 = do ,windowLine (wth-60, 40+3*hf) (wllen,40+3*hf) ,windowLine (wth-wllen,40+4*hf) (60,40+4*hf) ,sPS (crx,cry) 0 $ PutCrit miniGunCrit - ,sPS (wth-20,hgt/2+40) 0 randC + ,sPS (wth-20,hgt/2+40) 0 randC1 ,sPS (wth/2,hgt/2) 0 putLamp ,blockLine ( 0, 40+1*hf) (wllen,40+1*hf) ,blockLine (wth-wllen, 40+2*hf) ( wth,40+2*hf) @@ -258,7 +248,6 @@ randFirstWeapon = do ++ replicate 2 autoGun ++ [launcher] -randC = randC1 weaponEmptyRoom :: RandomGen g => State g (Tree (Either Room Room)) weaponEmptyRoom = do @@ -285,21 +274,21 @@ weaponUnderCrits = do (connectRoom (set rmPS plmnts corridorN)) rcp' <- roomCenterPillar let rcp = over rmPS ( sPS (120,80) 0 putLamp : ) rcp' - deadEndRoom <- takeOne [roomPillars,rcp] + deadEndRoom' <- takeOne [roomPillars,rcp] junctionRoom <- takeOne [Left tEast,Left tWest] return $ treeFromTrunk [Left corridorN,Left corridorN] $ Node junctionRoom [continuationRoom - ,deadRoom deadEndRoom + ,deadRoom deadEndRoom' ] weaponBehindPillar :: RandomGen g => State g (Tree (Either Room Room)) weaponBehindPillar = do - crPos <- takeOne $ [(x,y) | x <- [20,220], y <- [20,220]] ++ [(120,160),(120,200)] + cpos <- takeOne $ [(x,y) | x <- [20,220], y <- [20,220]] ++ [(120,160),(120,200)] let d p = argV $ (120,80) -.- p let plmnts1 = [sPS (120,160) 0 $ RandPS randFirstWeapon - ,sPS crPos (d crPos) randC1 + ,sPS cpos (d cpos) randC1 ] rcp <- roomCenterPillar return $ treeFromTrunk @@ -337,11 +326,11 @@ weaponLongCorridor = do let branch2 = treeFromTrunk (replicate i2 $ Left corridorN) (deadRoom $ putWp corridor) return $ Node (Left root) [branch1,branch2] where - putCrs = over rmPS (++ [sPS (10,40) (-pi/2) randC ,sPS (-10,40) (-pi/2) randC ]) + putCrs = over rmPS (++ [sPS (10,40) (-pi/2) randC1 ,sPS (-10,40) (-pi/2) randC1 ]) putWp = set rmPS [sPS (20,40) 0 $ RandPS randFirstWeapon ,sPS (20,60) 0 putLamp ] critInDeadEnd :: Room -critInDeadEnd = set rmPS [sPS (0,0) 0 randC] deadEndRoom +critInDeadEnd = set rmPS [sPS (0,0) 0 randC1] deadEndRoom deadEndRoom :: Room deadEndRoom = Room @@ -367,7 +356,7 @@ weaponRoom = join $ takeOne roomCCrits :: RandomGen g => State g (Tree (Either Room Room)) roomCCrits = do ps <- replicateM 20 $ randInCirc 9 - let plmnts = map (\p -> sPS p 0 randC) + let plmnts = map (\p -> sPS p 0 randC1) $ zipWith (+.+) [(x,y) | x<-[110,130,150,170,190], y<- [70,90,110,130,150]] ps lamps = [sPS (50,100) 0 putLamp , sPS (175,100) 0 putLamp] return $ connectRoom $ over rmPS ((lamps ++) . (plmnts ++)) $ roomC 200 200 @@ -457,10 +446,10 @@ shootersRoom = do pistolerRoom :: RandomGen g => State g Room pistolerRoom = do let f2 x y = singleBlock (x,y) - f3 x y = [blockLine (x-20,y) (x+20,y) - ,blockLine (x,y-20) (x,y+20) ] - f4 x y = [blockLine (x-20,y-20) (x+20,y+20) - ,blockLine (x+20,y-20) (x-20,y+20) ] + --f3 x y = [blockLine (x-20,y) (x+20,y) + -- ,blockLine (x,y-20) (x,y+20) ] + --f4 x y = [blockLine (x-20,y-20) (x+20,y+20) + -- ,blockLine (x+20,y-20) (x-20,y+20) ] f <- takeOne [f2] h <- state $ randomR (400,800) let w = h diff --git a/src/Dodge/Room/Airlock.hs b/src/Dodge/Room/Airlock.hs index f3f87e8eb..bdfe961d6 100644 --- a/src/Dodge/Room/Airlock.hs +++ b/src/Dodge/Room/Airlock.hs @@ -154,4 +154,4 @@ airlockCrystal n = Room col = dim $ dim $ bright red pss :: [(Point2,Point2)] pss = reverse $ fmap ( (\x -> ((50,x),(50,x+50)) ) . fromIntegral) - [20,22..70] + [20::Int,22..70] diff --git a/src/Dodge/Room/Branch.hs b/src/Dodge/Room/Branch.hs index d0b5e45f2..2324a6c44 100644 --- a/src/Dodge/Room/Branch.hs +++ b/src/Dodge/Room/Branch.hs @@ -3,12 +3,12 @@ Collections of rooms that branch into multiple paths. -} module Dodge.Room.Branch where -import Geometry +--import Geometry import Dodge.Room.Data import Dodge.Room.Door import Dodge.Room.Link import Dodge.Room.Procedural -import Dodge.LevelGen.Data +--import Dodge.LevelGen.Data import Dodge.Layout.Tree.Polymorphic import Control.Monad.State diff --git a/src/Dodge/Room/Link.hs b/src/Dodge/Room/Link.hs index 773d7e753..2b021123e 100644 --- a/src/Dodge/Room/Link.hs +++ b/src/Dodge/Room/Link.hs @@ -64,7 +64,7 @@ shiftRoomToLink l r (p,a) = last $ _rmLinks r shiftRoomBy :: (Point2,Float) -> Room -> Room -shiftRoomBy shift@(pos,rot) r = +shiftRoomBy shift r = over rmPolys (fmap (map (shiftPointBy shift))) $ over rmLinks (fmap (shiftLinkBy shift)) $ over rmPath (map (shiftPathPointBy shift)) @@ -72,14 +72,22 @@ shiftRoomBy shift@(pos,rot) r = $ over rmBound (fmap (map (shiftPointBy shift))) r +shiftLinkBy + :: (Point2,Float) + -> (Point2,Float) + -> (Point2,Float) shiftLinkBy (pos,rot) (p,r) = (shiftPointBy (pos,rot) p, r + rot) + +shiftPSBy + :: (Point2,Float) + -> Placement + -> Placement shiftPSBy (pos,rot) ps = ps & placementSpot . psPos %~ shiftPointBy (pos,rot) & placementSpot . psRot %~ (+ rot) ---shiftPSBy (pos,rot) ps = case ps of --- PS {} -> over psPos (shiftPointBy (pos,rot)) --- $ over psRot (+rot) --- ps - +shiftPathPointBy + :: (Point2,Float) + -> (Point2,Point2) + -> (Point2,Point2) shiftPathPointBy s (p1,p2) = (shiftPointBy s p1, shiftPointBy s p2) diff --git a/src/Dodge/Room/LongDoor.hs b/src/Dodge/Room/LongDoor.hs index f2192d4ab..4f716584a 100644 --- a/src/Dodge/Room/LongDoor.hs +++ b/src/Dodge/Room/LongDoor.hs @@ -57,8 +57,8 @@ twinSlowDoorRoom drID w h x = Room [0..nDrp] drR = fmap ((\h' -> ((-x,-h'),(-x,h-h'))) . (* h) . (/ fromIntegral nDrp) . fromIntegral) [0..nDrp] - nDrp = ceiling h - cond w = or $ M.lookup (DoorNumOpen drID) (_worldState w) + nDrp = ceiling h :: Int + cond w' = or $ M.lookup (DoorNumOpen drID) (_worldState w') col = dim $ dim $ bright red twinSlowDoorChasers @@ -90,7 +90,7 @@ slowDoorRoom = do ys' <- replicateM 5 $ state $ randomR (h+20,y) let crits = zipWith (\p r -> sPS p r randC1) ps rs lsources = [sPS (x/2,30) 0 putLamp, sPS (x/2,y-30) 0 putLamp] - barrels = zipWith (\x y -> sPS (x,y) 0 $ PutCrit explosiveBarrel) xs' ys' + barrels = zipWith (\x' y' -> sPS (x',y') 0 $ PutCrit explosiveBarrel) xs' ys' pillarsa = [] pillarsb = putBlockRect (x/5-20) (x/5+20) (h/2-20) (h/2+20) ++ putBlockRect (2*x/5-20) (2*x/5+20) (h/2-20) (h/2+20) @@ -99,8 +99,8 @@ slowDoorRoom = do pillarsc = putBlockRect (x/3-20) (x/3+20) (h/2-20) (h/2+20) ++ putBlockRect (2*x/3-20) (2*x/3+20) (h/2-20) (h/2+20) pillars <- takeOne [pillarsa, pillarsb, pillarsc] - let cond x = (snd . fst) x > h + 40 - cond2 x = (snd . fst) x < h - 40 + let cond x' = (snd . fst) x' > h + 40 + cond2 x' = (snd . fst) x' < h - 40 but <- takeOne [PutBtDoor (dim $ light red) butPos butRot (0,h) (x,h) -- ,PutSwitchDoor (dim $ light red) butPos butRot (0,h) (x,h) ] @@ -112,4 +112,5 @@ slowDoorRoom = do ) ) +randC1 :: PSType randC1 = RandPS $ takeOne $ map PutCrit $ armourChaseCrit : replicate 50 chaseCrit diff --git a/src/Dodge/Room/NoNeedWeapon.hs b/src/Dodge/Room/NoNeedWeapon.hs index 2eb76f5e0..dbbf31fde 100644 --- a/src/Dodge/Room/NoNeedWeapon.hs +++ b/src/Dodge/Room/NoNeedWeapon.hs @@ -5,7 +5,7 @@ module Dodge.Room.NoNeedWeapon import Dodge.Data import Dodge.Creature import Dodge.Creature.State.Data -import Dodge.Creature.Inanimate +--import Dodge.Creature.Inanimate import Dodge.Room.Data import Dodge.Room.Procedural import Dodge.Room.Link @@ -13,7 +13,7 @@ import Dodge.RandomHelp import Dodge.LevelGen.Data import Control.Lens -import Control.Monad +--import Control.Monad import Control.Monad.State import System.Random {- | diff --git a/src/Dodge/Room/Placement.hs b/src/Dodge/Room/Placement.hs index 45bfe054a..dcee12ef8 100644 --- a/src/Dodge/Room/Placement.hs +++ b/src/Dodge/Room/Placement.hs @@ -12,12 +12,16 @@ import Geometry import Data.List import Control.Lens - +putLamp :: PSType putLamp = PutCrit lamp singleBlock :: Point2 -> [Placement] -singleBlock a = [sPS a 0 $ PutBlock [5,20,20] (greyN 0.5) - $ reverse $ rectNSWE 10 (-10) (-10) 10] +singleBlock a = + [sPS a 0 + $ PutBlock [5,20,20] (greyN 0.5) + $ reverse + $ rectNSWE 10 (-10) (-10) 10 + ] {- Places a line of blocks between two points. Width 9, also extends out from each point by 9. @@ -128,20 +132,45 @@ subZipWith f g xs ys = let (zs,ws) = partition f xs in zipWith g zs ys ++ ws +isPutID :: Int -> Placement -> Bool isPutID i ps = Just i == ps ^? placementSpot . psType . putID +putBlockRect + :: Float + -> Float + -> Float + -> Float + -> [Placement] putBlockRect a x b y = [ blockLine (a,b) (a,y) , blockLine (a,y) (x,y) , blockLine (x,y) (x,b) , blockLine (x,b) (a,b) ] +putBlockV + :: Float + -> Float + -> Float + -> Float + -> [Placement] putBlockV a x b y = [ blockLine (a,b) (a,y) , blockLine (x,b) (a,b) ] +putBlockC + :: Float + -> Float + -> Float + -> Float + -> [Placement] putBlockC a x b y = [ blockLine (a,b) (a,y) , blockLine (x,b) (a,b) , blockLine (a,y) (x,y) ] +putBlockN + :: Float + -> Float + -> Float + -> Float + -> [Placement] putBlockN a x b y = [ blockLine (a,b) (a,y) , blockLine (x,b) (a,b) , blockLine (x,y) (x,b) diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index 1545f18af..d95377b7c 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -12,16 +12,17 @@ import Dodge.Room.Data import Dodge.Room.Placement import Dodge.Room.Link import Dodge.Item.Consumable +import Dodge.Item.Equipment import Dodge.Item.Weapon import Dodge.RandomHelp import Dodge.LevelGen import Dodge.LevelGen.Data import Dodge.Creature -import Dodge.Default +--import Dodge.Default import Geometry import Picture -import Data.List (nub,nubBy,sortBy,minimumBy) +import Data.List import Data.Function (on) import qualified Data.Tuple.Extra as Tup import qualified Data.Map as M @@ -94,19 +95,19 @@ combineRooms r r' = Room , _rmPS = _rmPS r ++ _rmPS r' , _rmBound = _rmBound r ++ _rmBound r' } -{- The top fourth of a room of a given height. -} -fourth - :: Float -- ^ Distance from center of room to top edge - -> Room -fourth w = Room - { _rmPolys = [ [(0,0),(w,w),(-w,w)] ] - , _rmLinks = [((0,w), 0)] - , _rmPath = [((0,w),(0,0)),((0,0),(0,w))] - , _rmPS = - [sPS (0,w/2) 0 putLamp - ] - , _rmBound = [[(0,0),(w,w),(-w,w)]] - } +--{- The top fourth of a room of a given height. -} +--fourth +-- :: Float -- ^ Distance from center of room to top edge +-- -> Room +--fourth w = Room +-- { _rmPolys = [ [(0,0),(w,w),(-w,w)] ] +-- , _rmLinks = [((0,w), 0)] +-- , _rmPath = [((0,w),(0,0)),((0,0),(0,w))] +-- , _rmPS = +-- [sPS (0,w/2) 0 putLamp +-- ] +-- , _rmBound = [[(0,0),(w,w),(-w,w)]] +-- } {- Randomly generate a top fourth of a room possibly with a wall. Add a light and a 'PutNothing' placement. -} fourthWall :: RandomGen g => Float -> State g Room @@ -136,18 +137,17 @@ fourthWall w = do , _rmPS = b , _rmBound = [[(0,0),(w,w),(-w,w)]] } - -fourthCorner :: Float -> Room -fourthCorner w = Room - { _rmPolys = [ [(0,0),(w,w),(0,2*w),(-w,w)] ] - , _rmLinks = - [((w/2,3*w/2), negate $ pi/4) - ,((negate $ w/2,3*w/2), pi/4) - ] - , _rmPath = [((0,w),(0,0)),((0,0),(0,w))] - , _rmPS = [sPS (0,w) 0 putLamp] - , _rmBound = [[(w,w),(0,2*w),(-w,w)]] - } +--fourthCorner :: Float -> Room +--fourthCorner w = Room +-- { _rmPolys = [ [(0,0),(w,w),(0,2*w),(-w,w)] ] +-- , _rmLinks = +-- [((w/2,3*w/2), negate $ pi/4) +-- ,((negate $ w/2,3*w/2), pi/4) +-- ] +-- , _rmPath = [((0,w),(0,0)),((0,0),(0,w))] +-- , _rmPS = [sPS (0,w) 0 putLamp] +-- , _rmBound = [[(w,w),(0,2*w),(-w,w)]] +-- } fourthCornerWall :: RandomGen g => Float -> State g Room fourthCornerWall w = do @@ -261,5 +261,5 @@ centerVaultRoom n w h d = do (over worldState (M.insert (DoorNumOpen i) True)) (over worldState (M.insert (DoorNumOpen i) False)) ] - cond i w = or $ M.lookup (DoorNumOpen i) (_worldState w) + cond i w' = or $ M.lookup (DoorNumOpen i) (_worldState w') diff --git a/src/Dodge/Room/RoadBlock.hs b/src/Dodge/Room/RoadBlock.hs index 94115032a..13d48995f 100644 --- a/src/Dodge/Room/RoadBlock.hs +++ b/src/Dodge/Room/RoadBlock.hs @@ -9,7 +9,7 @@ import Dodge.Room.Link import Dodge.Room.Placement import Dodge.Room.Corridor import Dodge.LevelGen.Data -import Dodge.RandomHelp +--import Dodge.RandomHelp import Dodge.Creature import Dodge.Layout.Tree.Polymorphic diff --git a/src/Dodge/Room/Teleport.hs b/src/Dodge/Room/Teleport.hs index 51d0d63d0..6b7a40893 100644 --- a/src/Dodge/Room/Teleport.hs +++ b/src/Dodge/Room/Teleport.hs @@ -9,7 +9,7 @@ import Dodge.Base import Dodge.Room.Data import Dodge.Room.Procedural import Dodge.Room.Placement -import Dodge.Layout +--import Dodge.Layout import Dodge.LevelGen.Data import Geometry import Picture @@ -44,5 +44,4 @@ telRoomLev i = do levelReset pp w | dist (_crPos $ you w) (_ppPos pp) < 20 = makeExplosionAt (_ppPos pp) $ startNewGame w | otherwise = w - ppPoly pp = map (+.+ _ppPos pp) ppFootprint startNewGame w = w & worldTriggers %~ S.insert (ResetLevel i) diff --git a/src/Dodge/Room/Treasure.hs b/src/Dodge/Room/Treasure.hs index 871e3e83b..01de338c0 100644 --- a/src/Dodge/Room/Treasure.hs +++ b/src/Dodge/Room/Treasure.hs @@ -10,9 +10,9 @@ import Dodge.Room.Data import Dodge.Room.Placement import Dodge.LevelGen.Data -import Data.List +--import Data.List import Control.Monad.State -import Control.Lens +--import Control.Lens import System.Random {- | A triangular room with loot at the top (with 'PutID' 2), creatures in the bottom two corners (with 'PutID' 0), diff --git a/src/Dodge/SoundLogic.hs b/src/Dodge/SoundLogic.hs index 36067b03d..09df04d92 100644 --- a/src/Dodge/SoundLogic.hs +++ b/src/Dodge/SoundLogic.hs @@ -20,28 +20,6 @@ module Dodge.SoundLogic ( , pauseSound -- * Synonyms for sound identifiers - , clickSound - , reloadSound - , pickUpSound - , putDownSound - , fireSound - , grenadeBang - , tapQuiet - , twoStepSound - , healSound - , doorSound - , twoStepSlowSound - , knifeSound - , buzzSound - , hitSound - , autoGunSound - , shotgunSound - , teleSound - , longGunSound - , launcherSound - , smokeTrailSound - , foot1Sound - , foot2Sound , module Dodge.SoundLogic.Synonyms ) where import Dodge.Data diff --git a/src/Dodge/SoundLogic/Synonyms.hs b/src/Dodge/SoundLogic/Synonyms.hs index 642092292..ff7de2688 100644 --- a/src/Dodge/SoundLogic/Synonyms.hs +++ b/src/Dodge/SoundLogic/Synonyms.hs @@ -1,7 +1,7 @@ module Dodge.SoundLogic.Synonyms where -reloadSound,putDownSound,pickUpSound,fireSound,grenadeBang,healSound,teleSound,twoStepSlowSound :: Int +clickSound , reloadSound , pickUpSound , putDownSound , fireSound , grenadeBang , tapQuiet , twoStepSound , healSound , doorSound , twoStepSlowSound , knifeSound , buzzSound , hitSound , autoGunSound , shotgunSound , teleSound , longGunSound , launcherSound , smokeTrailSound , foot1Sound , foot2Sound , drawWeaponSound , holsterWeaponSound :: Int clickSound = 1 reloadSound = 2 pickUpSound = 4 @@ -27,3 +27,4 @@ foot2Sound = 23 drawWeaponSound = 4 holsterWeaponSound = 5 + diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 3d1ced58f..ec1269713 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -8,12 +8,12 @@ module Dodge.Update import Dodge.Data import Dodge.Data.Menu import Dodge.World.Trigger.Data -import Dodge.Config.Data +--import Dodge.Config.Data import Dodge.Base import Dodge.WallCreatureCollisions import Dodge.LevelGen.Block import Dodge.Update.Camera -import Dodge.Update.UsingInput +--import Dodge.Update.UsingInput import Dodge.SoundLogic import Dodge.Inventory import Dodge.Initialisation @@ -29,6 +29,7 @@ import qualified Data.IntMap.Strict as IM import qualified Data.Map as M import Control.Lens +update :: World -> World update = update' . pushSideEffects pushSideEffects :: World -> World @@ -40,7 +41,7 @@ pushSideEffects w = w For most menus the only way to change the world is using event handling. -} update' :: World -> World update' w = case _menuLayers w of - (WaitMessage s i: ls) + (WaitMessage s i: _) | i < 1 -> w & doubleArgumentFor _worldEvents | otherwise -> w & menuLayers %~ ( (WaitMessage s (i-1) :) . tail ) (GameOverMenu : _) -> updateParticles @@ -99,6 +100,7 @@ updateTriggers w where cr = _creatures w IM.! 0 & crPos .~ (0,0) +updateSoundQueue :: World -> World updateSoundQueue = set soundQueue [] . set sounds M.empty updateLightSources :: World -> World @@ -106,6 +108,7 @@ updateLightSources w = set tempLightSources (catMaybes tlss) w' where (w',tlss) = mapAccumR (\a b -> _tlsUpdate b a b) w $ _tempLightSources w +updateProjectiles :: World -> World updateProjectiles w = IM.foldr' _pjUpdate w $ _projectiles w {- Apply internal particle updates, delete 'Nothing's. -} @@ -126,7 +129,7 @@ updateWalls :: World -> World updateWalls w = IM.foldr (fromMaybe id . (^? doorMech)) w (_walls w) ppEvents :: World -> World -ppEvents w = IM.foldr (\pp w -> _ppEvent pp pp w) w $ _pressPlates w +ppEvents w = IM.foldr (\pp w' -> _ppEvent pp pp w') w $ _pressPlates w updateSeenWalls :: World -> World updateSeenWalls w = foldr markSeen w wallsToUpdate @@ -136,10 +139,10 @@ updateSeenWalls w = foldr markSeen w wallsToUpdate $ nRays 20 markSeen i = set (walls . ix i . wlSeen) True -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) +--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) checkEndGame :: World -> World checkEndGame w @@ -158,7 +161,7 @@ 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) + springVels = IM.foldr' (clClSpringVel c) (_clVel c) (cloudsNearPoint oldPos w) oldPos = _clPos c newPos = oldPos +.+ newVel hitWl = collideCircWalls' oldPos newPos 5 $ wallsNearPoint newPos w @@ -169,8 +172,8 @@ moveCloud c w = _clEffect c c . theUpdate $ w & clouds . ix (_clID c) . clVel .~ finalVel & clouds . ix (_clID c) . clPos .~ finalPos -clClSpringVel :: Cloud -> World -> Cloud -> Point2 -> Point2 -clClSpringVel a w b v +clClSpringVel :: Cloud -> Cloud -> Point2 -> Point2 +clClSpringVel a b v | ida == idb = v | dist pa pb < radDist = v +.+ 0.1 *.* safeNormalizeV (pa -.- pb) | otherwise = v @@ -218,10 +221,4 @@ visibleWalls p1 p2 ws $ IM.toList ws where f (i,wl) = (uncurry intersectSegSeg' (_wlLine wl) p1 p2, (i,wl)) - takeUntil h xs = - let (ys,zs) = span h xs - in ys ++ tf zs - where - tf (x:_) = [x] - tf _ = [] diff --git a/src/Dodge/Update/Camera.hs b/src/Dodge/Update/Camera.hs index b88fc5d5e..590028935 100644 --- a/src/Dodge/Update/Camera.hs +++ b/src/Dodge/Update/Camera.hs @@ -13,40 +13,38 @@ import Dodge.Item.Attachment.Data import Geometry import Control.Lens -import Control.Monad import Data.Maybe import qualified Data.Set as S import qualified Data.IntMap.Strict as IM import qualified SDL - -{- -Update the screen camera rotation and position, including any in rold scope/remote camera modifiers; -update where your avatar's view is from. - -} +{- Update the screen camera rotation and position, including any in rold scope/remote camera modifiers; +update where your avatar's view is from. -} updateCamera :: World -> World -updateCamera = rotCam . moveCamera . updateScopeZoom - +updateCamera = rotCam . moveCamera . updateScopeZoom {- Updte the center of the screen camera center and where your avatar's view is from in world. -} moveCamera :: World -> World moveCamera w = w & cameraCenter .~ idealPos & cameraViewFrom .~ sightFrom where - aimRangeFactor | _cameraZoom w == 0 = 0 - | otherwise = fromMaybe 0 (yourItem w ^? itAimingRange) / _cameraZoom w - aimingMult | SDL.ButtonRight `S.member` _mouseButtons w = 1 - | otherwise = 0 + aimRangeFactor + | _cameraZoom w == 0 = 0 + | otherwise = fromMaybe 0 (yourItem w ^? itAimingRange) / _cameraZoom w + aimingMult + | SDL.ButtonRight `S.member` _mouseButtons w = 1 + | otherwise = 0 ypos = _crPos $ you w - idealOffset = rotateV (_cameraRot w) (aimRangeFactor * aimingMult *.* _mousePos w) - currentOffset = currentPos -.- camCenter + --idealOffset = rotateV (_cameraRot w) (aimRangeFactor * aimingMult *.* _mousePos w) + --currentOffset = currentPos -.- camCenter idealPos = camCenter +.+ rotateV (_cameraRot w) (aimRangeFactor * aimingMult *.* _mousePos w) - currentPos = _cameraCenter w + --currentPos = _cameraCenter w camCenter = ypos +.+ scope isCam :: Bool isCam = fromMaybe False $ yourItem w ^? itAttachment . _Just . scopeIsCamera scope = fromMaybe (0,0) $ yourItem w ^? itAttachment . _Just . scopePos - sightFrom | isCam = camCenter - | otherwise = ypos + sightFrom + | isCam = camCenter + | otherwise = ypos updateScopeZoom :: World -> World updateScopeZoom w @@ -73,6 +71,7 @@ updateScopeZoom w updateScope (ItScope _ _ _ bl) = ItScope (0,0) 0 1 bl updateScope otherAtt = otherAtt +zoomSpeed :: Float zoomSpeed = 39/40 zoomInLongGun :: World -> World @@ -96,16 +95,18 @@ zoomOutLongGun w wpPointer = creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) wp = _crInv (_creatures w IM.! 0) IM.! _crInvSel (_creatures w IM.! 0) Just currentZoom = wp ^? itAttachment . _Just . scopeZoom - currentCursorDisplacement = fromJust $ _itAttachment wp + --currentCursorDisplacement = fromJust $ _itAttachment wp +rotCam :: World -> World rotCam = rotateCameraL . rotateCameraR . zoomCamIn . zoomCamOut . autoZoomCam rotateCameraL :: World -> World -rotateCameraL w | rotateCameraPlusKey (_keyConfig w) `S.member` _keys w - = w & cameraRot +~ 0.015 - & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) +rotateCameraL w + | rotateCameraPlusKey (_keyConfig w) `S.member` _keys w + = w & cameraRot +~ 0.015 + & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0)) . itAttachment . _Just . scopePos %~ rotateV 0.015 - | otherwise = w + | otherwise = w rotateCameraR :: World -> World rotateCameraR w | rotateCameraMinusKey (_keyConfig w) `S.member` _keys w = w & cameraRot -~ 0.015 @@ -127,9 +128,7 @@ Automatically sets the zoom of the camera according to the surrounding walls. autoZoomCam :: World -> World autoZoomCam w = over cameraZoom changeZoom w where - maxViewDistance = 800 camPos = _cameraViewFrom w - camRot = _cameraRot w wallZoom = farWallDist camPos w idealZoom | SDL.ButtonRight `S.member` _mouseButtons w = scZoom * @@ -168,6 +167,5 @@ farWallDist cpos w = min (halfWidth w / (horizontalMax+50) ) (halfHeight w / (ve zs = takeWhile (< maxViewDistance) [-maxViewDistance,negate $ 0.75*maxViewDistance..] maxViewDistance = 800 - -dirRays :: Float -> [Point2] -dirRays dir = take 11 $ iterate (rotateV (0.5 * pi / 10)) $ rotateV (dir-pi*0.25) (600,0) +--dirRays :: Float -> [Point2] +--dirRays dir = take 11 $ iterate (rotateV (0.5 * pi / 10)) $ rotateV (dir-pi*0.25) (600,0) diff --git a/src/Dodge/WallCreatureCollisions.hs b/src/Dodge/WallCreatureCollisions.hs index e4bb9ae90..73b4ed057 100644 --- a/src/Dodge/WallCreatureCollisions.hs +++ b/src/Dodge/WallCreatureCollisions.hs @@ -20,9 +20,9 @@ colCrWall :: World -> Creature -> Creature colCrWall w c | p1 == p2 = pushOrCrush ls c | otherwise = c & crPos %~ - collideCorners rad p1 wallPoints + collideCorners rad wallPoints . collideWalls rad p1 ls - . checkPushThroughs rad p1 ls + . checkPushThroughs p1 ls where rad = _crRad c + wallBuffer p1 = _crOldPos c @@ -39,27 +39,28 @@ colCrWall w c -- -- probably best to push check pushing through walls before creature springs -- the amount to push creatures out from walls, extra to their radius +wallBuffer :: Float wallBuffer = 0 -- the following tests whether or not a point is on a wall, and if so pushes it -- out from the wall -- this is then repeated if the point ends up on a new wall collideWalls :: Float -> Point2 -> [(Point2,Point2)] -> Point2 -> Point2 -collideWalls rad cp1 walls cp2 = case (listToMaybe.mapMaybe (pushOutFromWall rad cp2)) walls of +collideWalls rad cp1 wls cp2 = case (listToMaybe.mapMaybe (pushOutFromWall rad cp2)) wls of Nothing -> cp2 - Just cp3 -> case (listToMaybe.reverse.mapMaybe (pushOutFromWall rad cp3)) walls of + Just cp3 -> case (listToMaybe.reverse.mapMaybe (pushOutFromWall rad cp3)) wls of Nothing -> cp3 Just cp4 -> 0.5 *.* (cp4 +.+ cp1) -- pushes a point out from a list of walls -- if multiple new points occur, chooses the one closest to the orignal point pushOutFromWalls :: Float -> [(Point2,Point2)] -> Point2 -> Point2 -pushOutFromWalls rad walls p = +pushOutFromWalls rad wls p = fromMaybe p . listToMaybe . sortBy (compare `on` dist p) $ mapMaybe (pushOutFromWall rad p) - walls + wls pushOrCrush :: [(Point2,Point2)] -> Creature -> Creature pushOrCrush wls cr = case mapMaybe (pushOutFromWall (_crRad cr) cpos) wls of @@ -81,8 +82,6 @@ pushOutFromWall rad cp2 (wp1,wp2) wp2' = (rad *.* norm) +.+ wp2 newP = errorClosestPointOnLine 5 wp1' wp2' cp2 isOnWall = circOnSegNoEndpoints wp1 wp2 cp2 rad - isJust Nothing = False - isJust _ = True pushOutFromCorners :: World -> Creature -> Creature pushOutFromCorners w cr = cr & crPos .~ newPos @@ -90,8 +89,8 @@ pushOutFromCorners w cr = cr & crPos .~ newPos newPos = foldr (intersectCirclePoint (_crRad cr)) (_crPos cr) ls ls = nub . concatMap (\(x,y) -> [x,y]) . IM.elems $ _wlLine <$> wallsNearPoint (_crPos cr) w -collideCorners :: Float -> Point2 -> [Point2] -> Point2 -> Point2 -collideCorners rad p1 ps p2 = foldr (intersectCirclePoint rad) p2 ps +collideCorners :: Float -> [Point2] -> Point2 -> Point2 +collideCorners rad ps p2 = foldr (intersectCirclePoint rad) p2 ps -- collide circles with points (outer corners) intersectCirclePoint :: Float -> Point2 -> Point2 -> Point2 @@ -99,19 +98,17 @@ intersectCirclePoint rad p cCen | dist cCen p > rad = cCen | otherwise = p +.+ (rad *.* errorNormalizeV 65 (cCen -.- p)) -checkPushThroughs :: Float -> Point2 -> [(Point2,Point2)] -> Point2 -> Point2 -checkPushThroughs rad cp1 walls cp2 - = fromMaybe cp2 $ (listToMaybe.mapMaybe (checkPushThrough rad cp1 cp2)) walls +checkPushThroughs :: Point2 -> [(Point2,Point2)] -> Point2 -> Point2 +checkPushThroughs cp1 wls cp2 + = fromMaybe cp2 $ (listToMaybe.mapMaybe (checkPushThrough cp1 cp2)) wls -checkPushThrough :: Float -> Point2 -> Point2 -> (Point2,Point2) -> Maybe Point2 -checkPushThrough rad cp1 cp2 (wp1,wp2) +checkPushThrough :: Point2 -> Point2 -> (Point2,Point2) -> Maybe Point2 +checkPushThrough cp1 cp2 (wp1,wp2) | isPushedThrough = intersectSegSeg' cp1 cp2 wp1 wp2 | otherwise = Nothing where - norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2) - wp1' = (rad *.* norm) +.+ wp1 - wp2' = (rad *.* norm) +.+ wp2 - newP = errorClosestPointOnLine 5 wp1' wp2' cp2 + --norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2) + --wp1' = (rad *.* norm) +.+ wp1 + --wp2' = (rad *.* norm) +.+ wp2 + --newP = errorClosestPointOnLine 5 wp1' wp2' cp2 isPushedThrough = isRHS wp1 wp2 cp2 && isJust (intersectSegSeg' cp1 cp2 wp1 wp2) - isJust Nothing = False - isJust _ = True diff --git a/src/Dodge/WorldEvent.hs b/src/Dodge/WorldEvent.hs index f4b00f748..184815132 100644 --- a/src/Dodge/WorldEvent.hs +++ b/src/Dodge/WorldEvent.hs @@ -3,40 +3,30 @@ module Dodge.WorldEvent , module Dodge.WorldEvent.Bullet , module Dodge.WorldEvent.Flash , module Dodge.WorldEvent.ThingsHit - , module Dodge.WorldEvent.HelperParticle , module Dodge.WorldEvent.Cloud , module Dodge.WorldEvent.HitEffect , module Dodge.WorldEvent.Explosion , module Dodge.WorldEvent.SpawnParticle ) where - import Dodge.WorldEvent.Bullet import Dodge.WorldEvent.Flash import Dodge.WorldEvent.ThingsHit -import Dodge.WorldEvent.HelperParticle +--import Dodge.WorldEvent.HelperParticle import Dodge.WorldEvent.Cloud import Dodge.WorldEvent.HitEffect import Dodge.WorldEvent.Explosion import Dodge.WorldEvent.SpawnParticle -import Dodge.WorldEvent.Shockwave +--import Dodge.WorldEvent.Shockwave import Dodge.LightSources import Dodge.Creature.State.Data import Dodge.Data -import Dodge.Base -import Dodge.SoundLogic -import Dodge.RandomHelp +--import Dodge.Base import Geometry -import Picture +--import Picture import Control.Lens -import Control.Monad.State - import System.Random - -import Data.Maybe -import Data.Function -import Data.List import qualified Data.IntMap.Strict as IM createBarrelSpark :: Point2 -> Float -> Maybe Int -> Int -> Int -> World -> World diff --git a/src/Dodge/WorldEvent/Bullet.hs b/src/Dodge/WorldEvent/Bullet.hs index 6dd927ede..cee31a711 100644 --- a/src/Dodge/WorldEvent/Bullet.hs +++ b/src/Dodge/WorldEvent/Bullet.hs @@ -4,20 +4,16 @@ Bullet update. module Dodge.WorldEvent.Bullet where import Dodge.Data -import Dodge.Base - +--import Dodge.Base import Dodge.WorldEvent.ThingsHit - -import Picture +--import Picture import Geometry import Control.Lens - -import Data.Maybe -import Data.List -import Data.Function (on) -import Data.Bifunctor -import qualified Data.IntMap.Strict as IM +--import Data.Maybe +--import Data.List +--import Data.Bifunctor +--import qualified Data.IntMap.Strict as IM {- Update for a generic bullet. @@ -32,9 +28,7 @@ mvGenBullet' w bt | otherwise = hiteff bt (thingsHitExceptCr mcr p (p +.+ vel) w) w where mcr = _btPassThrough' bt - col = _btColor' bt (p:ps) = _btTrail' bt vel = _btVel' bt hiteff = _btHitEffect' bt - wth = _btWidth' bt t = _btTimer' bt diff --git a/src/Dodge/WorldEvent/Cloud.hs b/src/Dodge/WorldEvent/Cloud.hs index c4dbba4a8..6369f8b46 100644 --- a/src/Dodge/WorldEvent/Cloud.hs +++ b/src/Dodge/WorldEvent/Cloud.hs @@ -3,9 +3,7 @@ module Dodge.WorldEvent.Cloud import Dodge.Data import Dodge.Base - -import Geometry - +--import Geometry import Picture import Control.Lens diff --git a/src/Dodge/WorldEvent/DamageBlock.hs b/src/Dodge/WorldEvent/DamageBlock.hs new file mode 100644 index 000000000..837adcab0 --- /dev/null +++ b/src/Dodge/WorldEvent/DamageBlock.hs @@ -0,0 +1,16 @@ +module Dodge.WorldEvent.DamageBlock + ( damageBlocksBy + ) + where +import Dodge.Data + +import Data.Maybe +import Control.Lens +{- | Given a wall, if it is a damageable block + - then damage it and connecting walls by a certain amount. -} +damageBlocksBy :: Int -> Wall -> World -> World +{-# INLINE damageBlocksBy #-} +damageBlocksBy x wall w + | isJust (wall ^? blHP) = foldr (\j -> walls . ix j . blHP -~ x) w (_blIDs wall) + | otherwise = w + diff --git a/src/Dodge/WorldEvent/Explosion.hs b/src/Dodge/WorldEvent/Explosion.hs index 95611aa22..d5fab863c 100644 --- a/src/Dodge/WorldEvent/Explosion.hs +++ b/src/Dodge/WorldEvent/Explosion.hs @@ -3,7 +3,6 @@ Explosions: creation of shockwave and particles at a given point. -} module Dodge.WorldEvent.Explosion where - import Dodge.Data import Dodge.Base import Dodge.WorldEvent.SpawnParticle @@ -16,7 +15,7 @@ import Picture import Control.Monad.State import Data.List -import Data.Maybe +--import Data.Maybe import System.Random import qualified Data.IntMap.Strict as IM import Control.Lens @@ -78,6 +77,6 @@ makeExplosionAt p w times = randomRs (20,25) $ _randGen w mF q v size time = makeFlameletTimed q v Nothing size time newFs = zipWith4 mF fPs (fmap (3 *.*) fVs') sizes times - addFlames w = foldr ($) w newFs + addFlames w' = foldr ($) w' newFs pushAgainstWalls q = maybe q (uncurry (+.+)) $ reflectPointWalls p q $ wallsNearPoint q w diff --git a/src/Dodge/WorldEvent/Flash.hs b/src/Dodge/WorldEvent/Flash.hs index cf336af1d..d65f2d820 100644 --- a/src/Dodge/WorldEvent/Flash.hs +++ b/src/Dodge/WorldEvent/Flash.hs @@ -11,18 +11,15 @@ flicker : potentially long, moving, abrupt changes in alpha module Dodge.WorldEvent.Flash where import Dodge.Data -import Dodge.Base +--import Dodge.Base import Dodge.Picture import Dodge.LightSources - import Dodge.WorldEvent.ThingsHit import Dodge.WorldEvent.HelperParticle - import Picture import Geometry import Data.Maybe (maybeToList) - import Control.Lens glareAt :: Int -> Float -> Float -> Color -> Int -> Float -> Point2 -> World -> World @@ -70,12 +67,13 @@ lowLightPic :: Float -> Float -> Color -> (Point2, Point2) -> World -> Picture lowLightPic len wdth col (a,b) w = case thingsHit a b w of ((p, E3x2 wall):_) -> setCol . lineOfThickness wdth $ [alongSegBy len p wa, alongSegBy len p wb] - where x = len *.* normalizeV (wa -.- wb) - (wa,wb) = _wlLine wall + where + (wa,wb) = _wlLine wall ((p, E3x1 cr):_) -> setCol . uncurry translate cp . rotate (-0.25 * pi + argV (p -.- cp)) $ thickArc 0 (pi/2) (_crRad cr) wdth - where cp = _crPos cr + where + cp = _crPos cr _ -> blank where setCol = color col . setDepth (-0.5) . setLayer 2 @@ -93,6 +91,7 @@ explosionFlashAt p = over tempLightSources ((:) $ tLightFade 20 150 intensityFu | x < 10 = 1 / (10 - fromIntegral x) | otherwise = 1 +flameGlareAt :: Point2 -> World -> World flameGlareAt = glareAt 1 10 5 (withAlpha 0.05 orange) 8 40 lowLightDirected :: Color -> Point2 -> Point2 -> [Float] -> World -> World diff --git a/src/Dodge/WorldEvent/HelperParticle.hs b/src/Dodge/WorldEvent/HelperParticle.hs index cbef753e5..c0dda26b8 100644 --- a/src/Dodge/WorldEvent/HelperParticle.hs +++ b/src/Dodge/WorldEvent/HelperParticle.hs @@ -1,14 +1,9 @@ -{- -Helper functions for particles. --} +{- Helper functions for particles. -} module Dodge.WorldEvent.HelperParticle where - import Dodge.Data -{- -A simple timer update for particles. --} +{- A simple timer update for particles. -} ptTimer' :: Int -> World -> Particle -> (World, Maybe Particle) -ptTimer' 0 w pt = (w, Nothing) +ptTimer' 0 w _ = (w, Nothing) ptTimer' n w pt = (w, Just $ pt {_ptUpdate' = ptTimer' (n-1)}) diff --git a/src/Dodge/WorldEvent/HitEffect.hs b/src/Dodge/WorldEvent/HitEffect.hs index 4183fa2c4..22d4bfd80 100644 --- a/src/Dodge/WorldEvent/HitEffect.hs +++ b/src/Dodge/WorldEvent/HitEffect.hs @@ -2,21 +2,25 @@ module Dodge.WorldEvent.HitEffect where import Dodge.Data import Dodge.Creature.State.Data - import Geometry import Data.Bifunctor import Data.Maybe - import Control.Lens type HitCreatureEffect = Particle -> Point2 -> Creature -> World -> World type HitWallEffect = Particle -> Point2 -> Wall -> World -> World type HitForceFieldEffect = Particle -> Point2 -> ForceField -> World -> World -passThroughAll :: HitCreatureEffect -> HitWallEffect -> HitForceFieldEffect -> - Particle -> [(Point2, Either3 Creature Wall ForceField)] -> World -> (World, Maybe Particle) -passThroughAll crEff wlEff ffEff pt hitThings w = (w, mvPt) +passThroughAll + :: HitCreatureEffect + -> HitWallEffect + -> HitForceFieldEffect + -> Particle + -> [(Point2, Either3 Creature Wall ForceField)] -- ^ hit things + -> World + -> (World, Maybe Particle) +passThroughAll _ _ _ pt _ w = (w, mvPt) where mvPt = Just $ pt & btTrail' .~ (newP : trl) & btTimer' %~ (\t -> t - 1) @@ -24,24 +28,38 @@ passThroughAll crEff wlEff ffEff pt hitThings w = (w, mvPt) trl = _btTrail' pt newP = head trl +.+ _btVel' pt -destroyOnImpact :: HitCreatureEffect -> HitWallEffect -> HitForceFieldEffect -> - Particle -> [(Point2, Either3 Creature Wall ForceField)] -> World -> (World, Maybe Particle) +destroyOnImpact + :: HitCreatureEffect + -> HitWallEffect + -> HitForceFieldEffect + -> Particle + -> [(Point2, Either3 Creature Wall ForceField)] + -> World + -> (World, Maybe Particle) destroyOnImpact crEff wlEff ffEff pt hitThings w = case hitThings of [] -> ( w, mvPt) ((p,E3x1 cr):_) -> (crEff pt p cr w, destroyAt p) ((p,E3x2 wl):_) -> (wlEff pt p wl w, destroyAt p) ((p,E3x3 ff):_) -> (ffEff pt p ff w, destroyAt p) - where destroyAt hitp = Just $ pt & btTrail' .~ (hitp : trl) - & btTimer' .~ 3 - mvPt = Just $ pt & btTrail' .~ (newP : trl) - & btTimer' %~ (\t -> t - 1) - & btPassThrough' .~ Nothing - trl = _btTrail' pt - wth = _btWidth' pt - newP = head trl +.+ _btVel' pt + where + destroyAt hitp = Just $ pt + & btTrail' .~ (hitp : trl) + & btTimer' .~ 3 + mvPt = Just $ pt + & btTrail' .~ (newP : trl) + & btTimer' %~ (\t -> t - 1) + & btPassThrough' .~ Nothing + trl = _btTrail' pt + newP = head trl +.+ _btVel' pt -penWalls :: HitCreatureEffect -> HitWallEffect -> HitForceFieldEffect -> - Particle -> [(Point2, Either3 Creature Wall ForceField)] -> World -> (World, Maybe Particle) +penWalls + :: HitCreatureEffect + -> HitWallEffect + -> HitForceFieldEffect + -> Particle + -> [(Point2, Either3 Creature Wall ForceField)] + -> World + -> (World, Maybe Particle) penWalls crEff wlEff ffEff pt hitThings w = case hitThings of [] -> ( w, mvPt) ((p,E3x1 cr):_) -> (crEff pt p cr w, destroyAt p) @@ -49,19 +67,23 @@ penWalls crEff wlEff ffEff pt hitThings w = case hitThings of ((p,E3x2 wl):hs) | isJust (wl ^? blHP) -> first (wlEff pt p wl) $ penWalls crEff wlEff ffEff pt hs w ((p,E3x2 wl):_) | otherwise -> (wlEff pt p wl w, destroyAt p) - where destroyAt hitp = Just $ pt & btTrail' .~ (hitp : trl) - & btTimer' .~ 3 - mvPt = Just $ pt & btTrail' .~ (newP : trl) - & btTimer' %~ (\t -> t - 1) - & btPassThrough' .~ Nothing - trl = _btTrail' pt - wth = _btWidth' pt - newP = head trl +.+ _btVel' pt + where + destroyAt hitp = Just $ pt + & btTrail' .~ (hitp : trl) + & btTimer' .~ 3 + mvPt = Just $ pt + & btTrail' .~ (newP : trl) + & btTimer' %~ (\t -> t - 1) + & btPassThrough' .~ Nothing + trl = _btTrail' pt + newP = head trl +.+ _btVel' pt doFlameDam :: Int -> Particle -> Point2 -> Creature -> World -> World doFlameDam amount pt p cr = over (creatures . ix (_crID cr) . crState . crDamage) - ((:) $ Flaming amount sp p ep) - where sp = _btPos' pt - ep = sp +.+ _btVel' pt + ((:) $ Flaming amount sp p ep) + where + sp = _btPos' pt + ep = sp +.+ _btVel' pt +noEff :: a -> b -> c -> d -> d noEff _ _ _ = id diff --git a/src/Dodge/WorldEvent/Shockwave.hs b/src/Dodge/WorldEvent/Shockwave.hs index 911611f45..2017a1f11 100644 --- a/src/Dodge/WorldEvent/Shockwave.hs +++ b/src/Dodge/WorldEvent/Shockwave.hs @@ -4,6 +4,7 @@ module Dodge.WorldEvent.Shockwave ) where import Dodge.Data +import Dodge.WorldEvent.DamageBlock import Dodge.Creature.State.Data import Dodge.Base import Dodge.Picture.Layer @@ -72,14 +73,8 @@ mvShockwave is w pt t = _btTimer' pt tFraction = fromIntegral t / fromIntegral (_btMaxTime' pt) rad = r - (3/4) * r * tFraction - dams = over creatures (IM.map damCr) . flip (IM.foldr damageBlocks) hitBlocks + dams = over creatures (IM.map damCr) . flip (IM.foldr (damageBlocksBy 1)) hitBlocks hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w - damageBlocks wall w - = case wall ^? blHP of - Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1)) - w - (_blIDs wall) - _ -> w damCr cr | _crID cr `elem` is = cr | dist (_crPos cr) p < rad + _crRad cr = over (crState . crDamage) @@ -100,7 +95,7 @@ inverseShockwaveAt -> Float -- Push amount parameter -> World -> World -inverseShockwaveAt p rad dam push pushexp = over particles (theShockwave :) +inverseShockwaveAt p rad _ push pushexp = over particles (theShockwave :) where theShockwave = Particle { _ptDraw = const blank @@ -124,14 +119,8 @@ moveInverseShockWave t p r push pushexp w pt $ color cyan $ thickCircle rad thickness) rad = r - (4/40) * r * fromIntegral (10 - t) thickness = fromIntegral (10 - t) **2 * rad / 40 - dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks + dams = over creatures (IM.map damCr) . flip (foldr (damageBlocksBy 1)) hitBlocks hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w - damageBlocks wall w - = case wall ^? blHP of - Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1)) - w - (_blIDs wall) - _ -> w damCr cr | dist (_crPos cr) p < rad + _crRad cr = over (crState . crDamage) ((:) $ PushDam 1 (25 *.* safeNormalizeV (p -.- _crPos cr))) diff --git a/src/Dodge/WorldEvent/Sound.hs b/src/Dodge/WorldEvent/Sound.hs index 5f0b22833..fcacc1be1 100644 --- a/src/Dodge/WorldEvent/Sound.hs +++ b/src/Dodge/WorldEvent/Sound.hs @@ -1,8 +1,6 @@ module Dodge.WorldEvent.Sound where import Dodge.Data -import Geometry.Data (Point2) - import Dodge.SoundLogic import System.Random diff --git a/src/Dodge/WorldEvent/SpawnParticle.hs b/src/Dodge/WorldEvent/SpawnParticle.hs index 1f0907130..8e00c537c 100644 --- a/src/Dodge/WorldEvent/SpawnParticle.hs +++ b/src/Dodge/WorldEvent/SpawnParticle.hs @@ -12,7 +12,6 @@ import Dodge.WorldEvent.HitEffect import Dodge.WorldEvent.ThingsHit import Dodge.WorldEvent.Cloud import Dodge.WorldEvent.Flash -import Dodge.WorldEvent.HelperParticle import Dodge.WorldEvent.Bullet import Dodge.SoundLogic import Dodge.RandomHelp @@ -98,7 +97,7 @@ moveFlame moveFlame rotd w pt | time <= 0 = (smokeGen w, Nothing) | otherwise = case thingsHitExceptCr (_btPassThrough' pt) sp ep w of - ((p,E3x1 cr):_) -> (soundAndGlare damcrs , mvPt') + ((_,E3x1 _):_) -> (soundAndGlare damcrs , mvPt') (thing@(p,E3x2 wl):_) -> (fst $ hiteff [thing] damcrs , rfl wl p) _ -> (soundAndGlare damcrs , mvPt) where @@ -198,12 +197,8 @@ drawFlamelet rot pt = setLayer 1 $ pictures [pic , piu , pi2 , glow] sc = (*) 2 $ log $ 1 + fromIntegral time / 20 s1 = (*) 2 $ log $ 2 + fromIntegral time / 40 s2 = 0.5 * (sc + s1) - thepicture = pictures [pic , piu , pi2 , glow] - -{- -Update of a flamelet. -Applies movement and attaches damage to nearby creatures. - -} +{- Update of a flamelet. +Applies movement and attaches damage to nearby creatures. -} moveFlamelet :: World -> Particle -> (World, Maybe Particle) moveFlamelet w pt | _btTimer' pt <= 0 = ( w, Nothing) @@ -297,11 +292,10 @@ moveTeslaArc p d i w = f1 (E3x1 cr) = Just $ _crID cr f1 _ = Nothing hitCrs = mapMaybe f1 $ take 14 $ crsLightChain p d 0 w - damCrs i = over (creatures . ix i . crHP) (\hp -> hp - 5) + damCrs cid = over (creatures . ix cid . crHP) (\hp -> hp - 5) f2 0 = cyan f2 1 = azure f2 _ = white - sID = newProjectileKey w q1 = last $ init ps' q2 = last ps' hitWall = reflectPointWalls q1 ((2 *.* q2) -.- q1) $ wallsNearPoint q1 w @@ -372,13 +366,11 @@ crOrWallSensitive p dir wlAttract w = g (E3x2 p1) = 100 + dist p p1 -- tweak makes it more likely to hit crs first --g (E3x2 p1) = dist p p1 - 100 -- tweak makes it more likely to hit walls first g (E3x1 cr1) = dist p $ _crPos cr1 + g _ = 0 (arcLen,_) = randomR (25,50) $ _randGen w -- BUG: can hit crs through walls - -{- -Finds whether a creature or wall is in front of a given point and direction. -Evaluates to a creature as an 'E3x1' or a wall as an 'E3x2'. - -} +{- Finds whether a creature or wall is in front of a given point and direction. +Evaluates to a creature as an 'E3x1' or a wall as an 'E3x2'. -} crOrWall :: Point2 -> Float -> World -> Either3 Creature Point2 Point2 crOrWall p dir w = fromMaybe (E3x3 $ p +.+ rotateV dir (arcLen,0)) $ listToMaybe $ sortBy (compare `on` g) @@ -400,8 +392,8 @@ crOrWall p dir w = fromMaybe (E3x3 $ p +.+ rotateV dir (arcLen,0)) g (E3x2 p1) = 100 + dist p p1 -- tweak makes it more likely to hit crs first --g (E3x2 p1) = dist p p1 - 100 -- tweak makes it more likely to hit walls first g (E3x1 cr1) = dist p $ _crPos cr1 + g _ = 0 (arcLen,_) = randomR (25,50) $ _randGen w - -- | Create a spark. -- If the spark is created by another Particle, it cannot be directly added to -- the list, hence the redirect through worldEvents. @@ -409,7 +401,7 @@ createSpark :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World createSpark time colid pos dir maycid w = w & worldEvents %~ ( (over particles (spark :) . sparkFlashAt pos') . ) where - spark = Bul' + spark = Bul' { _ptDraw = drawBul , _ptUpdate' = mvGenBullet' , _btVel' = rotateV dir (5,0) @@ -428,4 +420,6 @@ createSpark time colid pos dir maycid w ep = sp +.+ _btVel' bt drawBul :: Particle -> Picture -drawBul pt = setLayer 1 . color white $ thickLine (take 2 $ _btTrail' pt) (_btWidth' pt) +drawBul pt = setLayer 1 . color thecolor $ thickLine (take 2 $ _btTrail' pt) (_btWidth' pt) + where + thecolor = _btColor' pt diff --git a/src/Dodge/WorldEvent/ThingsHit.hs b/src/Dodge/WorldEvent/ThingsHit.hs index 54651412c..074dce9cd 100644 --- a/src/Dodge/WorldEvent/ThingsHit.hs +++ b/src/Dodge/WorldEvent/ThingsHit.hs @@ -10,7 +10,6 @@ import Geometry import qualified Data.IntMap.Strict as IM import Data.List import Data.Maybe -import Data.Function (on) {- List those objects that appear on a line. -} thingsHit :: Point2 -- ^ Line start point @@ -19,7 +18,7 @@ thingsHit -> [(Point2, Either3 Creature Wall ForceField)] thingsHit sp ep w | sp == ep = [] - | otherwise = sortBy (compare `on` dist sp . fst) (crs ++ walls ++ ffs) + | otherwise = sortOn (dist sp . fst) (crs ++ wls ++ ffs) where hitCrs = IM.elems $ IM.filter (\cr -> circOnSeg sp ep (_crPos cr) (_crRad cr)) @@ -33,8 +32,8 @@ thingsHit sp ep w f i m = case IM.lookup i m of Just val -> val _ -> IM.empty - walls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls) - hitPoint w = uncurry (intersectSegSeg' sp ep) (_wlLine w) + wls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls) + hitPoint w' = uncurry (intersectSegSeg' sp ep) (_wlLine w') hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w) ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs {- List objects that appear on a line. @@ -66,7 +65,7 @@ thingsHitExceptCrLongLine (Just cid) sp ep = filter crNotCid . thingsHitLongLine thingsHitLongLine :: Point2 -> Point2 -> World -> [(Point2, Either3 Creature Wall ForceField)] thingsHitLongLine sp ep w | sp == ep = [] - | otherwise = sortOn (dist sp . fst) (crs ++ walls ++ ffs) + | otherwise = sortOn (dist sp . fst) (crs ++ wls ++ ffs) where crs = zip crPs (map E3x1 hitCrs) hitCrs = IM.elems @@ -74,7 +73,7 @@ thingsHitLongLine sp ep w $ _creatures w -- $ creaturesAlongLine sp ep w crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs - walls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls) + wls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls) hitWls = wallsOnLine sp ep $ wallsAlongLine sp ep w hitPoint wl = uncurry (intersectSegSeg' sp ep) (_wlLine wl) hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w) diff --git a/src/DoubleStack.hs b/src/DoubleStack.hs index 8ed55ddb0..cf754b653 100644 --- a/src/DoubleStack.hs +++ b/src/DoubleStack.hs @@ -8,11 +8,14 @@ newtype DS a = DS (a,[a],[a]) Unsafe. -} fromListL :: [a] -> DS a fromListL (x:xs) = DS (x,xs,[]) +fromListL _ = undefined singleton :: a -> DS a singleton x = DS (x,[],[]) +head :: DS a -> a head (DS (x,_,_)) = x +left, right :: DS a -> [a] left (DS (_,l,_)) = l right (DS (_,_,r)) = r diff --git a/src/Geometry/Data.hs b/src/Geometry/Data.hs index 9a3adf4ad..68a9f27bf 100644 --- a/src/Geometry/Data.hs +++ b/src/Geometry/Data.hs @@ -1,7 +1,7 @@ module Geometry.Data - ( Point2 (..) - , Point3 (..) - , Point4 (..) + ( Point2 + , Point3 + , Point4 ) where type Point2 = (Float,Float) diff --git a/src/Picture/Preload.hs b/src/Picture/Preload.hs index bce688260..73cd0ba2b 100644 --- a/src/Picture/Preload.hs +++ b/src/Picture/Preload.hs @@ -1,20 +1,18 @@ {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} module Picture.Preload ( RenderData (..) , preloadRender , cleanUpRenderPreload ) where - import Picture.Data import Shader -import Geometry (Point2,Point3,Point4) - -import Graphics.Rendering.OpenGL hiding (Point (..),translate,scale,imageHeight,imageWidth) +import Geometry.Data +import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight) import Control.Lens import Foreign - import qualified Control.Foldl as F data RenderData = RenderData @@ -34,7 +32,6 @@ data RenderData = RenderData , _fbo2 :: (FramebufferObject, TextureObject, RenderbufferObject) , _fbo3 :: (FramebufferObject, TextureObject, RenderbufferObject) } - makeLenses ''RenderData preloadRender :: IO RenderData @@ -187,7 +184,7 @@ pokeBezQStrat (RenderBezQ vs) = fmap (\((x,y,z),(r,g,b,a),(s,t,u,v)) -> [[x,y,z] pokeBezQStrat _ = [] {-# INLINE pokeTriStrat #-} -pokeTriStrat :: RenderType -> [[[Float]]] +pokeTriStrat,pokeCharStrat,pokeArcStrat,pokeLineStrat,pokeEllStrat :: RenderType -> [[[Float]]] pokeTriStrat (RenderPoly vs) = fmap (\((x,y,z),(r,g,b,a)) -> [[x,y,z],[r,g,b,a]]) vs pokeTriStrat _ = [] @@ -203,6 +200,7 @@ pokeLineStrat _ = [] pokeEllStrat (RenderEllipse vs) = fmap (\((x,y,z),(r,g,b,a)) -> [[x,y,z],[r,g,b,a]]) vs pokeEllStrat _ = [] +vert, geom, frag :: ShaderType vert = VertexShader geom = GeometryShader frag = FragmentShader @@ -215,4 +213,3 @@ pokeWPColStrat (((x,y),(z,w)),(r,g,b,a)) = [[[x,y,z,w],[r,g,b,a]]] pokeBGStrat :: a -> [[[Float]]] pokeBGStrat = const [] - diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs index 5a6111d13..6b0e9e937 100644 --- a/src/Picture/Render.hs +++ b/src/Picture/Render.hs @@ -9,21 +9,21 @@ module Picture.Render where import Shader -import MatrixHelper +--import MatrixHelper import Picture.Preload import Picture.Data import Picture.Tree import Geometry -import Control.Lens +--import Control.Lens import Control.Monad import qualified Control.Foldl as F import Foreign hiding (rotate) -import Graphics.Rendering.OpenGL hiding (Line,translate,scale,imageHeight,imageWidth,Polygon,Color,T) -import Data.Foldable +import Graphics.Rendering.OpenGL hiding (Line,translate,scale,imageHeight,Polygon,Color,T) +--import Data.Foldable import Data.Tuple.Extra import Data.Maybe (fromJust) -import qualified Data.IntMap.Strict as IM +--import qualified Data.IntMap.Strict as IM import qualified SDL setWallDepth @@ -190,7 +190,7 @@ renderBackground -> (Float,Float) -- Translation -> (Float,Float) -- Window size -> IO () -renderBackground pdata rot zoom (tranx,trany) (winx,winy) = do +renderBackground pdata rot camZoom (tranx,trany) (winx,winy) = do -- depthFunc $= Just Less -- set drawing for on top --blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One)) @@ -200,7 +200,7 @@ renderBackground pdata rot zoom (tranx,trany) (winx,winy) = do bindVertexArrayObject $= Just (_vao $ _shaderVAO $ _backgroundShader pdata) let backPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _shaderVAO $ _backgroundShader pdata backPtr2 = (\(_,x,_) -> x) $ _vaoBufferTargets (_shaderVAO $ _backgroundShader pdata) !! 1 - pokeFourOff backPtr 0 (tranx,trany,rot,zoom) + pokeFourOff backPtr 0 (tranx,trany,rot,camZoom) pokeTwoOff backPtr2 0 (winx,winy) textureBinding Texture2D $= _textureObject <$> _shaderTexture (_backgroundShader pdata) drawArrays Points 0 1 @@ -212,8 +212,8 @@ setCommonUniforms -> (Float,Float) -- ^ Translation -> (Float,Float) -- ^ Window size -> IO () -setCommonUniforms pdata rot zoom (tranx,trany) (winx,winy) = do - setShaderUniforms rot zoom (tranx,trany) (winx,winy) +setCommonUniforms pdata rot camZoom (tranx,trany) (winx,winy) = do + setShaderUniforms rot camZoom (tranx,trany) (winx,winy) ( extractProgAndUnis (_lightingFloorShader pdata) : extractProgAndUnis (_lightingOccludeShader pdata) : extractProgAndUnis (_lightingWallShader pdata) diff --git a/src/Preload.hs b/src/Preload.hs index e43222568..5416a69ca 100644 --- a/src/Preload.hs +++ b/src/Preload.hs @@ -9,8 +9,8 @@ import Preload.Update import Picture.Preload import Sound.Data -import Control.Lens -import GHC.Word (Word32) +--import Control.Lens +--import GHC.Word (Word32) import qualified SDL.Mixer as Mix @@ -20,4 +20,4 @@ cleanUpPreload pd = do cleanUpSoundPreload $ _soundData pd cleanUpSoundPreload :: SoundData a -> IO () -cleanUpSoundPreload sd = Mix.closeAudio +cleanUpSoundPreload _ = Mix.closeAudio