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

Delete cruft, add Reader monad to some internal ai

Browse Source
This commit is contained in:
jgk
2021-05-16 21:42:11 +02:00
parent 0798cc0b0e
commit d7fcdbf550
69 changed files with 721 additions and 2894 deletions
Download Patch File Download Diff File Expand all files Collapse all files
app/Main.hs
+2 -2
View File
@@ -24,7 +24,7 @@ import Music
import Control.Concurrent
import Control.Lens
import Foreign (Word32)
import Control.Monad (when,void)
import Control.Monad
import System.Random
import qualified Data.Map as M
import qualified Data.IntMap as IM
@@ -82,7 +82,7 @@ doPreload = do
checkForGlErrors :: IO ()
checkForGlErrors = do
errs <- errors
when (length errs > 0) $ putStrLn $ "GLerror during doLoop: " ++ unwords (map show errs)
unless (null errs) $ putStrLn $ "GLerror during doLoop: " ++ unwords (map show errs)
setWindowSize :: Int -> Int -> KeyConfigSDL-> World -> World
setWindowSize x y z w = w
src/Dodge/AIs.hs
-104
View File
@@ -1,104 +0,0 @@
module Dodge.AIs
(
) where
import Dodge.Creature.Stance.Data
import Dodge.Creature.State.Data
import Dodge.Creature.Impulse.Data
import Dodge.Data hiding (Action (..), Impulse (..), Strategy (..))
import Dodge.Base
import Dodge.Path
import Dodge.SoundLogic
import Dodge.Creature.Action
import Dodge.Creature.Action.Movement
import Dodge.RandomHelp
import Dodge.WorldEvent
import Dodge.Creature.Picture
import Geometry
import Picture
import Data.List
import Data.Char
import Data.Maybe
import Data.Function
import Data.Graph.Inductive.Graph hiding ((&))
import Data.Graph.Inductive.PatriciaTree
import Data.Graph.Inductive.Query.SP
import qualified Data.ByteString as B
import qualified Data.Set as S
import qualified Data.IntMap.Strict as IM
import qualified Data.Map as M
import Control.Lens
import Control.Applicative
import Control.Monad
import Control.Monad.State
import Control.Concurrent
import System.Random
import Foreign.ForeignPtr
----
---- encircleAI' :: Int -> World -> World
---- encircleAI' cid w =
---- let cr = _creatures w IM.! cid
---- cpos = _crPos cr
---- damageYou = over (creatures . ix 0 . crHP) (\hp -> hp - 10) . soundOnce hitSound
---- ypos = _crPos $ you w
---- flockers = IM.filter (flip (canSeePoint cid) w . _crPos)
---- $ IM.filter (factionIs $ EncircleFlock)
---- $ _creatures w
---- tp | length flockers <= 1 = ypos
---- | otherwise = ypos +.+
---- f (max 0 (magV (ypos -.- cenp) - 30) )
---- *.* safeNormalizeV (cpos -.- cenp)
---- where f x = 150 * sigmoid (x-10)
---- cenp = (1 / fromIntegral (length flockers)) *.*
---- foldr1 (+.+)
---- (map _crPos $ IM.elems flockers)
---- combinedRad = _crRad cr + _crRad (you w)
---- replaceGoal newImpulses = over (creatures . ix cid . crState . goals)
---- (\gs -> newImpulses ++ tail gs)
---- addGoal newImpulses = over (creatures . ix cid . crState . goals)
---- (\gs -> newImpulses ++ gs)
---- replaceImpulse newActions = over (creatures . ix cid . crState . goals)
---- (\((_:as):ass) -> (newActions ++ as):ass)
---- addImpulse newActions = over (creatures . ix cid . crState . goals)
---- (\(as:ass) -> (newActions++as):ass)
---- in if _crHP cr <= 0 then killCr cid w else
---- case head $ _goals $ _crState cr of
---- [] | canSee cid (_yourID w) w
---- -> replaceGoal [[MoveToFor tp 10]] w
---- | otherwise -> w
---- (MoveToFor p x:_)
---- | dist ypos cpos < combinedRad + 5
---- && abs ((_crDir cr) - argV (ypos -.- cpos)) < pi/4 -- same error as above
---- && x == 0
---- -> over (creatures . ix cid . crPos)
---- (+.+ (12 *.* errorNormalizeVAI (ypos -.- cpos)))
---- $ replaceImpulse [MeleeAttack 5]
---- $ damageYou
---- w
---- | canSee cid (_yourID w) w && dist cpos ypos < 50
---- -> mvForward 2 cid $ turnTowardSpeed 0.5 ypos cid
---- $ replaceImpulse [MoveToFor ypos (max 0 (x-1))] w
---- | x == 0 && canSee cid (_yourID w) w
---- -> mvForward 2 cid $ turnTowardSpeed 0.5 p cid
---- $ replaceImpulse [MoveToFor tp 0] w
---- | x == 0 -> replaceImpulse [MoveToFor p 10] w
---- | canSee cid (_yourID w) w
---- -> mvForward 2 cid $ turnTowardSpeed 0.5 p cid
---- $ replaceImpulse [MoveToFor p (x-1)] w
---- | dist cpos p < 20 -> w
---- | otherwise -> mvForward 2 cid $ turnTowardSpeed 0.5 p cid w
---- (MeleeAttack x:_)
---- | x == 0 -> replaceImpulse [WaitFor 5] w
---- | otherwise -> replaceImpulse [MeleeAttack (x-1)] w
---- (WaitFor x:gls)| x == 0 -> replaceImpulse [] w
---- | canSee cid (_yourID w) w
---- -> turnTowardSpeed 0.02 ypos cid
---- $ replaceImpulse [WaitFor (x-1)] w
---- | otherwise -> replaceImpulse [WaitFor (x-1)] w
errorNormalizeVAI :: Point2 -> Point2
errorNormalizeVAI (0,0) = error "problem with function: errorNormalizeVAI in DodgeAIs"
errorNormalizeVAI p = normalizeV p
----------------
src/Dodge/AIs.hs.orig
-1954
View File
File diff suppressed because it is too large Load Diff
src/Dodge/Base.hs
+18 -11
View File
@@ -45,9 +45,9 @@ midPadL i x xs ys = take j (xs ++ repeat x) ++ ys
j = i - length ys
takeUntil :: (a -> Bool) -> [a] -> [a]
takeUntil f ps = case span (not . f) ps of
takeUntil f ps = case break f ps of
(xs,[]) -> xs
(xs,(y:_)) -> xs ++ [y]
(xs, y:_ ) -> xs ++ [y]
you :: World -> Creature
you w = _creatures w IM.! _yourID w
@@ -63,7 +63,7 @@ crItem w cid = _crInv cr IM.! _crInvSel cr
where
cr = _creatures w IM.! cid
yourItemRef w = (creatures . ix (_yourID w) . crInv . ix (_crInvSel (you w)))
yourItemRef w = creatures . ix (_yourID w) . crInv . ix (_crInvSel (you w))
wallNormal :: Wall -> Point2
wallNormal wl = normalizeV . vNormal $ a -.- b
@@ -73,22 +73,21 @@ wallNormal wl = normalizeV . vNormal $ a -.- b
wallsOnLine :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall]
wallsOnLine p1 p2 ws = hitWalls
where
hitPoint w = intersectSegSeg' p1 p2 (fst $ _wlLine w) (snd $ _wlLine w)
hitPoint w = uncurry (intersectSegSeg' p1 p2) (_wlLine w)
hitWalls = filter (isJust . hitPoint) (IM.elems ws)
wallOnLine :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Wall
wallOnLine p1 p2 ws
= listToMaybe $ sortBy f hitWalls
where
hitPoint w = intersectSegSeg' p1 p2 (fst $ _wlLine w) (snd $ _wlLine w)
hitPoint w = uncurry (intersectSegSeg' p1 p2) (_wlLine w)
hitWalls = filter (isJust . hitPoint) (IM.elems ws)
f w1 w2 = compare (magV (p1 -.- fromJust (hitPoint w1))) (magV (p1 -.- fromJust (hitPoint w2)))
wallsOnCirc :: Point2 -> Float -> IM.IntMap Wall -> [Wall]
wallsOnCirc p r wls = IM.elems $ IM.filter f wls
wallsOnCirc :: Point2 -> Float -> IM.IntMap Wall -> IM.IntMap Wall
wallsOnCirc p r = IM.filter f
where
f wl = circOnSeg (fst $ _wlLine wl) (snd $ _wlLine wl) p r
f wl = uncurry circOnSeg (_wlLine wl) p r
allWalls :: World -> IM.IntMap Wall
allWalls w = IM.unions $ concatMap IM.elems $ IM.elems $ _wallsZone w
@@ -288,7 +287,7 @@ collidePointWallsNorm p1 p2 ws
= listToMaybe
. sortOn f
. IM.elems
$ IM.mapMaybe (( \(x,y) -> intersectSegSeg' p1 p2 x y <&> (, vNormal $ x -.- y ) )
$ IM.mapMaybe (( \(x,y) -> intersectSegSeg' p1 p2 x y <&> ( , vNormal $ x -.- y ) )
. _wlLine) ws
where
f (a,_) = magV (p1 -.- a)
@@ -301,7 +300,7 @@ collidePointWallsCol p1 p2 ws
. sortOn f
. IM.elems
$ IM.mapMaybe ( (\(m, c) -> m <&> (, c))
. (\w -> (intersectSegSeg' p1 p2 (fst $ _wlLine w) (snd $ _wlLine w), _wlColor w))) ws
. (\w -> (uncurry (intersectSegSeg' p1 p2) (_wlLine w), _wlColor w))) ws
where
f (a,_) = magV (p1 -.- a)
{- | Looks for first collision of a point with walls.
@@ -507,3 +506,11 @@ isAnimate cr = case _crActionPlan cr of
_ -> True
sigmoid x = x/sqrt(1+x^2)
{- | In order to force a list, apply with seq. -}
forceSpine :: [a] -> ()
forceSpine = foldr (const id) ()
forceList :: [a] -> [a]
forceList l = seq (forceSpine l) l
src/Dodge/Base/Collide.hs
+13 -18
View File
@@ -13,9 +13,7 @@ import Control.Lens
hasLOS :: Point2 -> Point2 -> World -> Bool
{-# INLINE hasLOS #-}
hasLOS p1 p2 w = (not $ pointHitsWalls p1 p2 nearbyWalls)
where
nearbyWalls = wallsAlongLine p1 p2 w
hasLOS p1 p2 w = not $ pointHitsWalls p1 p2 $ wallsAlongLine p1 p2 w
-- | looks for first collision of a point with walls
-- if found, gives point and reflection velocity
reflectPointWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
@@ -56,11 +54,11 @@ reflectPointWallsDamped dfact p1 p2 ws
-- | Test if a point collides with walls
pointHitsWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
pointHitsWalls p1 p2
= any $ isJust . ( \(x,y) -> intersectSegSeg' p1 p2 x y) . _wlLine
= any $ isJust . uncurry (intersectSegSeg' p1 p2) . _wlLine
-- | Test if there something blocking a walk
collidePointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
collidePointWalkable p1 p2 ws
= any (isJust . ( \(x,y) -> intersectSegSeg' p1 p2 x y) . _wlLine)
= any (isJust . uncurry (intersectSegSeg' p1 p2) . _wlLine)
$ IM.filter (fromMaybe True . (^? doorPathable)) ws
furthestPointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
@@ -69,7 +67,7 @@ furthestPointWalkable p1 p2 ws
. listToMaybe
. sortOn (dist p1)
. IM.elems
$ IM.mapMaybe ( ( \(x,y) -> intersectSegSeg' p1 p2 x y) . _wlLine) ws
$ IM.mapMaybe ( uncurry (intersectSegSeg' p1 p2) . _wlLine) ws
collidePointIndirect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
{-# INLINE collidePointIndirect #-}
@@ -77,7 +75,7 @@ collidePointIndirect p1 p2 ws
= listToMaybe
. sortOn (dist p1)
. IM.elems
. IM.mapMaybe ( ( \(x,y) -> intersectSegSeg' p1 p2 x y) . _wlLine)
. IM.mapMaybe ( uncurry (intersectSegSeg' p1 p2) . _wlLine)
$ IM.filter (not . _wlIsSeeThrough) ws
{- | Checks to see whether someone can fire bullets effectively between two points.
- Not sure if this needs vision as well, need to make this uniform. -}
@@ -86,13 +84,13 @@ collidePointFire p1 p2 ws
= listToMaybe
. sortOn (dist p1)
. IM.elems
. IM.mapMaybe ( ( \(x,y) -> intersectSegSeg' p1 p2 x y) . _wlLine )
. IM.mapMaybe ( uncurry (intersectSegSeg' p1 p2) . _wlLine )
$ IM.filter (\wl -> not (_wlIsSeeThrough wl && isJust (wl ^? blHP))) ws
{- | Checks to see whether someone can fire bullets effectively between two points.
- Not sure if this needs vision as well, need to make this uniform. -}
collidePointFireVision :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
collidePointFireVision p1 p2 ws
= any ( isJust . ( \(x,y) -> intersectSegSeg' p1 p2 x y) . _wlLine)
= any ( isJust . uncurry (intersectSegSeg' p1 p2) . _wlLine)
$ IM.filter notBlockWindow ws
where
notBlockWindow wl = case wl ^? blHP of
@@ -125,15 +123,14 @@ canSeePoint i p w = hasLOS p1 p w
pathToPointFireable :: Int -> Point2 -> World -> Bool
pathToPointFireable i p w
= not
. pointHitsWalls (_crPos (_creatures w IM.! i)) p
$ IM.filter (not . isJust . \wl -> wl ^? blHP) $ wallsAlongLine p1 p w
. pointHitsWalls (_crPos $ _creatures w IM.! i) p
$ IM.filter (isNothing . (^? blHP) ) $ wallsAlongLine p1 p w
where
p1 = _crPos (_creatures w IM.! i)
canSeePointAll :: Int -> Point2 -> World -> Bool
canSeePointAll i targPos w
= and
$ map (flip (canSeePoint i) w . (\p -> (targPos +.+ radius *.* p))) [(1,0),(0,1),(-1,0),(0,-1)]
= 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
@@ -141,8 +138,7 @@ canSeePointAll i targPos w
canSeeAny :: Int -> Int -> World -> Bool
canSeeAny fromID toID w
= or
$ map (flip (canSeePoint fromID) w . (\p -> (cpos +.+ radius *.* p))) [(1,0),(0,1),(-1,0),(0,-1)]
= any (flip (canSeePoint fromID) w . (\p -> cpos +.+ radius *.* p)) [(1,0),(0,1),(-1,0),(0,-1)]
where
cr = _creatures w IM.! toID
cpos = _crPos cr
@@ -150,8 +146,7 @@ canSeeAny fromID toID w
canSeeAll :: Int -> Int -> World -> Bool
canSeeAll fromID toID w
= and
$ map (flip (canSeePoint fromID) w . (\p -> (cpos +.+ radius *.* p))) [(1,0),(0,1),(-1,0),(0,-1)]
= all (flip (canSeePoint fromID) w . (\p -> cpos +.+ radius *.* p)) [(1,0),(0,1),(-1,0),(0,-1)]
where
cr = _creatures w IM.! toID
cpos = _crPos cr
@@ -164,7 +159,7 @@ canWalk i j w = not $ collidePointWalkable ipos jpos $ wallsAlongLine ipos jpos
jpos = _crPos (_creatures w IM.! j)
canSeeIndirect :: Int -> Int -> World -> Bool
canSeeIndirect i j w = not . isJust . collidePointIndirect ipos jpos $ wallsAlongLine ipos jpos w
canSeeIndirect i j w = isNothing . collidePointIndirect ipos jpos $ wallsAlongLine ipos jpos w
where
ipos = _crPos (_creatures w IM.! i)
jpos = _crPos (_creatures w IM.! j)
src/Dodge/Config/KeyConfig.hs
+1 -1
View File
@@ -7,7 +7,7 @@ import Foreign.C.Types
import GHC.Generics
import qualified GHC.Int
import qualified SDL
import SDL.Internal.Numbered as SDL.Internal.Numbered
import qualified SDL.Internal.Numbered
import System.Directory
src/Dodge/Creature.hs
+10 -66
View File
@@ -9,10 +9,8 @@ module Dodge.Creature
where
import Dodge.Creature.Stance.Data
import Dodge.Creature.State.Data
import Dodge.Creature.Impulse.Data
import Dodge.Creature.ImpulseRat
import Dodge.Creature.ActionRat
import Dodge.Creature.Rationality.Data
import Dodge.Creature.AlertLevel
import Dodge.Creature.SetTarget
import Dodge.Creature.Test
@@ -21,7 +19,6 @@ import Dodge.Creature.PistolCrit
import Dodge.Creature.LtAutoCrit
import Dodge.Creature.SpreadGunCrit
import Dodge.Data
import Dodge.AIs
import Dodge.Default
import Dodge.Base
import Dodge.Item.Weapon
@@ -35,7 +32,6 @@ import Dodge.Creature.Rationality
import Dodge.Creature.ChooseTarget
import Dodge.Item
import Dodge.Picture.Layer
import Dodge.Creature.Picture
import Picture
import Geometry
@@ -63,7 +59,6 @@ spawnerCrit = defaultCreature
{ --_crUpdate = stateUpdate $ spawnerAI chaseCrit
_crHP = 300
, _crPict = basicCrPict blue
, _crState = defaultState {_goals = [[WaitFor 0]] }
, _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
}
smallChaseCrit :: Creature
@@ -78,10 +73,11 @@ smallChaseCrit = defaultCreature
}
chaseCrit :: Creature
chaseCrit = defaultCreature
{ _crUpdate = stateUpdate $ impulsiveAI $ composeInternalAIs
[ chaseTarget targetYouLOS
, \ _ -> crMeleeCooldown . _Just %~ (max 0 . subtract 1)
]
{ _crUpdate = stateUpdate $ impulsiveAIR $
chaseTargetR targetYouLOS <=<
overrideMeleeCloseTargetR <=<
basicPerceptionUpdateR [0] <=<
return . (crMeleeCooldown . _Just %~ (max 0 . subtract 1))
, _crHP = 300
, _crPict = basicCrPict green
, _crInv = IM.empty
@@ -93,7 +89,6 @@ armourChaseCrit = defaultCreature
{ _crUpdate = stateUpdate $ meleeCooldown $ impulsiveAI $ chaseTarget targetYouLOS
, _crHP = 300
, _crPict = basicCrPict green
, _crState = defaultState {_goals = [[Wait]]}
, _crInv = IM.fromList
[(0,frontArmour)
,(1,medkit 200)
@@ -139,7 +134,6 @@ longCrit = defaultCreature
, _crInv = IM.fromList [(0,longGun),(1,medkit 100)]
, _crInvSel = 0
, _crRad = 10
, _crState = defaultState {_goals = [[InitGuard]]}
, _crHP = 300
}
multGunCrit :: Creature
@@ -149,7 +143,6 @@ multGunCrit = defaultCreature
, _crInv = IM.fromList [(0,multGun),(1,medkit 100)]
, _crInvSel = 0
, _crRad = 10
, _crState = defaultState {_goals = [[InitGuard]]}
, _crHP = 300
, _crUpdate = stateUpdate $ impulsiveAI $ composeInternalAIs
[ performActions
@@ -197,68 +190,21 @@ autoCrit = defaultCreature
, _crInv = IM.fromList [(0,autoGun),(1,medkit 100)]
, _crInvSel = 0
, _crRad = 10
, _crState = defaultState {_goals = [[InitGuard]]}
, _crHP = 300
}
addArmour :: Creature -> Creature
addArmour = over crInv insarmour
where
insarmour xs = IM.insert (newKey xs) frontArmour xs
--packCrits :: (Int -> World -> World) -> [Int] -> [Creature]
--packCrits ai is = [(defaultCreature i)
-- { _crPos = (150,10+20*fromIntegral i)
-- , _crPict = swarmPict
-- , _crUpdate = ai i
-- --, _crUpdate = swarmAI is i
-- , _crRad = 3
-- , _crHP = 1
-- , _crMass = 2
-- }
-- | i <- is]
--queenBeeCrit :: Int -> Creature
--queenBeeCrit cID = (defaultCreature cID)
-- { _crRad = 20
-- , _crCorpse = color (greyN 0.5) $ circleSolid 20
-- , _crPict = const $ pictures [color black $ circSolid 20
-- ,color yellow $ circLine 20
-- ]
-- , _crUpdate = checkDead cID . makeStateAI queenBeeAI cID
-- , _crState = QueenBee 0 20
-- , _crMass = 20
-- }
--antCrit :: Int -> Creature
--antCrit cID = (defaultCreature cID)
-- { _crPos = (0,100 + 3 * fromIntegral cID)
-- , _crUpdate = checkDead cID . makeStateAI (antAI 2) cID
-- , _crState = AntMove 50
-- , _crPict = antPic
-- , _crRad = 3
-- , _crHP = 1
-- , _crMass = 2
-- , _crCorpse = color (greyN 0.5) $ circSolid 3
-- }
-- where i = evalState (state (randomR (1::Int,100))) (mkStdGen cID)
--antPic = const $ pictures [ translate (-1) 0 $ circleSolid 2
-- , translate (2) 0 $ circleSolid 1
-- , translate (1) 0 $ circleSolid 1
-- , line [(3,3),(-3,-3)]
-- , line [(-3,3),(3,-3)]
-- , line [(0,-3),(0,3)]
-- ]
{- |
The creature you control.
ID 0.
-}
{- | The creature you control.
ID 0. -}
startCr :: Creature
startCr = defaultCreature
{ _crPos = (0,0)
, _crOldPos = (0,0)
, _crDir = 0
, _crID = 0
, _crPict = basicCrPict $ black
, _crPict = basicCrPict black
, _crUpdate = stateUpdate yourControl
, _crRad = 10
, _crMass = 10
@@ -268,9 +214,7 @@ startCr = defaultCreature
, _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ pictures [color (greyN 0.8) $ circleSolid 10, circLine 10]
, _crFaction = PlayerFaction
}
{- |
Items you start with.
-}
{- | Items you start with. -}
startInventory = IM.fromList (zip [0..20]
(
[bezierGun
@@ -298,5 +242,5 @@ startInventory = IM.fromList (zip [0..20]
++
repeat NoItem))
smokeGenGun = effectGun "smoke" $ \_ -> spawnSmokeAtCursor
smokeGenGun = effectGun "smoke" $ const spawnSmokeAtCursor
src/Dodge/Creature/AI.hs
-11
View File
@@ -1,11 +0,0 @@
module Dodge.Creature.AI
where
import Dodge.Data
import Control.Lens
import System.Random
insectAI
:: ( World -> StdGen -> Creature -> (World -> World, StdGen, Creature) )
-> World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature)
insectAI = undefined
src/Dodge/Creature/AI/Data.hs
-12
View File
@@ -1,12 +0,0 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
module Dodge.Creature.AI.Data
where
import Dodge.Creature.State.Data
import Dodge.Creature.Impulse.Data
import Control.Lens
data Intelligence
= Zombie { _crImpulse :: Impulse }
| Inanimate
src/Dodge/Creature/Action.hs
+11 -14
View File
@@ -1,6 +1,5 @@
{- | Actions performed by creatures within the world
-}
{-# LANGUAGE BangPatterns #-}
module Dodge.Creature.Action
( module Dodge.Creature.Action
, module Dodge.Creature.Action.UseItem
@@ -36,9 +35,9 @@ crStrafeLeft
-> Creature
crStrafeLeft speed cr = advanceStepCounter s2 $ over crPos (+.+ p) cr
where
p = (*.*) s2 $ unitVectorAtAngle $ (_crDir cr + pi/2)
p = s2 *.* unitVectorAtAngle (_crDir cr + pi/2)
equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr
s2 = (speed * equipFactor)
s2 = speed * equipFactor
crStrafeRight
:: Float -- ^ Speed
@@ -46,9 +45,9 @@ crStrafeRight
-> Creature
crStrafeRight speed cr = advanceStepCounter s2 $ over crPos (+.+ p) cr
where
p = (*.*) s2 $ unitVectorAtAngle $ (_crDir cr - pi/2)
p = s2 *.* unitVectorAtAngle (_crDir cr - pi/2)
equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr
s2 = (speed * equipFactor)
s2 = speed * equipFactor
turnTo
:: Point2 -- ^ Target point
@@ -239,7 +238,7 @@ blinkAction n w
cp = _crPos $ _creatures w IM.! n
p2 = reflectPointWalls cp p1 $ wallsAlongLine cp p1 w
r = 1.5 * _crRad (_creatures w IM.! n)
p3 = fromMaybe p1 (fmap ((\p -> moveAmountToward p r cp) . fst) p2)
p3 = maybe p1 ((\p -> moveAmountToward p r cp) . fst) p2
blinkShockwave
:: Int -- ^ Blinking creature ID.
@@ -317,7 +316,6 @@ pickUpItem cid flit w = case maybeInvSlot of
updateItLocation invid w' = case _itID it of
Nothing -> w'
Just j -> w' & itemPositions . ix j .~ InInv 0 invid
{- | Creature attempts to moves under its own steam.
The idea is that this may or may not work, depending on the status of the creature.
For now, though, this cannot fail. -}
@@ -329,25 +327,24 @@ crMvBy p' cr = advanceStepCounter (magV p) $ over crPos (+.+ p) cr
where
p = (*.*) (equipFactor * aimingFactor) $ rotateV (_crDir cr) p'
equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr
aimingFactor | (_posture $ _crStance cr) == Aiming
= fromMaybe 1 $ it ^? itAimingSpeed
| otherwise = 1
aimingFactor
| _posture (_crStance cr) == Aiming = fromMaybe 1 $ it ^? itAimingSpeed
| otherwise = 1
it = _crInv cr IM.! _crInvSel cr
crMvForward
:: Float -- ^ Speed
-> Creature
-> Creature
crMvForward speed cr = crMvBy (speed,0) cr
crMvForward speed = crMvBy (speed,0)
advanceStepCounter
:: Float -- ^ Speed
-> Creature
-> Creature
advanceStepCounter speed cr = over (crStance . carriage) f cr
advanceStepCounter speed = crStance . carriage %~ f
where
f (w@Walking {}) = w {_stepToAdd = ceiling speed}
f w@Walking{} = w{_stepToAdd = ceiling speed}
f s = s
creatureTurn :: Float -> Creature -> Creature
src/Dodge/Creature/Action/Movement.hs
+1 -1
View File
@@ -9,7 +9,7 @@ import Control.Lens
strafeTo :: Float -> Point2 -> Int -> World -> World
strafeTo speed targPos cid w = over (creatures . ix cid . crPos) (+.+ q) w
where q = (*.*) (speed * equipFactor * wpFactor)
$ safeNormalizeV $ (targPos -.- _crPos cr)
$ safeNormalizeV $ targPos -.- _crPos cr
equipFactor = product $ map equipSpeed $ IM.elems $ _crInv $ _creatures w IM.! cid
cr = _creatures w IM.! cid
wpFactor = _itAimingSpeed (_crInv cr IM.! _crInvSel cr)
src/Dodge/Creature/Action/UseItem.hs
+8 -11
View File
@@ -7,10 +7,13 @@ import Dodge.Inventory
import qualified Data.IntMap as IM
import Control.Lens
import Data.Maybe (fromMaybe)
import Data.Maybe (maybe)
useItem :: Int -> World -> World
useItem n w = equippedItemEffect n w
useItem n w = itemEffect n it w
where
c = _creatures w IM.! n
it = _crInv c IM.! _crInvSel c
crUseItem :: Creature -> World -> World
--crUseItem cr = itemEffect (_crID cr) (_crInv cr IM.! _crInvSel cr)
@@ -24,18 +27,12 @@ tryUseItem cid w = case w ^? creatures . ix cid of
Just cr -> itemEffect cid (_crInv cr IM.! _crInvSel cr) w
Nothing -> w
equippedItemEffect :: Int -> World -> World
equippedItemEffect n w = itemEffect n it w
where
c = _creatures w IM.! n
it = _crInv c IM.! _crInvSel c
itemEffect
:: Int -- ^ Creature id (I am almost certain)
-> Item
-> World
-> World
itemEffect n (Consumable {_cnEffect=eff }) w = fromMaybe w $ rmSelectedInvItem n <$> eff n w
itemEffect n (Weapon {_wpFire=eff}) w = eff n w
itemEffect n (Throwable {_twFire = eff}) w = eff n w
itemEffect n Consumable{_cnEffect=eff } w = maybe w (rmSelectedInvItem n) (eff n w)
itemEffect n Weapon{_wpFire=eff} w = eff n w
itemEffect n Throwable{_twFire = eff} w = eff n w
itemEffect _ _ w = w
src/Dodge/Creature/ActionRat.hs
+3 -4
View File
@@ -20,7 +20,6 @@ import Dodge.Data
import Dodge.Base
import Dodge.Base.Collide
import Dodge.Creature.ChooseTarget
import Dodge.Creature.Rationality.Data
import Dodge.Creature.Stance.Data
import Dodge.Creature.Test
import Geometry
@@ -216,7 +215,7 @@ applyNewStrategies
applyNewStrategies w cr = case cr ^? crActionPlan . crStrategy of
Just (StrategyActions strat acs) -> cr & crActionPlan . crAction .~ acs
& crActionPlan . crStrategy .~ strat
otherwise -> cr
_ -> cr
doStrategyActions
:: World
@@ -225,7 +224,7 @@ doStrategyActions
doStrategyActions w cr = case cr ^? crActionPlan . crStrategy of
Just (StrategyActions strat acs) -> cr & crActionPlan . crAction .~ acs
& crActionPlan . crStrategy .~ strat
otherwise -> cr
_ -> cr
updateShoot
:: World
@@ -270,7 +269,7 @@ watchUpdateStrat
-> Creature
watchUpdateStrat fs w cr = case cr ^? crActionPlan . crStrategy of
Just WatchAndWait -> cr
& crActionPlan . crStrategy .~ listGuard (fs, (\_ _ -> WatchAndWait)) (w, cr) w cr
& crActionPlan . crStrategy .~ listGuard (fs, \_ _ -> WatchAndWait) (w, cr) w cr
_ -> cr
listGuard :: ([(a -> Bool, b)] , b) -> a -> b
src/Dodge/Creature/AlertLevel.hs
+14 -6
View File
@@ -3,11 +3,12 @@ module Dodge.Creature.AlertLevel
where
import Dodge.Data
import Dodge.Creature.AlertLevel.Data
import Dodge.Base.Collide
import Dodge.Base
--import Dodge.Base.Collide
import Control.Lens
import Control.Monad.Reader
import qualified Data.IntMap.Strict as IM
{- | Ties together (currently) an awareness and attention update -}
basicPerceptionUpdate
:: [Int] -- ^ List of creature ids that may direct attention and awareness
@@ -15,13 +16,20 @@ basicPerceptionUpdate
-> Creature
-> Creature
basicPerceptionUpdate is w cr
= basicAwarenessUpdate w $
basicAttentionUpdate is w cr
= basicAwarenessUpdate w $ basicAttentionUpdate is w cr
basicPerceptionUpdateR
:: [Int] -- ^ List of creature ids that may direct attention and awareness
-> Creature
-> Reader World Creature
basicPerceptionUpdateR is cr = reader $ \w ->
basicAwarenessUpdate w $ basicAttentionUpdate is w cr
{- | Update a creatures awareness based upon the creatures current direction
of attention -}
basicAwarenessUpdate
:: World -> Creature -> Creature
basicAwarenessUpdate w cr = case _crAttentionDir cr of
basicAwarenessUpdate _ cr = case _crAttentionDir cr of
AttentiveTo is -> cr & crAwarenessLevel %~ updateAwareness is
Fixated i -> cr & crAwarenessLevel
%~ ( IM.insert i (Cognizant 100) . IM.mapMaybe decreaseAwareness)
@@ -54,4 +62,4 @@ basicAttentionUpdate
-> Creature
-> Creature
basicAttentionUpdate cids w cr = cr & crAttentionDir .~
AttentiveTo (filter (\cid -> canSee (_crID cr) cid w) cids)
AttentiveTo (forceList $ filter (\cid -> canSee (_crID cr) cid w) cids)
src/Dodge/Creature/AlertLevel/Data.hs
+7 -2
View File
@@ -1,5 +1,8 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
module Dodge.Creature.AlertLevel.Data
where
import Control.Lens
data AwakeLevel
= Comatose
@@ -9,9 +12,11 @@ data AwakeLevel
| Overstrung
data AttentionDir
= AttentiveTo [Int]
| Fixated Int
= AttentiveTo {_unAttentiveTo :: [Int]}
| Fixated {_unFixated :: Int }
data AwarenessLevel
= AwarenessInt Int
| Cognizant Int
makeLenses ''AttentionDir
src/Dodge/Creature/Data.hs
-5
View File
@@ -1,5 +0,0 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
module Dodge.Creature.Data
where
import Control.Lens
src/Dodge/Creature/Impulse/Data.hs
-58
View File
@@ -1,58 +0,0 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
module Dodge.Creature.Impulse.Data
where
import Dodge.Creature.Stance.Data
import Geometry.Data
import Control.Lens
data Impulse
= MoveTo Point2
| MoveToFor Point2 Int
| MoveFire Point2 Point2
| PathTo Point2
| PathAlong [Point2]
| SubPathTo Point2 Int Point2
| Wait
| WaitFor Int
| WaitForID Int Int
| FireAt Point2
| FireAtID Int Point2
| Fire
| Reload
| IncreaseAlert Int
| Guard Point2 Point2
| Search Int
| SearchNear Point2
| AimAt Point2 Int
| InitGuard
| Init
| MeleeAttack Int
| InitTrackYou
| TrackYou
| Track Int
| TrackFor Int Int
| TurnByFor Float Int
| TurnTo Point2
| TurnToward Point2
| TurnTowardAngle Float
| StrafeLeftAround Int Point2
| StrafeRightAround Int Point2
| StrafeLeftFor Int
| StrafeRightFor Int
| StrafeLeftForSpeed Int Float
| StrafeRightForSpeed Int Float
| StrafeLeftFire
| StrafeRightFire
| MoveForwardFor Int
| MoveForwardFire
| MoveBackwardFor Int
| MoveByFor Point2 Int
| MoveBackwardFire
| ImpulseID Int Impulse
| AtRange Float
| AtRanges Float Float
| RepeatAction Int Impulse
| MakeJudgement
| SetPosture Posture
deriving (Eq,Show)
src/Dodge/Creature/ImpulseRat.hs
+59 -16
View File
@@ -4,23 +4,22 @@ import Dodge.Data
import Dodge.Base
import Dodge.Creature.ChooseTarget
import Dodge.Creature.State.Data
import Dodge.Creature.Rationality.Data
import Geometry
import qualified Data.IntMap as IM
import Control.Lens
import Control.Monad.Reader
encircle :: Creature -> IM.IntMap Creature -> Creature -> Point2
encircle tcr crs cr
| length crs <= 1 = ypos
| otherwise = ypos +.+ f (max 0 (magV (ypos -.- cenp) - 30) ) *.* safeNormalizeV (cpos -.- cenp)
| otherwise = ypos +.+ f (max 0 (magV (ypos -.- cenp) - 80) ) *.* safeNormalizeV (cpos -.- cenp)
where
cpos = _crPos cr
ypos = _crPos tcr
f x = 150 * sigmoid (x-10)
cenp = (1 / fromIntegral (length crs)) *.* foldr1 (+.+) (map _crPos $ IM.elems crs)
lineOrth :: Creature -> IM.IntMap Creature -> Creature -> Point2
lineOrth tcr crs cr = p
where
@@ -64,6 +63,19 @@ spreadOut ycr crs cr = p
| dist ypos cpos > 90 = 1
| otherwise = 1.5
swarmUsingCenter
:: (Creature -> Point2 -> Creature -> Creature)
-> (Point2 -> Creature -> Creature)
-> World
-> Creature
-> Creature
swarmUsingCenter updT upd w cr = case _crTarget cr of
Nothing -> upd cenp cr
Just tcr -> updT tcr cenp cr
where
cid = _crID cr
cenp = _crGroupCenter $ _creatureGroups w IM.! (_crGroupID $ _crGroup $ _creatures w IM.! cid)
flockChaseTarget
:: (Creature -> IM.IntMap Creature -> Creature -> Creature) -- ^ Update with target
-> (IM.IntMap Creature -> Creature -> Creature) -- ^ Update without target
@@ -100,17 +112,52 @@ chaseTarget targFunc w cr = case targFunc cr w of
Nothing -> cr
Just crTarg -> cr & crActionPlan . crImpulse .~ chaseTarg cr crTarg
chaseTargetR
:: (Creature -> World -> Maybe Creature) -- ^ Function for determining target
-> Creature
-> Reader World Creature
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
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
where
cpos = _crPos cr
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
where
cpos = _crPos cr
chaseTarg' :: Point2 -> Creature -> Creature -> [Impulse]
chaseTarg' p cr crT
| dist tpos cpos < combinedRad + 5
&& abs ((_crDir cr) - argV (tpos -.- cpos)) < pi/4
&& abs (_crDir cr - argV (tpos -.- cpos)) < pi/4
&& _crMeleeCooldown cr == Just 0
= [Melee (_crID crT)]
| dist tpos cpos < combinedRad + 5
&& abs ((_crDir cr) - argV (tpos -.- cpos)) < pi/4
&& abs (_crDir cr - argV (tpos -.- cpos)) < pi/4
= [ TurnToward tpos 0.05 ]
| abs ((_crDir cr) - argV (p -.- cpos)) < pi/4
= [MoveForward 2.5 , TurnToward p 0.2, RandomTurn 0.2 ]
| abs (_crDir cr - argV (p -.- cpos)) < pi/4
= [MoveForward 2.5 , TurnToward p 0.2 , RandomTurn 0.2 ]
| otherwise = [MoveForward 2.5 , TurnToward p 0.05, RandomTurn 0.2 ]
where
cpos = _crPos cr
@@ -120,13 +167,9 @@ chaseTarg' p cr crT
chaseTarg :: Creature -> Creature -> [Impulse]
chaseTarg cr crT
| dist tpos cpos < combinedRad + 5
&& abs ((_crDir cr) - argV (tpos -.- cpos)) < pi/4
&& _crMeleeCooldown cr == Just 0
= [Melee (_crID crT)]
| dist tpos cpos < combinedRad + 5
&& abs ((_crDir cr) - argV (tpos -.- cpos)) < pi/4
&& abs (_crDir cr - argV (tpos -.- cpos)) < pi/4
= [ TurnToward tpos 0.05 ]
| abs ((_crDir cr) - argV (tpos -.- cpos)) < pi/4
| abs (_crDir cr - argV (tpos -.- cpos)) < pi/4
= [MoveForward 2.5 , TurnToward tpos 0.2, RandomTurn 0.2 ]
| otherwise = [MoveForward 2.5 , TurnToward tpos 0.05, RandomTurn 0.2 ]
where
@@ -146,13 +189,13 @@ impulseShootAtTarget targFunc w cr = case targFunc cr w of
impulseShootAtTarg :: Creature -> Creature -> [Impulse]
impulseShootAtTarg cr crT
| dist tpos cpos < combinedRad + 5
&& abs ((_crDir cr) - argV (tpos -.- cpos)) < pi/4
&& abs (_crDir cr - argV (tpos -.- cpos)) < pi/4
&& _crMeleeCooldown cr == Just 0
= [Melee (_crID crT)]
| dist tpos cpos < combinedRad + 5
&& abs ((_crDir cr) - argV (tpos -.- cpos)) < pi/4
&& abs (_crDir cr - argV (tpos -.- cpos)) < pi/4
= [ TurnToward tpos 0.05 ]
| abs ((_crDir cr) - argV (tpos -.- cpos)) < pi/4
| abs (_crDir cr - argV (tpos -.- cpos)) < pi/4
= [MoveForward 2.5 , TurnToward tpos 0.2, RandomTurn 0.2 ]
| otherwise = [MoveForward 2.5 , TurnToward tpos 0.05, RandomTurn 0.2 ]
where
src/Dodge/Creature/Inanimate.hs
+2 -5
View File
@@ -6,7 +6,6 @@ module Dodge.Creature.Inanimate
import Dodge.Data
import Dodge.Creature.Stance.Data
import Dodge.Creature.State.Data
import Dodge.Creature.Impulse.Data
import Dodge.Base
import Dodge.Picture.Layer
import Dodge.Default
@@ -59,8 +58,7 @@ barrel = defaultInanimate
, color (greyN 0.5) $ circleSolid 8
]
, _crState = defaultState
{_goals = [[Wait]]
,_crSpState = Barrel []
{_crSpState = Barrel []
}
, _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
}
@@ -74,8 +72,7 @@ explosiveBarrel = defaultInanimate
, color orange $ circleSolid 10
]
, _crState = defaultState
{_goals = [[Wait]]
,_crSpState = Barrel []
{_crSpState = Barrel []
}
, _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
,_crApplyDamage = \_ c -> (id, c)
src/Dodge/Creature/LauncherCrit.hs
+2 -2
View File
@@ -52,7 +52,7 @@ launcherCrit = defaultCreature
}
retreatFire :: Action
retreatFire = ImpulsesList ( [ [ UseItem ] ] ++ replicate 20 [ Turn 0.16 ])
retreatFire = ImpulsesList ( [ UseItem ] : replicate 20 [ Turn 0.16 ])
`DoActionThen`
HolsterWeapon
`DoActionThen`
@@ -60,7 +60,7 @@ retreatFire = ImpulsesList ( [ [ UseItem ] ] ++ replicate 20 [ Turn 0.16 ])
`DoActionThen`
DrawWeapon
`DoActionThen`
ImpulsesList ( [[UseItem]] ++ replicate 20 [ Turn $ negate 0.16 ] )
ImpulsesList ( [UseItem] : replicate 20 [ Turn $ negate 0.16 ] )
`DoActionThen`
HolsterWeapon
`DoActionThen`
src/Dodge/Creature/LtAutoCrit.hs
+1 -1
View File
@@ -72,4 +72,4 @@ chooseMovement cr w
tcr = _creatures w IM.! 0
p = _crPos tcr
v = vNormal $ p -.- cpos
p' = p +.+ 0.5 *.* (v -.- 20 *.* (normalizeV v))
p' = p +.+ 0.5 *.* (v -.- 20 *.* normalizeV v)
src/Dodge/Creature/Picture.hs
+3 -3
View File
@@ -33,17 +33,17 @@ basicCrPict col cr = pictures
| pdam > 99 = color white $ circleSolid $ _crRad cr
| otherwise = pictures [color col' $ circleSolid $ _crRad cr, circLine $ _crRad cr]
pastDams = _crPastDamage $ _crState cr
pdam = sum $ concatMap (map _dmAmount) $ pastDams
pdam = sum $ concatMap (map _dmAmount) pastDams
col' = light . light . light $ light col
bluntDam :: Maybe Point2
bluntDam = find isBluntDam (concat pastDams) >>= (\dm -> (-.-) <$> dm ^? dmFrom <*> dm ^? dmTo)
bluntScale = case fmap argV bluntDam of
Just a -> rotate (a + cdir) . scale 0.8 1.2 . rotate (negate $ cdir + a)
_ -> id
isBluntDam (Blunt {}) = True
isBluntDam Blunt{} = True
isBluntDam _ = False
piercingDam = find isPiercingDam (concat pastDams) >>= (\dm -> (-.-) <$> dm ^? dmFrom <*> dm ^? dmTo)
isPiercingDam (Piercing {}) = True
isPiercingDam Piercing{} = True
isPiercingDam _ = False
piercingMod = case fmap argV piercingDam of
Just a -> rotate (a + cdir) . scale 0.8 1.2 . rotate (negate $ cdir + a)
src/Dodge/Creature/PistolCrit.hs
+2 -2
View File
@@ -93,8 +93,8 @@ chooseMovement' cr w = takeOneWeighted [chargeProb,retreatProb,strafeProb,strafe
3
`DoReplicate`
ImpulsesList (replicate 9 [Move (0,-3)] ++ [[Move (0,-3),UseItem]])
yposl = ypos -.- 100 *.* (vNormal $ normalizeV $ ypos -.- cpos)
yposr = ypos +.+ 100 *.* (vNormal $ normalizeV $ ypos -.- cpos)
yposl = ypos -.- 100 *.* vNormal (normalizeV $ ypos -.- cpos)
yposr = ypos +.+ 100 *.* vNormal (normalizeV $ ypos -.- cpos)
retreatActions :: Creature -> Creature -> Action
retreatActions tcr cr =
src/Dodge/Creature/Rationality.hs
+28 -2
View File
@@ -2,7 +2,6 @@ module Dodge.Creature.Rationality
where
import Dodge.Data
import Dodge.Base.Collide
import Dodge.Creature.Rationality.Data
import Dodge.Creature.Action
import Dodge.Creature.Action.UseItem
import Dodge.Creature.State.Data
@@ -14,6 +13,7 @@ import Data.Maybe
import qualified Data.IntMap.Strict as IM
import System.Random
import Control.Lens
import Control.Monad.Reader
-- Alternatives would probably be a very good fit for actions...
@@ -24,6 +24,14 @@ composeInternalAIs
-> Creature
composeInternalAIs fs w c = foldr ($ w) c fs
impulsiveAIR
:: (Creature -> Reader World Creature)
-> World
-> (World -> World, StdGen)
-> Creature
-> ((World -> World, StdGen) , Maybe Creature)
impulsiveAIR impf w (f,g) cr = followImpulses w (f,g) . ($ w) . runReader . impf $ cr
impulsiveAI
:: (World -> Creature -> Creature) -- ^ Internal AI update, should determine impulses
-> World
@@ -84,7 +92,7 @@ followImpulse cr w imp = case imp of
rr a = fst $ randomR (-a,a) $ _randGen w
hitCr i = over (creatures . ix i . crState . crDamage) (addDam i)
. soundOnce (fromIntegral hitSound)
addDam i dams = (( Blunt 100 cpos (posFromID i) (posFromID i) ) : dams )
addDam i dams = Blunt 100 cpos (posFromID i) (posFromID i) : dams
actionUpdateAI
:: (World -> Creature -> Creature) -- ^ the function updating the actions
@@ -93,6 +101,24 @@ 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
| otherwise = listGuard (ps, z) x
listGuard (_,z) _ = z
performActions :: World -> Creature -> Creature
performActions w cr = cr
& crActionPlan . crImpulse .~ concat iss
src/Dodge/Creature/Rationality/Data.hs
-8
View File
@@ -1,8 +0,0 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
module Dodge.Creature.Rationality.Data
where
import Dodge.Creature.Stance.Data
import Geometry.Data
import Control.Lens
src/Dodge/Creature/SetTarget.hs
+2 -1
View File
@@ -8,10 +8,11 @@ import Dodge.Creature.AlertLevel.Data
import Control.Lens
import qualified Data.IntMap.Strict as IM
{- | Assumes that you are id 0: if creature is cognizant of you, sets you as target -}
targetYouWhenCognizant
:: World
-> Creature
-> Creature
targetYouWhenCognizant w cr = case cr ^? crAwarenessLevel . ix 0 of
Just (Cognizant _) -> cr & crTarget .~ Just (_creatures w IM.! 0)
Just (Cognizant _) -> cr & crTarget ?~ _creatures w IM.! 0
_ -> cr & crTarget .~ Nothing
src/Dodge/Creature/State.hs
+32 -49
View File
@@ -2,7 +2,6 @@ module Dodge.Creature.State where
import Dodge.Data
import Dodge.Creature.State.Data
import Dodge.Creature.Stance.Data
import Dodge.Data
import Dodge.Base
import Dodge.SoundLogic
import Dodge.RandomHelp
@@ -16,16 +15,11 @@ import Data.List
import Data.Char
import Data.Maybe
import Data.Function
--import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.PatriciaTree
import Data.Graph.Inductive.Query.SP
import Codec.BMP
import qualified Data.ByteString as B
import Control.Lens
import Control.Applicative
import Control.Monad.State
import Control.Monad
import qualified SDL as SDL
import qualified SDL
import qualified SDL.Mixer as Mix
import System.Random
import qualified Data.Set as S
@@ -38,7 +32,6 @@ type CRUpdate = World -> (World -> World,StdGen) -> Creature -> ((World -> World
meleeCooldown :: CRUpdate -> CRUpdate
meleeCooldown u w (f,g) cr = u w (f,g) $ cr & crMeleeCooldown . _Just %~ (max 0 . (\x -> x - 1))
-- | The movement is updated before the ai in order to correctly set the oldpos.
-- the whole of this update cycle could do with a rethink, it is becoming
-- convoluted
@@ -46,11 +39,11 @@ stateUpdate :: CRUpdate -> CRUpdate
stateUpdate u w (f,g) cr =
let (cr', g'') = updateMovement g cr
in case u w (f,g'') cr' of
((f',g') , maybeCr) -> ( (invSideEff cr . movementSideEff cr . deathEff . f'
, g')
, fmap (updateReloadCounter . doDamage . crAutoReload)
$ crOrCorpse =<< maybeCr
)
((f',g') , maybeCr) ->
( (invSideEff cr . movementSideEff cr . deathEff . f'
, g')
, fmap (updateReloadCounter . doDamage . crAutoReload) $ crOrCorpse =<< maybeCr
)
where
crOrCorpse cr
| cr ^. crHP > 0 = Just cr
@@ -60,11 +53,11 @@ stateUpdate u w (f,g) cr =
| otherwise = stopSoundFrom (CrWeaponSound (_crID cr))
. over decorations addCorpse
. dropByState cr
crBeforeDeath = colCrWall w $ cr
addCorpse = insertNewKey $ uncurry translate (_crOldPos cr)
$ rotate (_crDir cr)
(_crCorpse cr)
crBeforeDeath = colCrWall w cr
addCorpse = insertNewKey
$ uncurry translate (_crOldPos cr)
$ rotate (_crDir cr)
(_crCorpse cr)
-- | Drop items according to the creature state.
dropByState :: Creature -> World -> World
dropByState cr w = foldr (copyItemToFloor cr) w is
@@ -75,10 +68,8 @@ dropByState cr w = foldr (copyItemToFloor cr) w is
DropSpecific xs -> xs
DropAmount n -> take n $ evalState (shuffle $ IM.keys $ _crInv cr) (_randGen w)
setOldPos :: Creature -> Creature
setOldPos cr = set crOldPos (_crPos cr) cr
{- |
Given a creature and a velocity, applies friction to that creature and evaluates a
velocity to carry across frames.
@@ -86,17 +77,12 @@ velocity to carry across frames.
crFriction :: Creature -> Point2 -> Point2
crFriction cr vel = (0,0)
{- | In order to force a list, apply with seq. -}
forceSpine :: [a] -> ()
forceSpine = foldr (const id) ()
doDamage :: Creature -> Creature
doDamage cr = set (crState . crDamage) []
$ over (crState . crPastDamage) (f . take 20 . (dams :) ) damagedCr
$ over (crState . crPastDamage) (forceList . take 20 . (dams :) ) damagedCr
where
f l = seq (forceSpine l) l
dams = _crDamage $ _crState cr
damagedCr = snd $ (_crApplyDamage cr) dams cr
damagedCr = snd $ _crApplyDamage cr dams cr
sumDamage :: Creature -> DamageType -> Int -> Int
sumDamage cr dm x = x + _dmAmount dm
@@ -107,7 +93,7 @@ movementSideEff cr w
= case cr ^? crStance . carriage of
Just (Boosting v)
-> makeFlameletTimed
(oldPos +.+ (_crRad cr + 3) *.* (unitVectorAtAngle $ _crDir cr + pi))
(oldPos +.+ (_crRad cr + 3) *.* unitVectorAtAngle (_crDir cr + pi))
(momentum +.+ 1 *.* rotateV randDir (vInverse v))
Nothing
1
@@ -128,9 +114,6 @@ movementSideEff cr w
(randDir,g) = randomR (-0.5,0.5) $ _randGen w
(randAng,_) = randomR (0,2*pi) $ _randGen w
(v1:v2:v3:_) = fst $ runState ((sequence . repeat . randInCirc) 0.1) $ _randGen w
(r1:r2:r3:_) = map ((*.*) 100) (v2:v3:v1:[])
crHasMoved = dist (_crPos cr) (_crOldPos cr) > 0.5
takeStep x y | crHasMoved && x < 20 && x + y >= 20 = soundMultiFrom footor 22 3 0
| crHasMoved && x < 80 && x + y >= 80 = soundMultiFrom footor 23 3 0
@@ -139,15 +122,16 @@ movementSideEff cr w
invSideEff :: Creature -> World -> World
invSideEff cr w = weaponReloadSounds cr $ IM.foldrWithKey f w (_crInv cr)
where f i it w' = case it ^? itEffect . itInvEffect of
Nothing -> w'
Just g -> g cr i w'
where
f i it w' = case it ^? itEffect . itInvEffect of
Nothing -> w'
Just g -> g cr i w'
weaponReloadSounds :: Creature -> World -> World
weaponReloadSounds cr w = case _crInv cr IM.!? _crInvSel cr of
Just (Weapon {_wpReloadState = 0}) -> w
Just (Weapon {_wpReloadState = 1}) -> stopSoundFrom (CrReloadSound cid) w
Just (Weapon {}) -> soundFrom (CrReloadSound cid) reloadSound (1) 0 w
Just Weapon{_wpReloadState = 0} -> w
Just Weapon{_wpReloadState = 1} -> stopSoundFrom (CrReloadSound cid) w
Just Weapon{} -> soundFrom (CrReloadSound cid) reloadSound 1 0 w
_ -> w
where
cid = _crID cr
@@ -171,7 +155,7 @@ updateMovement g cr
isFrictionless :: Creature -> Bool
isFrictionless cr = case cr ^? crStance . carriage of
Just (Boosting _) -> True
Just (Floating) -> True
Just Floating -> True
_ -> False
updateReloadCounter :: Creature -> Creature
@@ -212,12 +196,11 @@ updateExpBarrel w (f,g) cr
damages = _crDamage $ _crState cr
pierceSparks :: [World -> World]
pierceSparks
= zipWith4 (\p a colid time-> (createBarrelSpark time colid (_crPos cr +.+ p) (a + argV p))
(Just $ _crID cr))
poss as colids times
as = randomRs (-0.7,0.7) $ g
colids = randomRs (0,11) $ g
times = randomRs (2,5) $ g
= zipWith4 (\p a -> createBarrelSpark (_crPos cr +.+ p) (a + argV p) (Just $ _crID cr))
poss as times colids
as = randomRs (-0.7,0.7) g
colids = randomRs (0,11) g
times = randomRs (2,5) g
(g',_) = split g
poss = _piercedPoints $ _crSpState $ _crState cr
--newCr = Just $ doDamage $ applyFuseDamage cr -- $ foldr perforate cr damages
@@ -229,7 +212,7 @@ updateExpBarrel w (f,g) cr
applyFuseDamage cr = over crHP (\hp -> hp - length (_piercedPoints
$ _crSpState $ _crState cr))
cr
hiss | poss == [] = id
hiss | null poss = id
| otherwise = soundMultiFrom [BarrelHiss 0,BarrelHiss 1] 41 50 1
stopSounds = stopSoundFrom (BarrelHiss 0) . stopSoundFrom (BarrelHiss 1)
@@ -237,14 +220,14 @@ damToExpBarrel :: [DamageType] -> Creature -> Creature
damToExpBarrel ds cr = foldr damToExpBarrel' (foldr damToExpBarrel' cr pierceDam) otherDam
where
(pierceDam,otherDam) = partition isPierce ds
isPierce (Piercing {}) = True
isPierce Piercing{} = True
isPierce _ = False
damToExpBarrel' :: DamageType -> Creature -> Creature
damToExpBarrel' (Piercing amount sp int ep) cr
= over (crState . crSpState . piercedPoints) ((:) $ int -.- _crPos cr)
$ over crHP (\hp -> hp - div amount 200) cr
damToExpBarrel' (PoisonDam {}) cr = cr
damToExpBarrel' (SparkDam {}) cr = cr
damToExpBarrel' (PushDam {_dmPushBack = v}) cr = cr Control.Lens.& crPos %~ (+.+) (1 / _crMass cr *.* v)
damToExpBarrel' PoisonDam {} cr = cr
damToExpBarrel' SparkDam {} cr = cr
damToExpBarrel' PushDam{_dmPushBack = v} cr = cr Control.Lens.& crPos %~ (+.+) (1 / _crMass cr *.* v)
damToExpBarrel' dt cr = cr Control.Lens.& crHP -~ _dmAmount dt
src/Dodge/Creature/State/Data.hs
+6 -11
View File
@@ -4,31 +4,25 @@ module Dodge.Creature.State.Data
where
import Geometry
import Dodge.Data.DamageType
import Dodge.Creature.Impulse.Data
import Dodge.Creature.Stance.Data
import Picture.Data
import Control.Lens
import qualified Data.IntSet as IS
data CreatureState = CrSt
{ _goals :: [[Impulse]]
, _crDamage :: [DamageType]
{ _crDamage :: [DamageType]
, _crPastDamage :: [[DamageType]]
, _crSpState :: CrSpState
, _crDropsOnDeath :: CreatureDropType
}
data CreatureDropType
= DropAll
| DropAmount Int
| DropSpecific [Int]
data CrSpState
= Barrel { _piercedPoints :: [Point2]}
| GenCr
deriving (Eq,Show,Ord)
data Faction
= GenericFaction Int
| ZombieFaction
@@ -39,11 +33,12 @@ data Faction
| ColorFaction Color
| PlayerFaction
deriving (Eq,Show)
data CrGroup
= LoneWolf
| Swarm { _swarm :: IS.IntSet }
| Swarm
{ _swarm :: IS.IntSet
, _crGroupID :: Int
}
| CrGroupID { _crGroupID :: Int }
makeLenses ''CreatureState
makeLenses ''CrSpState
makeLenses ''Impulse
src/Dodge/Creature/SwarmCrit.hs
+4 -3
View File
@@ -32,14 +32,15 @@ swarmCrit = defaultCreature
{ _crUpdate = stateUpdate $ impulsiveAI $ composeInternalAIs
[ flockPointTarget encircle targetYouLOS
, \ _ -> crMeleeCooldown . _Just %~ (max 0 . subtract 1)
, basicPerceptionUpdate [0]
-- , doStrategyActions
-- , targetYouWhenCognizant
]
, _crHP = 1
, _crRad = 2
, _crMass = 2
, _crPict = basicCrPict yellow
, _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
, _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ circleSolid 2
, _crFaction = ColorFaction yellow
, _crMeleeCooldown = Just 0
}
src/Dodge/Creature/Test.hs
+39
View File
@@ -16,6 +16,7 @@ import Data.List (find)
import Data.Maybe
import qualified Data.IntMap.Strict as IM
import Control.Lens
import Control.Monad.Reader
andTest :: (a -> Bool) -> (a -> Bool) -> a -> Bool
andTest f g a = f a && g a
@@ -28,31 +29,61 @@ crIsReloading (w,cr) = case cr ^? crInv . ix (_crInvSel cr) . wpReloadState of
Just t -> t > 0
_ -> False
crIsReloadingR :: Creature -> Reader World Bool
crIsReloadingR cr = return $ case cr ^? crInv . ix (_crInvSel cr) . wpReloadState of
Just t -> t > 0
_ -> False
crCanSeeCr :: Creature -> (World, Creature) -> Bool
crCanSeeCr tcr (w,cr) = hasLOS (_crPos cr) (_crPos tcr) w
crCanSeeR :: Creature -> Creature -> Reader World Bool
crCanSeeR tcr cr = reader $ \w -> hasLOS (_crPos cr) (_crPos tcr) w
crCanSeeCID :: Int -> (World, Creature) -> Bool
crCanSeeCID cid (w,cr) = hasLOS (_crPos cr) (_crPos $ _creatures w IM.! cid) w
crCanSeeCIDR :: Int -> Creature -> Reader World Bool
crCanSeeCIDR cid cr = reader $ \w -> hasLOS (_crPos cr) (_crPos $ _creatures w IM.! cid) w
crIsAiming :: (World,Creature) -> Bool
crIsAiming (_,cr) = _posture (_crStance cr) == Aiming
crIsAimingR :: Creature -> Reader World Bool
crIsAimingR cr = return $ _posture (_crStance cr) == Aiming
crHasTarget :: (World,Creature) -> Bool
crHasTarget (_,cr) = isJust $ cr ^? crTarget . _Just
crHasTargetR :: Creature -> Reader World Bool
crHasTargetR cr = return $ isJust $ cr ^? crTarget . _Just
crHasTargetLOS :: (World,Creature) -> Bool
crHasTargetLOS (w,cr) = case cr ^? crTarget . _Just of
Just i -> crCanSeeCr i (w,cr)
Nothing -> False
crHasTargetLOSR :: Creature -> Reader World Bool
crHasTargetLOSR cr = reader $ \w -> case cr ^? crTarget . _Just of
Just i -> crCanSeeCr i (w,cr)
Nothing -> False
crSafeDistFromTarg :: Float -> (World,Creature) -> Bool
crSafeDistFromTarg d (w,cr) = case cr ^? crTarget . _Just of
Just tcr -> dist (_crPos cr) (_crPos tcr) > d
Nothing -> True
crSafeDistFromTargR :: Float -> Creature -> Reader World Bool
crSafeDistFromTargR d cr = reader $ \w -> case cr ^? crTarget . _Just of
Just tcr -> dist (_crPos cr) (_crPos tcr) > d
Nothing -> True
crStratConMatches :: Strategy -> (World,Creature) -> Bool
crStratConMatches strat (_,cr) = eqConstr strat (_crStrategy $ _crActionPlan cr)
crStratConMatchesR :: Strategy -> Creature -> Reader World Bool
crStratConMatchesR strat cr = return $ eqConstr strat (_crStrategy $ _crActionPlan cr)
crAwayFromPost :: (World,Creature) -> Bool
crAwayFromPost (_,cr) = case find sentinelGoal $ _crGoal $ _crActionPlan cr of
Just (SentinelAt p dir) -> dist p (_crPos cr) > 15
@@ -60,3 +91,11 @@ crAwayFromPost (_,cr) = case find sentinelGoal $ _crGoal $ _crActionPlan cr of
where
sentinelGoal (SentinelAt p dir) = True
sentinelGoal _ = False
crAwayFromPostR :: Creature -> Reader World Bool
crAwayFromPostR cr = return $ case find sentinelGoal $ _crGoal $ _crActionPlan cr of
Just (SentinelAt p dir) -> dist p (_crPos cr) > 15
_ -> False
where
sentinelGoal (SentinelAt p dir) = True
sentinelGoal _ = False
src/Dodge/Creature/Update.hs
-1
View File
@@ -1,4 +1,3 @@
{-# LANGUAGE BangPatterns #-}
module Dodge.Creature.Update
where
import Dodge.Data
src/Dodge/Data.hs
+18 -11
View File
@@ -16,10 +16,8 @@ module Dodge.Data
, soundTime
) where
import Dodge.Picture.Layer.Data
import Dodge.Creature.Data
import Dodge.Creature.State.Data
import Dodge.Creature.Stance.Data
import Dodge.Creature.Rationality.Data
import Dodge.Creature.AlertLevel.Data
import Dodge.Data.Menu
import Dodge.Data.SoundOrigin
@@ -42,6 +40,7 @@ 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
@@ -58,6 +57,7 @@ data World = World
, _cameraViewFrom :: !Point2
, _creatures :: IM.IntMap Creature
, _creaturesZone :: IM.IntMap (IM.IntMap (IM.IntMap Creature))
, _creatureGroups :: IM.IntMap CrGroupParams
, _itemPositions :: IM.IntMap ItemPos
, _clouds :: IM.IntMap Cloud
, _cloudsZone :: IM.IntMap (IM.IntMap (IM.IntMap Cloud))
@@ -65,7 +65,7 @@ data World = World
, _particles :: ![Particle]
, _staticWalls :: [Wall]
, _walls :: !(IM.IntMap Wall)
, _wallsZone :: (IM.IntMap (IM.IntMap (IM.IntMap Wall)))
, _wallsZone :: IM.IntMap (IM.IntMap (IM.IntMap Wall))
, _forceFields :: IM.IntMap ForceField
, _floorItems :: IM.IntMap FloorItem
, _randGen :: StdGen
@@ -104,7 +104,13 @@ data World = World
, _config :: Configuration
, _sideEffects :: [PreloadData SoundOrigin -> IO (PreloadData SoundOrigin)]
, _doneSideEffects :: [PreloadData SoundOrigin -> IO (PreloadData SoundOrigin)]
}
}
data CrGroupParams = CrGroupParams
{ _crGroupParamID :: Int
, _crGroupIDs :: IS.IntSet
, _crGroupCenter :: Point2
, _crGroupUpdate :: World -> CrGroupParams -> Maybe CrGroupParams
}
data Corpse = Corpse
{ _cpPos :: Point2
, _cpPict :: Picture
@@ -380,8 +386,7 @@ data Particle
, _btMaxTime' :: Int
, _btTimer' :: Int
}
type HitEffect = Particle -> [(Point2, (Either3 Creature Wall ForceField))] -> World
-> (World,Maybe Particle)
type HitEffect = Particle -> [(Point2, Either3 Creature Wall ForceField)] -> World -> (World,Maybe Particle)
data Projectile
= Projectile
{ _pjPos :: Point2
@@ -540,26 +545,26 @@ data Action
,_waitThenAction :: Action
}
| DoActionWhile
{_doActionWhileCondition :: ( (World, Creature) -> Bool)
{_doActionWhileCondition :: (World, Creature) -> Bool
,_doActionWhileAction :: Action
}
| DoActionWhilePartial
{_doActionWhilePartial :: Action
,_doActionWhileCondition :: ( (World, Creature) -> Bool)
,_doActionWhileCondition :: (World, Creature) -> Bool
,_doActionWhileAction :: Action
}
| DoActionIf
{_doActionIfCondition :: ( (World, Creature) -> Bool)
{_doActionIfCondition :: (World, Creature) -> Bool
,_doActionIfAction :: Action
}
| DoActionIfElse
{_doActionIfElseIfAction :: Action
,_doActionIfElseCondition :: ( (World, Creature) -> Bool)
,_doActionIfElseCondition :: (World, Creature) -> Bool
,_doActionIfElseElseAction :: Action
}
| DoActionWhileThen
{_doActionWhileThenDo :: Action
,_doActionWhileThenCondition :: ( (World, Creature) -> Bool)
,_doActionWhileThenCondition :: (World, Creature) -> Bool
,_doActionWhileThenThen :: Action
}
| DoActions
@@ -619,6 +624,7 @@ data Strategy
| GetTo Point2
| Reload
| Flee
| MeleeStrike
deriving (Generic)
-- deriving (Eq,Ord,Show)
data Goal
@@ -646,6 +652,7 @@ makeLenses ''Button
makeLenses ''ActionPlan
makeLenses ''Impulse
makeLenses ''Action
makeLenses ''CrGroupParams
numColor :: Int -> Color
numColor 0 = (1,0,0,1)
src/Dodge/Default.hs
+13 -19
View File
@@ -1,4 +1,3 @@
{-# LANGUAGE BangPatterns #-}
{- |
Module : Dodge.Default
Description : Instances of data structures
@@ -10,7 +9,6 @@ import Dodge.Item.Weapon.ExtraEffect
import Dodge.Data
import Dodge.Creature.Stance.Data
import Dodge.Creature.State.Data
import Dodge.Creature.Rationality.Data
import Dodge.Creature.AlertLevel.Data
import Dodge.Data.Menu
import Dodge.SoundLogic
@@ -45,15 +43,13 @@ defaultCrystalWall = Wall
, _wlSeen = False
, _wlIsSeeThrough = True
}
{-
Door that opens on approach.
{- Door that opens on approach.
Pathable. -}
defaultAutoDoor = Door
{ _wlLine = ((0,0),(50,0))
, _wlID = 0
, _doorMech = id
, _wlColor = light $ dim $ dim $ dim $ yellow
, _wlColor = light $ dim $ dim $ dim yellow
, _wlSeen = False
, _wlIsSeeThrough = False
, _doorPathable = True
@@ -66,7 +62,7 @@ defaultDoor = Door
{ _wlLine = ((0,0),(50,0))
, _wlID = 0
, _doorMech = id
, _wlColor = light $ dim $ dim $ dim $ yellow
, _wlColor = light $ dim $ dim $ dim yellow
, _wlSeen = False
, _wlIsSeeThrough = False
, _doorPathable = False
@@ -101,8 +97,7 @@ defaultCreature = Creature
, _crGroup = LoneWolf
}
defaultState = CrSt
{ _goals = []
, _crDamage = []
{ _crDamage = []
, _crPastDamage = []
, _crSpState = GenCr
, _crDropsOnDeath = DropAmount 1
@@ -143,7 +138,7 @@ defaultApplyDamage :: [DamageType] -> Creature -> (World -> World, Creature)
defaultApplyDamage ds cr = (id, doPoisonDam $ foldr (\d c -> snd $ applyIndividualDamage d c) cr ds')
where
(ps,ds') = partition isPoison ds
isPoison (PoisonDam {}) = True
isPoison PoisonDam{} = True
isPoison _ = False
poisonDam = quot (max 0 (sum (map _dmAmount ps))) 10
doPoisonDam = over crHP (\hp -> hp - poisonDam)
@@ -174,7 +169,7 @@ defaultIt = Consumable
, _itName = "defaultIt"
, _itMaxStack = 3
, _itAmount = 2
, _cnEffect = \ _ -> return
, _cnEffect = const return
, _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
, _itEquipPict = \cr _ -> blank
, _itID = Nothing
@@ -187,10 +182,10 @@ defaultButton = Button
{ _btPict = onLayer WlLayer $ color red $ polygon $ rectNSEW 5 (-5) 10 (-10)
, _btPos = (0,0)
, _btRot = 0
, _btEvent = \b w -> set (buttons . ix (_btID b) . btPict)
(onLayer WlLayer $ color red $ polygon $ rectNSEW (-4) (-5) 10 (-10))
. set (buttons . ix (_btID b) . btState) BtNoLabel
. soundOnce 1 $ w
, _btEvent = \b w ->
set (buttons . ix (_btID b) . btPict) (onLayer WlLayer $ color red $ polygon $ rectNSEW (-4) (-5) 10 (-10))
. set (buttons . ix (_btID b) . btState) BtNoLabel
. soundOnce 1 $ w
, _btID = 0
, _btText = "Button"
, _btState = BtOff
@@ -204,15 +199,13 @@ defaultPT = Projectile
, _pjUpdate = id
}
defaultPP = PressPlate
{ _ppPict = onLayer PressPlateLayer $ color (dim $ dim $ bright $ blue) $ circleSolid 5
{ _ppPict = onLayer PressPlateLayer $ color (dim $ dim $ bright blue) $ circleSolid 5
, _ppPos = (0,0)
, _ppRot = 0
, _ppEvent = \pp -> id
, _ppEvent = const id
, _ppID = -1
, _ppText = "Pressure plate"
}
-- }}}
defaultWorld = World
{ _keys = S.empty
, _mouseButtons = S.empty
@@ -222,6 +215,7 @@ defaultWorld = World
, _cameraViewFrom = (0,0)
, _creatures = IM.empty
, _creaturesZone = IM.empty
, _creatureGroups = IM.empty
, _clouds = IM.empty
, _cloudsZone = IM.empty
, _itemPositions = IM.empty
src/Dodge/Event.hs
+8 -8
View File
@@ -108,14 +108,14 @@ wheelUpEvent w = case _carteDisplay w of
wheelDownEvent :: World -> World
wheelDownEvent w = case _carteDisplay w of
True | rbDown -> w & carteZoom .~ max 0.05 (z-(0.1*z))
| otherwise -> w & selLocation %~ (`mod` numLocs) . (\i -> i + 1)
False | rbDown -> fromMaybe (closeObjScrollDown w)
$ (yourItem w ^? itScrollDown)
<*> pure (_crInvSel (you w))
<*> pure w
| lbDown -> w {_cameraZoom = max (_cameraZoom w - 0.1) 0.01}
| otherwise -> downInvPos w
True
| rbDown -> w & carteZoom .~ max 0.05 (z-(0.1*z))
| otherwise -> w & selLocation %~ (`mod` numLocs) . (+ 1)
False
| rbDown -> fromMaybe (closeObjScrollDown w)
$ (yourItem w ^? itScrollDown) <*> pure (_crInvSel (you w)) <*> pure w
| lbDown -> w {_cameraZoom = max (_cameraZoom w - 0.1) 0.01}
| otherwise -> downInvPos w
where
rbDown = ButtonRight `S.member` _mouseButtons w
lbDown = ButtonLeft `S.member` _mouseButtons w
src/Dodge/Event/Keyboard.hs
-2
View File
@@ -25,7 +25,6 @@ import qualified Data.Set as S
import Control.Lens
import Picture
{- | Handles keyboard press and release.
On release, remove scancode from the 'Set' of pressed keys.
On press, adds the scancode, and perhaps applies a direct effect:
@@ -58,7 +57,6 @@ handlePressedKey True _ w = Just w
handlePressedKey _ scode w
| null (_menuLayers w) = handlePressedKeyInGame scode w
| otherwise = handlePressedKeyInMenu (head $ _menuLayers w) scode w
handlePressedKey _ _ w = Just w
debugKey :: Scancode -> World -> Maybe World
debugKey scancode w
src/Dodge/Floor.hs
+8 -7
View File
@@ -40,8 +40,7 @@ import Control.Lens
import Control.Monad.State
import Control.Monad.Loops
import System.Random
{- |
A test level tree. -}
{- | A test level tree. -}
roomTreex :: RandomGen g => State g (Maybe [Room])
roomTreex = do
struct' <- aTreeStrut
@@ -51,16 +50,19 @@ roomTreex = do
t = treeFromTrunk
[[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] ]++)
]
,[Corridor]
,[Corridor]
,[SpecificRoom . fmap (pure . Right) $ twinSlowDoorChasers 30]
,[SpecificRoom $ pure . Right <$> twinSlowDoorChasers 30]
,[Corridor]
,[DoorAno]
,[SpecificRoom $ fmap (pure . Right)
$ centerVaultExplosiveExit 50]
,[SpecificRoom $ pure . Right <$> centerVaultExplosiveExit 50]
,[SpecificRoom blockedCorridor]
,[OrAno [[DoorAno]
,[Corridor]
@@ -82,8 +84,7 @@ roomTreex = do
,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]]
]
t'
fmap (shiftExpandTree . expandTreeBy id) $ mapM annoToRoomTree t
shiftExpandTree . expandTreeBy id <$> mapM annoToRoomTree t
levx :: RandomGen g => State g [Room]
levx = untilJust roomTreex
src/Dodge/Graph.hs
+8 -6
View File
@@ -1,18 +1,20 @@
module Dodge.Graph
where
import Data.Function (on)
import Data.List
import Data.List.Extra
import Data.Bifunctor (first)
import Data.Graph
import Data.Maybe
pairsToIncidence :: (Eq a,Ord a) => [(a,a)] -> [(a,[a])]
pairsToIncidence = map ((\(xs,ys) -> (head xs,ys)) . unzip)
. groupBy ( (==) `on` fst)
. sort
pairsToIncidence
= map (first head . unzip)
. groupOn fst
. sort
incidenceToFunction :: Eq a => [(a,[a])] -> a -> [a]
incidenceToFunction xs a = case lookup a xs of Just ys -> ys
Nothing -> []
incidenceToFunction xs a = fromMaybe [] $ lookup a xs
mkNode :: (a,[a]) -> (a,a,[a])
mkNode (x,xs) = (x,x,xs)
src/Dodge/Inventory.hs
+25 -30
View File
@@ -2,30 +2,27 @@ module Dodge.Inventory
where
import Dodge.Data
import Dodge.Base
--import Dodge.SoundLogic
import Geometry
import Data.Maybe
import Data.List
import Data.Function (on)
import qualified Data.IntMap.Strict as IM
import System.Random
import Control.Lens
checkInvSlotsYou' :: Maybe Item -> World -> Maybe Int
checkInvSlotsYou' it w = fmap fst $ find cond invListSelFirst
where cond (_,NoItem) = True
cond (_,it' ) = itNotFull it' && fmap _itName it == Just (_itName it')
youCr = you w
youSel = _crInvSel youCr
invList = _crInv youCr
invListSelFirst = (youSel , invList IM.! youSel) : IM.toList invList
checkInvSlotsYou' it w = fst <$> find cond invListSelFirst
where
cond (_,NoItem) = True
cond (_,it' ) = itNotFull it' && fmap _itName it == Just (_itName it')
youCr = you w
youSel = _crInvSel youCr
invList = _crInv youCr
invListSelFirst = (youSel , invList IM.! youSel) : IM.toList invList
checkInvSlotsYou :: Item -> World -> Maybe Int
checkInvSlotsYou it w = fmap fst $ find cond invListSelFirst
checkInvSlotsYou it w = fst <$> find cond invListSelFirst
where
cond (_,NoItem) = True
cond (_,it' ) = itNotFull it' && _itName it == _itName it'
@@ -36,8 +33,9 @@ checkInvSlotsYou it w = fmap fst $ find cond invListSelFirst
checkInvSlots :: Item -> IM.IntMap Item -> Maybe Int
checkInvSlots it its = fmap fst $ find cond $ IM.toList its
where cond (_,NoItem) = True
cond (_,it' ) = itNotFull it' && _itName it == _itName it'
where
cond (_,NoItem) = True
cond (_,it' ) = itNotFull it' && _itName it == _itName it'
addItem :: Item -> Item -> Item
addItem it NoItem = it
@@ -57,7 +55,7 @@ rmInvItem
rmInvItem n i w =
let item = _crInv (_creatures w IM.! n) IM.! i
itRef = creatures . ix n . crInv . ix i
in case item of
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
@@ -67,28 +65,25 @@ rmInvItem n i 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
{-
Delete a creature's selected item, the item will no longer exist.
-}
{- Delete a creature's selected item, the item will no longer exist. -}
rmSelectedInvItem
:: Int -- ^ Creature id
-> World
-> World
rmSelectedInvItem cid w = rmInvItem cid (_crInvSel (_creatures w IM.! cid)) w
-- for now, left are floor items, right are buttons
closestActiveObject :: World -> Maybe (Either FloorItem Button)
closestActiveObject w = listToMaybe $ sortBy (compare `on` dist ypos . pos) $ actObjs
where ypos = _crPos $ you w
actObjs = filter (\obj -> dist ypos (pos obj) < 40 && hasLOS ypos (pos obj) w)
$ map Left (IM.elems $ _floorItems w) ++ activeButtons -- map Right (IM.elems $ _buttons w)
pos (Right x) = _btPos x
pos (Left x) = _flItPos x
activeButtons = map Right
. filter ( (/=) BtNoLabel . _btState)
. IM.elems
$ _buttons w
closestActiveObject w = listToMaybe $ sortOn (dist ypos . pos) actObjs
where
ypos = _crPos $ you w
actObjs = filter (\obj -> dist ypos (pos obj) < 40 && hasLOS ypos (pos obj) w)
$ map Left (IM.elems $ _floorItems w) ++ activeButtons -- map Right (IM.elems $ _buttons w)
pos (Right x) = _btPos x
pos (Left x) = _flItPos x
activeButtons = map Right
. filter ( (/=) BtNoLabel . _btState)
. IM.elems
$ _buttons w
updateCloseObjects :: World -> World
updateCloseObjects w = w & closeActiveObjects .~ unionBy eTest oldCloseFiltered currentClose
src/Dodge/Item.hs
+2 -2
View File
@@ -13,7 +13,7 @@ keyToken n = defaultEquipment
, _itName = "KEYTOKEN "++show n
, _itMaxStack = 5
, _itAmount = 1
, _itFloorPict = setDepth 0.5 $ keyPic
, _itFloorPict = setDepth 0.5 keyPic
, _itEquipPict = \cr _ -> setDepth 0 $ translate (-5) (-5) $ rotate (pi/2.5) keyPic
, _itEffect = NoItEffect
, _itHammer = HammerUp
@@ -36,7 +36,7 @@ latchkey n = defaultEquipment
, _itName = "KEY "++show n
, _itMaxStack = 1
, _itAmount = 1
, _itFloorPict = setDepth 0.5 $ latchkeyPic
, _itFloorPict = setDepth 0.5 latchkeyPic
, _itEquipPict = \cr _ -> setDepth 0 $ translate (-5) (-5) $ rotate (pi/2.5) latchkeyPic
, _itEffect = NoItEffect
, _itHammer = HammerUp
src/Dodge/Item/Consumable.hs
+1 -2
View File
@@ -29,6 +29,5 @@ heal25 :: Int -> World -> Maybe World
heal25 = heal 25
heal :: Int -> Int -> World -> Maybe World
heal hp n w | _crHP (_creatures w IM.! n) >= 10000 = Nothing
| otherwise = Just $ soundOnce healSound
$ over (creatures . ix n . crHP) ((min 10000) . (+ hp) ) w
| otherwise = Just $ soundOnce healSound w & creatures . ix n . crHP %~ min 10000 . (+ hp)
src/Dodge/Item/Weapon.hs
+2 -5
View File
@@ -1,8 +1,5 @@
{- |
Definitions of weapons.
In progress: move out effects into other modules.
-}
{-# LANGUAGE BangPatterns #-}
{- | Definitions of weapons.
In progress: move out effects into other modules. -}
module Dodge.Item.Weapon
( module Dodge.Item.Weapon
)
src/Dodge/Item/Weapon/Bullet.hs
+6 -6
View File
@@ -145,7 +145,7 @@ bulHitWall' bt p x w = damageBlocks x
spid = newKey $ _projectiles 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)
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
@@ -155,7 +155,7 @@ bulBounceWall' bt p wl w = damageBlocks wl $ over worldEvents addBouncer w
pOut = p +.+ safeNormalizeV (sp -.- p)
damageBlocks wall w
= case wall ^? blHP of
Just hp -> foldr (\j -> (walls . ix j . blHP -~ 5)) w (_blIDs wall)
Just hp -> foldr (\j -> walls . ix j . blHP -~ 5) w (_blIDs wall)
_ -> w
bouncer = (aGenBulAt' Nothing (_btColor' bt) pOut reflectVel
(_btHitEffect' bt) (_btWidth' bt)
@@ -180,7 +180,7 @@ bulIncWall' bt p wl w = damageBlocks wl $ incFlamelets w
pOut = p +.+ safeNormalizeV (sp -.- p)
damageBlocks wall w
= case wall ^? blHP of
Just hp -> foldr (\j -> (walls . ix j . blHP -~ 5)) w (_blIDs wall)
Just hp -> foldr (\j -> walls . ix j . blHP -~ 5) w (_blIDs wall)
_ -> w
wallV = uncurry (-.-) (_wlLine wl)
reflectVel = safeNormalizeV $ reflectIn wallV (_btVel' bt)
@@ -198,9 +198,9 @@ bulConWall' bt p wl w = damageBlocks wl $ mkwave w
pOut = p +.+ safeNormalizeV (sp -.- p)
damageBlocks wall w
= case wall ^? blHP of
Just hp -> foldr (\j -> (walls . ix j . blHP -~ 5)) w (_blIDs wall)
Just hp -> foldr (\j -> walls . ix j . blHP -~ 5) w (_blIDs wall)
_ -> w
mkwave = over worldEvents ((makeShockwaveAt [] p 15 4 1 white) . )
mkwave = over worldEvents ( makeShockwaveAt [] p 15 4 1 white . )
hvBulHitWall'
:: Particle
@@ -218,7 +218,7 @@ hvBulHitWall' bt p x w = damageBlocks x $ set randGen g $ foldr ($) w (sparks p
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)
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
src/Dodge/Item/Weapon/TriggerType.hs
+1 -1
View File
@@ -370,7 +370,7 @@ spreadNumVelWthHiteff spread num vel wth eff cid w = over particles (newbuls ++)
poss dirs colids
poss = map ((+.+) $ _crPos cr +.+ _crRad cr *.* unitVectorAtAngle (_crDir cr))
$ (replicateM num . randInCirc) 5 & evalState $ _randGen w
dirs = map ((_crDir cr) +) $ zipWith (+)
dirs = map (_crDir cr +) $ zipWith (+)
[-spread,-spread+(2*spread/fromIntegral num)..]
(randomRs (0,spread/5) (_randGen w))
colids = take num $ randomRs (0,11) (_randGen w)
src/Dodge/Item/Weapon/UseEffect.hs
+1 -1
View File
@@ -96,7 +96,7 @@ mvRadar x p w pt =
)
where
pic = onLayerL [levLayer ShadowLayer, 1] $ pictures sweepPics
putBlips = over worldEvents ( ( over particles (blips ++) ) . )
putBlips = over worldEvents ( over particles (blips ++) . )
blips = map (\p -> blipAt p (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)
src/Dodge/Layout.hs
+12 -12
View File
@@ -25,7 +25,7 @@ import Data.Maybe
import Data.Tree
import Data.Either
import Data.Function
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Graph hiding ((&))
import Data.Graph.Inductive.Basic
import Data.Graph.Inductive.PatriciaTree
import Data.Graph.Inductive.NodeMap
@@ -61,16 +61,17 @@ generateFromTree t w = updateWallZoning $ placeSpots plmnts
updateWallZoning :: World -> World
updateWallZoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w)) w
where
wallInZone wl | uncurry dist (_wlLine wl) <= 2*zoneSize
= insertIMInZone x y wlid wl
| otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips
where (x,y) = zoneOfPoint $ (uncurry pHalf (_wlLine wl))
wlid = _wlID wl
ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl)
wallInZone wl
| uncurry dist (_wlLine wl) <= 2*zoneSize = insertIMInZone x y wlid wl
| otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips
where
(x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl)
wlid = _wlID wl
ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl)
makePath :: Tree Room -> [(Point2,Point2)]
makePath = concat . map _rmPath . flatten
makePath = concatMap _rmPath . flatten
-- consider nubbing walls after dividing them
wallsFromTree :: Tree Room -> IM.IntMap Wall
@@ -81,7 +82,7 @@ wallsFromTree t =
. removeInverseWalls
. foldr cutWalls [] -- map (map (g . roundPoint2))
-- . map (map roundPoint2)
$ (concatMap _rmPolys $ flatten t)
$ concatMap _rmPolys (flatten t)
where
assignKeys = IM.fromList . zip [0..] . zipWith f [0..]
f i (x,y) = defaultWall {_wlLine = (x,y) , _wlID = i}
@@ -98,9 +99,8 @@ wallsFromRooms =
divideWall :: Wall -> [Wall]
divideWall wl
= let (a,b) = _wlLine wl
--ps = divideLine (zoneSize * 2) a b
ps = divideLine (zoneSize * 2) a b
in map (\(x,y) -> wl {_wlLine = (x,y)}) $ zip (init ps) (tail ps)
in zipWith (\ x y -> wl & wlLine .~ (x,y) ) (init ps) (tail ps)
divideWallIn :: Wall -> IM.IntMap Wall -> IM.IntMap Wall
divideWallIn wl wls =
@@ -130,7 +130,7 @@ shiftRoomTreeConstruction (Node t ts) = (Node t [] :) $ concat $
(_rmLinks t)
ts
where
f r = shiftRoomBy ((0,0) -.- (rotateV (pi-a) p),0) $ shiftRoomBy ((0,0),pi-a) r
f r = shiftRoomBy ( (0,0) -.- rotateV (pi-a) p , 0) $ shiftRoomBy ((0,0),pi-a) r
where
(p,a) = last $ _rmLinks r
src/Dodge/LevelGen.hs
+38 -38
View File
@@ -1,4 +1,3 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
-- | deals with placement of objects within the world
-- after they have had their coordinates set by the layout
@@ -8,9 +7,7 @@ module Dodge.LevelGen
, pairsToGraph
, makeButton
, makeSwitch
)
where
) where
import Dodge.Data
import Dodge.Base
import Dodge.Room.Data
@@ -29,22 +26,24 @@ import System.Random
import Control.Monad.State
import Control.Applicative
import Control.Lens
import Data.List
import Data.List.Extra
import Data.Function
import Data.Maybe
import qualified Data.IntMap.Strict as IM
import qualified Data.Set as S
import qualified Data.Map as M
placeSpots :: [Placement] -> World -> World
placeSpots pss w = foldr placeSpot w' $ map _placementSpot singlePlacements
placeSpots pss w = foldr (placeSpot . _placementSpot) w' singlePlacements
where
(singlePlacements, groupedPlacements) = partition isSPS pss
isSPS (SinglePlacement {}) = True
isSPS SinglePlacement{} = True
isSPS _ = False
gplmnts = groupBy ((==) `on` _groupPlacementID) $ sortOn _groupPlacementID groupedPlacements
w' = foldr updateGroup w gplmnts
gplmnts :: [[Placement]]
gplmnts = groupOn _groupPlacementID $ sortOn _groupPlacementID groupedPlacements
w' = foldr putGroup w gplmnts
putGroup :: [Placement] -> World -> World
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
@@ -53,20 +52,20 @@ placeSpots pss w = foldr placeSpot w' $ map _placementSpot singlePlacements
- After this, for each placement we apply the group placement function to
- the psType using a zipWith, and taking all the pstypes as a paramenter,
- then successively update the world using a foldr. -}
updateGroup :: [Placement] -> World -> World
updateGroup ps w =
let (w', psTypes) = mapAccumR updateSpot w $ map _placementSpot ps
fs = zipWith (\gp pst -> _groupPlacementFunc gp psTypes pst) ps psTypes
in foldr ($) w' fs
updateSpot :: World -> PlacementSpot -> (World, PSType)
updateSpot w ps = case _psType ps of
PutButton bt -> undefined
PutCrit cr -> placeUpdateCr cr p rot w
where
p = _psPos ps
rot = _psRot ps
--updateGroup :: [Placement] -> World -> World
--updateGroup ps w =
-- let (w', psTypes) = mapAccumR updateSpot w $ map _placementSpot ps
-- fs = zipWith (\gp pst -> _groupPlacementFunc gp psTypes pst) ps psTypes
-- in foldr ($) w' fs
--{- | -}
--updateSpot :: World -> PlacementSpot -> (World, PSType)
--updateSpot w ps = case _psType ps of
-- PutButton bt -> undefined
-- PutCrit cr -> placeUpdateCr cr p rot w
-- where
-- p = _psPos ps
-- rot = _psRot ps
{- | -}
placeSpot :: PlacementSpot -> World -> World
placeSpot ps w = case _psType ps of
PutButton bt -> placeBt bt p rot w
@@ -134,7 +133,7 @@ addPane wl (p0,p1) wls = IM.insert (newKey wls) (wl
})
wls
placeBt bt p rot w = over buttons addBT w
placeBt bt p rot = over buttons addBT
where
addBT bts = IM.insert (newKey bts) (bt {_btPos = p, _btRot = rot, _btID = newKey bts}) bts
{- Creates a floor item at a given point.
@@ -155,7 +154,7 @@ placeFlIt itm p rot = floorItems %~
}
) fis
placePressPlate pp p rot w = over pressPlates addPP w
placePressPlate pp p rot = over pressPlates addPP
where
addPP pps = IM.insert (newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps
@@ -166,20 +165,21 @@ placeUpdateCr scr p rot w = (w & creatures %~ IM.insert cid cr, PutCrit cr)
cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid}
placeCr :: Creature -> Point2 -> Float -> World -> World
placeCr crF p rot w = over creatures addCr w
placeCr crF p rot = over creatures addCr
where
addCr crs = IM.insert (newKey crs)
addCr crs = IM.insert
(newKey crs)
(crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = newKey crs})
crs
placeLS :: LightSource -> Picture -> Point2 -> Float -> World -> World
placeLS ls dec p rot w = over lightSources addLS
$ over decorations addDec w
where addLS lss = IM.insert (newKey lss)
(ls {_lsPos = p,_lsDir = rot,_lsID = newKey lss})
lss
addDec decs = IM.insert (newKey decs)
(uncurry translate p $ rotate (0 - rot) dec)
decs
placeLS ls dec p rot w = over lightSources addLS $ over decorations addDec w
where
addLS lss = IM.insert
(newKey lss)
(ls {_lsPos = p,_lsDir = rot,_lsID = newKey lss})
lss
addDec decs = IM.insert
(newKey decs)
(uncurry translate p $ rotate (negate rot) dec)
decs
src/Dodge/LevelGen/Data.hs
+4 -4
View File
@@ -8,7 +8,6 @@ import Picture
import Control.Lens
import Control.Monad.State
import System.Random
data PSType = PutCrit {_unPutCrit :: Creature}
| PutLS LightSource Picture
| PutButton Button
@@ -34,12 +33,13 @@ data Placement
= SinglePlacement {_placementSpot :: PlacementSpot }
| GroupedPlacement
{_groupPlacementID :: Int
,_groupPlacementFunc :: [PSType] -> PSType -> World -> World
-- ,_groupPlacementUpdate :: World -> Placement -> (World, Placement)
,_groupUpdate :: World -> [Placement] -> World
-- ,_groupPlacementFunc :: [PSType] -> PSType -> World -> World
,_placementSpot :: PlacementSpot
}
sPS :: Point2 -> Float -> PSType -> Placement
sPS p a = SinglePlacement . PS p a
makeLenses ''PSType
makeLenses ''PlacementSpot
makeLenses ''Placement
src/Dodge/LevelGen/SwarmPlacement.hs
+39 -8
View File
@@ -3,23 +3,54 @@ module Dodge.LevelGen.SwarmPlacement
)
where
import Dodge.Data
import Dodge.Base
import Dodge.LevelGen.Data
import Dodge.Creature.State.Data
import Geometry
import Data.List
import qualified Data.IntSet as IS
import qualified Data.IntMap as IM
import Control.Lens
swarmPS :: Int -> Point2 -> Float -> Creature -> Placement
swarmPS i p a cr = GroupedPlacement
{ _groupPlacementID = i
, _groupPlacementFunc = setSwarm
, _groupUpdate = setSwarm
-- , _groupPlacementFunc = setSwarm i
, _placementSpot = PS p a $ PutCrit cr
}
setSwarm :: [PSType] -> PSType -> World -> World
setSwarm psts (PutCrit cr) w
= w & creatures . ix cid . crGroup .~ theSwarm
setSwarm :: World -> [Placement] -> World
setSwarm w ps = updateCrs w' & creatureGroups %~ IM.insert gid theGroupParams
where
cid = _crID cr
theSwarm = Swarm swarmSet
swarmSet = IS.fromList $ map (_crID . _unPutCrit) psts
(w', crs) = mapAccumR updateCrit w ps
is = IS.fromList $ map _crID crs
cpos = centroid $ map _crPos crs
gid = newKey (_creatureGroups w')
theGroupParams = CrGroupParams
{ _crGroupParamID = gid
, _crGroupIDs = is
, _crGroupCenter = cpos
, _crGroupUpdate = crGroupUpdateCenter
}
updateCrs w'' = IS.foldl' (\w''' cid -> w''' & creatures . ix cid %~ setSwarmStatus) w'' is
setSwarmStatus = crGroup .~ Swarm {_swarm = is, _crGroupID = gid}
crGroupUpdateCenter :: World -> CrGroupParams -> Maybe CrGroupParams
crGroupUpdateCenter w cgp
| IM.null crs = Nothing
| otherwise = Just $ cgp & crGroupCenter .~
centroid (IM.map _crPos crs)
where
crs = IM.restrictKeys (_creatures w) (_crGroupIDs cgp)
updateCrit :: World -> Placement -> (World, Creature)
updateCrit w pl = (w & creatures %~ IM.insert cid cr
, cr
)
where
p = _psPos $ _placementSpot pl
rot = _psRot $ _placementSpot pl
scr = _unPutCrit $ _psType $ _placementSpot pl
cid = newKey (_creatures w)
cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid}
src/Dodge/LightSources.hs
+1 -1
View File
@@ -50,4 +50,4 @@ tLightRad i rmax rmin p = TLS
, _tlsUpdate = \w _ -> (w, Just $ tLightRad (i-1) rmax rmin p)
}
tLightAt i p = tLightRad i 100 0 p
tLightAt i = tLightRad i 100 0
src/Dodge/LoadSound.hs
+2 -6
View File
@@ -1,17 +1,13 @@
module Dodge.LoadSound where
-- imports {{{
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)
loadSounds = do
Mix.openAudio Mix.defaultAudio 128
@@ -57,7 +53,7 @@ loadSounds = do
glass3' <- Mix.load "./data/sound/Small-Piece-Of-Glass-Shattering-A3.wav"
glass4' <- Mix.load "./data/sound/Small-Piece-Of-Glass-Shattering-A4.wav"
foamSpray' <- Mix.load "./data/sound/foamSprayLoop.wav"
return $ IM.fromList $ zip [0..] $
return $ IM.fromList $ zip [0..]
[ pFireSound
, click
, reloadSound'
@@ -105,6 +101,6 @@ loadSounds = do
loadMusic :: IO (IM.IntMap Mix.Music)
loadMusic = do
undercity <- Mix.load "./data/music/firstCompo.mid"
return $ IM.fromList $ zip [0..] $
return $ IM.fromList $ zip [0..]
[ undercity
]
src/Dodge/Path.hs
+64 -82
View File
@@ -41,31 +41,24 @@ type SearchedNodes = (HP.MinHeap (Float,(Float,[Point2])), [Point2])
stripRight :: Either a b -> b
stripRight (Right x) = x
stepPath :: (Point2 -> [Point2]) -> Point2
-> SearchedNodes -> Either [Point2] SearchedNodes
stepPath f 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
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
)
stepPath' :: (Point2 -> [Point2]) -> Point2
-> SearchedNodes -> [Point2]
stepPath' f p s = case stepPath f p s of Left ps -> ps
Right s' -> stepPath' f p s'
stepPath :: (Point2 -> [Point2]) -> Point2 -> SearchedNodes -> Either [Point2] SearchedNodes
stepPath f 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
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)
stepPath' :: (Point2 -> [Point2]) -> Point2 -> SearchedNodes -> [Point2]
stepPath' f p s = case stepPath f p s of
Left ps -> ps
Right s' -> stepPath' f p s'
makePath' :: (Point2 -> [Point2]) -> Point2 -> Point2 -> [Point2]
makePath' f s e = stepPath' f e $ (HP.singleton (0,(0,[s])) , [])
makePath' f s e = stepPath' f e (HP.singleton (0,(0,[s])) , [])
makeNode :: Point2 -> SearchedNodes
makeNode e = (HP.singleton (0,(0,[e])) , [])
@@ -76,39 +69,36 @@ tp1 = (0,1)
tp2 = (0,20)
tp3 = (30,40)
f = incidenceToFunction $ pairsToIncidence [(tp1,tp2),(tp2,tp3)
,(tp2,tp1)
,(tp1,tp3)]
g = pairsToIncidence [(tp1,tp2),(tp2,tp3)
,(tp2,tp1)
,(tp1,tp3)]
f = incidenceToFunction $ pairsToIncidence
[(tp1,tp2)
,(tp2,tp3)
,(tp2,tp1)
,(tp1,tp3)
]
g = pairsToIncidence
[(tp1,tp2)
,(tp2,tp3)
,(tp2,tp1)
,(tp1,tp3)
]
pathBetween :: Point2 -> Point2 -> World -> Maybe [Point2]
pathBetween a b w = makePath' <$> return (\p -> _pathInc w M.! p) <*> a' <*> b'
where
nsa :: [Point2]
nsa = map snd $ concat $ lookLookups (zoneAroundPoint a) (_pathPoints w)
nsb = map snd $ concat $ lookLookups (zoneAroundPoint b) (_pathPoints w)
--a' = listToMaybe $ sortBy (compare `on` dist a) $ ns
--b' = listToMaybe $ sortBy (compare `on` dist b) $ ns
a' = listToMaybe $ filter (flip (isWalkable a) w) nsa
b' = listToMaybe $ filter (flip (isWalkable b) w) nsb
----
pathBetween a b w = (makePath' $ \p -> _pathInc w M.! p) <$> a' <*> b'
where
nsa :: [Point2]
nsa = map snd $ concat $ lookLookups (zoneAroundPoint a) (_pathPoints w)
nsb = map snd $ concat $ lookLookups (zoneAroundPoint b) (_pathPoints w)
a' = find (flip (isWalkable a) w) nsa
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
where g = _pathGraph w
nsa = concat $ lookLookups (zoneAroundPoint a) (_pathPoints w)
nsb = concat $ lookLookups (zoneAroundPoint b) (_pathPoints w)
-- a' = listToMaybe $ sortBy (compare `on` dist a . snd) $ filter (flip (isWalkable a) w . snd) ns
-- b' = listToMaybe $ sortBy (compare `on` dist b . snd) $ filter (flip (isWalkable b) w . snd) ns
a' = listToMaybe $ filter (flip (isWalkable a) w . snd) nsa
b' = listToMaybe $ filter (flip (isWalkable b) w . snd) nsb
where
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)
@@ -116,46 +106,38 @@ ezipWith f (Left x) (Right _) = Left x
ezipWith f (Right _) (Left y) = Left y
ezipWith f (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
a' = case listToMaybe $ sortBy (compare `on` dist a . snd)
-- a' = case listToMaybe
$ 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)
-- b' = case listToMaybe
$ 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
Right (Just xs) -> Right xs
Right (Nothing) -> Left $ "NO PATH" ++ show a ++ show b ++ show a' ++ show b'
Left m -> Left m
makePathBetween' a b w =
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
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 = pathBetween a b
makePathBetweenPs a b w = fmap (mapMaybe (lab g)) $ makePathBetween b a w
where g = _pathGraph w
makePathBetweenPs a b w = mapMaybe (lab g) <$> makePathBetween b a w
where
g = _pathGraph w
makePathBetweenPs' :: Point2 -> Point2 -> World -> Either String [Point2]
makePathBetweenPs' a b w = fmap (mapMaybe (lab g)) $ makePathBetween' a b w
where g = _pathGraph w
makePathBetweenPs' a b w = mapMaybe (lab g) <$> makePathBetween' a b w
where
g = _pathGraph w
pointTowardsImpulse :: Point2 -> Point2 -> World -> Maybe Point2
pointTowardsImpulse a b w = join $ fmap (listToMaybe . filter (flip (isWalkable a) w))
-- $ pathBetween a b w
$ makePathBetweenPs a b w
--
pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs a b w
pointTowardsImpulse' :: Point2 -> Point2 -> World -> Either String Point2
pointTowardsImpulse' a b w = join $ fmap (maybeToEither "NOSEEPATH" . listToMaybe . filter (flip (isWalkable a) w))
$ makePathBetweenPs' b a w
pointTowardsImpulse' a b w = (maybeToEither "NOSEEPATH" . find (flip (isWalkable a) w)) =<< makePathBetweenPs' b a w
maybeToEither :: a -> Maybe b -> Either a b
maybeToEither _ (Just x) = Right x
src/Dodge/RandomHelp.hs
+4 -4
View File
@@ -12,7 +12,7 @@ import Data.List
randomRanges :: (Random a,RandomGen g) => [a] -> State g a
randomRanges xs = join $ takeOne $ f xs
where
f (x:y:ys) = (state (randomR (x,y))) : (f ys)
f (x:y:ys) = state (randomR (x,y)) : f ys
f _ = []
takeOne :: RandomGen g => [a] -> State g a
@@ -20,7 +20,7 @@ takeOne xs = state (randomR (0,length xs - 1)) >>= (\i -> return (xs !! i))
takeOneWeighted :: (RandomGen g, Random b, Ord b, Num b) => [b] -> [a] -> State g a
takeOneWeighted ws xs = state (randomR (0, sum ws))
>>= (\w -> return (xs !! (i w ws)))
>>= (\w -> return (xs !! i w ws))
where
i y (z:zs)
| y <= z = 0
@@ -35,11 +35,11 @@ takeOneMore (xs,ys) = do
return (w:xs, zs ++ ws)
takeNMore :: RandomGen g => Int -> ([a],[a]) -> State g ([a],[a])
takeNMore n p = foldr (const ((=<<) takeOneMore)) (return p) [1..n]
takeNMore n p = foldr (const (>>= takeOneMore)) (return p) [1..n]
takeN :: RandomGen g => Int -> [a] -> State g [a]
takeN 0 xs = return []
takeN i xs = fmap fst $ takeNMore i ([],xs)
takeN i xs = fst <$> takeNMore i ([],xs)
-- | Randomly shuffle a list.
shuffle :: RandomGen g => [a] -> State g [a]
src/Dodge/Render.hs
+1 -1
View File
@@ -38,7 +38,7 @@ import qualified SDL
Central drawing function.
Returns a 'Word32' that should give the number of ticks it took to evaluate.
-}
doDrawing :: RenderData -> World -> IO (Word32)
doDrawing :: RenderData -> World -> IO Word32
doDrawing pdata w = do
sTicks <- SDL.ticks
clear [ColorBuffer,DepthBuffer]
src/Dodge/Render/Picture.hs
+4 -2
View File
@@ -169,8 +169,10 @@ ffToDraw w = filter (lineOnScreen w . _ffLine) $
_forceFields w
drawFF :: ForceField -> Picture
drawFF (FF {_ffLine = l, _ffColor = col}) = pictures [color white $ line l, color col
$ lineOfThickness 6 l ]
drawFF FF{_ffLine = l, _ffColor = col} = pictures
[color white $ line l
, color col $ lineOfThickness 6 l
]
drawFFShadow :: World -> ForceField -> [Picture]
drawFFShadow w ff
src/Dodge/Room.hs
+89 -93
View File
@@ -84,10 +84,8 @@ roomPillars = over rmLinks init $ set rmPS plmnts $ roomRect 240 240 2 2
f a x b y = putBlockRect a x b y
g a b c d = f a b a b ++ f a b c d ++ f c d a b ++ f c d c d
branchWith :: Room -> [Tree Room] -> Tree (Either Room Room)
branchWith r ts = Node (Left r) $ [return $ Right door] ++ fmap (fmap Left) ts
branchWith r ts = Node (Left r) $ return (Right door) : fmap (fmap Left) ts
glassSwitchBack :: RandomGen g => State g Room
glassSwitchBack = do
@@ -95,16 +93,17 @@ glassSwitchBack = do
hgt <- state $ randomR (400,600)
wllen <- state $ randomR (60,wth/2-40)
let hf = hgt/5
let plmnts = [windowLine (wth-60, hf) (wllen,hf)
,windowLine (wth-wllen,2*hf) (60, 2*hf)
,windowLine (wth-60, 3*hf) (wllen,3*hf)
,windowLine (wth-wllen,4*hf) (60, 4*hf)
,blockLine ( 0, 1*hf) (wllen,1*hf)
,blockLine (wth-wllen, 2*hf) ( wth,2*hf)
,blockLine ( 0, 3*hf) (wllen,3*hf)
,blockLine (wth-wllen, 4*hf) ( wth,4*hf)
, sPS (wth/2,hgt/2) 0 $ putLamp
]
let plmnts =
[windowLine (wth-60, hf) (wllen,hf)
,windowLine (wth-wllen,2*hf) (60, 2*hf)
,windowLine (wth-60, 3*hf) (wllen,3*hf)
,windowLine (wth-wllen,4*hf) (60, 4*hf)
,blockLine ( 0, 1*hf) (wllen,1*hf)
,blockLine (wth-wllen, 2*hf) ( wth,2*hf)
,blockLine ( 0, 3*hf) (wllen,3*hf)
,blockLine (wth-wllen, 4*hf) ( wth,4*hf)
, sPS (wth/2,hgt/2) 0 putLamp
]
return $ set rmPS plmnts $ roomRect wth hgt 2 6
manyDoors :: Int -> Tree (Either Room Room)
@@ -112,22 +111,22 @@ manyDoors i = treeFromPost (replicate i (Left door)) $ Right door
glassLesson :: RandomGen g => State g (Tree (Either Room Room))
glassLesson = do
corridors <- sequence $ replicate 3 $ fmap Left $ randomiseOutLinks corridor
return $ Node (Left $ botRoom) [deadRoom door,uppers, treeFromPost (Left door : corridors) $ Right door]
where uppers = Node (Left door) [deadRoom topRoom]
botRoom = set rmPS botplmnts
$ roomRect 200 200 1 1
topRoom = set rmPS topplmnts
$ roomRect 200 200 1 1
botplmnts = [sPS (0,0) 0 $ PutWall (rectNSWE (200) 0 (90) (110))
$ defaultCrystalWall
,sPS (50,100) 0 $ PutCrit miniGunCrit
,sPS (50,50) 0 putLamp
]
topplmnts = [windowLine (100,200) (100,0)
,sPS (50,100) 0 $ PutCrit miniGunCrit
,sPS (50,50) 0 putLamp
]
corridors <- replicateM 3 $ Left <$> randomiseOutLinks corridor
return $ Node (Left botRoom) [deadRoom door,uppers, treeFromPost (Left door : corridors) $ Right door]
where
uppers = Node (Left door) [deadRoom topRoom]
botRoom = set rmPS botplmnts $ roomRect 200 200 1 1
topRoom = set rmPS topplmnts $ roomRect 200 200 1 1
botplmnts =
[sPS (0,0) 0 $ PutWall (rectNSWE 200 0 90 110) defaultCrystalWall
,sPS (50,100) 0 $ PutCrit miniGunCrit
,sPS (50,50) 0 putLamp
]
topplmnts =
[windowLine (100,200) (100,0)
,sPS (50,100) 0 $ PutCrit miniGunCrit
,sPS (50,50) 0 putLamp
]
miniRoom1 :: RandomGen g => State g Room
miniRoom1 = do
@@ -145,7 +144,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 randC
,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)
@@ -155,9 +154,10 @@ miniRoom1 = do
return $ set rmPS plmnts $ shiftRoomBy ((0,40),0) $ roomRect wth hgt 2 4
miniTree2 :: RandomGen g => State g (Tree (Either Room Room))
miniTree2 = miniRoom1 >>= randomiseOutLinks >>= changeLinkTo (\p -> (snd . fst) p < 70)
>>= return . flip branchWith (replicate 3 $ treeFromPost [door,corridor]
critInDeadEnd )
miniTree2 = miniRoom1
>>= randomiseOutLinks
>>= changeLinkTo (\p -> (snd . fst) p < 70)
<&> flip branchWith (replicate 3 $ treeFromPost [door,corridor] critInDeadEnd)
miniRoom3 :: RandomGen g => State g (Tree (Either Room Room))
miniRoom3 = do
@@ -200,7 +200,7 @@ roomMiniIntro = fmap (g . expandTreeBy f) $ sequence $ treeFromPost
[return $ connectRoom door
,join $ takeOne [miniTree2,glassLesson]
]
$ fmap connectRoom $ randomiseOutLinks corridor
$ connectRoom <$> randomiseOutLinks corridor
where
f (Node (Right x) xs) = Node (Right (Right x)) $ map f xs
f (Node (Left x) xs) = Node (Left (Left x)) $ map f xs
@@ -245,7 +245,7 @@ allPairs xs = [(x,y) | x <- xs, y <- xs, x /= y]
randomCorridorFrom :: RandomGen g => [a] -> State g (Tree (Either a a))
randomCorridorFrom xs = do
rooms <- sequence $ replicate 5 $ takeOne xs
rooms <- replicateM 5 $ takeOne xs
return $ treeFromTrunk (map Left $ init rooms) (Node (Right (last rooms)) [])
{- Probabilites of the type of the first floor weapon. -}
randFirstWeapon :: State StdGen PSType
@@ -264,23 +264,25 @@ weaponEmptyRoom :: RandomGen g => State g (Tree (Either Room Room))
weaponEmptyRoom = do
w <- state $ randomR (220,300)
h <- state $ randomR (220,300)
let plmnts = [sPS (w/2,h-40) 0 $ RandPS randFirstWeapon
,sPS (20,20) (pi/2) $ randC1
,sPS (w-20,20) (pi/2) $ randC1
,sPS (w/2,h/2) 0 $ putLamp
]
(fmap connectRoom . randomiseOutLinks) =<< (changeLinkTo ((\p -> dist p (w/2,0) < 10) . fst)
$ set rmPS plmnts $ roomRect w h 2 2)
let plmnts =
[sPS (w/2,h-40) 0 $ RandPS randFirstWeapon
,sPS (20,20) (pi/2) randC1
,sPS (w-20,20) (pi/2) randC1
,sPS (w/2,h/2) 0 putLamp
]
(fmap connectRoom . randomiseOutLinks) =<<
changeLinkTo ((\p -> dist p (w/2,0) < 10) . fst) (set rmPS plmnts $ roomRect w h 2 2)
weaponUnderCrits :: RandomGen g => State g (Tree (Either Room Room))
weaponUnderCrits = do
let plmnts =
[sPS (20,0) 0 $ RandPS randFirstWeapon
,sPS (20,0) (0-pi/2) $ randC1
,sPS (20,20) (0-pi/2) $ randC1
[sPS (20,0) 0 $ RandPS randFirstWeapon
,sPS (20,0) (negate $ pi/2) randC1
,sPS (20,20) (negate $ pi/2) randC1
]
let continuationRoom = treeFromTrunk [Left corridorN,Left corridorN]
(connectRoom (set rmPS plmnts $ corridorN))
let continuationRoom = treeFromTrunk
[Left corridorN,Left corridorN]
(connectRoom (set rmPS plmnts corridorN))
rcp' <- roomCenterPillar
let rcp = over rmPS ( sPS (120,80) 0 putLamp : ) rcp'
deadEndRoom <- takeOne [roomPillars,rcp]
@@ -295,14 +297,16 @@ 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)]
let d p = argV $ (120,80) -.- p
let plmnts1 = [sPS (120,160) 0 $ RandPS randFirstWeapon
,sPS crPos (d crPos) $ randC1
]
let plmnts1 =
[sPS (120,160) 0 $ RandPS randFirstWeapon
,sPS crPos (d crPos) randC1
]
rcp <- roomCenterPillar
return $ treeFromTrunk [Left door
,Left $ over rmLinks tail $ over rmPS (++ plmnts1) rcp]
(connectRoom $ set rmPS [sPS (20,60) (0-pi/2) $ randC1]
$ corridorN)
return $ treeFromTrunk
[Left door
,Left $ over rmLinks tail $ over rmPS (++ plmnts1) rcp
]
(connectRoom $ set rmPS [sPS (20,60) (negate $ pi/2) randC1] corridorN)
weaponBetweenPillars :: RandomGen g => State g (Tree (Either Room Room))
weaponBetweenPillars = do
@@ -313,34 +317,31 @@ weaponBetweenPillars = do
d p = argV $ (120,120) -.- p
plmnts =
[sPS wpPos 0 $ RandPS randFirstWeapon
,sPS crPos1 (d crPos1) $ randC1
,sPS crPos2 (d crPos2) $ randC1
,sPS crPos1 (d crPos1) randC1
,sPS crPos2 (d crPos2) randC1
]
(fmap connectRoom . randomiseOutLinks) =<< (filterLinks f $ over rmPS (++plmnts) $ roomPillars)
(fmap connectRoom . randomiseOutLinks) =<< filterLinks f (over rmPS (++plmnts) roomPillars)
where
f (_,a) = a == 0
weaponLongCorridor :: RandomGen g => State g (Tree (Either Room Room))
weaponLongCorridor = do
root <- takeOne $ [tEast, tWest]
root <- takeOne [tEast, tWest]
connectingRoom <- takeOne
[tEast & rmPS .~ [sPS (-40,60) 0 $ putLamp]
,tWest & rmPS .~ [sPS ( 40,60) 0 $ putLamp]
[tEast & rmPS .~ [sPS (-40,60) 0 putLamp]
,tWest & rmPS .~ [sPS ( 40,60) 0 putLamp]
]
i1 <- state $ randomR (2,5)
i2 <- state $ randomR (2,5)
let branch1 = treeFromTrunk (replicate i1 $ Left corridorN) (connectRoom $ putCrs connectingRoom)
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
])
putWp = set rmPS [sPS (20,40) 0 $ RandPS randFirstWeapon
,sPS (20,60) 0 $ putLamp
]
where
putCrs = over rmPS (++ [sPS (10,40) (-pi/2) randC ,sPS (-10,40) (-pi/2) randC ])
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 randC] deadEndRoom
deadEndRoom :: Room
deadEndRoom = Room
@@ -365,8 +366,8 @@ weaponRoom = join $ takeOne
roomCCrits :: RandomGen g => State g (Tree (Either Room Room))
roomCCrits = do
ps <- sequence $ replicate 20 $ randInCirc 9
let plmnts = map (\p -> sPS p 0 $ randC)
ps <- replicateM 20 $ randInCirc 9
let plmnts = map (\p -> sPS p 0 randC)
$ 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
@@ -384,38 +385,33 @@ longRoom = do
,rectNSWE (h-35) (h-135) 65 85
]
let wsDefense = map (\ps -> sPS (0,0) 0 $ PutWall ps defaultCrystalWall)
[rectNSWE (95) (70) 0 25
,rectNSWE (95) (70) 50 75
[rectNSWE 95 70 0 25
,rectNSWE 95 70 50 75
]
brls <- fmap (map (\p -> sPS (p +.+ (10,200)) 0 $ PutCrit explosiveBarrel) )
$ sequence $ replicate 5 $ randInRect (w-20) 900
$ replicateM 5 $ randInRect (w-20) 900
let rm = roomRect w (h+70) 1 1 & rmPolys %~ ([rectNSWE h (h-165) (-45) (w+45)] ++)
changeLinkTo cond $ set rmPS (ws ++ brls ++ wsDefense ++
[sPS ( 12.5,h-25) 0 $ PutCrit longCrit
,sPS ( 37.5,h-25) 0 $ PutCrit longCrit
,sPS ( 62.5,h-25) 0 $ PutCrit longCrit
,sPS ( 25, 20) 0 $ putLamp
,sPS ( 25, h-10) 0 $ putLamp
]
)
$ rm
changeLinkTo cond $ rm & rmPS .~ ws ++ brls ++ wsDefense ++
[sPS ( 12.5,h-25) 0 $ PutCrit longCrit
,sPS ( 37.5,h-25) 0 $ PutCrit longCrit
,sPS ( 62.5,h-25) 0 $ PutCrit longCrit
,sPS ( 25, 20) 0 putLamp
,sPS ( 25,h-10) 0 putLamp
]
shooterRoom :: RandomGen g => State g Room
shooterRoom = do
h <- state $ randomR (200,300)
let cond x = (snd . fst) x < h - 40
changeLinkTo cond $ set rmPS ( [blockLine (50,50) (50,h)
,sPS ( 25,h-25) 0 $ PutCrit $ addArmour autoCrit
,sPS ( 75,h-30) 0 $ PutCrit explosiveBarrel
,sPS ( 75,h-60) 0 $ PutCrit explosiveBarrel
,sPS ( 85,h-10) 0 $ PutCrit explosiveBarrel
,sPS ( 85,h-45) 0 $ PutCrit explosiveBarrel
,sPS ( 75,h-80) 0 putLamp
]
)
$ roomRect 100 h 1 1
changeLinkTo cond $ roomRect 100 h 1 1 & rmPS .~
[blockLine (50,50) (50,h)
,sPS ( 25,h-25) 0 $ PutCrit $ addArmour autoCrit
,sPS ( 75,h-30) 0 $ PutCrit explosiveBarrel
,sPS ( 75,h-60) 0 $ PutCrit explosiveBarrel
,sPS ( 85,h-10) 0 $ PutCrit explosiveBarrel
,sPS ( 85,h-45) 0 $ PutCrit explosiveBarrel
,sPS ( 75,h-80) 0 putLamp
]
shootersRoom1 :: RandomGen g => State g Room
shootersRoom1 = do
src/Dodge/SoundLogic.hs
+4 -4
View File
@@ -70,13 +70,13 @@ resumeSound w = w
Consider replacing instances with 'soundOncePos'.
-}
soundOnce :: Int -> World -> World
soundOnce i = over soundQueue ((:) (i,0))
soundOnce i = soundQueue %~ ((i,0) : )
{-| Play a sound with a given position in the world.
Uses the angle between the given position and '_cameraViewFrom', taking into account '_cameraRot'.
-}
soundOncePos :: Int -> Point2 -> World -> World
soundOncePos i pos w = over soundQueue ((:) (i,a)) w
soundOncePos i pos w = w & soundQueue %~ ((i,a) :)
where
a = soundAngle pos w
@@ -88,7 +88,7 @@ soundOnceOrigin
-> SoundOrigin -- ^ The \"creator\" of the sound
-> Point2 -- ^ The position of the sound in the world
-> World -> World
soundOnceOrigin sType so p w = over sounds (M.insertWith (flip const) so theSound) w
soundOnceOrigin sType so p w = w & sounds %~ M.insertWith (\ _ x -> x) so theSound
where
theSound = Sound
{ _soundChunkID = sType
@@ -141,7 +141,7 @@ soundFrom
-> Int -- ^ Frames to play
-> Int -- ^ Fade out time (ms)
-> World -> World
soundFrom so sType time fadeTime w = over sounds (M.insertWith f so sound) w
soundFrom so sType time fadeTime = sounds %~ M.insertWith f so sound
where
sound = Sound
{ _soundChunkID = sType
src/Dodge/Update.hs
+11 -7
View File
@@ -9,7 +9,6 @@ import Dodge.Data
import Dodge.Data.Menu
import Dodge.World.Trigger.Data
import Dodge.Config.Data
import Dodge.Data.Menu
import Dodge.Base
import Dodge.WallCreatureCollisions
import Dodge.LevelGen.Block
@@ -67,6 +66,7 @@ update' w = case _menuLayers w of
. zoneClouds
. updateClouds
. updateCreatures
. updateCreatureGroups
. updateBlocks
. updateSeenWalls
. updateSoundQueue
@@ -84,6 +84,10 @@ update' w = case _menuLayers w of
cid = _clID cr
doubleArgumentFor f x = f x x
updateCreatureGroups :: World -> World
updateCreatureGroups w = w & creatureGroups %~
IM.mapMaybe (\cgp -> _crGroupUpdate cgp w cgp)
updateTriggers :: World -> World
updateTriggers w
| ResetLevel 1 `S.member` _worldTriggers w = generateFromList levx $ initialWorld
@@ -119,7 +123,7 @@ updateCreatures w = f $ set randGen newG $ set creatures (IM.mapMaybe id crs) w
{- |
Apply door mechanisms. -}
updateWalls :: World -> World
updateWalls w = IM.foldr (maybe id id . (^? doorMech)) w (_walls w)
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
@@ -158,8 +162,8 @@ moveCloud c w = _clEffect c c . theUpdate $ w
oldPos = _clPos c
newPos = oldPos +.+ newVel
hitWl = collideCircWalls' oldPos newPos 5 $ wallsNearPoint newPos w
finalPos = fromMaybe newPos (fmap fst hitWl)
finalVel = fromMaybe newVel (fmap snd hitWl)
finalPos = maybe newPos fst hitWl
finalVel = maybe newVel snd hitWl
theUpdate w' = w'
& clouds . ix (_clID c) . clTimer %~ (\t -> t - 1)
& clouds . ix (_clID c) . clVel .~ finalVel
@@ -168,7 +172,7 @@ moveCloud c w = _clEffect c c . theUpdate $ w
clClSpringVel :: Cloud -> World -> Cloud -> Point2 -> Point2
clClSpringVel a w b v
| ida == idb = v
| dist pa pb < radDist = v +.+ 0.1 *.* (safeNormalizeV (pa -.- pb))
| dist pa pb < radDist = v +.+ 0.1 *.* safeNormalizeV (pa -.- pb)
| otherwise = v
where
ida = _clID a
@@ -181,7 +185,7 @@ simpleCrSprings :: World -> World
simpleCrSprings w = IM.foldr' crSpring w $ _creatures w
crSpring :: Creature -> World -> World
crSpring c w = IM.foldr' (crCrSpring c) w $ cs
crSpring c w = IM.foldr' (crCrSpring c) w cs
where
cs = creaturesNearPoint (_crPos c) w
@@ -196,7 +200,7 @@ crCrSpring c1 c2 w
id1 = _crID c1
id2 = _crID c2
vec = _crPos c1 -.- _crPos c2
diff = magV $ vec
diff = magV vec
comRad = _crRad c1 + _crRad c2
overlap1 = ((comRad - diff) * _crMass c2 * 0.5 / massT) *.* errorNormalizeV 55 vec
overlap2 = ((comRad - diff) * _crMass c1 * 0.5 / massT) *.* errorNormalizeV 56 vec
src/Dodge/WallCreatureCollisions.hs
+5 -5
View File
@@ -27,7 +27,7 @@ colCrWall w c
rad = _crRad c + wallBuffer
p1 = _crOldPos c
p2 = _crPos c
ls = IM.elems $ fmap _wlLine $ wallsNearPoint p2 w
ls = IM.elems $ _wlLine <$> wallsNearPoint p2 w
wallPoints = nub $ concatMap (\(x,y) -> [x,y]) ls
-- colCrPushThrough :: World -> Creature -> Creature
@@ -65,13 +65,13 @@ pushOrCrush :: [(Point2,Point2)] -> Creature -> Creature
pushOrCrush wls cr = case mapMaybe (pushOutFromWall (_crRad cr) cpos) wls of
[] -> cr
[p] -> cr & crPos .~ p
_ -> cr & crState . crDamage %~ ( (Blunt 50 cpos cpos cpos) :)
_ -> cr & crState . crDamage %~ ( Blunt 50 cpos cpos cpos : )
where
cpos = _crPos cr
-- assumes that the wall is orientated
-- assumes wall points are different
pushOutFromWall :: Float -> Point2 -> (Point2,Point2) -> Maybe (Point2)
pushOutFromWall :: Float -> Point2 -> (Point2,Point2) -> Maybe Point2
pushOutFromWall rad cp2 (wp1,wp2)
| isOnWall = Just newP -- +.+ (1 *.* norm))
| otherwise = Nothing
@@ -88,7 +88,7 @@ pushOutFromCorners :: World -> Creature -> Creature
pushOutFromCorners w cr = cr & crPos .~ newPos
where
newPos = foldr (intersectCirclePoint (_crRad cr)) (_crPos cr) ls
ls = nub . concatMap (\(x,y) -> [x,y]) . IM.elems $ fmap _wlLine $ wallsNearPoint (_crPos cr) w
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
@@ -103,7 +103,7 @@ checkPushThroughs :: Float -> Point2 -> [(Point2,Point2)] -> Point2 -> Point2
checkPushThroughs rad cp1 walls cp2
= fromMaybe cp2 $ (listToMaybe.mapMaybe (checkPushThrough rad cp1 cp2)) walls
checkPushThrough :: Float -> Point2 -> Point2 -> (Point2,Point2) -> Maybe (Point2)
checkPushThrough :: Float -> Point2 -> Point2 -> (Point2,Point2) -> Maybe Point2
checkPushThrough rad cp1 cp2 (wp1,wp2)
| isPushedThrough = intersectSegSeg' cp1 cp2 wp1 wp2
| otherwise = Nothing
src/Dodge/WorldEvent.hs
+21 -21
View File
@@ -39,27 +39,27 @@ import Data.Function
import Data.List
import qualified Data.IntMap.Strict as IM
createBarrelSpark :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World
createBarrelSpark time colid pos dir maycid w = over worldEvents
((.) $ ( over particles ((:) spark)
. sparkFlashAt pos')
) w
where spark = Bul' { _ptDraw = drawBul
, _ptUpdate' = mvGenBullet'
, _btVel' = rotateV dir (5,0)
, _btColor' = numColor colid
, _btTrail' = [pos]
, _btPassThrough' = maycid
, _btWidth' = 1
, _btTimer' = time
, _btHitEffect' = destroyOnImpact sparkEff noEff noEff
}
x = fst $ randomR (0,20) $ _randGen w
pos' = pos +.+ rotateV dir (x,0)
sparkEff bt p cr = over (creatures . ix (_crID cr) . crState . crDamage)
((:) $ SparkDam 1 sp p ep)
where sp = head (_btTrail' bt)
ep = sp +.+ _btVel' bt
createBarrelSpark :: Point2 -> Float -> Maybe Int -> Int -> Int -> World -> World
createBarrelSpark pos dir maycid time colid w
= over worldEvents (( over particles (spark :) . sparkFlashAt pos') . ) w
where
spark = Bul'
{ _ptDraw = drawBul
, _ptUpdate' = mvGenBullet'
, _btVel' = rotateV dir (5,0)
, _btColor' = numColor colid
, _btTrail' = [pos]
, _btPassThrough' = maycid
, _btWidth' = 1
, _btTimer' = time
, _btHitEffect' = destroyOnImpact sparkEff noEff noEff
}
x = fst $ randomR (0,20) $ _randGen w
pos' = pos +.+ rotateV dir (x,0)
sparkEff bt p cr = over (creatures . ix (_crID cr) . crState . crDamage)
((:) $ SparkDam 1 sp p ep)
where sp = head (_btTrail' bt)
ep = sp +.+ _btVel' bt
src/Dodge/WorldEvent/Shockwave.hs
+1 -1
View File
@@ -72,7 +72,7 @@ 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 (foldr damageBlocks) hitBlocks
dams = over creatures (IM.map damCr) . flip (IM.foldr damageBlocks) hitBlocks
hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w
damageBlocks wall w
= case wall ^? blHP of
src/DoubleStack.hs
+4 -4
View File
@@ -17,17 +17,17 @@ left (DS (_,l,_)) = l
right (DS (_,_,r)) = r
pushL :: DS a -> DS a
pushL (DS (x,xs,(y:ys))) = DS (y,(x:xs),ys)
pushL (DS (x,xs, y:ys )) = DS (y, x:xs ,ys)
pushL ds = ds
pushR :: DS a -> DS a
pushR (DS (y,(x:xs),ys)) = DS (x,xs,(y:ys))
pushR (DS (y, x:xs ,ys)) = DS (x,xs, y:ys )
pushR ds = ds
cycleL :: DS a -> Maybe (DS a)
cycleL (DS (x,xs,(y:ys))) = Just $ DS (y,(x:xs),ys)
cycleL (DS (x,xs, y:ys )) = Just $ DS (y, x:xs ,ys)
cycleL _ = Nothing
cycleR :: DS a -> Maybe (DS a)
cycleR (DS (y,(x:xs),ys)) = Just $ DS (x,xs,(y:ys))
cycleR (DS (y, x:xs ,ys)) = Just $ DS (x,xs, y:ys )
cycleR _ = Nothing
src/Geometry.hs
+27 -79
View File
@@ -24,16 +24,13 @@ import Geometry.Vector
import Data.Function
import Data.List
import Data.Maybe
import Control.Applicative
-- | Return a point a distance away from a first point towards a second point.
-- Does not go past the second point.
alongSegBy :: Float -> Point2 -> Point2 -> Point2
alongSegBy !x !a !b = a +.+ y *.* normalizeV (b -.- a)
where
y = min x $ dist a b
-- | Given a line and a point return the point on the line closest to the
-- point.
closestPointOnLine
@@ -44,7 +41,6 @@ closestPointOnLine
{-# INLINE closestPointOnLine #-}
closestPointOnLine !a !b !p = a +.+ u *.* (b -.- a)
where u = closestPointOnLineParam a b p
-- | Given a line and a point return a value corresponding to how far along the
-- line the point is.
closestPointOnLineParam
@@ -55,36 +51,28 @@ closestPointOnLineParam
{-# INLINE closestPointOnLineParam #-}
closestPointOnLineParam !a !b !p
= (p -.- a) `dotV` (b -.- a) / (b -.- a) `dotV` (b -.- a)
-- | Draw a rectangle based on maximal N E S W values.
rectNESW :: Float -> Float -> Float -> Float -> [Point2]
rectNESW !a !b !c !d = [(b,a),(b,c),(d,c),(d,a) ]
-- | Draw a rectangle based on maximal N S E W values.
rectNSEW :: Float -> Float -> Float -> Float -> [Point2]
rectNSEW !n !s !e !w = rectNESW n e s w
-- | Draw a rectangle based on maximal N S W E values.
rectNSWE :: Float -> Float -> Float -> Float -> [Point2]
rectNSWE !n !s !w !e = [ (w,n), (w,s), (e,s), (e,n)]
-- | Draw a rectangle around the origin with given height and width
rectWdthHght :: Float -> Float -> [Point2]
rectWdthHght w h = rectNSWE h (-h) (-w) w
-- | Draw a rectangle around the origin with given height and width
-- | Test whether a point is in a polygon or on the polygon border.
-- Supposes the points in the
-- polygon are listed in anticlockwise order.
pointInOrOnPolygon :: Point2 -> [Point2] -> Bool
pointInOrOnPolygon !p (x:xs) = all (\l -> not (uncurry isRHS l p)) $ zip (x:xs) (xs ++ [x])
-- | Test whether a point is strictly inside a polygon.
-- Supposes the points in the polygon are listed in anticlockwise order.
pointInPolygon :: Point2 -> [Point2] -> Bool
pointInPolygon !p [] = False
pointInPolygon !p (x:xs) = all (\l -> uncurry (errorIsLHS 1) l p) $ zip (x:xs) (xs ++ [x])
-- | Debug version of 'pointInPolygon'.
errorPointInPolygon :: Int -> Point2 -> [Point2] -> Bool
errorPointInPolygon !i !p xs
@@ -92,36 +80,30 @@ errorPointInPolygon !i !p xs
| length xs == 2 = error "two point polygon"
| nub xs == xs = pointInPolygon p xs
| otherwise = error $ "errorPointInPolygon "++ show i
-- | Debug version of 'normalizeV'.
errorNormalizeV :: Int -> Point2 -> Point2
errorNormalizeV !i (0,0) = error $ "problem with function: errorNormalizeV "++show i
errorNormalizeV !i !p = normalizeV p
-- | Debug version of 'angleVV'.
errorAngleVV :: Int -> Point2 -> Point2 -> Float
errorAngleVV !i (0,0) _ = error $ "problem with function: errorAngleVV "++show i
errorAngleVV !i _ (0,0) = error $ "problem with function: errorAngleVV "++show i
errorAngleVV !i !p !p' = angleVV p p'
-- | Debug version of 'isLHS'.
errorIsLHS :: Int -> Point2 -> Point2 -> Point2 -> Bool
errorIsLHS !i !x !y
| x == y = error $ "problem with function: errorIsLHS " ++show i
| otherwise = isLHS x y
-- | Debug version of 'closestPointOnLine'
errorClosestPointOnLine :: Int -> Point2 -> Point2 -> Point2 -> Point2
errorClosestPointOnLine !i !x !y
| x == y = error $ "problem with function: errorClosestPointOnLine " ++show i
| otherwise = closestPointOnLine x y
-- | Debug version of 'closestPointOnLineParam'
errorClosestPointOnLineParam :: Int -> Point2 -> Point2 -> Point2 -> Float
errorClosestPointOnLineParam !i !x! y! z
| x == y = dist x z
| otherwise = closestPointOnLineParam x y z
-- | Test whether a point is on the LHS of a line.
-- Returns False if the line is of zero length.
isLHS
@@ -141,7 +123,6 @@ isLHS
a2 = y' - y
b1 = x'' - x
b2 = y'' - y
-- | Test whether a point is on the LHS of a line.
-- Returns False if the line is of zero length.
isRHS
@@ -161,14 +142,12 @@ isRHS
a2 = y' - y
b1 = x'' - x
b2 = y'' - y
-- | Reorder points to be anticlockwise around their center.
orderPolygon :: [Point2] -> [Point2]
orderPolygon [] = []
orderPolygon ps = sortBy (compare `on` \p -> argV (p -.- cen)) ps
where
cen = 1/ fromIntegral (length ps) *.* foldr1 (+.+) ps
-- | Adds a point to a convex polygon.
-- If the point is inside, returns the original.
-- Points ordered anticlockwise, input not checked.
@@ -176,21 +155,17 @@ addPointPolygon :: Point2 -> [Point2] -> [Point2]
addPointPolygon p ps
| pointInOrOnPolygon p ps = ps
| otherwise = orderPolygon $ p : ps
-- | Creates the convex hull of a set of points.
convexHull :: [Point2] -> [Point2]
convexHull (x:y:z:xs) = foldr addPointPolygon (orderPolygon (x:y:z:[])) xs
convexHull (x:y:z:xs) = foldr addPointPolygon (orderPolygon [x,y,z]) xs
convexHull _ = error "Tried to create the convex hull of two or less points"
-- | Return distance between two points.
dist :: Point2 -> Point2 -> Float
{-# INLINE dist #-}
dist !p1 !p2 = magV (p2 -.- p1)
-- | Return midpoint between two points.
pHalf :: Point2 -> Point2 -> Point2
pHalf !a !b = 0.5 *.* (a +.+ b)
-- | Test whether a circle is on a segment by intersecting a new normal segment through the
-- center of the circle with the segment itself.
-- Returns False if the circle center is beyond the enpoints of the
@@ -202,40 +177,34 @@ circOnSegNoEndpoints !p1 !p2 !c !rad = isJustTrue (fmap (\p -> magV (p -.- c) <
y = intersectSegLine' p1 p2 c (c +.+ vNormal (p1 -.- p2))
isJustTrue (Just True) = True
isJustTrue _ = False
-- | Test whether a circle is on a segment by intersecting a normal and testing
-- the distance to the endpoints of the segment.
circOnSeg :: Point2 -> Point2 -> Point2 -> Float -> Bool
{-# INLINE circOnSeg #-}
circOnSeg !p1 !p2 !c !rad = magV (p1 -.- c) <= rad || magV (p2 -.- c) <= rad
|| isJustTrue (fmap (\p -> magV (p -.- c) < rad) y)
|| isJustTrue (fmap (\p -> magV (p -.- c) < rad) y)
where
y = intersectSegLine' p1 p2 c (c +.+ vNormal (p1 -.- p2))
isJustTrue (Just True) = True
isJustTrue _ = False
-- | Find the difference between two Nums.
difference :: (Ord a, Num a) => a -> a -> a
difference x y
| x > y = x - y
| otherwise = y - x
-- | Given vector line direction and a vector movement,
-- reflects the movement accoring to the line.
reflectIn :: Point2 -> Point2 -> Point2
reflectIn line vec =
let angle = 2 * angleBetween line vec
in rotateV angle vec
reflectIn line vec = rotateV angle vec
where
angle = 2 * angleBetween line vec
-- | Find angle between two points.
-- Not normalised, ranges from -2*pi to 2*pi.
angleBetween :: Point2 -> Point2 -> Float
angleBetween v1 v2 = argV v1 - argV v2
-- | Return a list containing two copies of a pair.
doublePair :: (a,a) -> [(a,a)]
doublePair (x,y) = [(x,y),(y,x)]
-- | Test whether two polygons intersect by testing the intersection of each
-- consecutive pair of points.
polysIntersect :: [Point2] -> [Point2] -> Bool
@@ -245,40 +214,32 @@ polysIntersect (p:ps) (q:qs)
pairs1 = zip (p:ps) (ps++[p])
pairs2 = zip (q:qs) (qs++[q])
polysIntersect _ _ = False
-- | Test whether two polygons intersect or if one is contained in the other.
polysOverlap :: [Point2] -> [Point2] -> Bool
polysOverlap (p:ps) (q:qs) = polysIntersect (p:ps) (q:qs)
|| pointInPolygon p (q:qs)
|| pointInPolygon q (p:ps)
polysOverlap _ _ = False
-- | Test whether any polygons from a first list intersect with any polygons from
-- a second list.
anyPolyssIntersect :: [[Point2]] -> [[Point2]] -> Bool
anyPolyssIntersect x y = or $ polysIntersect <$> x <*> y
-- | Return n equidistant points on a circle with a radius of 600.
nRays :: Int -> [Point2]
nRays n = take n $ iterate (rotateV (2*pi/fromIntegral n)) (600,0)
-- | Return n equidistant points on a circle with a radius of x.
nRaysRad :: Int -> Float -> [Point2]
nRaysRad n x = take n $ iterate (rotateV (2*pi/fromIntegral n)) (x,0)
-- | Test whether an angle is to the left of another angle, according to the
-- smallest change in rotation between them.
-- This appears to sometimes fail if the angles are not normalized.
isLeftOfA :: Float -> Float -> Bool
isLeftOfA angle1 angle2 =
(angle1 - angle2 < pi && angle1 > angle2)
isLeftOfA angle1 angle2 = (angle1 - angle2 < pi && angle1 > angle2)
|| (angle2 - angle1 > pi && angle2 > angle1)
-- | Test whether a vector is to the left of another, according to the smallest
-- change of rotation between them.
isLeftOf :: Point2 -> Point2 -> Bool
isLeftOf x y = isLeftOfA (argV x) (argV y)
-- | Find the difference between two angles.
-- Possibly not correct...
diffAngles :: Float -> Float -> Float
@@ -292,7 +253,6 @@ diffAngles x y
differenceAngles = diffAngles
angleDifference = diffAngles
-- | Given a triangle where we know the length of a first side,
-- the length of a second side, and the angle between the first side and the
-- third side, finds the length of the third side.
@@ -305,7 +265,6 @@ ssaTri ab bc a
let c = asin ( (ab * sin a)/bc)
b = pi - (a + c)
in sin b * bc / sin a
-- | Given two points of a triangle and a third point, return
-- the point which lies between pa and pc' on a line from pb of length bc.
-- Note that there are likely two such points, this should return the point
@@ -316,7 +275,6 @@ ssaTriPoint pa pb pc' bc
a = errorAngleVV 6 (pb -.- pa) (pc' -.- pa)
ac = ssaTri ab bc a
in pa +.+ (ac *.* errorNormalizeV 47 (pc' -.- pa))
-- | Safe version of 'ssaTriPoint'.
ssaTriPoint' :: Point2 -> Point2 -> Point2 -> Float -> Maybe Point2
ssaTriPoint' pa pb pc' bc
@@ -333,41 +291,34 @@ ssaTriPointCorrect pa pb pc' bc
where
p = ssaTriPoint pa pb pc' bc
param = closestPointOnLineParam pa pc' p
-- | Given a segment and external point, find the closest point on the segment.
closestPointOnSeg :: Point2 -> Point2 -> Point2 -> Point2
closestPointOnSeg segP1 segP2 p
| errorClosestPointOnLineParam 3 segP1 segP2 p <= 0 = segP1
| errorClosestPointOnLineParam 4 segP1 segP2 p >= 1 = segP2
| otherwise = errorClosestPointOnLine 2 segP1 segP2 p
-- | Return Just a point if it is inside a circle, Nothing otherwise.
pointInCircle :: Point2 -> Float -> Point2 -> Maybe Point2
pointInCircle p r c
| p == c = Just p
| magV (p -.- c) < r = Just p
| otherwise = Nothing
-- | Determines if a moving point intersects with a circle,
-- if so, returns a point on circle that intersects with the line passing
-- throught the circle : HOPEFULLY THE CORRECT OF THE TWO!
collidePointCirc :: Point2 -> Point2 -> Float -> Point2 -> Maybe Point2
collidePointCirc p1 p2 rad c = ssaTriPoint' p2 c p1 rad
-- | As 'collidePointCirc', but changes the point to a measure of the distance.
collidePointCirc' :: Point2 -> Point2 -> Float -> Point2 -> Maybe Float
collidePointCirc' p1 p2 rad c = fmap (\x -> magV (x -.- p1))
(collidePointCirc p1 p2 rad c)
(collidePointCirc p1 p2 rad c)
-- | As 'collidePointCirc', but returns both the point and the measure of the distance.
collidePointCirc'' :: Point2 -> Point2 -> Float -> Point2 -> Maybe (Point2,Float)
collidePointCirc'' p1 p2 rad c = (,) <$> collidePointCirc p1 p2 rad c
<*> collidePointCirc' p1 p2 rad c
<*> collidePointCirc' p1 p2 rad c
-- | As 'collidePointCirc', but uses the supposedly correct version of ssaTriPoint.
collidePointCircCorrect :: Point2 -> Point2 -> Float -> Point2 -> Maybe Point2
collidePointCircCorrect p1 p2 rad c = ssaTriPointCorrect p2 c p1 rad
-- | Finds the height of a triangle using herons formula.
-- The base is the line between the first two points.
heron :: Point2 -> Point2 -> Point2 -> Float
@@ -380,7 +331,6 @@ heron x y z
s = (a+b+c)/2
area = sqrt(s*(s-a)*(s-b)*(s-c))
in 2*area/a
-- | Multiplies reflection in normal by factor.
reflectInParam :: Float -> Point2 -> Point2 -> Point2
reflectInParam x line vec =
@@ -388,7 +338,6 @@ reflectInParam x line vec =
rAng = rotateV angle vec
p = x *.* errorClosestPointOnLine 3 (0,0) (vNormal line) rAng
in rAng -.- p
--reflectIn' :: Point2 -> Point2 -> Point2 -> Point2 -> Point2
--reflectIn' l1 l2 v1 v2 = v1 +.+ reflectIn (l1 -.- l2) (v2 -.- v1)
@@ -397,47 +346,47 @@ isOnSeg l1 l2 p =
errorClosestPointOnLineParam 10 l1 (l1 +.+ vNormal (l2 -.- l1)) p == 0
&& errorClosestPointOnLineParam 11 l1 l2 p <= 1
&& errorClosestPointOnLineParam 12 l1 l2 p >= 0
-- | Divide a segment into a list of points with a maximal distance between
-- them.
-- the take 5000 here is a hack, otherwise divideLine seems to sometimes
-- generate an infinite list, and I don't know why
divideLine :: Float -> Point2 -> Point2 -> [Point2]
--divideLine x a b = map (\i -> a +.+ (i / (fromIntegral numPoints)) *.* (b -.- a))
divideLine x a b =
take 5000
divideLine x a b = take 5000
$ map (\i -> a +.+ (fromIntegral i / fromIntegral numPoints *.* (b -.- a)) )
ns
ns
where
d = dist a b
numPoints = max 1 $ ceiling $ d / x
ns = [0 .. numPoints]
-- | As 'divideLine', but must return an odd number of points.
divideLineOddNumPoints :: Float -> Point2 -> Point2 -> [Point2]
--divideLine x a b = map (\i -> a +.+ (i / (fromIntegral numPoints)) *.* (b -.- a))
divideLineOddNumPoints x a b = take 5000
$ map (\i -> a +.+ (fromIntegral i / fromIntegral numPoints *.* (b -.- a)) )
ns
ns
where
d = dist a b
numPoints' = max 1 $ ceiling $ d / x
numPoints | even numPoints' = numPoints'
| otherwise = numPoints' + 1
numPoints
| even numPoints' = numPoints'
| otherwise = numPoints' + 1
ns = [0 .. numPoints]
-- | Given two pairs of Ints, returns a list of pairs of Ints that form
-- a digital line between them.
digitalLine :: (Int,Int) -> (Int,Int) -> [(Int,Int)]
{-# INLINE digitalLine #-}
digitalLine (x1,y1) (x2,y2)
| abs (x1-x2) > abs (y1-y2) = [ (x,( (y1-y2) * x + x1*y2 - x2*y1) `rdiv` (x1-x2) )
| x <- intervalList x1 x2 ]
| otherwise = [ ( ((x1-x2) * y + y1*x2 - y2*x1) `rdiv` (y1-y2) , y)
| y <- intervalList y1 y2 ]
| abs (x1-x2) > abs (y1-y2) =
[ (x,( (y1-y2) * x + x1*y2 - x2*y1) `rdiv` (x1-x2) )
| x <- intervalList x1 x2
]
| otherwise =
[ ( ((x1-x2) * y + y1*x2 - y2*x1) `rdiv` (y1-y2) , y)
| y <- intervalList y1 y2
]
where
rdiv a b = round $ fromIntegral a / fromIntegral b
-- | Given two pairs of 'Int's, create a list of pairs of 'Int's that form a
-- rectangle between them.
digitalRect :: (Int,Int) -> (Int,Int) -> [(Int,Int)]
@@ -448,13 +397,11 @@ digitalRect (a,b) (c,d) = [(s,t) | s <- [minx .. maxx] , t <- [miny .. maxy]]
minx = min a c
maxy = max b d
miny = min b d
-- | Given two Ints, creates the list of Ints between these.
intervalList :: Int -> Int -> [Int]
intervalList x y
| y >= x = [x .. y]
| otherwise = reverse [y..x]
-- | Create points on the circumference of a circle with maximal distance
-- between them.
divideCircle :: Float -> Point2 -> Float -> [Point2]
@@ -478,7 +425,7 @@ arcStepwisePositive
-> Point2 -- ^ Center
-> Point2 -- ^ Start vector from center
-> [Point2]
arcStepwisePositive ssize a cen v = ((cen +.+) . (\rot -> rotateV rot v) ) <$> rots
arcStepwisePositive ssize a cen v = (cen +.+) . (`rotateV` v) <$> rots
where
rots :: [Float]
rots = map ((a*) . (/ fromIntegral n ) . fromIntegral) [0 .. n]
@@ -502,7 +449,6 @@ makeLoopPairs :: [Point2] -> [(Point2,Point2)]
makeLoopPairs [] = error "tried to make loop with empty list of points"
makeLoopPairs [x] = error "tried to make loop with singleton list of points"
makeLoopPairs (x:xs) = zip (x:xs) (xs ++ [x])
-- | Test whether a point is in a cone.
-- Note the pair is ordered.
-- Doesn't work for obtuse angles.
@@ -512,4 +458,6 @@ pointIsInCone
-> Point2 -- ^ Point to test.
-> Bool
pointIsInCone c (rightp,leftp) p = isLHS c rightp p && isLHS leftp c p
-- | TODO: implement using Control.Foldl
centroid :: Foldable t => t Point2 -> Point2
centroid xs = 1 / fromIntegral (length xs) *.* foldl' (+.+) (0,0) xs
src/Loop.hs
+2 -2
View File
@@ -1,6 +1,6 @@
{- |
Module : Loop
Description : Minimal game loop
Description : Simple game loop
This module sets up an SDL window which may be updated using a simple game loop.
-}
@@ -41,7 +41,7 @@ setupLoop
startWorld <- ioStartWorld
initializeAll
bracket
(createWindow (T.pack "A Minimal Game Loop") (winConfig xSize ySize))
(createWindow (T.pack "Simple Game Loop") (winConfig xSize ySize))
destroyWindow
$ \window -> bracket
(glCreateContext window)
src/Music.hs
-1
View File
@@ -1,4 +1,3 @@
{-# LANGUAGE TemplateHaskell #-}
module Music
where
import qualified SDL.Mixer as Mix
src/Picture.hs
+9 -9
View File
@@ -120,7 +120,7 @@ extrapolate (ox,oy) (ax,ay) (bx,by) (x,y) =
color :: RGBA -> Picture -> Picture
{-# INLINE color #-}
color c pic = OverPic id id 0 (const c) pic
color c = OverPic id id 0 (const c)
translate3 :: Float -> Float -> Point3 -> Point3
{-# INLINE translate3 #-}
@@ -128,15 +128,15 @@ translate3 a b (x,y,z) = (x+a,y+b,z)
translate :: Float -> Float -> Picture -> Picture
{-# INLINE translate #-}
translate x y pic = OverPic (translate3 x y) id 0 id pic
translate x y = OverPic (translate3 x y) id 0 id
setDepth :: Float -> Picture -> Picture
{-# INLINE setDepth #-}
setDepth d pic = OverPic (\(x,y,_) -> (x,y,d)) id 0 id pic
setDepth d = OverPic (\(x,y,_) -> (x,y,d)) id 0 id
setLayer :: Int -> Picture -> Picture
{-# INLINE setLayer #-}
setLayer i pic = OnLayer i pic
setLayer = OnLayer
scale3 :: Float -> Float -> Point3 -> Point3
{-# INLINE scale3 #-}
@@ -144,7 +144,7 @@ scale3 a b (x,y,z) = (x*a,y*b,z)
scale :: Float -> Float -> Picture -> Picture
{-# INLINE scale #-}
scale x y pic = OverPic (scale3 x y) (\(a,b) ->(a*x,b*y)) 0 id pic
scale x y = OverPic (scale3 x y) (\(a,b) ->(a*x,b*y)) 0 id
rotate3 :: Float -> Point3 -> Point3
{-# INLINE rotate3 #-}
@@ -154,7 +154,7 @@ rotate3 a (x,y,z) = (x',y',z)
rotate :: Float -> Picture -> Picture
{-# INLINE rotate #-}
rotate a pic = OverPic (rotate3 a) id a id pic
rotate a = OverPic (rotate3 a) id a id
pictures :: [Picture] -> Picture
{-# INLINE pictures #-}
@@ -162,9 +162,9 @@ pictures = Pictures
makeArc :: Float -> (Float,Float) -> [Point2]
{-# INLINE makeArc #-}
makeArc rad (a,b) = zipWith rotateV as (repeat (0,rad))
makeArc rad (a,b) = map (`rotateV` (0,rad)) angles
where
as = [a,a+step.. b]
angles = [a,a+step.. b]
step = pi * 0.2
circleSolid :: Float -> Picture
@@ -203,7 +203,7 @@ thickLine ps t = pictures $ f ps
thickCircle :: Float -> Float -> Picture
{-# INLINE thickCircle #-}
thickCircle rad wdth = thickArc 0 (2*pi) rad wdth
thickCircle = thickArc 0 (2*pi)
arcSolid :: Float -> Float -> Float -> Picture
{-# INLINE arcSolid #-}
src/SameConstr.hs
+1 -1
View File
@@ -1,4 +1,4 @@
{-# LANGUAGE DefaultSignatures, TypeOperators, FlexibleContexts #-}
{-# LANGUAGE TypeOperators, FlexibleContexts #-}
{- | Pulled from
https://stackoverflow.com/questions/10112733/haskell-simple-constructor-comparison-function
-}
src/Shader.hs
+9 -13
View File
@@ -1,4 +1,3 @@
{-# LANGUAGE QuasiQuotes #-}
module Shader
( makeShader
, addTexture
@@ -47,7 +46,7 @@ extractProgAndUnis :: FullShader a -> (Program,[UniformLocation])
extractProgAndUnis s = (_shaderProgram s, _shaderUniforms s)
pokeShaders :: [FullShader a] -> F.FoldM IO a [Int]
pokeShaders fss = traverse pokeShader fss
pokeShaders = traverse pokeShader
pokeShader :: FullShader a -> F.FoldM IO a Int
pokeShader fs = F.FoldM (pokeRender fls (zip ptrs nAtss)) (return 0) return
@@ -61,18 +60,17 @@ pokeRender :: (a -> [[[Float]]])
pokeRender toFs ptrs n rt = pokeList ptrs n (toFs rt)
pokeList :: [(Ptr Float,Int)] -> Int -> [[[Float]]] -> IO Int
pokeList ptrs n fsss = foldM (pokePtrs ptrs) n fsss
pokeList ptrs = foldM (pokePtrs ptrs)
pokePtrs :: [(Ptr Float,Int)] -> Int -> [[Float]] -> IO Int
pokePtrs ptrIs n fss = do
zipWithM_ f ptrIs fss
return $ n + 1
where f (ptr,i) fs = pokeArrayOff ptr (i*n) fs
where
f (ptr,i) fs = pokeArrayOff ptr (i*n) fs
pokeArrayOff :: Storable a => Ptr a -> Int -> [a] -> IO ()
pokeArrayOff ptr i xs =
zipWithM_ (pokeElemOff ptr) [i..] xs
pokeArrayOff ptr i = zipWithM_ (pokeElemOff ptr) [i..]
bindArrayBuffers :: Int -> [(BufferObject,Ptr Float,Int)] -> IO ()
{-# INLINE bindArrayBuffers #-}
@@ -82,22 +80,20 @@ bindArrayBuffers numVs ps = do
bufferData ArrayBuffer $= (fromIntegral $ floatSize * numVs * i, ptr, StreamDraw)
bindShaderBuffers :: [FullShader a] -> [Int] -> IO ()
bindShaderBuffers fss is =
zipWithM_ f fss is
bindShaderBuffers = zipWithM_ f
where
f fs i = bindArrayBuffers i $ _vaoBufferTargets $ _shaderVAO fs
drawShaders :: [FullShader a] -> [Int] -> IO ()
drawShaders fss is =
zipWithM_ drawShader fss is
drawShaders = zipWithM_ drawShader
drawShader :: FullShader a -> Int -> IO ()
{-# INLINE drawShader #-}
drawShader fs i = do
currentProgram $= Just (_shaderProgram fs)
bindVertexArrayObject $= (Just (_vao $ _shaderVAO fs))
bindVertexArrayObject $= Just (_vao $ _shaderVAO fs)
case _shaderTexture fs of
Just (ShaderTexture {_textureObject = to})
Just ShaderTexture{_textureObject = to}
-> textureBinding Texture2D $= Just to
_ -> return ()
drawArrays (_shaderDrawPrimitive fs) 0 (fromIntegral i)
src/Sound.hs
+5 -9
View File
@@ -50,10 +50,7 @@ In the update:
-}
playAndUpdate :: Ord a => SoundData a -> M.Map a Sound -> IO (M.Map a Sound)
playAndUpdate sData newSounds
= updateSounds (_loadedChunks sData) (mergeSounds newSounds (_playingSounds sData))
mergeSounds :: Ord a => M.Map a Sound -> M.Map a Sound -> M.Map a Sound
mergeSounds as bs = M.unionWith mergeSound as bs
= updateSounds (_loadedChunks sData) (M.unionWith mergeSound newSounds (_playingSounds sData))
mergeSound :: Sound -> Sound -> Sound
mergeSound newS oldS
@@ -85,7 +82,7 @@ tryPlay sd s = do
Mix.halt i
Mix.playOn i Mix.Once (sd IM.! _soundChunkID s)
return $ s
& soundChannel .~ Just i
& soundChannel ?~ i
& soundStatus .~ Playing
repetitions :: Sound -> Mix.Times
@@ -100,14 +97,13 @@ tryGetChannel s = case _soundChannel s of
decrementTimer :: Sound -> IO Sound
decrementTimer s = case _soundTime s of
Just t | t > 0 -> return $ s & soundTime .~ Just (t - 1)
| otherwise -> fadeOutMaybe (_soundChannel s) (_soundFadeTime s)
Just t
| t > 0 -> return $ s & soundTime ?~ t - 1
| otherwise -> fadeOutMaybe (_soundChannel s) (_soundFadeTime s)
>> return (s & soundTime .~ Nothing
& soundStatus .~ FadingOut)
Nothing -> return s
--applyPosition = return
applyPosition :: Sound -> IO Sound
applyPosition s = case _soundPos s of
Nothing -> return s
test/Spec.hs
+3 -3
View File
@@ -30,11 +30,11 @@ polygonStrictlyConvex ps = True
--prop_looping :: [Point2] -> [WallP] -> Bool
prop_looping = forAllShrink genTris shrinkTris $ \tris ->
(all (not . (\[a,b,c] -> isOnSeg a b c
not (any ( \[a,b,c] -> isOnSeg a b c
|| isOnSeg a c b
|| isOnSeg b c a
) ) tris)
==> (isLooping' $ foldr cutWalls' [] tris)
) tris)
==> isLooping' (foldr cutWalls' [] tris)
shrinkTris [] = []
shrinkTris (x:xs) = xs : map (x :) (shrinkTris xs)