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

Split UseItem module

Browse Source
This commit is contained in:
jgk
2021-03-16 11:54:41 +01:00
parent 97fd7f5576
commit ca5ff88522
19 changed files with 609 additions and 96 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/AIs.hs
+1 -1
View File
@@ -4,7 +4,7 @@ import Dodge.Data
import Dodge.Base
import Dodge.Path
import Dodge.SoundLogic
import Dodge.CreatureActions
import Dodge.CreatureAction
import Dodge.KeyEvents
import Dodge.RandomHelp
import Dodge.WorldActions
src/Dodge/CreatureActions.hs → src/Dodge/CreatureAction.hs
+9 -46
View File
@@ -1,6 +1,13 @@
{-# LANGUAGE BangPatterns #-}
module Dodge.CreatureActions where
module Dodge.CreatureAction
( module Dodge.CreatureAction
, useItemContinuous
, tryUseItem
)
where
-- imports {{{
import Dodge.CreatureAction.UseItem
import Dodge.Data
import Dodge.Base
import Dodge.SoundLogic
@@ -190,11 +197,7 @@ moveBy :: Int -> Point2 -> World -> World
moveBy n v = over (creatures . ix n . crPos) (+.+ v)
reloadWeapon :: Int -> World -> Maybe World
reloadWeapon cid w = if _unlimitedAmmo w then reloadWeaponUnlimited cid w
else reloadWeaponAmmoCheck cid w
reloadWeaponUnlimited :: Int -> World -> Maybe World
reloadWeaponUnlimited cid w =
reloadWeapon cid w =
let cr = _creatures w IM.! cid
it = _crInv cr IM.! _crInvSel cr
itRef = creatures . ix cid . crInv . ix (_crInvSel cr)
@@ -204,46 +207,6 @@ reloadWeaponUnlimited cid w =
$ set ( itRef . wpReloadState) rT w
_ -> Nothing
reloadWeaponAmmoCheck :: Int -> World -> Maybe World
reloadWeaponAmmoCheck cid w =
let cr = _creatures w IM.! cid
it = _crInv cr IM.! _crInvSel cr
itRef = creatures . ix cid . crInv . ix (_crInvSel cr)
in case it of
Weapon {_wpMaxAmmo=maxA,_wpLoadedAmmo=lA,_wpAmmoType=aT
,_wpReloadState=rS ,_wpReloadTime=rT}
-> do guard $ lA < maxA && rS == 0 && M.findWithDefault 0 aT (_crAmmo cr) > 0
toAdd <- Just $ min (_crAmmo (you w) M.! aT) (maxA - lA)
return $ over (creatures . ix cid . crAmmo) (M.adjust (\x -> x - toAdd) aT)
$ over ( itRef . wpLoadedAmmo) (\x -> x + toAdd)
$ set ( itRef . wpReloadState) rT w
_ -> Nothing
useItemContinuous :: Int -> World -> World
useItemContinuous n w = case (_crInv cr IM.! _crInvSel cr) ^? itHammer of
Just HammerUp -> useItem1 n $ setHammerDown w
Just NoHammer -> useItem1 n w
_ -> setHammerDown w
where
cr = _creatures w IM.! n
setHammerDown = creatures . ix n . crInv . ix (_crInvSel cr) . itHammer .~ HammerDown
tryUseItem :: Int -> World -> World
tryUseItem cid w = case w ^? creatures . ix cid of
Just cr -> useItem2 cid (_crInv cr IM.! _crInvSel cr) w
Nothing -> w
useItem1 :: Int -> World -> World
useItem1 n w = useItem2 n it w
where c = (_creatures w IM.! n)
it = _crInv c IM.! _crInvSel c
useItem2 :: Int -> Item -> World -> World
useItem2 n (Consumable {_cnEffect=eff }) w = fromMaybe w $ fmap (rmInvItem n) $ eff n w
useItem2 n (Weapon {_wpFire=eff}) w = eff n w
useItem2 n (Throwable {_twFire = eff}) w = eff n w
useItem2 _ _ w = w
createItemAt :: Point2 -> FloorItem -> World -> World
src/Dodge/CreatureAction/UseItem.hs
+35
View File
@@ -0,0 +1,35 @@
module Dodge.CreatureAction.UseItem
where
import Dodge.Data
import Dodge.Inventory
import qualified Data.IntMap as IM
import Control.Lens
import Data.Maybe (fromMaybe)
useItemContinuous :: Int -> World -> World
useItemContinuous n w = case (_crInv cr IM.! _crInvSel cr) ^? itHammer of
Just HammerUp -> useItem1 n $ setHammerDown w
Just NoHammer -> useItem1 n w
_ -> setHammerDown w
where
cr = _creatures w IM.! n
setHammerDown = creatures . ix n . crInv . ix (_crInvSel cr) . itHammer .~ HammerDown
tryUseItem :: Int -> World -> World
tryUseItem cid w = case w ^? creatures . ix cid of
Just cr -> useItem2 cid (_crInv cr IM.! _crInvSel cr) w
Nothing -> w
useItem1 :: Int -> World -> World
useItem1 n w = useItem2 n it w
where c = (_creatures w IM.! n)
it = _crInv c IM.! _crInvSel c
useItem2 :: Int -> Item -> World -> World
useItem2 n (Consumable {_cnEffect=eff }) w = fromMaybe w $ fmap (rmInvItem n) $ eff n w
useItem2 n (Weapon {_wpFire=eff}) w = eff n w
useItem2 n (Throwable {_twFire = eff}) w = eff n w
useItem2 _ _ w = w
src/Dodge/CreatureState.hs
+1 -1
View File
@@ -6,7 +6,7 @@ import Dodge.SoundLogic
import Dodge.RandomHelp
import Dodge.WorldActions
import Dodge.WallCreatureCollisions
import Dodge.CreatureActions
import Dodge.CreatureAction
import Geometry
src/Dodge/Critters.hs
-9
View File
@@ -125,7 +125,6 @@ miniGunCrit = basicCreature
, _crInv = IM.fromList [(0,miniGun)]
, _crInvSel = 0
, _crRad = 10
, _crAmmo = M.fromList [(PistolBullet, 1000)]
--, _crState = ShooterWait
, _crState = basicState {_goals = [[InitGuard]]}
, _crHP = 500
@@ -139,7 +138,6 @@ longCrit = basicCreature
, _crInv = IM.fromList [(0,longGun),(1,medkit 100)]
, _crInvSel = 0
, _crRad = 10
, _crAmmo = M.fromList [(PistolBullet, 1000)]
--, _crState = ShooterWait
, _crState = basicState {_goals = [[InitGuard]]}
, _crHP = 300
@@ -153,7 +151,6 @@ multGunCrit = basicCreature
, _crInv = IM.fromList [(0,multGun),(1,medkit 100)]
, _crInvSel = 0
, _crRad = 10
, _crAmmo = M.fromList [(PistolBullet, 1000)]
--, _crState = ShooterWait
, _crState = basicState {_goals = [[InitGuard]]}
, _crHP = 300
@@ -167,7 +164,6 @@ launcherCrit = basicCreature
, _crInv = IM.fromList [(0,launcher),(1,medkit 100)]
, _crInvSel = 0
, _crRad = 10
, _crAmmo = M.fromList [(PistolBullet, 1000)]
--, _crState = ShooterWait
, _crState = basicState {_goals = [[Init]]}
, _crHP = 300
@@ -181,7 +177,6 @@ spreadGunCrit = basicCreature
, _crInv = IM.fromList [(0,spreadGun),(1,medkit 100)]
, _crInvSel = 0
, _crRad = 10
, _crAmmo = M.fromList [(PistolBullet, 1000)]
--, _crState = ShooterWait
, _crState = basicState {_goals = [[Init]]}
, _crHP = 300
@@ -195,7 +190,6 @@ pistolCrit = basicCreature
, _crInv = IM.fromList [(0,pistol),(1,medkit 100)]
, _crInvSel = 0
, _crRad = 10
, _crAmmo = M.fromList [(PistolBullet, 1000)]
--, _crState = ShooterWait
, _crState = basicState {_goals = [[InitGuard]]}
, _crHP = 500
@@ -209,7 +203,6 @@ autoCrit = basicCreature
, _crInv = IM.fromList [(0,autoGun),(1,medkit 100)]
, _crInvSel = 0
, _crRad = 10
, _crAmmo = M.fromList [(PistolBullet, 1000)]
--, _crState = ShooterWait
, _crState = basicState {_goals = [[InitGuard]]}
, _crHP = 300
@@ -226,7 +219,6 @@ addArmour = over crInv insarmour
-- , _crInv = IM.fromList [(0,ltAutoGun)]
-- , _crInvSel = 0
-- , _crRad = 10
-- , _crAmmo = M.fromList [(PistolBullet, 1000)]
-- , _crState = basicState {_goals = [[InitGuard]]}
-- , _crHP = 50
-- }
@@ -370,7 +362,6 @@ startCr = basicCreature
]
++ repeat NoItem))
-- startInv
, _crAmmo = M.fromList [(PistolBullet, 0),(LiquidFuel, 100),(Battery, 20000),(Shell,200)]
, _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ pictures [color (greyN 0.8) $ circleSolid 10, circLine 10]
}
src/Dodge/Data.hs
-7
View File
@@ -77,7 +77,6 @@ data World = World
, _pathGraph' :: ~[(Point2,Point2)]
, _pathPoints :: ~(IM.IntMap (IM.IntMap [(Int,Point2)]))
, _pathInc :: ~(M.Map Point2 [Point2])
, _unlimitedAmmo :: Bool
, _storedLevel :: Maybe World
, _menuState :: MenuState
, _worldState :: M.Map WorldState Bool
@@ -144,7 +143,6 @@ data Creature = Creature
, _crMaxHP :: Int
, _crInv :: IM.IntMap Item
, _crInvSel :: Int
, _crAmmo :: M.Map Ammo Int
, _crState :: CreatureState
, _crCorpse :: Drawing
}
@@ -270,7 +268,6 @@ data PressPlate = PressPlate { _ppPict :: Drawing
}
data FloorItem = FlIt { _flIt :: Item , _flItPos :: Point2 , _flItRot :: Float, _flItID :: Int}
| FlAm { _flAm :: Ammo , _flItPos :: Point2 , _flAmNum :: Int , _flItID :: Int}
data ItemPos = InInv { _itCrId :: Int
, _itInvId :: Int
@@ -282,7 +279,6 @@ data Item = Weapon
{ _itName :: String
, _wpMaxAmmo :: Int
, _wpLoadedAmmo :: Int
, _wpAmmoType :: Ammo
, _wpReloadTime :: Int
, _wpReloadState :: Int
, _wpFireRate :: Int
@@ -597,9 +593,6 @@ data ForceField = FF { _ffLine :: [Point2] , _ffID :: Int
}
data FFState = FFDestroyable { _ffsHP :: Int }
data Ammo = PistolBullet | LiquidFuel | Battery | Shell
deriving (Eq,Ord,Enum)
data SoundOrigin = InventorySound
| BackgroundSound
| OnceSound
src/Dodge/Initialisation.hs
-1
View File
@@ -57,7 +57,6 @@ initialWorld = basicWorld
-- , _loadedSounds = IM.empty
, _sounds = M.empty
, _decorations = IM.empty
, _unlimitedAmmo = True
, _storedLevel = Nothing
, _menuState = LevelMenu 1
, _worldState = M.empty
src/Dodge/Item/Weapon.hs
+1 -23
View File
@@ -7,7 +7,7 @@ module Dodge.Item.Weapon
import Dodge.Data
import Dodge.Base
import Dodge.SoundLogic
import Dodge.CreatureActions
import Dodge.CreatureAction
import Dodge.RandomHelp
import Dodge.WorldActions
import Dodge.Debug
@@ -55,7 +55,6 @@ pistol = Weapon
, _itIdentity = Pistol
, _wpMaxAmmo = 15
, _wpLoadedAmmo = 15
, _wpAmmoType = PistolBullet
, _wpReloadTime = 40
, _wpReloadState = 0
, _wpFireRate = 8
@@ -100,7 +99,6 @@ autoGun = defaultGun
, _itIdentity = AutoGun
, _wpMaxAmmo = 30
, _wpLoadedAmmo = 30
, _wpAmmoType = PistolBullet
, _wpReloadTime = 80
, _wpReloadState = 0
, _wpFireRate = 6
@@ -164,7 +162,6 @@ rezGun = defaultGun
{ _itName = "REANIMATOR"
, _wpMaxAmmo = 50
, _wpLoadedAmmo = 50
, _wpAmmoType = Battery
, _wpReloadTime = 80
, _wpReloadState = 0
, _wpFireRate = 0
@@ -189,7 +186,6 @@ teslaGun = defaultAutoGun
, _itIdentity = TeslaGun
, _wpMaxAmmo = 200
, _wpLoadedAmmo = 200
, _wpAmmoType = Battery
, _wpReloadTime = 80
, _wpReloadState = 0
, _wpFireRate = 0
@@ -215,7 +211,6 @@ lasGun = defaultAutoGun
, _itIdentity = LasGun
, _wpMaxAmmo = 200
, _wpLoadedAmmo = 200
, _wpAmmoType = Battery
, _wpReloadTime = 80
, _wpReloadState = 0
, _wpFireRate = 0
@@ -260,7 +255,6 @@ forceFieldGun = defaultGun
, _itIdentity = ForceFieldGun
, _wpMaxAmmo = 100
, _wpLoadedAmmo = 100
, _wpAmmoType = Battery
, _wpReloadTime = 40
, _wpReloadState = 0
, _wpFireRate = 10
@@ -279,7 +273,6 @@ forceFieldGun = defaultGun
-- , _itIdentity = GrapGun
-- , _wpMaxAmmo = 1
-- , _wpLoadedAmmo = 1
-- , _wpAmmoType = Battery
-- , _wpReloadTime = 40
-- , _wpReloadState = 0
-- , _wpFireRate = 10
@@ -299,7 +292,6 @@ tractorGun = defaultAutoGun
, _itIdentity = TractorGun
, _wpMaxAmmo = 10000
, _wpLoadedAmmo = 10000
, _wpAmmoType = Battery
, _wpReloadTime = 40
, _wpReloadState = 0
, _wpFireRate = 0
@@ -319,7 +311,6 @@ launcher = defaultGun
, _itIdentity = Launcher
, _wpMaxAmmo = 30
, _wpLoadedAmmo = 30
, _wpAmmoType = Shell
, _wpReloadTime = 80
, _wpReloadState = 0
, _wpFireRate = 20
@@ -354,7 +345,6 @@ remoteLauncher = defaultGun
, _itIdentity = RemoteLauncher
, _wpMaxAmmo = 1
, _wpLoadedAmmo = 1
, _wpAmmoType = Shell
, _wpReloadTime = 80
, _wpReloadState = 0
, _wpFireRate = 10
@@ -375,7 +365,6 @@ hvAutoGun = defaultAutoGun
, _itIdentity = HvAutoGun
, _wpMaxAmmo = 100
, _wpLoadedAmmo = 100
, _wpAmmoType = PistolBullet
, _wpReloadTime = 200
, _wpReloadState = 0
, _wpFireRate = 25
@@ -402,7 +391,6 @@ ltAutoGun = defaultAutoGun
, _itIdentity = LtAutoGun
, _wpMaxAmmo = 25
, _wpLoadedAmmo = 25
, _wpAmmoType = PistolBullet
, _wpReloadTime = 80
, _wpReloadState = 0
, _wpFireRate = 4
@@ -427,7 +415,6 @@ miniGun = defaultAutoGun
, _itIdentity = MiniGun
, _wpMaxAmmo = 150
, _wpLoadedAmmo = 150
, _wpAmmoType = PistolBullet
, _wpReloadTime = 200
, _wpReloadState = 0
, _wpFireRate = 2
@@ -448,7 +435,6 @@ spreadGun = defaultGun
, _itIdentity = SpreadGun
, _wpMaxAmmo = 5
, _wpLoadedAmmo = 5
, _wpAmmoType = PistolBullet
, _wpReloadTime = 80
, _wpReloadState = 0
, _wpFireRate = 20
@@ -472,7 +458,6 @@ spreadGun = defaultGun
-- , _itIdentity = ShatterGun
-- , _wpMaxAmmo = 50
-- , _wpLoadedAmmo = 50
-- , _wpAmmoType = PistolBullet
-- , _wpReloadTime = 80
-- , _wpReloadState = 0
-- , _wpFireRate = 40
@@ -492,7 +477,6 @@ multGun = defaultGun
, _itIdentity = MultGun
, _wpMaxAmmo = 2
, _wpLoadedAmmo = 2
, _wpAmmoType = PistolBullet
, _wpReloadTime = 40
, _wpReloadState = 0
, _wpFireRate = 20
@@ -523,7 +507,6 @@ longGun = defaultGun
, _itIdentity = LongGun
, _wpMaxAmmo = 1
, _wpLoadedAmmo = 1
, _wpAmmoType = PistolBullet
, _wpReloadTime = 80
, _wpReloadState = 0
, _wpFireRate = 100
@@ -564,7 +547,6 @@ poisonSprayer = defaultAutoGun
, _itIdentity = PoisonSprayer
, _wpMaxAmmo = 500
, _wpLoadedAmmo = 500
, _wpAmmoType = LiquidFuel
, _wpReloadTime = 100
, _wpReloadState = 0
, _wpFireRate = 0
@@ -586,7 +568,6 @@ flamer = defaultAutoGun
, _itIdentity = Flamethrower
, _wpMaxAmmo = 250
, _wpLoadedAmmo = 250
, _wpAmmoType = LiquidFuel
, _wpReloadTime = 100
, _wpReloadState = 0
, _wpFireRate = 0
@@ -610,7 +591,6 @@ blinkGun = defaultGun
, _itIdentity = Blinker
, _wpMaxAmmo = 100
, _wpLoadedAmmo = 100
, _wpAmmoType = Battery
, _wpReloadTime = 20
, _wpReloadState = 0
, _wpFireRate = 0
@@ -1982,7 +1962,6 @@ radar = defaultGun
, _itIdentity = Generic
, _wpMaxAmmo = 100
, _wpLoadedAmmo = 100
, _wpAmmoType = PistolBullet
, _wpReloadTime = 200
, _wpReloadState = 0
, _wpFireRate = 120
@@ -2004,7 +1983,6 @@ sonar = defaultGun
, _itIdentity = Generic
, _wpMaxAmmo = 100
, _wpLoadedAmmo = 100
, _wpAmmoType = PistolBullet
, _wpReloadTime = 200
, _wpReloadState = 0
, _wpFireRate = 120
src/Dodge/Item/Weapon/TriggerType.hs
+1 -1
View File
@@ -2,7 +2,7 @@ module Dodge.Item.Weapon.TriggerType
where
import Dodge.Data
import Dodge.SoundLogic
import Dodge.CreatureActions (reloadWeapon)
import Dodge.CreatureAction (reloadWeapon)
import Dodge.WorldActions (muzFlareAt,lowLightAt,tLightAt)
import Dodge.RandomHelp
src/Dodge/KeyEvents.hs
+1 -1
View File
@@ -2,7 +2,7 @@ module Dodge.KeyEvents where
-- imports {{{
import Dodge.Data
import Dodge.Base
import Dodge.CreatureActions
import Dodge.CreatureAction
import Dodge.SoundLogic
import Dodge.Inventory
src/Dodge/Prototypes.hs
-2
View File
@@ -60,7 +60,6 @@ basicCreature = Creature
, _crMaxHP = 150
, _crInv = IM.empty
, _crInvSel = 0
, _crAmmo = M.empty
, _crState = basicState
, _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ circleSolid 10
}
@@ -208,7 +207,6 @@ basicWorld = World
, _sounds = M.empty
, _corpses = IM.empty
, _decorations = IM.empty
, _unlimitedAmmo = True
, _storedLevel = Nothing
, _menuState = LevelMenu 1
, _worldState = M.empty
src/Dodge/Rendering.hs
+1 -4
View File
@@ -362,7 +362,6 @@ displayAmount n | n > 1 = "-x" ++show n
rectangleSolid x y = polygon [(x,y),(x,-y),(-x,-y),(-x,y)]
drawItem :: FloorItem -> Drawing
drawItem (FlAm {_flItPos = p}) = uncurry translate p $ onLayer FlItLayer $ rectangleSolid 5 5
drawItem flIt = uncurry translate (_flItPos flIt)
$ rotateDrawing (radToDeg $ _flItRot flIt) (_itFloorPict (_flIt flIt))
@@ -415,9 +414,7 @@ drawItemName w flIt | magV (_crPos (you w) -.- _flItPos flIt) < 100
t = rotate (0 - (_cameraRot w))
. uncurry translate (zoom *.* (_flItPos flIt -.- _cameraPos w))
. rotate (_cameraRot w)
nameOfItem = case flIt of FlIt {} -> _itName $ _flIt flIt
FlAm {_flAm = PistolBullet} -> "Bullets"
FlAm {_flAm = LiquidFuel} -> "Liquid Fuel"
nameOfItem = _itName $ _flIt flIt
zoom = _cameraZoom w
ringPict :: Drawing
src/Dodge/WorldActions/Bullet.hs
+137
View File
@@ -0,0 +1,137 @@
module Dodge.WorldActions.Bullet
where
import Dodge.Data
import Dodge.Base
import Dodge.WorldActions.ThingsHit
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
mvBulletTrajectory :: (Int -> [Point2]) -> World -> Particle' -> (World, Maybe Particle')
mvBulletTrajectory velF w bt
| t <= 0 = (w, Nothing)
| t < 4 = (w, Just $ set btPassThrough' Nothing
$ set btTrail' (replicate numPs p ++ (p:ps) )
$ set ptPict' (bulLineLen numPs col wth (replicate numPs p ++ (p:ps) ) )
$ set btTimer' (t-1)
bt
)
| otherwise = case firstThingHit $ thingsHitExceptCrCurve mcr (p:newPs) w of
(_,Nothing) -> (w, Just $ set btPassThrough' Nothing
$ set btVel' newVel -- this may be useful for hit effects
$ set btTrail' (init (reverse newPs) ++ (p:ps))
$ set ptPict' (bulLineLen numPs col wth (init (reverse newPs) ++ (p:ps)))
$ set btTimer' (t-1) bt
)
(mvPs,Just (hitp,thing))
-> let newMvPs = leftPad numPs hitp (init $ reverse mvPs)
hitVel = speed *.* normalizeV ( hitp -.- (head $ reverse mvPs) )
in ( hiteff bt (hitp,thing) w
--in ( w
, Just $ set btPassThrough' Nothing
$ set btVel' hitVel -- this may be useful for hit effects
$ set btTrail' (newMvPs ++ (p:ps))
$ set ptPict' (bulLineLen numPs col wth (newMvPs ++ (p:ps)) )
$ set btTimer' 3 bt
)
where mcr = _btPassThrough' bt
col = _btColor' bt
(p:ps) = _btTrail' bt
hiteff = _btHitEffect' bt
wth = _btWidth' bt
t = _btTimer' bt
newPs = velF t
numPs = (length $ newPs) - 1
firstThingHit :: [[(Point2,(Either3 Creature Wall ForceField))]]
-> ([Point2], Maybe (Point2,Either3 Creature Wall ForceField))
firstThingHit hitList = second last $ unzip $ zip newPs
$ takeUntil isJust
$ map listToMaybe hitList
newVel = speed *.* ( last newPs -.- (last $ init newPs) )
speed = sum . map magV $ zipWith (-.-) (init newPs) (tail newPs)
thingsHitExceptCrCurve :: Maybe Int -> [Point2] -> World
-> [ [(Point2, (Either3 Creature Wall ForceField))]
]
thingsHitExceptCrCurve mcid ps@(a:b:_) w
= zipWith (\x y -> thingsHitExceptCr mcid x y w) ps $ tail ps
thingsHitExceptCrLine _ _ _ = []
thingsHitExceptCr :: Maybe Int -> Point2 -> Point2 -> World
-> [(Point2, (Either3 Creature Wall ForceField))]
thingsHitExceptCr Nothing sp ep = thingsHit sp ep
thingsHitExceptCr (Just cid) sp ep = filter crNotCid . thingsHit sp ep
where crNotCid (_,(E3x1 cr)) = _crID cr /= cid
crNotCid _ = True
mvGenBullet' :: World -> Particle' -> (World, Maybe Particle')
mvGenBullet' w bt
| t <= 0 = (w, Nothing)
| t < 4 = (w, Just $ set btPassThrough' Nothing
$ set btTrail' (p:p:ps)
$ set ptPict' (bulLine col wth (p:p:ps))
$ set btTimer' (t-1) bt
)
| otherwise = case thingsHitExceptCr mcr p (p +.+ vel) w of
[] -> (w, Just $ set btPassThrough' Nothing
$ set btTrail' (p +.+ vel :p:ps)
$ set ptPict' (bulLine col wth (p +.+ vel:p:ps))
$ set btTimer' (t-1) bt
)
((hitp,thing):_)
-> ( hiteff bt (hitp,thing) w
, Just $ set btPassThrough' Nothing
$ set btTrail' (hitp:p:ps)
$ set ptPict' (bulLine col wth (hitp:p:ps))
$ set btTimer' 3 bt
)
where mcr = _btPassThrough' bt
col = _btColor' bt
(p:ps) = _btTrail' bt
vel = _btVel' bt
hiteff = _btHitEffect' bt
wth = _btWidth' bt
t = _btTimer' bt
bulLineLen :: Int -> Color -> Float -> [Point2] -> Picture
bulLineLen n c w ps =
setLayer 1 . onLayer HPtLayer $ color c $ thickLine (take (n * 3) ps) w
bulLine c w = setLayer 1 . bulLinea c w
bulLinea :: Color -> Float -> [Point2] -> Picture
bulLinea _ _ [] = blank
bulLinea _ _ (x:[]) = blank
bulLinea col width (a:b:[]) -- (a:b:[])
= onLayer HPtLayer $ pictures $ reverse
[polygonCol $ zip (wedgeGeom width b a) $ [white,withAlpha 0 white,withAlpha 0 white]
,polygonCol $ zip (lineGeom (width+1.5) a b) $ [col,col,withAlpha 0 col,withAlpha 0 col]
]
bulLinea col width (a:b:c:[]) -- (a:b:[])
= onLayer HPtLayer $ pictures $ reverse
[polygonCol $ zip (wedgeGeom width b a) $ repeat white
,polygonCol $ zip (wedgeGeom width b c) $ [white,white,withAlpha 0 white]
,polygonCol $ zip (lineGeom (width+1.5) a c) $ [col,col,withAlpha 0 col,withAlpha 0 col]
]
bulLinea col width (a:b:_:c:[]) -- (a:b:[])
= onLayer HPtLayer $ pictures $ reverse
[polygonCol $ zip (wedgeGeom width b a) $ repeat white
,polygonCol $ zip (wedgeGeom width b c) $ [white,white,withAlpha 0 white]
,polygonCol $ zip (lineGeom (width+1.5) a c) $ [col,col,withAlpha 0 col,withAlpha 0 col]
]
bulLinea col width (a:b:_:_:c:_) -- (a:b:[])
= onLayer HPtLayer $ pictures $ reverse
[polygonCol $ zip (wedgeGeom width b a) $ repeat white
,polygonCol $ zip (wedgeGeom width b c) $ [white,white,withAlpha 0 white]
,polygonCol $ zip (lineGeom (width+1.5) a c) $ [col,col,withAlpha 0 col,withAlpha 0 col]
]
src/Dodge/WorldActions/Flash.hs
+80
View File
@@ -0,0 +1,80 @@
module Dodge.WorldActions.Flash
where
import Dodge.Data
import Dodge.Base
import Dodge.WorldActions.ThingsHit
import Dodge.WorldActions.HelperParticle
import Picture
import Geometry
import Control.Lens
flareAt :: Color -> Point2 -> World -> World
flareAt c p = flareAt' c 0.02 0.5 p
flareAt' :: Color -> Float -> Float -> Point2 -> World -> World
flareAt' col alphax alphay p
= -- over particles' ((:) (flashColAt col alphax p))
-- .
lowLightColAt col alphay p
lowLightColAt :: Color -> Float -> Point2 -> World -> World
lowLightColAt col alphay p w = foldr (lowLightColHit col alphay p) w ps
where ps = map ((+.+) p) $ nRaysRad 20 30
lowLightColHit :: Color -> Float -> Point2 -> Point2 -> World -> World
lowLightColHit col alphay a b w
= case thingsHitLongLine a b w of
((p, E3x2 wall):_)
-> over particles' ((:) (wallGlareCol col alphay p wall)) w
((p, E3x1 cr):_)
-> over afterParticles' ((:) (crGlareCol col alphay p cr)) w
_ -> w
flashColAt :: Color -> Float -> Point2 -> Particle'
flashColAt col alphax (x,y) =
Particle'
{ _ptPict' = pictures $
map (\i -> onLayerL [levLayer PtLayer]
$ color (withAlpha alphax col) $ translate x y $ circleSolid i
)
[20,25,30,35,40,45,50]
, _ptUpdate' = ptTimer' 1
}
wallGlareCol :: Color -> Float -> Point2 -> Wall -> Particle'
wallGlareCol col alphay p wl = wallGlareWidth 10 5 col alphay p wl
crGlareCol :: Color -> Float -> Point2 -> Creature -> Particle'
crGlareCol col alphay p cr = crGlareWidth 5 col alphay p cr
wallGlareWidth :: Float -> Float -> Color -> Float -> Point2 -> Wall -> Particle'
wallGlareWidth len wdth col alphay p wl =
Particle'
{ _ptPict' = onLayerL [levLayer GloomLayer + 2] $ l
, _ptUpdate' = ptTimer' 1
}
where l = color (withAlpha alphay col) $ lineOfThickness wdth $ [p +.+ x, p -.- x]
x = len *.* ( normalizeV $ a -.- b)
(a:b:_) = _wlLine wl
crGlareWidth :: Float -> Color -> Float -> Point2 -> Creature -> Particle'
crGlareWidth wdth col alphay p cr =
Particle'
{ _ptPict' = onLayerL [levLayer GloomLayer + 2] $ l cp
, _ptUpdate' = \w pt -> (w, Just $ pt {_ptPict' = onLayerL [levLayer GloomLayer + 2] $ upp cid w
,_ptUpdate' = ptTimer' 0
}
)
}
where l x = uncurry translate x
$ rotate (-0.25*pi + argV (p -.- x))
$ color (withAlpha alphay col)
$ thickArc 0 (pi/2) (_crRad cr) wdth
cp = _crPos cr
cid = _crID cr
upp cid' w' = case w' ^? creatures . ix cid . crPos of
Just y -> l y
_ -> blank
src/Dodge/WorldActions/HelperParticle.hs
+8
View File
@@ -0,0 +1,8 @@
module Dodge.WorldActions.HelperParticle
where
import Dodge.Data
ptTimer' :: Int -> World -> Particle' -> (World, Maybe Particle')
ptTimer' 0 w pt = (w, Nothing)
ptTimer' n w pt = (w, Just $ pt {_ptUpdate' = ptTimer' (n-1)})
src/Dodge/WorldActions/ThingsHit.hs
+56
View File
@@ -0,0 +1,56 @@
module Dodge.WorldActions.ThingsHit
where
import Dodge.Data
import Dodge.Base
import Geometry
import qualified Data.IntMap.Strict as IM
import Data.List
import Data.Maybe
import Data.Function (on)
thingsHitExceptCrLongLine :: Maybe Int -> Point2 -> Point2 -> World
-> [(Point2, (Either3 Creature Wall ForceField))]
thingsHitExceptCrLongLine Nothing sp ep = thingsHitLongLine sp ep
thingsHitExceptCrLongLine (Just cid) sp ep = filter crNotCid . thingsHitLongLine sp ep
where crNotCid (_,(E3x1 cr)) = _crID cr /= cid
crNotCid _ = True
thingsHitLongLine :: Point2 -> Point2 -> World -> [(Point2, (Either3 Creature Wall ForceField))]
thingsHitLongLine sp ep w = sortBy (compare `on` dist sp . fst) (crs ++ walls ++ ffs)
where
crs = zip crPs (map E3x1 hitCrs)
hitCrs = IM.elems $ IM.filter (\cr -> circOnLine sp ep (_crPos cr) (_crRad cr))
$ _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)
hitWls = wallsOnLine sp ep $ wallsAlongLine sp ep w
hitPoint wl = intersectSegSeg' sp ep (_wlLine wl !! 0) (_wlLine wl !! 1)
hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w)
ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs
thingsHit :: Point2 -> Point2 -> World -> [(Point2, (Either3 Creature Wall ForceField))]
thingsHit sp ep w = sortBy (compare `on` dist sp . fst) (crs ++ walls ++ ffs)
where
hitCrs = IM.elems $ IM.filter (\cr -> circOnLine sp ep (_crPos cr) (_crRad cr))
$ _creatures w
-- $ creaturesAlongLine sp ep w
-- creaturesAlongLine doesn't always
-- hit crs
crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs
crs = zip crPs (map E3x1 hitCrs)
hitWls = wallsOnLine sp ep (IM.unions [f b $ f a $ _wallsZone w | a<-[x-1,x,x+1]
, b<-[y-1,y,y+1]])
(x,y) = zoneOfPoint (0.5 *.* (sp +.+ ep))
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 = intersectSegSeg' sp ep (_wlLine w !! 0) (_wlLine w !! 1)
hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w)
ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs
src/Geometry/Bezier.hs
+27
View File
@@ -0,0 +1,27 @@
module Geometry.Bezier
where
import Geometry.Data
import Geometry.Vector
type BQuad = (Point2,Point2,Point2)
splitBezierquad :: BQuad -> Float -> (BQuad,BQuad)
splitBezierquad (a,b,c) z
= ( ( a
, (z *.* b) -.- ((z-1) *.* a)
, (z**2 *.* c) +.+ ((z-1)**2 *.* a) -.- (2*z*(z-1) *.* b)
)
, ( (z**2 *.* c) +.+ ((z-1)**2 *.* a) -.- (2*z*(z-1) *.* b)
, (z *.* c) -.- ((z-1) *.* b)
, c
)
)
bQuadToLine :: BQuad -> Int -> [Point2]
bQuadToLine (a,_,c) 0 = [a,c]
bQuadToLine x i = let (l,r) = splitBezierquad x 0.5
in bQuadToLine l (i-1) ++ bQuadToLine r (i-1)
bQuadToF :: (Point2,Point2,Point2) -> Float -> Point2
bQuadToF (c,b,a) t = t *.* (t *.* a +.+ (1-t) *.* b) +.+
(1-t) *.* (t *.* b +.+ (1-t) *.* c)
src/Geometry/Intersect.hs
+110
View File
@@ -0,0 +1,110 @@
module Geometry.Intersect
where
import Geometry.Data
import Control.Applicative
intersectSegBezquad :: Point2 -> Point2 -> Point2 -> Point2 -> Point2 -> [Point2]
intersectSegBezquad = undefined
intersectLineLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
{-# INLINE intersectLineLine' #-}
intersectLineLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
| den == 0 = Nothing
| otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den)
where
den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
intersectSegSeg' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
{-# INLINE intersectSegSeg' #-}
intersectSegSeg' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
| den == 0 = Nothing
| den > 0 && (t' < 0 || u' < 0 || t' > den || u' > den)
= Nothing
| den < 0 && (t' > 0 || u' > 0 || t' < den || u' < den)
= Nothing
| otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den)
where
den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
intersectSegLineFrom' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
{-# INLINE intersectSegLineFrom' #-}
intersectSegLineFrom' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
| den == 0 = Nothing
| den > 0 && ( t' < 0 || u' < 0 || t' > den )
= Nothing
| den < 0 && ( t' > 0 || u' > 0 || t' < den )
= Nothing
| otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den)
where
den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
intersectSegLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
{-# INLINE intersectSegLine' #-}
intersectSegLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
| den == 0 = Nothing
| den > 0 && (t' < 0 || t' > den)
= Nothing
| den < 0 && (t' > 0 || t' < den)
= Nothing
| otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den)
where
den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
-- intersectSegSeg is sometimes broken-- the following fixes at least some of
-- the cases
-- it is, however, slow
myIntersectSegSeg a@(ax,ay) b@(bx,by) c@(cx,cy) d@(dx,dy) = case ratIntersectLineLine a b c d of
Nothing -> Nothing
Just (x,y) -> if inbetween x && inbetween' y
then Just (x,y)
else Nothing
where inbetween x = ((ax <= x && x <= bx) || (bx <= x && x <= ax)) &&
((cx <= x && x <= dx) || (dx <= x && x <= cx))
inbetween' y = ((ay <= y && y <= by) || (by <= y && y <= ay)) &&
((cy <= y && y <= dy) || (dy <= y && y <= cy))
myIntersectLineLine :: (Eq a,Fractional a) => (a,a) -> (a,a) -> (a,a) -> (a,a) -> Maybe (a,a)
myIntersectLineLine a@(ax,ay) b c@(cx,cy) d
| linGrad a b == Nothing = fmap ((,) ax) $ axisInt (c *-* (ax,0)) (d *-* (ax,0))
| linGrad c d == Nothing = fmap ((,) cx) $ axisInt (a *-* (cx,0)) (b *-* (cx,0))
| otherwise
= case linGrad a b ^-^ linGrad c d of
Just 0 -> Nothing
_ -> liftA2 (,) newx
((linGrad a b ^*^ newx) ^+^ axisInt a b)
where (^-^) = liftA2 (-)
(^+^) = liftA2 (+)
(^/^) = liftA2 (/)
(^*^) = liftA2 (*)
newx = (axisInt c d ^-^ axisInt a b) ^/^ (linGrad a b ^-^ linGrad c d)
(*-*) (ax,ay) (bx,by) = (ax-bx,ay-by)
ratIntersectLineLine :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
ratIntersectLineLine a b c d = fmap toNumPoint2 $ myIntersectLineLine (toRatPoint2 a) (toRatPoint2 b) (toRatPoint2 c) (toRatPoint2 d)
where toRatPoint2 (x,y) = (toRational x, toRational y)
toNumPoint2 (x,y) = (fromRational x, fromRational y)
f = toRatPoint2 . roundPoint2
roundPoint2 :: Point2 -> Point2
roundPoint2 (x,y) = (fromIntegral $ round x,fromIntegral $ round y)
linGrad :: (Eq a,Fractional a) => (a,a) -> (a,a) -> Maybe a
linGrad (x,y) (a,b) | x-a == 0 = Nothing
| otherwise = Just $ (y-b)/(x-a)
axisInt :: (Eq a,Fractional a) => (a,a) -> (a,a) -> Maybe a
axisInt p (a,b) = pure b ^-^ (pure a ^*^ linGrad p (a,b))
where (^-^) = liftA2 (-)
(^*^) = liftA2 (*)
intersectSegsSeg :: [Point2] -> Point2 -> Point2 -> Maybe Point2
intersectSegsSeg = undefined
src/Geometry/Vector.hs
+141
View File
@@ -0,0 +1,141 @@
{-# LANGUAGE BangPatterns #-}
module Geometry.Vector
where
import Geometry.Data
zeroZ :: Point2 -> Point3
{-# INLINE zeroZ #-}
zeroZ (x,y) = (x,y,0)
infixl 6 +.+, -.-
infixl 7 *.*
(+.+) :: Point2 -> Point2 -> Point2
{-# INLINE (+.+) #-}
(x1, y1) +.+ (x2, y2) =
let
!x = x1 + x2
!y = y1 + y2
in (x, y)
(-.-) :: Point2 -> Point2 -> Point2
{-# INLINE (-.-) #-}
(x1, y1) -.- (x2, y2) =
let
!x = x1 - x2
!y = y1 - y2
in (x, y)
(*.*) :: Float -> Point2 -> Point2
{-# INLINE (*.*) #-}
a *.* (x2, y2) =
let
!x = a * x2
!y = a * y2
in (x, y)
infixl 6 +.+.+, -.-.-
infixl 7 *.*.*
(+.+.+) :: Point3 -> Point3 -> Point3
{-# INLINE (+.+.+) #-}
(x1, y1, z1) +.+.+ (x2, y2, z2) =
let
!x = x1 + x2
!y = y1 + y2
!z = z1 + z2
in (x, y, z)
(-.-.-) :: Point3 -> Point3 -> Point3
{-# INLINE (-.-.-) #-}
(x1, y1, z1) -.-.- (x2, y2, z2) =
let
!x = x1 - x2
!y = y1 - y2
!z = z1 - z2
in (x, y, z)
(*.*.*) :: Point3 -> Point3 -> Point3
{-# INLINE (*.*.*) #-}
(x1, y1, z1) *.*.* (x2, y2, z2) =
let
!x = x1 * x2
!y = y1 * y2
!z = z1 * z2
in (x, y, z)
normalizeV :: Point2 -> Point2
{-# INLINE normalizeV #-}
normalizeV p = (1 / magV p) *.* p
angleVV :: Point2 -> Point2 -> Float
{-# INLINE angleVV #-}
angleVV a b = let ma = magV a
mb = magV b
d = a `dotV` b
in acos $ d / (ma * mb)
dotV :: Point2 -> Point2 -> Float
{-# INLINE dotV #-}
dotV (x,y) (z,w) = x*z + y*w
argV :: Point2 -> Float
{-# INLINE argV #-}
argV (x,y) = normalizeAngle $ atan2 y x
detV :: Point2 -> Point2 -> Float
{-# INLINE detV #-}
detV (x1, y1) (x2, y2)
= x1 * y2 - y1 * x2
-- | Angle in radians, anticlockwise from +ve x-axis.
unitVectorAtAngle :: Float -> Point2
{-# INLINE unitVectorAtAngle #-}
unitVectorAtAngle r
= (cos r, sin r)
-- | Rotate a vector by an angle (in radians). +ve angle is counter-clockwise.
rotateV :: Float -> Point2 -> Point2
rotateV r (x, y)
= ( x * cos r - y * sin r
, x * sin r + y * cos r)
{-# INLINE rotateV #-}
-- | Convert degrees to radians
degToRad :: Float -> Float
degToRad d = d * pi / 180
{-# INLINE degToRad #-}
-- | Convert radians to degrees
radToDeg :: Float -> Float
radToDeg r = r * 180 / pi
{-# INLINE radToDeg #-}
-- | Normalize an angle to be between 0 and 2*pi radians
normalizeAngle :: Float -> Float
normalizeAngle f = f - 2 * pi * floor' (f / (2 * pi))
where floor' :: Float -> Float
floor' x = fromIntegral (floor x :: Int)
{-# INLINE normalizeAngle #-}
vNormal :: Point2 -> Point2
{-# INLINE vNormal #-}
vNormal (x,y) = (y,-x)
vInverse :: Point2 -> Point2
vInverse (x,y) = (-x,-y)
normV :: Point2 -> Point2
{-# INLINE normV #-}
normV (0,0) = (0,0)
normV p = (1/magV p ) *.* p
magV :: Point2 -> Float
{-# INLINE magV #-}
magV (x,y) = sqrt $ x^2 + y^2
crossV :: Point2 -> Point2 -> Float
crossV (ax,ay) (bx,by) = ax*by - ay*bx