Merge branch 'master' of ssh://git.xkjq.uk:30001/justin/loop
This commit is contained in:
Ross
+28
-26
@@ -1,31 +1,33 @@
|
||||
module Main where
|
||||
import Dodge.Data
|
||||
import Dodge.Default
|
||||
import Dodge.Event
|
||||
import Dodge.Floor
|
||||
import Dodge.Initialisation
|
||||
import Dodge.Layout
|
||||
import Dodge.LoadConfig
|
||||
import Dodge.LoadSound
|
||||
import Dodge.Menu
|
||||
import Dodge.Render
|
||||
import Dodge.Rooms
|
||||
import Dodge.Update
|
||||
import LoadConfig
|
||||
import Loop
|
||||
import Picture
|
||||
import Picture.Preload
|
||||
import Picture.Render
|
||||
import Preload
|
||||
import Shader
|
||||
import Sound
|
||||
import Sound.Preload
|
||||
import Loop
|
||||
import Shader
|
||||
import LoadConfig
|
||||
import Dodge.Default
|
||||
import Dodge.Data
|
||||
import Dodge.Initialisation
|
||||
import Dodge.Rooms
|
||||
import Dodge.Layout
|
||||
import Dodge.Update
|
||||
import Dodge.Event
|
||||
import Dodge.Render
|
||||
import Dodge.Menu
|
||||
import Dodge.Floor
|
||||
import Dodge.LoadConfig
|
||||
import Dodge.LoadSound
|
||||
import Picture
|
||||
import Picture.Render
|
||||
import Picture.Preload
|
||||
import Sound
|
||||
import Preload
|
||||
import Sound.Preload
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Lens
|
||||
import Foreign (Word32)
|
||||
|
||||
import Control.Monad (void, when)
|
||||
import Control.Monad (when,void)
|
||||
|
||||
import System.Random
|
||||
|
||||
import System.Random
|
||||
|
||||
@@ -53,9 +55,9 @@ main = do
|
||||
(fmap (setWindowSize sizex sizey keyConfig) firstWorld)
|
||||
( \preData w -> do
|
||||
startTicks <- SDL.ticks
|
||||
doDrawing (_renderData preData) w
|
||||
playSoundQueue (_soundData preData) (_soundQueue w)
|
||||
newSoundData <- playAndUpdate (_sounds w) (_soundData preData)
|
||||
void $ doDrawing (_renderData preData) w
|
||||
playSoundQueue (_loadedChunks $ _soundData preData) (_soundQueue w)
|
||||
newPlayingSounds <- playAndUpdate (_soundData preData) (_sounds w)
|
||||
|
||||
endTicks <- SDL.ticks
|
||||
let lastFrameTicks = _frameTimer preData
|
||||
@@ -67,7 +69,7 @@ main = do
|
||||
)
|
||||
|
||||
|
||||
return $ preData & soundData .~ newSoundData
|
||||
return $ preData & soundData . playingSounds .~ newPlayingSounds
|
||||
& frameTimer .~ endTicks
|
||||
)
|
||||
(flip $ menuEvents handleEvent)
|
||||
|
||||
+4
-2
@@ -5,13 +5,15 @@ import Dodge.RandomHelp
|
||||
import Geometry
|
||||
|
||||
import System.Random
|
||||
import Control.Monad (replicateM)
|
||||
import Data.Functor ((<&>))
|
||||
import Control.Monad.State
|
||||
import Data.List (zip4)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
[ps1, ps2, ps3, ps4] <- mapM randomPoints [500,500,500,500]
|
||||
fs <- sequence $ replicate 500 (randomRIO (1,20))
|
||||
fs <- replicateM 500 (randomRIO (1,20))
|
||||
defaultMain
|
||||
[ bgroup "circLine tests"
|
||||
[ bench "circLine" $ nf (map $ uncurry4 circOnLine) (zip4 ps1 ps2 ps3 fs)
|
||||
@@ -22,4 +24,4 @@ main = do
|
||||
uncurry4 f (a,b,c,d) = f a b c d
|
||||
|
||||
randomPoints :: Int -> IO [Point2]
|
||||
randomPoints i = getStdGen >>= return . evalState (sequence $ replicate i $ randInCirc 500)
|
||||
randomPoints i = getStdGen <&> evalState (replicateM i $ randInCirc 500)
|
||||
|
||||
+123
-65
@@ -583,8 +583,9 @@ collidePointWallsNorm p1 p2 ws = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe
|
||||
) ws
|
||||
where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
|
||||
|
||||
-- looks for first collision of a point with walls
|
||||
-- if found, gives point and colour of wall
|
||||
{- | Looks for first collision of a point with walls.
|
||||
If found, gives point and colour of wall.
|
||||
-}
|
||||
collidePointWallsCol :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Color)
|
||||
collidePointWallsCol p1 p2 ws = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe
|
||||
( (\(m, c) -> fmap (flip (,) c) m)
|
||||
@@ -592,8 +593,9 @@ collidePointWallsCol p1 p2 ws = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe
|
||||
(_wlLine w !! 0) (_wlLine w !! 1), _wlColor w))
|
||||
) ws
|
||||
where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
|
||||
-- looks for first collision of a point with walls
|
||||
-- if found, gives point, and normal and colour of wall
|
||||
{- | Looks for first collision of a point with walls.
|
||||
If found, gives point, and normal and colour of wall.
|
||||
-}
|
||||
collidePointWallsNormCol :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2,Color)
|
||||
collidePointWallsNormCol p1 p2 ws
|
||||
= listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe m ws
|
||||
@@ -603,7 +605,7 @@ collidePointWallsNormCol p1 p2 ws
|
||||
m w = let (a1,a2,a3) = ls w
|
||||
in fmap (\a4 -> (a4,a2,a3)) a1
|
||||
|
||||
--returns the first creature, if any, that a point intersects with
|
||||
-- | Returns the first creature, if any, that a point intersects with.
|
||||
collidePointCreatures :: Point2 -> Point2 -> World -> Maybe Int
|
||||
collidePointCreatures p1 p2 w = fmap fst $ listToMaybe $ sortBy (csnd) $ IM.toList $
|
||||
IM.mapMaybe (\x ->
|
||||
@@ -611,8 +613,8 @@ collidePointCreatures p1 p2 w = fmap fst $ listToMaybe $ sortBy (csnd) $ IM.toLi
|
||||
)
|
||||
(_creatures w)
|
||||
where csnd (_,a) (_,b) = compare a b
|
||||
--as for collidePointCreatures, only increases the radius of creatures by a
|
||||
--fixed amount, thus collides a moving circle with creaures
|
||||
-- | As for 'collidePointCreatures', only increases the radius of creatures by a
|
||||
--fixed amount, thus collides a moving circle with creaures.
|
||||
collideCircCreatures :: Point2 -> Point2 -> Float -> World -> Maybe Int
|
||||
collideCircCreatures p1 p2 rad w = fmap fst $ listToMaybe $ sortBy (csnd) $ IM.toList $
|
||||
IM.mapMaybe (\x ->
|
||||
@@ -622,35 +624,46 @@ collideCircCreatures p1 p2 rad w = fmap fst $ listToMaybe $ sortBy (csnd) $ IM.t
|
||||
where csnd (_,a) (_,b) = compare a b
|
||||
|
||||
|
||||
--returns the first creature, if any, that a point intersects with, gives point
|
||||
--in creature on line
|
||||
-- | Returns the first creature, if any, that a point intersects with, gives point
|
||||
--in creature on line.
|
||||
collidePointCrsPoint :: Point2 -> Point2 -> World -> Maybe (Point2,Int)
|
||||
collidePointCrsPoint p1 p2 w = fmap f $ listToMaybe $ sortBy (csndsnd) $ IM.toList $
|
||||
IM.mapMaybe (\x ->
|
||||
collidePointCirc'' p1 p2 (_crRad x) (_crPos x)
|
||||
)
|
||||
(_creatures w)
|
||||
where csndsnd (_,(_,a)) (_,(_,b)) = compare a b
|
||||
f (cID,(p,_)) = (p,cID)
|
||||
where
|
||||
csndsnd (_,(_,a)) (_,(_,b)) = compare a b
|
||||
f (cID,(p,_)) = (p,cID)
|
||||
collideCircCrsPoint :: Point2 -> Point2 -> Float -> World -> Maybe (Point2,Int)
|
||||
collideCircCrsPoint p1 p2 rad w = fmap f $ listToMaybe $ sortBy (csndsnd) $ IM.toList $
|
||||
IM.mapMaybe (\x ->
|
||||
collidePointCirc'' p1 p2 (rad + _crRad x) (_crPos x)
|
||||
)
|
||||
(_creatures w)
|
||||
where csndsnd (_,(_,a)) (_,(_,b)) = compare a b
|
||||
f (cID,(p,_)) = (p,cID)
|
||||
collideCircCrsPoint p1 p2 rad w
|
||||
= fmap f
|
||||
. listToMaybe
|
||||
. sortBy (csndsnd)
|
||||
. IM.toList
|
||||
$ IM.mapMaybe (\x ->
|
||||
collidePointCirc'' p1 p2 (rad + _crRad x) (_crPos x)
|
||||
)
|
||||
(_creatures w)
|
||||
where
|
||||
csndsnd (_,(_,a)) (_,(_,b)) = compare a b
|
||||
f (cID,(p,_)) = (p,cID)
|
||||
|
||||
|
||||
-- makes a creatures not hittable
|
||||
-- | Makes a creature not hittable.
|
||||
collidePointCrsWithoutPoint :: Int -> Point2 -> Point2 -> World -> Maybe (Point2,Int)
|
||||
collidePointCrsWithoutPoint cid p1 p2 w = fmap f $ listToMaybe $ sortBy (csndsnd) $ IM.toList $
|
||||
IM.mapMaybe (\x ->
|
||||
collidePointCirc'' p1 p2 (_crRad x) (_crPos x)
|
||||
)
|
||||
(IM.delete cid $ _creatures w)
|
||||
where csndsnd (_,(_,a)) (_,(_,b)) = compare a b
|
||||
f (cID,(p,_)) = (p,cID)
|
||||
collidePointCrsWithoutPoint cid p1 p2 w
|
||||
= fmap f
|
||||
. listToMaybe
|
||||
. sortBy (csndsnd)
|
||||
. IM.toList
|
||||
$ IM.mapMaybe (\x ->
|
||||
collidePointCirc'' p1 p2 (_crRad x) (_crPos x)
|
||||
)
|
||||
(IM.delete cid $ _creatures w)
|
||||
where
|
||||
csndsnd (_,(_,a)) (_,(_,b)) = compare a b
|
||||
f (cID,(p,_)) = (p,cID)
|
||||
|
||||
circOnSomeWall :: Point2 -> Float -> World -> Bool
|
||||
circOnSomeWall p rad w = any (\(x:y:_) -> circOnSeg x y p rad)
|
||||
@@ -664,55 +677,85 @@ crsNearPoint :: Float -> Point2 -> World -> Bool
|
||||
crsNearPoint d p w = any (\c -> dist (_crPos c) p < (d + _crRad c)) (_creatures w)
|
||||
|
||||
crsOnLine :: Point2 -> Point2 -> World -> [Creature]
|
||||
crsOnLine p1 p2 w = IM.elems
|
||||
$ IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr))
|
||||
$ _creatures w
|
||||
crsOnLine p1 p2 w
|
||||
= IM.elems
|
||||
. IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr))
|
||||
$ _creatures w
|
||||
|
||||
crsOnThickLine :: Float -> Point2 -> Point2 -> World -> [Creature]
|
||||
crsOnThickLine thickness p1 p2 w = IM.elems
|
||||
$ IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr + thickness))
|
||||
$ _creatures w
|
||||
crsOnThickLine thickness p1 p2 w
|
||||
= IM.elems
|
||||
. IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr + thickness))
|
||||
$ _creatures w
|
||||
|
||||
{- | Find 'Maybe' the closest creature to a point, within a circle.
|
||||
-}
|
||||
nearestCrInRad :: Point2 -> Float -> World -> Maybe Creature
|
||||
nearestCrInRad p r w = let crs = IM.filter (\cr -> dist p (_crPos cr) < r) $ _creatures w
|
||||
sortedCrs = sortBy (compare `on` (dist p . _crPos)) $ IM.elems crs
|
||||
in listToMaybe sortedCrs
|
||||
nearestCrInRad p r w
|
||||
= let crs = IM.filter (\cr -> dist p (_crPos cr) < r) $ _creatures w
|
||||
sortedCrs = sortBy (compare `on` (dist p . _crPos)) $ IM.elems crs
|
||||
in listToMaybe sortedCrs
|
||||
|
||||
nearestCrInTri :: Point2 -> Float -> Float -> World -> Maybe Creature
|
||||
{- | Find 'Maybe' the closest creature in front of a point in a right-angle-triangle shape.
|
||||
-}
|
||||
nearestCrInTri
|
||||
:: Point2
|
||||
-> Float -- ^ Direction (radians +ve anticlockwise from x-axis).
|
||||
-> Float -- ^ Distance.
|
||||
-> World -> Maybe Creature
|
||||
nearestCrInTri p dir x w
|
||||
= let crs = IM.filter (\cr -> errorPointInPolygon 1 (_crPos cr) tri) $ _creatures w
|
||||
sortedCrs = sortBy (compare `on` (dist p . _crPos)) $ IM.elems crs
|
||||
in listToMaybe sortedCrs
|
||||
where tri = [p
|
||||
,p +.+ rotateV (dir-pi/4) (x,0)
|
||||
,p +.+ rotateV (dir+pi/4) (x,0)
|
||||
]
|
||||
|
||||
nearestCrInFront :: Point2 -> Float -> Float -> World -> Maybe Creature
|
||||
where
|
||||
tri = [p
|
||||
,p +.+ rotateV (dir-pi/4) (x,0)
|
||||
,p +.+ rotateV (dir+pi/4) (x,0)
|
||||
]
|
||||
{- | Find 'Maybe' the closes creature in front of a point in a given direction for
|
||||
a given distance.
|
||||
The shapes within which creatures are searched are a triangle then rectangle.
|
||||
-}
|
||||
nearestCrInFront
|
||||
:: Point2
|
||||
-> Float -- ^ Direction (radians +ve anticlockwise from x-axis).
|
||||
-> Float -- ^ Distance.
|
||||
-> World -> Maybe Creature
|
||||
nearestCrInFront p dir x w
|
||||
= let crs = IM.filter (\cr -> errorPointInPolygon 2 (_crPos cr) rec) $ _creatures w
|
||||
sortedCrs = sortBy (compare `on` (dist p . _crPos)) $ IM.elems crs
|
||||
in listToMaybe sortedCrs
|
||||
where rec = [p
|
||||
,pR
|
||||
,pR1
|
||||
,pL1
|
||||
,pL
|
||||
]
|
||||
pR = p +.+ rotateV (dir - pi*(3/8)) (x/2,0)
|
||||
pL = p +.+ rotateV (dir + pi*(3/8)) (x/2,0)
|
||||
pR1 = pR +.+ rotateV dir (x/2,0)
|
||||
pL1 = pL +.+ rotateV dir (x/2,0)
|
||||
where
|
||||
rec = [p
|
||||
,pR
|
||||
,pR1
|
||||
,pL1
|
||||
,pL
|
||||
]
|
||||
pR = p +.+ rotateV (dir - pi*(3/8)) (x/2,0)
|
||||
pL = p +.+ rotateV (dir + pi*(3/8)) (x/2,0)
|
||||
pR1 = pR +.+ rotateV dir (x/2,0)
|
||||
pL1 = pL +.+ rotateV dir (x/2,0)
|
||||
|
||||
{- | Test whether a creature is in a polygon.
|
||||
-}
|
||||
crInPolygon :: Creature -> [Point2] -> Bool
|
||||
crInPolygon cr xs = errorPointInPolygon 3 (_crPos cr) xs
|
||||
|
||||
{- | Uses a layer to set the depth.
|
||||
-}
|
||||
onLayer :: Layer -> Picture -> Picture
|
||||
onLayer l = setDepth $ 1 - fromIntegral (levLayer l) / 100
|
||||
|
||||
{- | Set a depth according to a list of numbers.
|
||||
Lists are lexicographically ordered if input values are always less than 100.
|
||||
Higher numbers will get placed on top of lower numbers.
|
||||
-}
|
||||
onLayerL :: [Int] -> Picture -> Picture
|
||||
onLayerL is = setDepth (1 - (sum $ zipWith (/) (map fromIntegral is) $ map (\x->100**x) [1..]))
|
||||
onLayerL is = setDepth (1 - (sum $ zipWith (/) (map fromIntegral is) $ map (100 **) [1..]))
|
||||
|
||||
{- | For depth testing, set layer values.
|
||||
-}
|
||||
levLayer :: Layer -> Int
|
||||
levLayer BgLayer = 20
|
||||
levLayer PressPlateLayer = 45
|
||||
@@ -729,6 +772,8 @@ levLayer LabelLayer = 80
|
||||
levLayer InvLayer = 85
|
||||
levLayer MenuLayer = 90
|
||||
|
||||
{- | Transform coordinates from world position to normalised screen coordinates.
|
||||
-}
|
||||
worldPosToScreen :: World -> Point2 -> Point2
|
||||
worldPosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
|
||||
where
|
||||
@@ -739,6 +784,9 @@ worldPosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
|
||||
, y * 2 / _windowY w
|
||||
)
|
||||
|
||||
{- | Transform coordinates from the map position to normalised screen
|
||||
coordinates.
|
||||
-}
|
||||
cartePosToScreen :: World -> Point2 -> Point2
|
||||
cartePosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
|
||||
where
|
||||
@@ -749,32 +797,42 @@ cartePosToScreen w = doWindowScale . doRotate . doZoom . doTranslate
|
||||
, y * 2 / _windowY w
|
||||
)
|
||||
|
||||
{- | The mouse position in world coordinates.
|
||||
-}
|
||||
mouseWorldPos :: World -> Point2
|
||||
mouseWorldPos w = _cameraCenter w +.+ (1/_cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w)
|
||||
|
||||
{- | The mouse position in map coordinates
|
||||
-}
|
||||
mouseCartePos :: World -> Point2
|
||||
mouseCartePos w = _carteCenter w +.+ (1/_carteZoom w) *.* rotateV (_carteRot w) (_mousePos w)
|
||||
|
||||
{- | Create a logistic function given three parameters.
|
||||
-}
|
||||
logistic :: Float -> Float -> Float -> (Float -> Float)
|
||||
logistic x0 l k x = l / (1 + exp (k*(x0 - x)))
|
||||
|
||||
wallLOS :: [Point2] -> Point2 -> Point2 -> Bool
|
||||
{-# INLINE wallLOS #-}
|
||||
wallLOS !(x:y:_) !c !p = isRHS c x y || isLHS p x' y' || isLHS c p x || isRHS c p y
|
||||
where n = 10 *.* (normV . vNormal $ y -.- x)
|
||||
x' = x +.+ n
|
||||
y' = y +.+ n
|
||||
|
||||
wallsLOS :: Foldable t => t [Point2] -> Point2 -> Point2 -> Bool
|
||||
{-# INLINE wallsLOS #-}
|
||||
wallsLOS !ls !c !p = all (\l -> wallLOS l c p) ls
|
||||
|
||||
mvPointTowardAtSpeed :: Float -> Point2 -> Point2 -> Point2
|
||||
{- | given a target and a start point, shift toward the end point by a given
|
||||
amount.
|
||||
If close enough, end up on the end point
|
||||
-}
|
||||
mvPointTowardAtSpeed
|
||||
:: Float -- ^ Speed.
|
||||
-> Point2 -- ^ End point.
|
||||
-> Point2 -- ^ Start point.
|
||||
-> Point2
|
||||
mvPointTowardAtSpeed speed !ep !p
|
||||
| dist p ep < speed = ep
|
||||
| otherwise = p +.+ speed *.* normalizeV (ep -.- p)
|
||||
|
||||
mvPointToward :: Point2 -> Point2 -> Point2
|
||||
{- | given a target and a start point, shift toward the end point by 1.
|
||||
If close enough, end up on the end point
|
||||
-}
|
||||
mvPointToward
|
||||
:: Point2 -- ^ End point.
|
||||
-> Point2 -- ^ Start point.
|
||||
-> Point2
|
||||
mvPointToward !ep !p | dist p ep < 1 = ep
|
||||
| otherwise = p +.+ normalizeV (ep -.- p)
|
||||
|
||||
|
||||
@@ -14,6 +14,7 @@ import Dodge.Item.Consumable
|
||||
import Dodge.WorldEvent.Cloud
|
||||
import Dodge.Creature.YourControl
|
||||
import Dodge.Creature.Inanimate
|
||||
import Dodge.Item
|
||||
|
||||
import Picture
|
||||
import Geometry
|
||||
@@ -255,13 +256,9 @@ startCr = defaultCreature
|
||||
[pistol
|
||||
,blinkGun
|
||||
,spawnGun lamp
|
||||
,flameGrenade
|
||||
,teslaGrenade
|
||||
,poisonSprayer
|
||||
,autoGun
|
||||
,launcher
|
||||
,flameLauncher
|
||||
,poisonLauncher
|
||||
,teslaLauncher
|
||||
,lasGun
|
||||
,grenade
|
||||
,ltAutoGun,flamer,multGun,spreadGun,remoteLauncher
|
||||
@@ -272,7 +269,6 @@ startCr = defaultCreature
|
||||
,miniGun
|
||||
,medkit 50
|
||||
,bezierGun
|
||||
,poisonSprayer
|
||||
]
|
||||
++ repeat NoItem))
|
||||
, _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ pictures [color (greyN 0.8) $ circleSolid 10, circLine 10]
|
||||
|
||||
@@ -7,7 +7,7 @@ module Dodge.CreatureAction
|
||||
where
|
||||
-- imports {{{
|
||||
import Dodge.CreatureAction.UseItem
|
||||
|
||||
import Dodge.WorldEvent.Shockwave
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Dodge.SoundLogic
|
||||
@@ -223,7 +223,7 @@ createItemAt p it w = over floorItems (IM.insert i (set flItPos p
|
||||
|
||||
blinkAction :: Int -> World -> World
|
||||
blinkAction n w = soundOnce teleSound $ set (creatures . ix n . crPos) p3
|
||||
$ blinkShockwave p3
|
||||
$ blinkShockwave n p3
|
||||
$ inverseShockwaveAt cp 40 2 2 2
|
||||
w
|
||||
where p1 = _cameraCenter w +.+ (1 / _cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w)
|
||||
@@ -232,8 +232,12 @@ blinkAction n w = soundOnce teleSound $ set (creatures . ix n . crPos) p3
|
||||
r = 1.5 * _crRad (_creatures w IM.! n)
|
||||
p3 = fromMaybe p1 (fmap ((\p -> moveAmountToward p r cp) . fst) p2)
|
||||
|
||||
blinkShockwave :: Point2 -> World -> World
|
||||
blinkShockwave p = makeShockwaveAt p 40 1 2 cyan
|
||||
blinkShockwave
|
||||
:: Int -- ^ Blinking creature ID.
|
||||
-> Point2
|
||||
-> World
|
||||
-> World
|
||||
blinkShockwave i p = makeShockwaveAt [i] p 60 1 2 cyan
|
||||
|
||||
moveAmountToward :: Point2 -> Float -> Point2 -> Point2
|
||||
moveAmountToward p1 am p2
|
||||
|
||||
@@ -0,0 +1,53 @@
|
||||
module Dodge.Item
|
||||
where
|
||||
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Dodge.Default
|
||||
import Picture
|
||||
|
||||
keyToken :: Int -> Item
|
||||
keyToken n = defaultEquipment
|
||||
{ _itIdentity = Generic
|
||||
, _itName = "KEYTOKEN "++show n
|
||||
, _itMaxStack = 5
|
||||
, _itAmount = 1
|
||||
, _itFloorPict = setDepth 0.5 $ keyPic
|
||||
, _itEquipPict = \cr _ -> setDepth 0 $ translate (-5) (-5) $ rotate (pi/2.5) keyPic
|
||||
, _itEffect = NoItEffect
|
||||
, _itHammer = HammerUp
|
||||
, _itID = Nothing
|
||||
, _itAimingSpeed = 1
|
||||
, _itAimingRange = 0
|
||||
, _itZoom = defaultItZoom
|
||||
, _itInvColor = yellow
|
||||
, _itInvDisplay = _itName
|
||||
}
|
||||
keyPic = color green $
|
||||
pictures [translate (-4) 0 $ thickCircle 4 2
|
||||
,lineOfThickness 2 [(0,0),(8,0),(8,-4)]
|
||||
,lineOfThickness 2 [(4,0),(4,-4)]
|
||||
]
|
||||
|
||||
latchkey :: Int -> Item
|
||||
latchkey n = defaultEquipment
|
||||
{ _itIdentity = Generic
|
||||
, _itName = "KEY "++show n
|
||||
, _itMaxStack = 1
|
||||
, _itAmount = 1
|
||||
, _itFloorPict = setDepth 0.5 $ latchkeyPic
|
||||
, _itEquipPict = \cr _ -> setDepth 0 $ translate (-5) (-5) $ rotate (pi/2.5) latchkeyPic
|
||||
, _itEffect = NoItEffect
|
||||
, _itHammer = HammerUp
|
||||
, _itID = Nothing
|
||||
, _itAimingSpeed = 1
|
||||
, _itAimingRange = 0
|
||||
, _itZoom = defaultItZoom
|
||||
, _itInvColor = yellow
|
||||
, _itInvDisplay = _itName
|
||||
}
|
||||
latchkeyPic = color yellow $
|
||||
pictures [translate (-4) 0 $ thickCircle 4 2
|
||||
,lineOfThickness 2 [(0,0),(8,0),(8,-4)]
|
||||
,lineOfThickness 2 [(4,0),(4,-4)]
|
||||
]
|
||||
@@ -920,9 +920,6 @@ flamerAngle = 0.3
|
||||
aSelf :: Int -> World -> World
|
||||
aSelf = blinkAction
|
||||
|
||||
|
||||
|
||||
|
||||
reflect :: Float -> Float -> Float
|
||||
reflect a b = a + 2*(a-b)
|
||||
|
||||
@@ -1581,28 +1578,6 @@ jetPack = defaultEquipment
|
||||
, _itID = Nothing
|
||||
}
|
||||
|
||||
latchkey :: Int -> Item
|
||||
latchkey n = defaultEquipment
|
||||
{ _itIdentity = Generic
|
||||
, _itName = "KEY "++show n
|
||||
, _itMaxStack = 1
|
||||
, _itAmount = 1
|
||||
, _itFloorPict = onLayer FlItLayer $ latchkeyPic
|
||||
, _itEquipPict = \cr _ -> onLayer PtLayer $ translate (-5) (-5) $ rotate (pi/2.5) latchkeyPic
|
||||
, _itEffect = NoItEffect
|
||||
, _itHammer = HammerUp
|
||||
, _itID = Nothing
|
||||
, _itAimingSpeed = 1
|
||||
, _itAimingRange = 0
|
||||
, _itZoom = defaultItZoom
|
||||
, _itInvColor = yellow
|
||||
, _itInvDisplay = _itName
|
||||
}
|
||||
latchkeyPic = color yellow $
|
||||
pictures [translate (-4) 0 $ thickCircle 4 2
|
||||
,lineOfThickness 2 [(0,0),(8,0),(8,-4)]
|
||||
,lineOfThickness 2 [(4,0),(4,-4)]
|
||||
]
|
||||
|
||||
|
||||
-- }}}
|
||||
|
||||
@@ -5,6 +5,7 @@ import Dodge.Base
|
||||
import Dodge.WorldEvent
|
||||
import Dodge.SoundLogic
|
||||
import Dodge.RandomHelp
|
||||
import Dodge.WorldEvent.Shockwave
|
||||
|
||||
import Dodge.Creature.Property
|
||||
|
||||
@@ -129,7 +130,7 @@ bulConCr' bt p cr w
|
||||
where cid = _crID cr
|
||||
sp = head $ _btTrail' bt
|
||||
ep = sp +.+ _btVel' bt
|
||||
mkwave = over worldEvents $ (.) (makeShockwaveAt p 15 4 1 white)
|
||||
mkwave = over worldEvents $ (.) (makeShockwaveAt [] p 15 4 1 white)
|
||||
|
||||
bulHitWall' :: Particle' -> Point2 -> Wall -> World -> World
|
||||
bulHitWall' bt p x w = damageBlocks x
|
||||
@@ -195,7 +196,7 @@ bulConWall' bt p wl w = damageBlocks wl
|
||||
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 5)) w (_blIDs wall)
|
||||
_ -> w
|
||||
wallV = (_wlLine wl !! 1 -.- _wlLine wl !! 0)
|
||||
mkwave = over worldEvents $ (.) (makeShockwaveAt p 15 4 1 white)
|
||||
mkwave = over worldEvents $ (.) (makeShockwaveAt [] p 15 4 1 white)
|
||||
|
||||
hvBulHitWall' :: Particle' -> Point2 -> Wall -> World -> World
|
||||
hvBulHitWall' bt p x w = damageBlocks x
|
||||
|
||||
+23
-16
@@ -1,5 +1,7 @@
|
||||
module Dodge.SoundLogic where
|
||||
import Dodge.Data
|
||||
import Sound.Preload (SoundStatus (..))
|
||||
|
||||
import Control.Lens
|
||||
import qualified Data.Map as M
|
||||
|
||||
@@ -19,22 +21,24 @@ soundOnceOrigin :: Int -> SoundOrigin -> World -> World
|
||||
soundOnceOrigin sType so = over sounds (M.insertWith (flip const) so sound)
|
||||
where
|
||||
sound = Sound
|
||||
{ _soundType = sType
|
||||
, _soundTime = Nothing
|
||||
, _soundFadeTime = 0
|
||||
, _soundChannel = Nothing
|
||||
, _soundPos = Nothing
|
||||
{ _soundChunkID = sType
|
||||
, _soundTime = Nothing
|
||||
, _soundFadeTime = 0
|
||||
, _soundStatus = ToStart
|
||||
, _soundChannel = Nothing
|
||||
, _soundPos = Nothing
|
||||
}
|
||||
|
||||
soundFrom :: SoundOrigin -> Int -> Int -> Int -> World -> World
|
||||
soundFrom so sType time fadeTime w = over sounds (M.insertWith f so sound) w
|
||||
where
|
||||
sound = Sound
|
||||
{ _soundType = sType
|
||||
, _soundTime = Just time
|
||||
, _soundFadeTime = fadeTime
|
||||
, _soundChannel = Nothing
|
||||
, _soundPos = Nothing
|
||||
{ _soundChunkID = sType
|
||||
, _soundTime = Just time
|
||||
, _soundStatus = ToStart
|
||||
, _soundFadeTime = fadeTime
|
||||
, _soundChannel = Nothing
|
||||
, _soundPos = Nothing
|
||||
}
|
||||
f _ s = s {_soundTime = Just time, _soundFadeTime = fadeTime}
|
||||
|
||||
@@ -43,12 +47,15 @@ soundMultiFrom [] _ _ _ w = w
|
||||
soundMultiFrom (so:sos) sType time fadeTime w
|
||||
| so `M.member` _sounds w = soundMultiFrom sos sType time fadeTime w
|
||||
| otherwise = over sounds (M.insert so sound) w
|
||||
where sound = Sound { _soundType = sType
|
||||
, _soundTime = Nothing
|
||||
, _soundFadeTime = fadeTime
|
||||
, _soundChannel = Nothing
|
||||
, _soundPos = Nothing
|
||||
}
|
||||
where
|
||||
sound = Sound
|
||||
{ _soundChunkID = sType
|
||||
, _soundTime = Nothing
|
||||
, _soundStatus = ToStart
|
||||
, _soundFadeTime = fadeTime
|
||||
, _soundChannel = Nothing
|
||||
, _soundPos = Nothing
|
||||
}
|
||||
|
||||
|
||||
stopSoundFrom :: SoundOrigin -> World -> World
|
||||
|
||||
+1
-46
@@ -19,6 +19,7 @@ import Dodge.WorldEvent.Cloud
|
||||
import Dodge.WorldEvent.HitEffect
|
||||
import Dodge.WorldEvent.Explosion
|
||||
import Dodge.WorldEvent.SpawnParticle
|
||||
import Dodge.WorldEvent.Shockwave
|
||||
import Dodge.LightSources
|
||||
|
||||
import Dodge.Data
|
||||
@@ -38,52 +39,6 @@ import Data.Function
|
||||
import Data.List
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
|
||||
|
||||
shockWaveDamage :: Point2 -> Float -> Int -> World -> World
|
||||
shockWaveDamage p rad amount w = flip (foldr damageBlocks) hitBlocks $ over creatures (IM.map f) w
|
||||
where f cr | dist (_crPos cr) p < rad + _crRad cr = over (crState . crDamage)
|
||||
((:) $ Concussive amount p 2 0.5 rad) cr
|
||||
| otherwise = cr
|
||||
hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w
|
||||
damageBlocks wall w
|
||||
= case wall ^? blHP of
|
||||
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - (div amount 2)))
|
||||
w
|
||||
(_blIDs wall)
|
||||
_ -> w
|
||||
|
||||
|
||||
inverseShockwaveAt :: Point2 -> Float -> Int -> Float -> Float -> World -> World
|
||||
inverseShockwaveAt p rad dam push pushexp = over particles' ((:) theShockwave)
|
||||
where theShockwave
|
||||
= Particle'
|
||||
{ _ptDraw = const blank
|
||||
, _ptUpdate' = moveInverseShockWave 10 p rad push pushexp
|
||||
}
|
||||
moveInverseShockWave :: Int -> Point2 -> Float -> Float -> Float -> World -> Particle' -> (World, Maybe Particle')
|
||||
moveInverseShockWave 0 _ _ _ _ w _ = (w, Nothing)
|
||||
moveInverseShockWave t p r push pushexp w pt
|
||||
= (dams w, Just $ newupdate $ newpic pt )
|
||||
where newupdate = set ptUpdate' $ moveInverseShockWave (t-1) p r push pushexp
|
||||
newpic = set ptDraw (const $ onLayer PtLayer $ uncurry translate p
|
||||
$ color cyan $ thickCircle rad thickness)
|
||||
rad = r - (4/40) * r * fromIntegral (10 - t)
|
||||
thickness = (fromIntegral (10 - t))**2 * rad / 40
|
||||
dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks
|
||||
hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w
|
||||
damageBlocks wall w
|
||||
= case wall ^? blHP of
|
||||
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1))
|
||||
w
|
||||
(_blIDs wall)
|
||||
_ -> w
|
||||
damCr cr | dist (_crPos cr) p < rad + _crRad cr
|
||||
= over (crState . crDamage)
|
||||
((:) $ PushDam 1 (25 *.* safeNormalizeV (p -.- _crPos cr)))
|
||||
cr
|
||||
| otherwise = cr
|
||||
|
||||
|
||||
createBarrelSpark :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World
|
||||
createBarrelSpark time colid pos dir maycid w = over worldEvents
|
||||
((.) $ ( over particles' ((:) spark)
|
||||
|
||||
@@ -7,7 +7,7 @@ import Dodge.WorldEvent.SpawnParticle
|
||||
import Dodge.WorldEvent.Flash
|
||||
import Dodge.RandomHelp
|
||||
import Dodge.SoundLogic
|
||||
|
||||
import Dodge.WorldEvent.Shockwave
|
||||
import Geometry
|
||||
import Picture
|
||||
|
||||
@@ -57,7 +57,7 @@ makeExplosionAt :: Point2 -> World -> World
|
||||
makeExplosionAt p w = soundOnce grenadeBang
|
||||
. addFlames
|
||||
. explosionFlashAt p
|
||||
$ makeShockwaveAt p 50 10 1 white
|
||||
$ makeShockwaveAt [] p 50 10 1 white
|
||||
w
|
||||
where
|
||||
fVs = fst $ runState ((sequence . take 75 . repeat . randInCirc) 1) $ _randGen w
|
||||
@@ -74,73 +74,3 @@ makeExplosionAt p w = soundOnce grenadeBang
|
||||
pushAgainstWalls q = fromMaybe q $ fmap (\(x,y)-> x +.+ y)
|
||||
$ collidePointWalls p q $ wallsNearPoint q w
|
||||
|
||||
makeShockwaveAt :: Point2 -> Float -> Int -> Float -> Color
|
||||
-> World -> World
|
||||
makeShockwaveAt p rad dam push col = over particles' ((:) theShockwave)
|
||||
where theShockwave = shockwaveAt p rad dam push col 10
|
||||
|
||||
shockwaveAt :: Point2 -> Float -> Int -> Float -> Color -> Int -> Particle'
|
||||
shockwaveAt p rad dam push col maxtime
|
||||
= Shockwave'
|
||||
{ _ptDraw = const blank
|
||||
, _ptUpdate' = mvShockwave'
|
||||
, _btColor' = col
|
||||
, _btPos' = p
|
||||
, _btRad' = rad
|
||||
, _btDam' = dam
|
||||
, _btPush' = push
|
||||
, _btMaxTime' = maxtime
|
||||
, _btTimer' = maxtime
|
||||
}
|
||||
|
||||
mvShockwave' :: World -> Particle' -> (World, Maybe Particle')
|
||||
mvShockwave' w pt
|
||||
| _btTimer' pt <= 0 = (w, Nothing)
|
||||
| otherwise
|
||||
= (dams w , Just $ set btTimer' (t - 1) $ set ptDraw (const pic) pt)
|
||||
where
|
||||
r = _btRad' pt
|
||||
p = _btPos' pt
|
||||
push = _btPush' pt
|
||||
dam = _btDam' pt
|
||||
t = _btTimer' pt
|
||||
tFraction = fromIntegral t / fromIntegral (_btMaxTime' pt)
|
||||
pic = onLayer PtLayer $ uncurry translate p
|
||||
$ color (_btColor' pt) $ thickCircle rad thickness
|
||||
rad = r - (3/4) * r * tFraction
|
||||
thickness = tFraction**2 * r
|
||||
dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks
|
||||
hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w
|
||||
damageBlocks wall w
|
||||
= case wall ^? blHP of
|
||||
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1))
|
||||
w
|
||||
(_blIDs wall)
|
||||
_ -> w
|
||||
damCr cr | dist (_crPos cr) p < rad + _crRad cr
|
||||
= over (crState . crDamage)
|
||||
((:) $ PushDam dam (25 * push *.* safeNormalizeV (_crPos cr -.- p)))
|
||||
cr
|
||||
| otherwise = cr
|
||||
moveShockWave :: Int -> Point2 -> Float -> Float -> Float -> World -> Particle' -> (World, Maybe Particle')
|
||||
moveShockWave 0 _ _ _ _ w _ = (w, Nothing)
|
||||
moveShockWave t p r push pushexp w pt
|
||||
= (dams w, Just $ newupdate $ newpic pt )
|
||||
where newupdate = set ptUpdate' $ moveShockWave (t-1) p r push pushexp
|
||||
newpic = set ptDraw (const $ onLayer PtLayer $ uncurry translate p
|
||||
$ color cyan $ thickCircle rad thickness)
|
||||
rad = r - (3/40) * r * fromIntegral t
|
||||
thickness = (fromIntegral t)**2 * rad / 40
|
||||
dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks
|
||||
hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w
|
||||
damageBlocks wall w
|
||||
= case wall ^? blHP of
|
||||
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1))
|
||||
w
|
||||
(_blIDs wall)
|
||||
_ -> w
|
||||
damCr cr | dist (_crPos cr) p < rad + _crRad cr
|
||||
= over (crState . crDamage)
|
||||
((:) $ PushDam 1 (25 *.* safeNormalizeV (_crPos cr -.- p)))
|
||||
cr
|
||||
| otherwise = cr
|
||||
|
||||
@@ -0,0 +1,114 @@
|
||||
module Dodge.WorldEvent.Shockwave
|
||||
( makeShockwaveAt
|
||||
, inverseShockwaveAt
|
||||
)
|
||||
where
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Geometry
|
||||
import Picture
|
||||
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import Control.Lens
|
||||
|
||||
makeShockwaveAt
|
||||
:: [Int] -- ^ IDs of invulnerable creatures.
|
||||
-> Point2 -- ^ Center of shockwave.
|
||||
-> Float -- ^ Maximal radius.
|
||||
-> Int -- ^ Damage caused per frame.
|
||||
-> Float -- ^ Amount of pushback per frame.
|
||||
-> Color -- ^ Color of shockwave.
|
||||
-> World -- ^ Start world.
|
||||
-> World
|
||||
makeShockwaveAt is p rad dam push col = over particles' ((:) theShockwave)
|
||||
where theShockwave = shockwaveAt is p rad dam push col 10
|
||||
|
||||
shockwaveAt
|
||||
:: [Int] -- ^ IDs of invulnerable creatures.
|
||||
-> Point2 -> Float -> Int -> Float -> Color -> Int -> Particle'
|
||||
shockwaveAt is p rad dam push col maxtime
|
||||
= Shockwave'
|
||||
{ _ptDraw = drawShockwave
|
||||
, _ptUpdate' = mvShockwave' is
|
||||
, _btColor' = col
|
||||
, _btPos' = p
|
||||
, _btRad' = rad
|
||||
, _btDam' = dam
|
||||
, _btPush' = push
|
||||
, _btMaxTime' = maxtime
|
||||
, _btTimer' = maxtime
|
||||
}
|
||||
|
||||
drawShockwave :: Particle' -> Picture
|
||||
drawShockwave pt = pic
|
||||
where
|
||||
pic = onLayer PtLayer $ uncurry translate p
|
||||
$ color (_btColor' pt) $ thickCircle rad thickness
|
||||
p = _btPos' pt
|
||||
r = _btRad' pt
|
||||
thickness = tFraction**2 * r
|
||||
rad = r - (3/4) * r * tFraction
|
||||
tFraction = fromIntegral t / fromIntegral (_btMaxTime' pt)
|
||||
t = _btTimer' pt
|
||||
|
||||
mvShockwave'
|
||||
:: [Int] -- ^ IDs of invulnerable creatures.
|
||||
-> World -> Particle' -> (World, Maybe Particle')
|
||||
mvShockwave' is w pt
|
||||
| _btTimer' pt <= 0 = (w, Nothing)
|
||||
| otherwise
|
||||
= (dams w , Just $ set btTimer' (t - 1) pt) -- $ set ptDraw (const pic) pt)
|
||||
where
|
||||
r = _btRad' pt
|
||||
p = _btPos' pt
|
||||
push = _btPush' pt
|
||||
dam = _btDam' 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
|
||||
hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w
|
||||
damageBlocks wall w
|
||||
= case wall ^? blHP of
|
||||
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1))
|
||||
w
|
||||
(_blIDs wall)
|
||||
_ -> w
|
||||
damCr cr | _crID cr `elem` is = cr
|
||||
| dist (_crPos cr) p < rad + _crRad cr
|
||||
= over (crState . crDamage)
|
||||
((:) $ PushDam dam (25 * push *.* safeNormalizeV (_crPos cr -.- p)))
|
||||
cr
|
||||
| otherwise = cr
|
||||
|
||||
-------------------------------------------------
|
||||
|
||||
inverseShockwaveAt :: Point2 -> Float -> Int -> Float -> Float -> World -> World
|
||||
inverseShockwaveAt p rad dam push pushexp = over particles' ((:) theShockwave)
|
||||
where theShockwave
|
||||
= Particle'
|
||||
{ _ptDraw = const blank
|
||||
, _ptUpdate' = moveInverseShockWave 10 p rad push pushexp
|
||||
}
|
||||
moveInverseShockWave :: Int -> Point2 -> Float -> Float -> Float -> World -> Particle' -> (World, Maybe Particle')
|
||||
moveInverseShockWave 0 _ _ _ _ w _ = (w, Nothing)
|
||||
moveInverseShockWave t p r push pushexp w pt
|
||||
= (dams w, Just $ newupdate $ newpic pt )
|
||||
where newupdate = set ptUpdate' $ moveInverseShockWave (t-1) p r push pushexp
|
||||
newpic = set ptDraw (const $ onLayer PtLayer $ uncurry translate p
|
||||
$ color cyan $ thickCircle rad thickness)
|
||||
rad = r - (4/40) * r * fromIntegral (10 - t)
|
||||
thickness = (fromIntegral (10 - t))**2 * rad / 40
|
||||
dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks
|
||||
hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w
|
||||
damageBlocks wall w
|
||||
= case wall ^? blHP of
|
||||
Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1))
|
||||
w
|
||||
(_blIDs wall)
|
||||
_ -> w
|
||||
damCr cr | dist (_crPos cr) p < rad + _crRad cr
|
||||
= over (crState . crDamage)
|
||||
((:) $ PushDam 1 (25 *.* safeNormalizeV (p -.- _crPos cr)))
|
||||
cr
|
||||
| otherwise = cr
|
||||
+9
-15
@@ -90,13 +90,13 @@ errorPointInPolygon !i !p xs
|
||||
|
||||
-- | Debug version of 'normalizeV'.
|
||||
errorNormalizeV :: Int -> Point2 -> Point2
|
||||
errorNormalizeV !i !(0,0) = error $ "problem with function: errorNormalizeV "++show i
|
||||
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 (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'.
|
||||
@@ -117,12 +117,6 @@ errorClosestPointOnLineParam !i !x! y! z
|
||||
| x == y = dist x z
|
||||
| otherwise = closestPointOnLineParam x y z
|
||||
|
||||
-- | Normalize a vector to be unit length.
|
||||
-- For (0,0) return (0,0).
|
||||
safeNormalizeV :: Point2 -> Point2
|
||||
safeNormalizeV !(0,0) = (0,0)
|
||||
safeNormalizeV !p = normalizeV p
|
||||
|
||||
-- | Test whether a point is on the LHS of a line.
|
||||
-- Returns False if the line is of zero length.
|
||||
isLHS
|
||||
@@ -132,9 +126,9 @@ isLHS
|
||||
-> Bool
|
||||
{-# INLINE isLHS #-}
|
||||
isLHS
|
||||
!(x,y)
|
||||
!(x',y')
|
||||
!(x'',y'')
|
||||
(x,y)
|
||||
(x',y')
|
||||
(x'',y'')
|
||||
| (x,y) == (x',y') = False
|
||||
| otherwise = a1 * b2 - a2 * b1 > 0
|
||||
where
|
||||
@@ -152,9 +146,9 @@ isRHS
|
||||
-> Bool
|
||||
{-# INLINE isRHS #-}
|
||||
isRHS
|
||||
!(x,y)
|
||||
!(x',y')
|
||||
!(x'',y'')
|
||||
(x,y)
|
||||
(x',y')
|
||||
(x'',y'')
|
||||
| (x,y) == (x',y') = False
|
||||
| otherwise = a1 * b2 - a2 * b1 < 0
|
||||
where
|
||||
|
||||
@@ -3,8 +3,15 @@ module Geometry.Bezier
|
||||
import Geometry.Data
|
||||
import Geometry.Vector
|
||||
|
||||
{- | A synonym describing a quadratic Bezier curve as three 'Point2's: start,
|
||||
control and end.
|
||||
-}
|
||||
type BQuad = (Point2,Point2,Point2)
|
||||
|
||||
{- | Split a quadratic Bezier curve into two at a fractional point along the
|
||||
curve.
|
||||
If the fraction is not between 0 and 1, this will create backwards curves.
|
||||
-}
|
||||
splitBezierquad :: BQuad -> Float -> (BQuad,BQuad)
|
||||
splitBezierquad (a,b,c) z
|
||||
= ( ( a
|
||||
@@ -17,11 +24,16 @@ splitBezierquad (a,b,c) z
|
||||
)
|
||||
)
|
||||
|
||||
{- | Split a quadratic Bezier curve into a given number of straight lines, and
|
||||
return the list of points defining these lines.
|
||||
-}
|
||||
bQuadToLine :: BQuad -> Int -> [Point2]
|
||||
bQuadToLine (a,_,c) 0 = [a,c]
|
||||
bQuadToLine x i = let (l,r) = splitBezierquad x 0.5
|
||||
in bQuadToLine l (i-1) ++ bQuadToLine r (i-1)
|
||||
|
||||
{- | Transform a quadratic Bezier curve into a function.
|
||||
-}
|
||||
bQuadToF :: (Point2,Point2,Point2) -> Float -> Point2
|
||||
bQuadToF (c,b,a) t = t *.* (t *.* a +.+ (1-t) *.* b) +.+
|
||||
(1-t) *.* (t *.* b +.+ (1-t) *.* c)
|
||||
|
||||
@@ -4,7 +4,6 @@ module Geometry.Data
|
||||
, Point4 (..)
|
||||
)
|
||||
where
|
||||
|
||||
type Point2 = (Float,Float)
|
||||
type Point3 = (Float,Float,Float)
|
||||
type Point4 = (Float,Float,Float,Float)
|
||||
|
||||
@@ -1,12 +1,9 @@
|
||||
module Geometry.Intersect
|
||||
where
|
||||
import Geometry.Data
|
||||
|
||||
import Control.Applicative
|
||||
|
||||
intersectSegBezquad :: Point2 -> Point2 -> Point2 -> Point2 -> Point2 -> [Point2]
|
||||
intersectSegBezquad = undefined
|
||||
|
||||
-- | If two lines intersect, return 'Just' that point.
|
||||
intersectLineLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
|
||||
{-# INLINE intersectLineLine' #-}
|
||||
intersectLineLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
|
||||
@@ -16,6 +13,7 @@ intersectLineLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
|
||||
den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
|
||||
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
|
||||
|
||||
-- | If two segments intersect, return 'Just' that point.
|
||||
intersectSegSeg' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
|
||||
{-# INLINE intersectSegSeg' #-}
|
||||
intersectSegSeg' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
|
||||
@@ -30,6 +28,8 @@ intersectSegSeg' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
|
||||
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
|
||||
u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
|
||||
|
||||
-- | Intended to intersect a segment with a half-line-segment, ie a segment
|
||||
-- extending infinitely in one direction.
|
||||
intersectSegLineFrom' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
|
||||
{-# INLINE intersectSegLineFrom' #-}
|
||||
intersectSegLineFrom' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
|
||||
@@ -44,7 +44,7 @@ intersectSegLineFrom' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
|
||||
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
|
||||
u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
|
||||
|
||||
-- this is probably not correct...
|
||||
-- | Similar to 'intersectSegLineFrom'', but this version is probably not correct...
|
||||
intersectSegLineext :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
|
||||
{-# INLINE intersectSegLineext #-}
|
||||
intersectSegLineext (x1,y1) (x2,y2) (x3,y3) (x4,y4)
|
||||
@@ -59,6 +59,7 @@ intersectSegLineext (x1,y1) (x2,y2) (x3,y3) (x4,y4)
|
||||
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
|
||||
u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
|
||||
|
||||
-- | Intersect a segment with a line.
|
||||
intersectSegLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
|
||||
{-# INLINE intersectSegLine' #-}
|
||||
intersectSegLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
|
||||
@@ -73,9 +74,13 @@ intersectSegLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
|
||||
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
|
||||
u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
|
||||
|
||||
-- intersectSegSeg is sometimes broken-- the following fixes at least some of
|
||||
-- the cases
|
||||
-- it is, however, slow
|
||||
-- | Due to floating point issues, 'intersectSegSeg'' is not always
|
||||
-- accurate---'myIntersectSegSeg'
|
||||
-- fixes at least some of
|
||||
-- the problem cases by transforming the points into rationals and then doing the
|
||||
-- intersection.
|
||||
-- This version is, probably, slower---both testing and benchmarking should be
|
||||
-- done.
|
||||
myIntersectSegSeg a@(ax,ay) b@(bx,by) c@(cx,cy) d@(dx,dy) = case ratIntersectLineLine a b c d of
|
||||
Nothing -> Nothing
|
||||
Just (x,y) -> if inbetween x && inbetween' y
|
||||
@@ -86,6 +91,7 @@ myIntersectSegSeg a@(ax,ay) b@(bx,by) c@(cx,cy) d@(dx,dy) = case ratIntersectLin
|
||||
inbetween' y = ((ay <= y && y <= by) || (by <= y && y <= ay)) &&
|
||||
((cy <= y && y <= dy) || (dy <= y && y <= cy))
|
||||
|
||||
-- | Polymorphic intersection of fractional line points.
|
||||
myIntersectLineLine :: (Eq a,Fractional a) => (a,a) -> (a,a) -> (a,a) -> (a,a) -> Maybe (a,a)
|
||||
myIntersectLineLine a@(ax,ay) b c@(cx,cy) d
|
||||
| linGrad a b == Nothing = fmap ((,) ax) $ axisInt (c *-* (ax,0)) (d *-* (ax,0))
|
||||
@@ -102,24 +108,46 @@ myIntersectLineLine a@(ax,ay) b c@(cx,cy) d
|
||||
newx = (axisInt c d ^-^ axisInt a b) ^/^ (linGrad a b ^-^ linGrad c d)
|
||||
(*-*) (ax,ay) (bx,by) = (ax-bx,ay-by)
|
||||
|
||||
-- | Transforms floating points to rationals then performs line intersection.
|
||||
ratIntersectLineLine :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
|
||||
ratIntersectLineLine a b c d = fmap toNumPoint2 $ myIntersectLineLine (toRatPoint2 a) (toRatPoint2 b) (toRatPoint2 c) (toRatPoint2 d)
|
||||
where toRatPoint2 (x,y) = (toRational x, toRational y)
|
||||
toNumPoint2 (x,y) = (fromRational x, fromRational y)
|
||||
f = toRatPoint2 . roundPoint2
|
||||
|
||||
{- | Round the floats within a 'Point2' to the nearest integer.
|
||||
__Examples__
|
||||
Rounding jumps after intervals of .5:
|
||||
|
||||
>>> roundPoint (0.5,0.5001)
|
||||
(0.0,1.0)
|
||||
|
||||
but is symmetric around 0:
|
||||
|
||||
>>> roundPoint2 (0.5,-0.5)
|
||||
(0.0,0.0)
|
||||
|
||||
-}
|
||||
|
||||
roundPoint2 :: Point2 -> Point2
|
||||
roundPoint2 (x,y) = (fromIntegral $ round x,fromIntegral $ round y)
|
||||
|
||||
-- | Given two points, finds the linear gradient if it is non-infinite.
|
||||
linGrad :: (Eq a,Fractional a) => (a,a) -> (a,a) -> Maybe a
|
||||
linGrad (x,y) (a,b) | x-a == 0 = Nothing
|
||||
| otherwise = Just $ (y-b)/(x-a)
|
||||
|
||||
-- | Given two points, finds the intersection with the y axis if it exists.
|
||||
axisInt :: (Eq a,Fractional a) => (a,a) -> (a,a) -> Maybe a
|
||||
axisInt p (a,b) = pure b ^-^ (pure a ^*^ linGrad p (a,b))
|
||||
where (^-^) = liftA2 (-)
|
||||
(^*^) = liftA2 (*)
|
||||
|
||||
|
||||
-- | Placeholder, undefined.
|
||||
intersectSegsSeg :: [Point2] -> Point2 -> Point2 -> Maybe Point2
|
||||
intersectSegsSeg = undefined
|
||||
|
||||
-- | Placeholder: should intersect a segment with a bezier curve.
|
||||
intersectSegBezquad :: Point2 -> Point2 -> Point2 -> Point2 -> Point2 -> [Point2]
|
||||
intersectSegBezquad = undefined
|
||||
|
||||
|
||||
+48
-13
@@ -2,7 +2,8 @@
|
||||
module Geometry.Vector
|
||||
where
|
||||
import Geometry.Data
|
||||
|
||||
{- | Moves from to three dimensions, adding zero in z direction.
|
||||
-}
|
||||
zeroZ :: Point2 -> Point3
|
||||
{-# INLINE zeroZ #-}
|
||||
zeroZ (x,y) = (x,y,0)
|
||||
@@ -10,6 +11,8 @@ zeroZ (x,y) = (x,y,0)
|
||||
infixl 6 +.+, -.-
|
||||
infixl 7 *.*
|
||||
|
||||
{- | 2D coordinate-wise addition.
|
||||
-}
|
||||
(+.+) :: Point2 -> Point2 -> Point2
|
||||
{-# INLINE (+.+) #-}
|
||||
(x1, y1) +.+ (x2, y2) =
|
||||
@@ -17,7 +20,8 @@ infixl 7 *.*
|
||||
!x = x1 + x2
|
||||
!y = y1 + y2
|
||||
in (x, y)
|
||||
|
||||
{- | 2D coordinate-wise subtraction.
|
||||
-}
|
||||
(-.-) :: Point2 -> Point2 -> Point2
|
||||
{-# INLINE (-.-) #-}
|
||||
(x1, y1) -.- (x2, y2) =
|
||||
@@ -25,7 +29,8 @@ infixl 7 *.*
|
||||
!x = x1 - x2
|
||||
!y = y1 - y2
|
||||
in (x, y)
|
||||
|
||||
{- | 2D scalar multiplication.
|
||||
-}
|
||||
(*.*) :: Float -> Point2 -> Point2
|
||||
{-# INLINE (*.*) #-}
|
||||
a *.* (x2, y2) =
|
||||
@@ -37,6 +42,9 @@ a *.* (x2, y2) =
|
||||
infixl 6 +.+.+, -.-.-
|
||||
infixl 7 *.*.*
|
||||
|
||||
|
||||
{- | 3D coordinate-wise addition.
|
||||
-}
|
||||
(+.+.+) :: Point3 -> Point3 -> Point3
|
||||
{-# INLINE (+.+.+) #-}
|
||||
(x1, y1, z1) +.+.+ (x2, y2, z2) =
|
||||
@@ -46,6 +54,8 @@ infixl 7 *.*.*
|
||||
!z = z1 + z2
|
||||
in (x, y, z)
|
||||
|
||||
{- | 3D coordinate-wise subtraction.
|
||||
-}
|
||||
(-.-.-) :: Point3 -> Point3 -> Point3
|
||||
{-# INLINE (-.-.-) #-}
|
||||
(x1, y1, z1) -.-.- (x2, y2, z2) =
|
||||
@@ -55,6 +65,8 @@ infixl 7 *.*.*
|
||||
!z = z1 - z2
|
||||
in (x, y, z)
|
||||
|
||||
{- | 3D scalar multiplication.
|
||||
-}
|
||||
(*.*.*) :: Point3 -> Point3 -> Point3
|
||||
{-# INLINE (*.*.*) #-}
|
||||
(x1, y1, z1) *.*.* (x2, y2, z2) =
|
||||
@@ -64,10 +76,15 @@ infixl 7 *.*.*
|
||||
!z = z1 * z2
|
||||
in (x, y, z)
|
||||
|
||||
{- | Normalize a vector to length 1.
|
||||
-}
|
||||
normalizeV :: Point2 -> Point2
|
||||
{-# INLINE normalizeV #-}
|
||||
normalizeV p = (1 / magV p) *.* p
|
||||
|
||||
{- | Angle between two vectors.
|
||||
Always positive.
|
||||
-}
|
||||
angleVV :: Point2 -> Point2 -> Float
|
||||
{-# INLINE angleVV #-}
|
||||
angleVV a b = let ma = magV a
|
||||
@@ -75,20 +92,28 @@ angleVV a b = let ma = magV a
|
||||
d = a `dotV` b
|
||||
in acos $ d / (ma * mb)
|
||||
|
||||
{- | Dot product.
|
||||
-}
|
||||
dotV :: Point2 -> Point2 -> Float
|
||||
{-# INLINE dotV #-}
|
||||
dotV (x,y) (z,w) = x*z + y*w
|
||||
|
||||
{- | Given vector, returns the angle, anticlockwise from +ve x-axis, in radians.
|
||||
-}
|
||||
argV :: Point2 -> Float
|
||||
{-# INLINE argV #-}
|
||||
argV (x,y) = normalizeAngle $ atan2 y x
|
||||
|
||||
{- | Determinant of the matrix formed by two vectors.
|
||||
-}
|
||||
detV :: Point2 -> Point2 -> Float
|
||||
{-# INLINE detV #-}
|
||||
detV (x1, y1) (x2, y2)
|
||||
= x1 * y2 - y1 * x2
|
||||
|
||||
-- | Angle in radians, anticlockwise from +ve x-axis.
|
||||
{- | Given an angle in radians, anticlockwise from +ve x-axis, returns the
|
||||
corresponding unit vector.
|
||||
-}
|
||||
unitVectorAtAngle :: Float -> Point2
|
||||
{-# INLINE unitVectorAtAngle #-}
|
||||
unitVectorAtAngle r
|
||||
@@ -106,36 +131,46 @@ degToRad :: Float -> Float
|
||||
degToRad d = d * pi / 180
|
||||
{-# INLINE degToRad #-}
|
||||
|
||||
|
||||
-- | Convert radians to degrees
|
||||
radToDeg :: Float -> Float
|
||||
radToDeg r = r * 180 / pi
|
||||
{-# INLINE radToDeg #-}
|
||||
|
||||
|
||||
-- | Normalize an angle to be between 0 and 2*pi radians
|
||||
normalizeAngle :: Float -> Float
|
||||
normalizeAngle f = f - 2 * pi * floor' (f / (2 * pi))
|
||||
where floor' :: Float -> Float
|
||||
floor' x = fromIntegral (floor x :: Int)
|
||||
{-# INLINE normalizeAngle #-}
|
||||
normalizeAngle f = f - 2 * pi * floor' (f / (2 * pi))
|
||||
where
|
||||
floor' :: Float -> Float
|
||||
floor' x = fromIntegral (floor x :: Int)
|
||||
|
||||
{- | Rotate vector by pi/2 clockwise.
|
||||
-}
|
||||
vNormal :: Point2 -> Point2
|
||||
{-# INLINE vNormal #-}
|
||||
vNormal (x,y) = (y,-x)
|
||||
|
||||
{- | Negate a vector.
|
||||
-}
|
||||
vInverse :: Point2 -> Point2
|
||||
vInverse (x,y) = (-x,-y)
|
||||
|
||||
normV :: Point2 -> Point2
|
||||
{-# INLINE normV #-}
|
||||
normV (0,0) = (0,0)
|
||||
normV p = (1/magV p ) *.* p
|
||||
{- | Normalize a vector safely: on (0,0) return (0,0).
|
||||
-}
|
||||
safeNormalizeV :: Point2 -> Point2
|
||||
{-# INLINE safeNormalizeV #-}
|
||||
safeNormalizeV (0,0) = (0,0)
|
||||
safeNormalizeV p = (1/magV p ) *.* p
|
||||
|
||||
{- | Magnitude of a vector.
|
||||
-}
|
||||
magV :: Point2 -> Float
|
||||
{-# INLINE magV #-}
|
||||
magV (x,y) = sqrt $ x^2 + y^2
|
||||
|
||||
{- | Magnitude of the cross product of two vectors.
|
||||
Identical to detV.
|
||||
-}
|
||||
crossV :: Point2 -> Point2 -> Float
|
||||
crossV (ax,ay) (bx,by) = ax*by - ay*bx
|
||||
|
||||
|
||||
@@ -8,7 +8,6 @@ import Foreign.C.Types
|
||||
import GHC.Generics
|
||||
import qualified GHC.Int
|
||||
import qualified SDL
|
||||
import SDL.Internal.Numbered as SDL.Internal.Numbered
|
||||
|
||||
import System.Directory
|
||||
|
||||
|
||||
+1
-1
@@ -1,6 +1,6 @@
|
||||
{-|
|
||||
Module : Loop
|
||||
Description : A minimal game loop
|
||||
Description : Minimal game loop
|
||||
|
||||
This module sets up an SDL window which may be updated using a simple game loop.
|
||||
-}
|
||||
|
||||
+113
-49
@@ -1,21 +1,125 @@
|
||||
module Sound
|
||||
where
|
||||
{-|
|
||||
Module : Sound
|
||||
Description : Channel selection and storage
|
||||
|
||||
This module checks for empty channels and plays sounds on them.
|
||||
It uses data chunks loaded into an IntMap to determine the actual sounds played.
|
||||
Sound specifications of type 'Sound' loaded into a Map can be used to
|
||||
keep track of which sounds are playing.
|
||||
Uses SDL.Mixer.
|
||||
-}
|
||||
module Sound (
|
||||
-- * Simple (One-Shot) Playback
|
||||
playSoundQueue
|
||||
-- * Complex Playback
|
||||
, playAndUpdate
|
||||
) where
|
||||
import Sound.Preload
|
||||
|
||||
import Control.Monad
|
||||
|
||||
import qualified SDL.Mixer as Mix
|
||||
|
||||
import Data.Maybe
|
||||
import qualified Data.IntMap as IM
|
||||
import qualified Data.Map as M
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Lens
|
||||
{- | Start playing new sounds and update sound specifications.
|
||||
A Map of new sound specifications is merged with a Map of already playing sounds,
|
||||
then sounds in the merged Map are updated.
|
||||
The Map of updated sound specifications is returned.
|
||||
|
||||
playSoundQueue :: SoundData a -> [Int] -> IO ()
|
||||
playSoundQueue sd ns = forM_ ns $ \n -> playIfFree (_loadedChunks sd IM.! n) Mix.Once
|
||||
New sounds with the same keys as
|
||||
already playing sounds are merged in the following manner:
|
||||
|
||||
-- this can be cleaned up
|
||||
* the '_soundChannel' is set to the old value
|
||||
* if the old '_soundStatus' was 'FadingOut', it is replaced with the new status (allowing playback to be restarted using 'ToStart')
|
||||
* all other fields are set to the new value.
|
||||
|
||||
In the update:
|
||||
|
||||
1. sounds with a value 'ToStart' commence playing
|
||||
2. timers are decremented and any fading status is set
|
||||
3. sounds that have stopped playing are removed from the map.
|
||||
-}
|
||||
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
|
||||
|
||||
mergeSound :: Sound -> Sound -> Sound
|
||||
mergeSound newS oldS
|
||||
| _soundStatus oldS == FadingOut
|
||||
= newS & soundChannel .~ _soundChannel oldS
|
||||
| otherwise = newS & soundChannel .~ _soundChannel oldS
|
||||
& soundStatus .~ _soundStatus oldS
|
||||
|
||||
updateSounds :: Ord a => IM.IntMap Mix.Chunk -> M.Map a Sound -> IO (M.Map a Sound)
|
||||
updateSounds sd ss = do
|
||||
may <- mapM (runMaybeT . updateSound sd) ss
|
||||
return $ M.mapMaybe id may
|
||||
|
||||
updateSound :: IM.IntMap Mix.Chunk -> Sound -> MaybeT IO Sound
|
||||
updateSound sd s =
|
||||
initialisePlaying sd s >>= liftIO . decrementTimer >>= cleanupHalted
|
||||
|
||||
initialisePlaying :: IM.IntMap Mix.Chunk -> Sound -> MaybeT IO Sound
|
||||
initialisePlaying sd s = case _soundStatus s of
|
||||
ToStart -> tryPlay sd s
|
||||
_ -> return s
|
||||
|
||||
tryPlay :: IM.IntMap Mix.Chunk -> Sound -> MaybeT IO Sound
|
||||
tryPlay sd s = do
|
||||
i <- tryGetChannel s
|
||||
liftIO $ do
|
||||
Mix.halt i
|
||||
Mix.playOn i Mix.Once (sd IM.! _soundChunkID s)
|
||||
return $ s
|
||||
& soundChannel .~ Just i
|
||||
& soundStatus .~ Playing
|
||||
|
||||
repetitions :: Sound -> Mix.Times
|
||||
repetitions s = case _soundTime s of
|
||||
Nothing -> Mix.Once
|
||||
_ -> Mix.Forever
|
||||
|
||||
tryGetChannel :: Sound -> MaybeT IO Mix.Channel
|
||||
tryGetChannel s = case _soundChannel s of
|
||||
Just i -> return i
|
||||
Nothing -> MaybeT $ Mix.getAvailable Mix.DefaultGroup
|
||||
|
||||
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)
|
||||
>> return (s & soundTime .~ Nothing
|
||||
& soundStatus .~ FadingOut)
|
||||
Nothing -> return s
|
||||
|
||||
fadeOutMaybe :: Maybe Mix.Channel -> Int -> IO ()
|
||||
fadeOutMaybe (Just x) fadeT = Mix.fadeOut (fromIntegral fadeT + 1) x
|
||||
fadeOutMaybe _ _ = return ()
|
||||
|
||||
cleanupHalted :: Sound -> MaybeT IO Sound
|
||||
cleanupHalted s = do
|
||||
i <- MaybeT $ return $ _soundChannel s
|
||||
isPlaying <- liftIO $ Mix.playing i
|
||||
if isPlaying
|
||||
then return s
|
||||
else mzero
|
||||
|
||||
-----------------------------------------------------------------
|
||||
{- | Play sounds from a list of indices.
|
||||
Each sound starts playing (and will not repeat) if there is a free channel.
|
||||
Use this if you don't care about timing, overlapping, fading, or sound positions.
|
||||
-}
|
||||
playSoundQueue :: IM.IntMap Mix.Chunk -> [Int] -> IO ()
|
||||
playSoundQueue chunkMap ns = forM_ ns $ \n -> playIfFree (chunkMap IM.! n) Mix.Once
|
||||
{- | Given a chunk, attempt to play this on a free channel a given number of
|
||||
times. Returns 'Just' the channel if succeeds.
|
||||
-}
|
||||
playIfFree :: Mix.Chunk -> Mix.Times -> IO (Maybe Mix.Channel)
|
||||
playIfFree c times = do
|
||||
mayChan <- Mix.getAvailable Mix.DefaultGroup
|
||||
@@ -23,43 +127,3 @@ playIfFree c times = do
|
||||
Nothing -> return Nothing
|
||||
Just i -> Just <$> Mix.playOn i times c
|
||||
|
||||
playSoundIfFree :: Mix.Chunk -> Sound -> IO (Maybe Sound)
|
||||
playSoundIfFree c s = case _soundTime s of
|
||||
Just _ -> (playIfFree c Mix.Forever) >>= return . f
|
||||
Nothing -> playIfFree c Mix.Once >>= return . f
|
||||
where
|
||||
f :: Maybe Mix.Channel -> Maybe Sound
|
||||
f = fmap (\chan -> (s & soundChannel .~ Just chan))
|
||||
|
||||
haltMaybe :: Maybe Mix.Channel -> IO (Maybe Sound)
|
||||
haltMaybe (Just x) = Mix.halt x >> return Nothing
|
||||
haltMaybe Nothing = return Nothing
|
||||
|
||||
-- logic: check if sound is playing:
|
||||
-- if so, decrement timers, and/or stop playing and remove
|
||||
-- if not, check if there is free channel:
|
||||
-- if so, start playing
|
||||
-- if not, remove sound
|
||||
playSound :: SoundData a -> Sound -> IO (Maybe Sound)
|
||||
playSound sd s = case _soundChannel s of
|
||||
Just i -> case _soundTime s of
|
||||
Just t | t > 0 -> return $ Just $ set soundTime (Just $ t - 1) s
|
||||
| otherwise -> haltMaybe (_soundChannel s)
|
||||
Nothing -> Mix.playing i >>= (\b -> if b
|
||||
then return (Just s)
|
||||
else return Nothing
|
||||
)
|
||||
Nothing -> playSoundIfFree (_loadedChunks sd IM.! _soundType s) s
|
||||
|
||||
playSounds :: SoundData a -> IO (SoundData a)
|
||||
playSounds sd = do
|
||||
newSounds <- mapM (playSound sd) (_playingSounds sd)
|
||||
return $ sd & playingSounds .~ M.mapMaybe id newSounds
|
||||
|
||||
updatePlaying :: Ord a => M.Map a Sound -> M.Map a Sound -> M.Map a Sound
|
||||
updatePlaying new old = M.unionWith f new old
|
||||
where
|
||||
f newSound oldSound = newSound {_soundChannel = _soundChannel oldSound}
|
||||
|
||||
playAndUpdate :: Ord a => M.Map a Sound -> SoundData a -> IO (SoundData a)
|
||||
playAndUpdate new sd = playSounds $ over playingSounds (updatePlaying new) sd
|
||||
|
||||
+12
-5
@@ -7,16 +7,23 @@ import qualified Data.Map as M
|
||||
import Control.Lens
|
||||
import Geometry
|
||||
|
||||
data SoundStatus
|
||||
= Playing
|
||||
| FadingOut
|
||||
| ToStart
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
data SoundData a = SoundData
|
||||
{_loadedChunks :: IM.IntMap Mix.Chunk
|
||||
,_playingSounds :: M.Map a Sound
|
||||
}
|
||||
data Sound = Sound
|
||||
{ _soundTime :: Maybe Int
|
||||
, _soundFadeTime :: Int
|
||||
, _soundChannel :: Maybe Mix.Channel
|
||||
, _soundPos :: Maybe Point2
|
||||
, _soundType :: Int
|
||||
{ _soundTime :: Maybe Int
|
||||
, _soundFadeTime :: Int
|
||||
, _soundStatus :: SoundStatus
|
||||
, _soundChannel :: Maybe Mix.Channel
|
||||
, _soundPos :: Maybe Point2
|
||||
, _soundChunkID :: Int
|
||||
}
|
||||
deriving (Eq,Ord,Show)
|
||||
|
||||
|
||||
Reference in New Issue
Block a user