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

Cleanup warnings

Browse Source
This commit is contained in:
jgk
2021-05-17 22:39:18 +02:00
parent d7fcdbf550
commit 69f915a894
102 changed files with 1243 additions and 1185 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base.hs
+38 -13
View File
@@ -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)
src/Dodge/Base/Collide.hs
+3 -6
View File
@@ -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
src/Dodge/Base/Window.hs
+2 -1
View File
@@ -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
src/Dodge/Config/Data.hs
+2 -4
View File
@@ -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
src/Dodge/Config/KeyConfig.hs
+85 -82
View File
@@ -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
src/Dodge/Config/Update.hs
+1 -2
View File
@@ -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.
-}
src/Dodge/Creature.hs
+21 -49
View File
@@ -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
src/Dodge/Creature/Action.hs
+12 -12
View File
@@ -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
src/Dodge/Creature/Action/Flee.hs
+1 -1
View File
@@ -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
src/Dodge/Creature/ActionRat.hs
+57 -29
View File
@@ -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
src/Dodge/Creature/AutoCrit.hs
+52
View File
@@ -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
}
src/Dodge/Creature/ImpulseRat.hs
+16 -12
View File
@@ -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
src/Dodge/Creature/Inanimate.hs
+2 -1
View File
@@ -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
src/Dodge/Creature/LauncherCrit.hs
+4 -4
View File
@@ -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
src/Dodge/Creature/LtAutoCrit.hs
+7 -8
View File
@@ -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)
src/Dodge/Creature/Picture.hs
+10 -9
View File
@@ -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)]
src/Dodge/Creature/PistolCrit.hs
+16 -16
View File
@@ -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 = []
src/Dodge/Creature/Rationality.hs
+23 -32
View File
@@ -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
src/Dodge/Creature/SetTarget.hs
+7
View File
@@ -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
src/Dodge/Creature/SpreadGunCrit.hs
+24 -26
View File
@@ -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 = []
src/Dodge/Creature/State.hs
+23 -29
View File
@@ -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
src/Dodge/Creature/State/Data.hs
+1 -1
View File
@@ -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
src/Dodge/Creature/SwarmCrit.hs
+9 -11
View File
@@ -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
src/Dodge/Creature/Update.hs
+1 -1
View File
@@ -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 )
src/Dodge/Creature/YourControl.hs
+7 -7
View File
@@ -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
src/Dodge/Data.hs
+5 -11
View File
@@ -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)
src/Dodge/Debug.hs
+1 -2
View File
@@ -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
src/Dodge/Default.hs
+23 -9
View File
@@ -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
src/Dodge/Event.hs
+18 -25
View File
@@ -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
src/Dodge/Event/Keyboard.hs
+4 -3
View File
@@ -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
src/Dodge/Event/Menu.hs
+6 -3
View File
@@ -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
src/Dodge/Event/Test.hs
+8 -9
View File
@@ -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
src/Dodge/Floor.hs
+22 -22
View File
@@ -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]
src/Dodge/Graph.hs
-1
View File
@@ -1,6 +1,5 @@
module Dodge.Graph
where
import Data.Function (on)
import Data.List.Extra
import Data.Bifunctor (first)
src/Dodge/Initialisation.hs
+1 -6
View File
@@ -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
src/Dodge/Inventory.hs
+5 -16
View File
@@ -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
src/Dodge/Item.hs
+5 -4
View File
@@ -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)]
src/Dodge/Item/Attachment.hs
+13 -13
View File
@@ -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
src/Dodge/Item/Equipment.hs
+60
View File
@@ -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
}
src/Dodge/Item/Weapon.hs
+59 -85
View File
@@ -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
src/Dodge/Item/Weapon/Bullet.hs
+22 -46
View File
@@ -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
src/Dodge/Item/Weapon/Decoration.hs
+1 -1
View File
@@ -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
src/Dodge/Item/Weapon/ExtraEffect.hs
+11 -7
View File
@@ -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)
src/Dodge/Item/Weapon/Grenade.hs
+7 -7
View File
@@ -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)
src/Dodge/Item/Weapon/InventoryDisplay.hs
+3 -8
View File
@@ -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
src/Dodge/Item/Weapon/Laser.hs
+9 -8
View File
@@ -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
src/Dodge/Item/Weapon/TriggerType.hs
+4 -7
View File
@@ -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
src/Dodge/Item/Weapon/UseEffect.hs
+7 -9
View File
@@ -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
src/Dodge/Layout.hs
+5 -15
View File
@@ -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 =
src/Dodge/Layout/Generate.hs
+3 -3
View File
@@ -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
src/Dodge/Layout/Tree.hs
+3 -3
View File
@@ -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
src/Dodge/Layout/Tree/Either.hs
+2 -1
View File
@@ -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
src/Dodge/Layout/Tree/Shift.hs
+2 -2
View File
@@ -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.
-}
src/Dodge/LevelGen.hs
+25 -12
View File
@@ -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
src/Dodge/LevelGen/AutoDoor.hs
+11 -9
View File
@@ -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
src/Dodge/LevelGen/Block.hs
+19 -15
View File
@@ -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"
src/Dodge/LevelGen/InnerWalls.hs
+5 -7
View File
@@ -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
src/Dodge/LevelGen/LineBlock.hs
+9 -12
View File
@@ -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
src/Dodge/LevelGen/Pathing.hs
+9 -11
View File
@@ -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]
src/Dodge/LevelGen/StaticWalls.hs
+24 -23
View File
@@ -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]
src/Dodge/LevelGen/Switch.hs
+2
View File
@@ -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/"
}
src/Dodge/LevelGen/TriggerDoor.hs
+4 -5
View File
@@ -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
src/Dodge/LightSources.hs
+13 -7
View File
@@ -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
src/Dodge/LoadSound.hs
-6
View File
@@ -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)
src/Dodge/Path.hs
+36 -31
View File
@@ -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 =
src/Dodge/Render.hs
+22 -22
View File
@@ -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)
src/Dodge/Render/HUD.hs
+12 -14
View File
@@ -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
src/Dodge/Render/MenuScreen.hs
+4 -4
View File
@@ -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")
src/Dodge/Render/Picture.hs
+13 -13
View File
@@ -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)
src/Dodge/Room.hs
+22 -33
View File
@@ -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
src/Dodge/Room/Airlock.hs
+1 -1
View File
@@ -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]
src/Dodge/Room/Branch.hs
+2 -2
View File
@@ -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
src/Dodge/Room/Link.hs
+14 -6
View File
@@ -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)
src/Dodge/Room/LongDoor.hs
+6 -5
View File
@@ -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
src/Dodge/Room/NoNeedWeapon.hs
+2 -2
View File
@@ -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
{- |
src/Dodge/Room/Placement.hs
+32 -3
View File
@@ -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)
src/Dodge/Room/Procedural.hs
+28 -28
View File
@@ -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')
src/Dodge/Room/RoadBlock.hs
+1 -1
View File
@@ -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
src/Dodge/Room/Teleport.hs
+1 -2
View File
@@ -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)
src/Dodge/Room/Treasure.hs
+2 -2
View File
@@ -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),
src/Dodge/SoundLogic.hs
-22
View File
@@ -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
src/Dodge/SoundLogic/Synonyms.hs
+2 -1
View File
@@ -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
src/Dodge/Update.hs
+14 -17
View File
@@ -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 _ = []
src/Dodge/Update/Camera.hs
+25 -27
View File
@@ -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)
src/Dodge/WallCreatureCollisions.hs
+18 -21
View File
@@ -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
src/Dodge/WorldEvent.hs
+4 -14
View File
@@ -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
src/Dodge/WorldEvent/Bullet.hs
+6 -12
View File
@@ -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
src/Dodge/WorldEvent/Cloud.hs
+1 -3
View File
@@ -3,9 +3,7 @@ module Dodge.WorldEvent.Cloud
import Dodge.Data
import Dodge.Base
import Geometry
--import Geometry
import Picture
import Control.Lens
src/Dodge/WorldEvent/DamageBlock.hs
+16
View File
@@ -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
src/Dodge/WorldEvent/Explosion.hs
+2 -3
View File
@@ -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
src/Dodge/WorldEvent/Flash.hs
+6 -7
View File
@@ -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
src/Dodge/WorldEvent/HelperParticle.hs
+3 -8
View File
@@ -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)})
src/Dodge/WorldEvent/HitEffect.hs
+50 -28
View File
@@ -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
src/Dodge/WorldEvent/Shockwave.hs
+4 -15
View File
@@ -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)))
src/Dodge/WorldEvent/Sound.hs
-2
View File
@@ -1,8 +1,6 @@
module Dodge.WorldEvent.Sound
where
import Dodge.Data
import Geometry.Data (Point2)
import Dodge.SoundLogic
import System.Random
src/Dodge/WorldEvent/SpawnParticle.hs
+12 -18
View File
@@ -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
src/Dodge/WorldEvent/ThingsHit.hs
+5 -6
View File
@@ -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)
src/DoubleStack.hs
+3
View File
@@ -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
src/Geometry/Data.hs
+3 -3
View File
@@ -1,7 +1,7 @@
module Geometry.Data
( Point2 (..)
, Point3 (..)
, Point4 (..)
( Point2
, Point3
, Point4
)
where
type Point2 = (Float,Float)
src/Picture/Preload.hs
+5 -8
View File
@@ -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 []

Some files were not shown because too many files have changed in this diff Show More