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

Add source files, commit before reverting pictures to lists

Browse Source
This commit is contained in:
jgk
2021-02-15 00:07:55 +01:00
parent c6bcfacc7a
commit 8447844bcd
41 changed files with 13677 additions and 35 deletions
Download Patch File Download Diff File Expand all files Collapse all files
app/Main.hs
+13 -35
View File
@@ -6,9 +6,6 @@ import Shaders
import Render
import Shapes
import Dodge.Rendering
import Dodge.RenderPicture
import Dodge.Picture
import Dodge.Prototypes
import Dodge.Data
import Dodge.Initialisation
@@ -17,7 +14,11 @@ import Dodge.Layout
import Dodge.LoadSound
import Dodge.Update
import Dodge.KeyEvents
import Dodge.Preload
import Dodge.Rendering
import Picture
import Picture.Render
import Picture.Preload
import Control.Concurrent
import Control.Lens
@@ -38,31 +39,6 @@ initWorld = initialWorld
pps = [(0,0),(50,0),(0,25)]
ppt = [(0,0),(-50,0),(20,25)]
tSh = TextShape
[((0.0,0.0,0),(1,0,1,1),(s,1))
,((0.5,0.0,0),(1,1,1,1),(e,1))
,((0.5,1.0,0),(1,1,1,1),(e,0))
,((0.0,1.0,0),(1,1,1,1),(s,0))
]
where x = 1/128
s = 20 * x
e = s + x
tSh' = TShape'
[0.0,0.0,0,1,0,1,1,s,1
,0.5,0.0,0,1,1,1,1,e,1
,0.5,1.0,0,1,1,1,1,e,0
,0.0,1.0,0,1,1,1,1,s,0
] TriangleFan
where x = 1/128
s = 20 * x
e = s + x
tSha = TShape'
[0.0,0.0,0,1,1,1,1
,50 ,0.0,0,1,1,1,1
,50 ,50 ,0,1,1,1,1
,0.0,1.0,0,1,1,1,1
] TriangleFan
main :: IO ()
main = do
-- loadedSounds <- loadSounds
@@ -70,15 +46,17 @@ main = do
"windowName"
800 600
doPreload'
cleanUpPreload
(initializeWorld $ generateFromTree lev1 $ initWorld)
(-- \((bs:fs:ts:_),tes) w -> --do render setparams w egFade
\preData w -> --do render setparams w egFade
--renderPicture preData (draw blank w)
renderPicture' preData (pictures' [--scale' 0.5 0.9 $ polygon' [(0,0),(0,0.5),(0.5,0.5),(0.5,0.0)]
scale' 0.0005 0.0005 $ text' "asdf"
]
)
-- renderTex'' preData tSh
renderPicture' preData (draw blank w)
-- renderPicture' preData
-- (pictures [scale 0.5 0.9 $ polygon [(0,0),(0,-0.5),(-0.5,-0.5),(-0.5,0.0)]
-- ,scale 0.5 0.9 $ polygon [(0,0),(0,-0.5),(-0.5,-0.5),(-0.5,0.0)]
-- ,color red $ scale 0.0005 0.0005 $ text "asdf"
-- ]
-- )
)
handleEvent
(\w -> Just $ update w)
package.yaml
+9
View File
@@ -38,6 +38,8 @@ dependencies:
- monad-loops
- JuicyPixels
- vector
- dlist
- deepseq
library:
source-dirs: src
@@ -48,8 +50,15 @@ executables:
source-dirs: app
ghc-options:
- -threaded
- -O2
- -rtsopts
- -with-rtsopts=-N
- -fno-liberate-case
- -fno-state-hack
- -funfolding-use-threshold1000
- -funfolding-keeness-factor1000
- -fllvm
- -optlo-O3
dependencies:
- loop
src/Dodge/AIs.hs
+1966
View File
File diff suppressed because it is too large Load Diff
src/Dodge/Base.hs
+740
View File
@@ -0,0 +1,740 @@
--{-# LANGUAGE Strict #-}
{-# LANGUAGE BangPatterns #-}
module Dodge.Base where
-- imports {{{
import Dodge.Data
import Geometry
import Picture
import Control.Lens
import Control.Monad.State
import Data.List
import Data.Function
import Data.Maybe
import Data.Bifunctor
import qualified Data.IntMap.Strict as IM
import qualified Data.IntSet as IS
import qualified Data.Set as S
-- }}}
--
you :: World -> Creature
you w = _creatures w IM.! _yourID w
aCrPos :: Int -> World -> Point2
aCrPos i w = _crPos $ _creatures w IM.! i
yourItem :: World -> Item
yourItem w = _crInv (you w) IM.! _crInvSel (you w)
yourItemRef w = (creatures . ix (_yourID w) . crInv . ix (_crInvSel (you w)))
halfWidth,halfHeight :: World -> Float
halfWidth w = _windowX w / 2
halfHeight w = _windowY w / 2
hasLOS :: Point2 -> Point2 -> World -> Bool
{-# INLINE hasLOS #-}
hasLOS p1 p2 w = (not $ collidePointWallsSimple p1 p2 nearbyWalls)
&& (not $ collidePointSmoke p1 p2 nearbySmoke)
where nearbyWalls = wallsAlongLine p1 p2 w
nearbySmoke = _smoke w -- smokeAlongLine p1 p2 w
smokeLOS :: Point2 -> Point2 -> World -> Bool
smokeLOS p1 p2 w = not $ collidePointSmoke p1 p2 nearbySmoke
where nearbySmoke = _smoke w
hasLOSIndirect :: Point2 -> Point2 -> World -> Bool
hasLOSIndirect p1 p2 w = case collidePointIndirect p1 p2 $ wallsAlongLine p1 p2 w
of Just _ -> False
Nothing -> True && smokeLOS p1 p2 w
isWalkable :: Point2 -> Point2 -> World -> Bool
isWalkable p1 p2 w = not $ collidePointWalkable p1 p2 nearbyWalls
where nearbyWalls = wallsAlongLine p1 p2 w
canSee :: Int -> Int -> World -> Bool
canSee i j w = hasLOS p1 p2 w
--canSee i j w = not $ collidePointWallsSimple p1 p2
-- nearbyWalls
where p1 = _crPos (_creatures w IM.! i)
p2 = _crPos (_creatures w IM.! j)
nearbyWalls = wallsAlongLine p1 p2 w
canSeePoint :: Int -> Point2 -> World -> Bool
canSeePoint i p w = hasLOS p1 p w
--canSeePoint i p w = case collidePointWalls p1 p nearbyWalls
-- of Just _ -> False
-- Nothing -> True
where nearbyWalls = wallsAlongLine p1 p w
p1 = _crPos (_creatures w IM.! i)
pathToPointFireable :: Int -> Point2 -> World -> Bool
pathToPointFireable i p w = not $ collidePointWallsSimple (_crPos (_creatures w IM.! i))
p
walls
where walls = IM.filter (not . isJust . \wl -> wl ^? blHP)
$ wallsAlongLine p1 p w
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)]
where cr = _creatures w IM.! i
cpos = _crPos cr
radius = _crRad cr
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)]
where cr = _creatures w IM.! toID
cpos = _crPos cr
radius = _crRad cr
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)]
where cr = _creatures w IM.! toID
cpos = _crPos cr
radius = _crRad cr
canWalk :: Int -> Int -> World -> Bool
canWalk i j w = not $ collidePointWalkable ipos jpos $ wallsAlongLine ipos jpos w
where ipos = _crPos (_creatures w IM.! i)
jpos = _crPos (_creatures w IM.! j)
canSeeIndirect :: Int -> Int -> World -> Bool
canSeeIndirect i j w = case collidePointIndirect ipos jpos $ wallsAlongLine ipos jpos w
of Just _ -> False
Nothing -> True && smokeLOS ipos jpos w
where ipos = _crPos (_creatures w IM.! i)
jpos = _crPos (_creatures w IM.! j)
canSeeFire :: Point2 -> Point2 -> World -> Bool
canSeeFire p p' w = (not $ collidePointFireVision p p' $ wallsAlongLine p p' w)
&& smokeLOS p p' w
canSeeFireVision :: Int -> Int -> World -> Bool
canSeeFireVision i j w = (not $ collidePointFireVision ipos jpos $ wallsAlongLine ipos jpos w)
&& smokeLOS ipos jpos w
where ipos = _crPos (_creatures w IM.! i)
jpos = _crPos (_creatures w IM.! j)
canSeeFireVisionAny :: Int -> Int -> World -> Bool
canSeeFireVisionAny i j w = (not $ and $ fmap ($ (wallsAlongLine (_crPos icr) (_crPos jcr) w) )
$ zipWith collidePointFireVision ips jps
) && smokeLOS (_crPos icr) (_crPos jcr) w
where icr = _creatures w IM.! i
jcr = _creatures w IM.! j
ips = map (\p -> (_crPos icr +.+ _crRad icr *.* p)) [(1,0),(0,1),(-1,0),(0,-1)]
jps = map (\p -> (_crPos jcr +.+ _crRad jcr *.* p)) [(1,0),(0,1),(-1,0),(0,-1)]
canSeeFireVisionAll :: Int -> Int -> World -> Bool
canSeeFireVisionAll i j w = (not $ or $ fmap ($ (wallsAlongLine (_crPos icr) (_crPos jcr) w) )
$ zipWith collidePointFireVision ips jps
) && smokeLOS (_crPos icr) (_crPos jcr) w
where icr = _creatures w IM.! i
jcr = _creatures w IM.! j
ips = map (\p -> (_crPos icr +.+ _crRad icr *.* p)) [(1,0),(0,1),(-1,0),(0,-1)]
jps = map (\p -> (_crPos jcr +.+ _crRad jcr *.* p)) [(1,0),(0,1),(-1,0),(0,-1)]
-- looks for first collision of a point with walls
-- if found, returns wall
-- I'm sure there is a better way of doing this, one that propagates Nothing in a nice way
--wallsOnLine :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall]
--wallsOnLine p1 p2 ws = hitWalls
-- where hitPoint w = myIntersectSegSeg p1 p2 (_wlLine w !! 0) (_wlLine w !! 1)
-- hitWalls = filter (\w -> Nothing /= hitPoint w) (IM.elems ws)
wallsOnLine :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall]
wallsOnLine p1 p2 ws = hitWalls
where hitPoint w = intersectSegSeg' p1 p2 (_wlLine w !! 0) (_wlLine w !! 1)
hitWalls = filter (\w -> Nothing /= hitPoint w) (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 (_wlLine w !! 0) (_wlLine w !! 1)
--where hitPoint w = myIntersectSegSeg p1 p2 (_wlLine w !! 0) (_wlLine w !! 1)
hitWalls = filter (\w -> Nothing /= hitPoint w) (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
where f wl = circOnLine (_wlLine wl !! 0) (_wlLine wl !! 1) p r
wallsNearPoint :: Point2 -> World -> IM.IntMap Wall
wallsNearPoint p w = IM.unions [f b $ f a $ _wallsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
where (x,y) = zoneOfPoint p
f i m = case IM.lookup i m of Just val -> val
_ -> IM.empty
-- possible BUG, was associated with thingsHitLongLine
wallsAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Wall
{-# INLINE wallsAlongLine #-}
--wallsAlongLine a b w = IM.unions [f y $ f x $ _wallsZone w | (x,y) <- zoneOfLine a b]
-- where f i m = case IM.lookup i m of Just val -> val
-- _ -> IM.empty
wallsAlongLine a b w = IM.foldrWithKey' g IM.empty kps
where g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _wallsZone w) s))
kps = zoneOfLine' a b
f i m = case IM.lookup i m of Just val -> val
_ -> IM.empty
wallsNearZone' :: IM.IntMap IS.IntSet -> World -> IM.IntMap Wall
{-# INLINE wallsNearZone' #-}
wallsNearZone' im w = IM.foldrWithKey' g IM.empty im
where g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _wallsZone w) s))
f i m = case IM.lookup i m of Just val -> val
_ -> IM.empty
wallsAlongCirc :: Point2 -> Float -> World -> IM.IntMap Wall
wallsAlongCirc p r w = IM.unions [f y $ f x $ _wallsZone w | (x,y) <- zoneOfCircle p r]
where f i m = case IM.lookup i m of Just val -> val
_ -> IM.empty
allWalls :: World -> IM.IntMap Wall
allWalls w = IM.unions $ concatMap IM.elems $ IM.elems $ _wallsZone w
creaturesNearPoint :: Point2 -> World -> IM.IntMap Creature
creaturesNearPoint p w = IM.unions [f b $ f a $ _creaturesZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
where (x,y) = zoneOfPoint p
f i m = case IM.lookup i m of Just val -> val
_ -> IM.empty
cloudsNearPoint :: Point2 -> World -> IM.IntMap Cloud
cloudsNearPoint p w = IM.unions [f b $ f a $ _cloudsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
where (x,y) = zoneOfPoint p
f i m = case IM.lookup i m of Just val -> val
_ -> IM.empty
-- possible BUG, occurs when used in thingsHitLongLine
creaturesAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Creature
--creaturesAlongLine a b w = IM.unions [f y $ f x $ _creaturesZone w | (x,y) <- zoneOfLine a b]
-- where f i m = case IM.lookup i m of Just val -> val
-- _ -> IM.empty
creaturesAlongLine a b w = IM.foldrWithKey' g IM.empty kps
where g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _creaturesZone w) s))
kps = zoneOfLine' a b
f i m = case IM.lookup i m of Just val -> val
_ -> IM.empty
zoneSize :: Float
zoneSize = 50
--zoneSize = 100
floorHun :: Float -> Int
floorHun x = floor $ x / zoneSize
zoneOfPoint :: Point2 -> (Int,Int)
zoneOfPoint (x,y) = (floorHun x, floorHun y)
zoneNearPoint :: Point2 -> [(Int,Int)]
zoneNearPoint (x',y') = [(a,b) | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
where x = floorHun x'
y = floorHun y'
zoneAroundPoint :: Point2 -> [(Int,Int)]
zoneAroundPoint (x',y') = [(a,b) | a<-[x-3..x+3] , b<-[y-3..y+3]]
where x = floorHun x'
y = floorHun y'
zoneAroundPoint' :: Int -> Point2 -> IM.IntMap IS.IntSet
zoneAroundPoint' i (x',y') = IM.fromSet (const ys) xs
where x = floorHun x'
y = floorHun y'
xs = IS.fromAscList [x-i..x+i]
ys = IS.fromAscList [y-i..y+i]
-- the laser seemed to be occasionally missing creatures,
-- if this reoccurs, maybe change
-- divide line factor from 2 to 1.5
bres :: Point2 -> Point2 -> [(Int,Int)]
bres a b = bresenham (zoneOfPoint a) (zoneOfPoint b)
bresx :: Point2 -> Point2 -> [(Int,Int)]
bresx a b = bresenham (x-1,y-1) (x'-1,y'-1)
where (x,y) = zoneOfPoint a
(x',y') = zoneOfPoint b
zoneOfLine :: Point2 -> Point2 -> [(Int,Int)]
zoneOfLine (aa,ab) (ba,bb) = nub $ concatMap f
$ bresenham (zoneOfPoint (aa,ab)) (zoneOfPoint (ba,bb))
where f (x,y) = [(p,r) | p <-[x-1,x,x+1] , r<-[y-1,y,y+1]]
--zoneOfLine (aa,ab) (ba,bb) = nub $ concatMap f
-- $ bresenham (zoneOfPoint (aa-n,ab-n)) (zoneOfPoint (ba-n,bb-n))
-- where f (x,y) = [(p,r) | p <-[x,x+1] , r<-[y,y+1]]
-- n = zoneSize * 0.5
expandLine :: [(Int,Int)] -> IM.IntMap IS.IntSet
{-# INLINE expandLine #-}
expandLine xs = IM.map expandSet
$ IM.unionsWith IS.union [im, IM.mapKeysMonotonic (+1) im, IM.mapKeysMonotonic (+2) im]
where im = IM.fromListWith IS.union $ map (\(a,b)->(a,IS.singleton b)) xs
expandSet s = IS.insert (mk+2) $ IS.insert (mk+1) s
--expandSet s = s
where mk = IS.findMax s
zoneOfLine' :: Point2 -> Point2 -> IM.IntMap IS.IntSet
{-# INLINE zoneOfLine' #-}
zoneOfLine' a b = expandLine $ bresenham (x-1,y-1) (x'-1,y'-1)
where (x,y) = zoneOfPoint a
(x',y') = zoneOfPoint b
--zoneOfLine a b = concatMap zoneNearPoint $ divideLine (2 * zoneSize) a b
--zoneOfLine a b = concatMap zoneNearPoint $ divideLine zoneSize a b
zoneOfCircle :: Point2 -> Float -> [(Int,Int)]
zoneOfCircle p r = concatMap zoneNearPoint $ divideCircle (1.5 * zoneSize) p r
-- looking at this again, I am not convinced it deals correctly with the
-- rotation of the world
zoneOfScreen :: World -> [(Int,Int)]
zoneOfScreen w = [(a,b) | a <- [x - n .. x + n]
, b <- [y - n .. y + n]
]
where (x,y) = zoneOfPoint $ _cameraPos w
n = ceiling $ wh / (_cameraZoom w * zoneSize)
wh = max (_windowX w) (_windowY w)
zoneOfDoubleScreen :: World -> [(Int,Int)]
zoneOfDoubleScreen w = [(a,b) | a <- [x - n .. x + n]
, b <- [y - n .. y + n]
]
where (x,y) = zoneOfPoint $ _cameraPos w
n = (ceiling $ wh / (_cameraZoom w * zoneSize)) * 2
wh = max (_windowX w) (_windowY w)
zoneOfSight :: World -> [(Int,Int)]
zoneOfSight w = [(a,b) | a <- [minimum xs .. maximum xs]
, b <- [minimum ys .. maximum ys]
]
where (xs,ys) = unzip $ map zoneOfPoint $ screenPolygon w ++ [_cameraCenter w]
screenPolygon :: World -> [Point2]
screenPolygon w = [tr,tl,bl,br]
where scRot = rotateV (_cameraRot w)
scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p
scTran p = p +.+ _cameraPos w
tr = scTran $ scRot $ scZoom ( halfWidth w, halfHeight w)
tl = scTran $ scRot $ scZoom (-halfWidth w, halfHeight w)
br = scTran $ scRot $ scZoom ( halfWidth w,-halfHeight w)
bl = scTran $ scRot $ scZoom (-halfWidth w,-halfHeight w)
wallsNearZones :: [(Int,Int)] -> World -> IM.IntMap Wall
wallsNearZones is w = IM.unions [f b $ f a $ _wallsZone w | (a,b) <- is]
where f i m = case IM.lookup i m of Just val -> val
_ -> IM.empty
ixZone :: IM.IntMap (IM.IntMap a) -> Point2 -> a
ixZone z (x,y) = z IM.! floorHun x IM.! floorHun y
ixNZ :: IM.IntMap (IM.IntMap a) -> Point2 -> [a]
ixNZ z p = lookLookups (zoneNearPoint p) z
lookLookup :: Int -> Int -> (IM.IntMap (IM.IntMap a)) -> Maybe a
lookLookup i j z = case IM.lookup i z of
Just z' -> IM.lookup j z'
Nothing -> Nothing
lookLookups :: [(Int,Int)] -> (IM.IntMap (IM.IntMap a)) -> [a]
lookLookups xs z = mapMaybe (flip (uncurry lookLookup) z) xs
-- looks for first collision of a point with walls
-- if found, gives point and reflection velocity
collidePointWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
collidePointWalls p1 p2 ws = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe
(( \(x:y:_) -> fmap (flip (,)
(reflectIn (x -.- y) (p2 -.- p1))
. (+.+ errorNormalizeV 39 (vNormal (x -.- y)))
) (intersectSegSeg' p1 p2 x y)
) . _wlLine
) ws
where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
-- looks for if a point collides with walls
collidePointWallsSimple :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
collidePointWallsSimple p1 p2 = any $ isJust . ( \(x:y:_) -> intersectSegSeg' p1 p2 x y)
. _wlLine
collidePointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
collidePointWalkable p1 p2 ws = any (isJust
. ( \(x:y:_) -> intersectSegSeg' p1 p2 x y)
. _wlLine
) unwalkableWalls
where unwalkableWalls = IM.filter notDoor ws
notDoor (AutoDoor {}) = False
notDoor _ = True
furthestPointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
furthestPointWalkable p1 p2 ws = head $ (sortBy (compare `on` dist p1) $ IM.elems
$ IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y)
. _wlLine
) ws
) ++ [p2]
collidePointIndirect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
collidePointIndirect p1 p2 ws = listToMaybe $ sortBy (compare `on` dist p1) $ IM.elems
$ IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y)
. _wlLine
) notWindows
where notWindows = IM.filter (not . _wlIsSeeThrough) ws
collidePointFire :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
collidePointFire p1 p2 ws = listToMaybe $ sortBy (compare `on` dist p1) $ IM.elems
$ IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y)
. _wlLine
) notWindows
where notWindows = IM.filter (\wl -> not (_wlIsSeeThrough wl && isJust (wl ^? blHP))
) ws
collidePointFireVision :: Point2 -> Point2 -> IM.IntMap Wall -> Bool
collidePointFireVision p1 p2 ws = any ( isJust
. ( \(x:y:_) -> intersectSegSeg' p1 p2 x y)
. _wlLine
)
$ IM.filter notBlockWindow ws
where notBlockWindow wl = case wl ^? blHP of
Just _ -> not $ _wlIsSeeThrough wl
Nothing -> True
collidePointSmoke :: Point2 -> Point2 -> [Smoke] -> Bool
collidePointSmoke a b = any $ isJust . uncurry (intersectSegSeg' a b) . smokePerpLine a b
smokePerpLine :: Point2 -> Point2 -> Smoke -> (Point2,Point2)
smokePerpLine a b sm = (p +.+ orth, p -.- orth)
where
p = _smPos sm
orth = _smRad sm *.* safeNormalizeV (vNormal (a -.- b))
-- shit this is ugly
lineOfThickness :: Float -> [Point2] -> Picture
lineOfThickness t = pictures . f
where f (x:y:ys)
| x == y = f (x:ys)
| otherwise
= polygon [x +.+ n x y, x -.- n x y, y -.- n x y, y +.+ n x y] : f (y:ys)
f _ = []
n a b = (t*0.5) *.* errorNormalizeV 42 (vNormal (a -.- b))
wedgeOfThickness :: Float -> Point2 -> Point2 -> Picture
wedgeOfThickness t x y
| x == y = blank
| otherwise = pictures [uncurry translate x $ circleSolid (0.5*t)
,polygon [x +.+ n x y, x -.- n x y, y]
]
where n a b = (t*0.5) *.* errorNormalizeV 4200 (vNormal (a -.- b))
insertInZoneWith :: Int -> Int -> (a -> a -> a) -> a -> IM.IntMap (IM.IntMap a)
-> IM.IntMap (IM.IntMap a)
insertInZoneWith x y fun obj = IM.insertWith f x $ IM.singleton y obj
where-- f :: IM.IntMap a -> IM.IntMap a -> IM.IntMap a
f _ = IM.insertWith fun y obj
insertIMInZone :: Int -> Int -> Int -> a -> IM.IntMap (IM.IntMap (IM.IntMap a))
-> IM.IntMap (IM.IntMap (IM.IntMap a))
insertIMInZone x y obid obj = IM.insertWith f x $ IM.singleton y $ IM.singleton obid obj
where f _ = IM.insertWith g y $ IM.singleton obid obj
g _ = IM.insert obid obj
adjustIMZone :: (a -> a) -> Int -> Int -> Int -> IM.IntMap (IM.IntMap (IM.IntMap a))
-> IM.IntMap (IM.IntMap (IM.IntMap a))
adjustIMZone f x y n m = IM.adjust f' x m
where f' = IM.adjust f'' y
f'' = IM.adjust f n
newKey :: IM.IntMap a -> Int
newKey m = case IM.lookupMax m of
Just (n,_) -> n+1
Nothing -> 0
newParticleKey :: World -> Int
newParticleKey w = case IM.lookupMax (_particles w) of
Just (n,_) -> n+1
Nothing -> 0
newCrKey :: World -> Int
newCrKey w = case IM.lookupMax (_creatures w) of
Just (n,_) -> n+1
Nothing -> 0
insertNewKey :: a -> IM.IntMap a -> IM.IntMap a
insertNewKey x m = case IM.lookupMax m of
Nothing -> IM.singleton 0 x
Just (k,_) -> IM.insert (k+1) x m
reflectPointCreature :: Point2 -> Point2 -> Creature -> Maybe (Point2, Point2, Int)
reflectPointCreature p1 p2 cr =
case collidePointCirc p1 p2 (_crRad cr) (_crPos cr) of
Nothing -> Nothing
Just p3 -> Just ( p1
, errorNormalizeV 35 (ssaTriPoint p2 (_crPos cr) p1 (_crRad cr) -.- _crPos cr)
+.+ (_crPos cr -.- _crOldPos cr)
--, errorNormalizeV 36 $
-- ssaTriPoint p1 (_crPos cr) p2 (_crRad cr)
-- -.- _crOldPos cr
, _crID cr)
reflectPointCreatures :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe (Point2,Point2,Int)
reflectPointCreatures p1 p2 cs = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe
(reflectPointCreature p1 p2) cs
where f (a,_,_) (b,_,_) = compare (magV (a -.- p1)) (magV (b -.- p1))
reflectCircCreature :: Float -> Point2 -> Point2 -> Creature -> Maybe (Point2, Point2, Int)
reflectCircCreature rad p1 p2 cr =
case collidePointCirc p1 p2 (rad + _crRad cr) (_crPos cr) of
Nothing -> Nothing
Just p3 -> Just ( p1
, errorNormalizeV 37 (ssaTriPoint p2 (_crPos cr) p1 (_crRad cr) -.- _crPos cr)
+.+ (_crPos cr -.- _crOldPos cr)
--, errorNormalizeV 38 $
-- ssaTriPoint p1 (_crPos cr) p2 (_crRad cr)
-- -.- _crOldPos cr
, _crID cr)
reflectCircCreatures :: Float -> Point2 -> Point2 -> IM.IntMap Creature -> Maybe (Point2,Point2,Int)
reflectCircCreatures rad p1 p2 cs = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe
(reflectCircCreature rad p1 p2) cs
where f (a,_,_) (b,_,_) = compare (magV (a -.- p1)) (magV (b -.- p1))
-- collides a point with forcefields
-- if found, returns point of collision, deflection if required, and the id
collidePointFFs = undefined
collidePointFF = undefined
--
--collidePointFFs :: Point2 -> Point2 -> StdGen -> IM.IntMap ForceField
-- -> Maybe (Point2,(Maybe (Point2,StdGen),Int))
--collidePointFFs p1 p2 g fs = listToMaybe $ sortBy f $ IM.elems
-- $ IM.mapMaybe (collidePointFF p1 p2 g) fs
-- where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
--
--collidePointFF :: Point2 -> Point2 -> StdGen -> ForceField
-- -> Maybe (Point2,(Maybe (Point2,StdGen),Int))
--collidePointFF p1 p2 g ff = fmap f ip
-- where (p3:p4:_) = _ffLine ff
-- ip = intersectSegSeg' p1 p2 p3 p4
-- ref = (_ffDeflect ff) <*> Just g <*> Just (p2 -.- p1) <*> Just ff
-- f p = (p, (ref, _ffID ff))
--
-- looks for first collision of a point with walls
-- if found, gives point and reflection velocity, reflection damped in normal
collidePointWalls' :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
collidePointWalls' p1 p2 ws
= listToMaybe $ sortBy f $ IM.elems
$ IM.mapMaybe
(( \(x:y:_) -> fmap (flip (,) (reflectInParam 0.5 (x -.- y) (p2 -.- p1))
. (+.+ errorNormalizeV 40 (vNormal (x -.- y)))
)
(intersectSegSeg' p1 p2 x y)
) . _wlLine
) ws
where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
-- looks for first collision of a circle with walls
-- if found, gives point and reflection velocity, reflection damped in normal
collideCircWalls' :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2)
collideCircWalls' p1 p2 rad ws
= listToMaybe $ sortBy f $ IM.elems
$ IM.mapMaybe
(( \(x:y:_) -> fmap (flip (,) (reflectInParam 0.5 (x -.- y) (p2 -.- p1))
. (+.+ errorNormalizeV 40 (vNormal (x -.- y)))
)
(intersectSegSeg' p1 p2 x y)
) . shiftByRad . _wlLine
) ws
where f (a,_) (b,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
shiftByRad (a:b:_) = map ((+.+) (rad *.* normalizeV (vNormal (a -.- b))))
[a +.+ rad *.* (normalizeV (a -.-b))
,b +.+ rad *.* (normalizeV (b -.-a))
]
-- this shifts the wall out, and for outer corners extends the wall
-- not sure what this does for inner corners, hopefully won't cause a problem
-- the alternative would be to separately bounce off corner points...
-- unfortunately, doesn't allow for collisions when the circle spawns on the
-- wall
-- looks for first collision of a point with walls
-- if found, gives point and normal of wall
collidePointWallsNorm :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
collidePointWallsNorm p1 p2 ws = listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe
(( \(x:y:_) -> fmap (flip (,) ( vNormal $ x -.- y ))
(intersectSegSeg' p1 p2 x y)
) . _wlLine
) 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
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)
. (\w -> (intersectSegSeg' p1 p2
(_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
collidePointWallsNormCol :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2,Color)
collidePointWallsNormCol p1 p2 ws
= listToMaybe $ sortBy f $ IM.elems $ IM.mapMaybe m ws
where f (a,_,_) (b,_,_) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
ls w = let (x:y:_) = _wlLine w
in (intersectSegSeg' p1 p2 x y, vNormal (x -.- y), _wlColor w)
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
collidePointCreatures :: Point2 -> Point2 -> World -> Maybe Int
collidePointCreatures p1 p2 w = fmap fst $ listToMaybe $ sortBy (csnd) $ IM.toList $
IM.mapMaybe (\x ->
collidePointCirc' p1 p2 (_crRad x) (_crPos x)
)
(_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
collideCircCreatures :: Point2 -> Point2 -> Float -> World -> Maybe Int
collideCircCreatures p1 p2 rad w = fmap fst $ listToMaybe $ sortBy (csnd) $ IM.toList $
IM.mapMaybe (\x ->
collidePointCirc' p1 p2 (rad + _crRad x) (_crPos x)
)
(_creatures w)
where csnd (_,a) (_,b) = compare a b
--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)
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)
-- makes a creatures 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)
circOnSomeWall :: Point2 -> Float -> World -> Bool
circOnSomeWall p rad w = any (\(x:y:_) -> circOnLine x y p rad)
$ fmap _wlLine $ IM.elems $ wallsNearPoint p w
crsNearLine :: Float -> [Point2] -> World -> Bool
crsNearLine d (p1:p2:_) w = any (\c -> circOnLine p1 p2 (_crPos c) (d + _crRad c))
$ IM.filter (\cr -> _crMass cr > 4) $ _creatures w
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 -> circOnLine p1 p2 (_crPos cr) (_crRad cr))
$ _creatures w
crsOnThickLine :: Float -> Point2 -> Point2 -> World -> [Creature]
crsOnThickLine thickness p1 p2 w = IM.elems
$ IM.filter (\cr -> circOnLine p1 p2 (_crPos cr) (_crRad cr + thickness))
$ _creatures w
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
nearestCrInTri :: Point2 -> Float -> Float -> 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
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)
crInPolygon :: Creature -> [Point2] -> Bool
crInPolygon cr xs = errorPointInPolygon 3 (_crPos cr) xs
onLayer :: Layer -> Picture -> Picture
onLayer l = setDepth (fromIntegral (levLayer l) / 100)
--onLayer :: Layer -> Picture -> [(Picture, [Int])]
--onLayer l p = [(p, [levLayer l])]
onLayerL :: [Int] -> Picture -> Picture
onLayerL is = setDepth (sum $ zipWith (/) (map fromIntegral is) $ map (\x->100**x) [1..])
levLayer :: Layer -> Int
levLayer BgLayer = 20
levLayer PressPlateLayer = 45
levLayer CorpseLayer = 50
levLayer FlItLayer = 55
levLayer CrLayer = 60
levLayer WlLayer = 65
levLayer GloomLayer = 67
levLayer UPtLayer = 70
levLayer PtLayer = 72
levLayer HPtLayer = 73
levLayer ShadowLayer = 75
levLayer LabelLayer = 80
levLayer InvLayer = 85
levLayer MenuLayer = 90
mouseWorldPos :: World -> Point2
mouseWorldPos w = _cameraPos w +.+ (1/_cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w)
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
translateDrawing = translate
rotateDrawing = rotate
src/Dodge/Block.hs
+105
View File
@@ -0,0 +1,105 @@
{-# LANGUAGE BangPatterns #-}
module Dodge.Block where
import Dodge.Data
import Dodge.Base
import Dodge.SoundLogic
import Geometry
import Picture.Data
import Control.Lens
import Data.List
import Data.Function
import qualified Data.IntMap.Strict as IM
import System.Random
import Control.Monad.State
updateBlocks :: World -> World
updateBlocks w = (\w' -> seq (_wallsZone w') w') $ flip (foldr removeFromZone) deadPanes
$ over walls (\wls -> wls `seq` IM.filter (not . blockIsDead) wls)
degradeBlocks
-- w
where degradeBlocks = deadBlocks `seq` foldr killBlock w deadBlocks
removeFromZone :: Wall -> World -> World
removeFromZone bl = over (wallsZone . ix x . ix y) (IM.delete (_wlID bl))
where (x,y) = zoneOfPoint $ pHalf (_wlLine bl !! 0) (_wlLine bl !! 1)
deadPanes = filter blockIsDead (IM.elems $ _walls w)
deadBlocks = nubBy ((==) `on` _blIDs) deadPanes
blockIsDead wl = case wl ^? blHP of Just x -> x <= 0
Nothing -> False
killBlock :: Wall -> World -> World
killBlock bl w = f bl .
flip (foldr unshadow)
-- flip (foldr (\i -> set (walls . ix i . blVisible) (True)))
(_blShadows bl)
$ w
where
f bl@(Block {_blDegrades = (x:xs)}) = degradeBlock bl . hitSound bl
f bl = hitSound' bl
hitSound bl | _wlIsSeeThrough bl = soundMultiFrom sos (soundid+8) 25 0
| otherwise = soundMultiFrom sos soundid 25 0
hitSound' bl | _wlIsSeeThrough bl = soundMultiFrom sos (soundid+4) 25 0
| otherwise = soundMultiFrom sos soundid 25 0
sos = [BlockDegradeSound 0,BlockDegradeSound 1]
(soundid,_) = randomR (29,32) $ _randGen w
unshadow :: Int -> World -> World
unshadow bid w = case w ^? walls . ix bid of
Just b -> let (x,y) = zoneOfPoint $ pHalf (_wlLine b !! 0) (_wlLine b !! 1)
in w & wallsZone . ix x . ix y . ix bid . blVisible %~ \_ -> True
Nothing -> w
degradeBlock :: Wall -> World -> World
degradeBlock bl w = let blid = _wlID bl
bls = map (\i -> _walls w IM.! i) (_blIDs $ _walls w IM.! blid)
ps = reverse $ orderPolygon $ nub $ concatMap _wlLine bls
(newPs,g) = runState (shrinkPolygon 0.5 ps) $ _randGen w
(x:xs) = _blDegrades bl
in addBlock newPs (x + _blHP bl) (_wlColor bl) (_wlIsSeeThrough bl) xs $ set randGen g w
pushPointTowardsBy :: RandomGen g => Float -> Point2 -> [Point2] -> State g Point2
pushPointTowardsBy x p ps = do
xs <- sequence $ take (length ps) $ repeat $ state $ randomR (0, x / (fromIntegral $ length ps))
let toAdd p' y = y *.* (p' -.- p)
return $ p +.+ foldr1 (+.+) (zipWith toAdd ps xs)
shrinkPolygon :: RandomGen g => Float -> [Point2] -> State g [Point2]
shrinkPolygon x ps = sequence $ map (flip (pushPointTowardsBy x) ps) ps
addBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World
addBlock (p:ps) hp col isSeeThrough degradability w
| hp <= 0 && degradability == [] = w
| hp <= 0 = addBlock (p:ps) (head degradability + hp) col isSeeThrough (tail degradability) w
| otherwise = over wallsZone (flip (IM.foldr wallInZone) blocks)
$ over walls (IM.union blocks) w
--addBlock (p:p':ps) w = over walls (IM.insert i b) w
where
lines = zip (p:ps) (ps ++ [p])
i = newKey $ _walls w
is = [i.. i + length lines-1]
blocks = IM.fromList $ zip is
$ zipWith (\j (a,b) -> Block { _wlLine = [a,b]
, _wlID = j
-- , _wlColor = greyN 0.5
, _wlColor = col
, _wlDraw = Nothing
, _wlSeen = False
, _blIDs = is
, _blHP = hp
, _wlIsSeeThrough = isSeeThrough
, _blVisible = True
, _blShadows = []
, _blDegrades = degradability
}
) is lines
wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize
= insertIMInZone x y wlid wl
| otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips
where (x,y) = zoneOfPoint $ (pHalf (_wlLine wl !! 0) (_wlLine wl !! 1))
wlid = _wlID wl
ips = map zoneOfPoint $ divideLine (2*zoneSize) (_wlLine wl !! 0) (_wlLine wl !! 1)
src/Dodge/Camera.hs
+163
View File
@@ -0,0 +1,163 @@
module Dodge.Camera where
import Dodge.Data
import Dodge.Base
import Geometry
import Control.Lens
import Control.Monad
import Data.Maybe
import qualified Data.Set as S
import qualified Data.IntMap.Strict as IM
import qualified SDL as SDL
updateCamera :: World -> World
updateCamera = rotCam . moveCamera . updateAimTime . updateScopeZoom
updateAimTime :: World -> World
updateAimTime w
| SDL.ButtonRight `S.member` _mouseButtons w
= w & cameraAimTime %~ \t -> min (t+1) 10
| otherwise = w & cameraAimTime %~ \t -> max (t-1) 0
moveCamera :: World -> World
moveCamera w = w & cameraPos .~ idealPos
& cameraCenter .~ sightFrom
where aimRangeFactor | _cameraZoom w == 0 = 0
| otherwise = (fromMaybe 0 $ yourItem w ^? itAimingRange) / _cameraZoom w
aimTimeFactor = fromIntegral (w ^. cameraAimTime) / 10
aimingMult | SDL.ButtonRight `S.member` _mouseButtons w = 1
| otherwise = 0
ypos = _crPos $ you w
idealOffset = rotateV (_cameraRot w) (aimRangeFactor * aimingMult *.* _mousePos w)
currentOffset = currentPos -.- camCenter
idealPos = camCenter +.+ rotateV (_cameraRot w)
-- (aimRangeFactor * aimTimeFactor *.* _mousePos w)
(aimRangeFactor * aimingMult *.* _mousePos w)
currentPos = _cameraPos w
camCenter = ypos +.+ scope
isCam :: Bool
isCam = fromMaybe False $ yourItem w ^? itAttachment . _Just . scopeIsCamera
scope = fromMaybe (0,0) $ yourItem w ^? itAttachment . _Just . scopePos
sightFrom | isCam = camCenter
| otherwise = ypos
updateScopeZoom :: World -> World
updateScopeZoom w
| SDL.ButtonRight `S.member` _mouseButtons w = case w ^? scppoint of
Just x
| x > 9 -> zoomInLongGun $ zoomInLongGun
$ w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
. itAttachment . _Just . scopeZoomChange -~ 2
| x > 0 -> zoomInLongGun
$ w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
. itAttachment . _Just . scopeZoomChange -~ 1
| x < -9 -> zoomOutLongGun $ zoomOutLongGun
$ w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
. itAttachment . _Just . scopeZoomChange +~ 2
| x < 0 -> zoomOutLongGun $ zoomOutLongGun
$ w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
. itAttachment . _Just . scopeZoomChange +~ 1
| otherwise -> w
_ -> w
| otherwise = w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
. itAttachment . _Just %~ updateScope
where scppoint = creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
. itAttachment . _Just . scopeZoomChange
updateScope (ItScope _ _ _ bl) = ItScope (0,0) 0 1 bl
updateScope otherAtt = otherAtt
zoomSpeed = 39/40
zoomInLongGun :: World -> World
zoomInLongGun w | currentZoom < 8 = over (wpPointer . itAttachment . _Just . scopePos)
(\p -> p +.+ (4-(4*zoomSpeed)) / currentZoom *.* mousep)
$ over (wpPointer . itAttachment . _Just . scopeZoom) (\z -> z / zoomSpeed)
w
| otherwise = w
where wpPointer = creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
wp = _crInv (_creatures w IM.! 0) IM.! (_crInvSel (_creatures w IM.! 0))
Just currentZoom = wp ^? itAttachment . _Just . scopeZoom
mousep = rotateV (_cameraRot w) $ _mousePos w
zoomOutLongGun :: World -> World
zoomOutLongGun w | currentZoom > 0.5 = over (wpPointer . itAttachment . _Just . scopePos)
-- (\p -> p -.- 2/(2 * currentZoom) *.* _mousePos w)
-- (\p -> p -.- 2*zoomSpeed/currentZoom *.* p)
(\p -> p)
$ over (wpPointer . itAttachment . _Just . scopeZoom) (\z -> z * zoomSpeed)
w
| otherwise = w
where wpPointer = creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
wp = _crInv (_creatures w IM.! 0) IM.! (_crInvSel (_creatures w IM.! 0))
Just currentZoom = wp ^? itAttachment . _Just . scopeZoom
currentCursorDisplacement = fromJust $ _itAttachment wp
rotCam = rotateCameraL . rotateCameraR . zoomCamIn . zoomCamOut . zoomCam
rotateCameraL :: World -> World
rotateCameraL w | SDL.KeycodeQ `S.member` _keys w
= w & cameraRot +~ 0.015
& creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
. itAttachment . _Just . scopePos %~ rotateV 0.015
| otherwise = w
rotateCameraR :: World -> World
rotateCameraR w | SDL.KeycodeE `S.member` _keys w
= w & cameraRot -~ 0.015
& creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
. itAttachment . _Just . scopePos %~ rotateV (-0.015)
| otherwise = w
zoomCamIn :: World -> World
zoomCamIn w | SDL.KeycodeJ `S.member` _keys w
= w {_cameraZoom = _cameraZoom w + 0.01}
| otherwise = w
zoomCamOut :: World -> World
zoomCamOut w | SDL.KeycodeK `S.member` _keys w
= w {_cameraZoom = max (_cameraZoom w - 0.01) 0.01}
| otherwise = w
-- the 395 here limits the max zoom out, is 25 less than the current screen
-- size, thus matches up with it
zoomCam :: World -> World
--zoomCam w = w
zoomCam w = over cameraZoom changeZoom w
where maxViewDistance = 800
camPos = _cameraCenter w
camRot = _cameraRot w
wallZoom = min (halfWidth w / (horizontalMax+10) )
(halfHeight w / (verticalMax+10) )
idealZoom | SDL.ButtonRight `S.member` _mouseButtons w
= scZoom *
(
min (fromMaybe 20 $ yourItem w ^? itZoom . itAimZoomMax)
$ max (fromMaybe 0.2 $ yourItem w ^? itZoom . itAimZoomMin)
(wallZoom * fromMaybe 1 (yourItem w ^? itZoom . itAimZoomFac))
)
| otherwise
= min (fromMaybe 20 $ yourItem w ^? itZoom . itZoomMax)
$ max (fromMaybe 0.2 (yourItem w ^? itZoom . itZoomMin))
(wallZoom * fromMaybe 1 (yourItem w ^? itZoom . itZoomFac))
changeZoom curZoom | curZoom > idealZoom + 0.01 = 0.05 * (19*curZoom + idealZoom)
| curZoom < idealZoom - 0.01 = 0.05 * (19*curZoom + idealZoom)
| otherwise = idealZoom
-- zs = take 20 [-maxViewDistance,0 - 0.9*maxViewDistance..]
zs = take 9 [-maxViewDistance,0 - 0.8*maxViewDistance..]
rRays = rotF [( maxViewDistance,y) | y <- zs]
lRays = rotF [(-maxViewDistance,y) | y <- zs]
tRays = rotF [(y, maxViewDistance) | y <- zs]
bRays = rotF [(y,-maxViewDistance) | y <- zs]
rotF = map (h . (+.+) camPos . rotateV (_cameraRot w))
h p = fromMaybe p $ collidePointIndirect camPos p $ wallsAlongLine camPos p w
h' x p = dotV (rotateV camRot x) (p -.- camPos)
horizontalMax = maximum $ map (h' (1,0)) rRays ++ map (h' (-1,0)) lRays
verticalMax = maximum $ map (h' (0,1)) tRays ++ map (h' (0,-1)) bRays
scZoom = fromMaybe 1 $ yourItem w ^? itAttachment . _Just . scopeZoom
dirRays :: Float -> [Point2]
dirRays dir = take 11 $ iterate (rotateV (0.5 * pi / 10)) $ rotateV (dir-pi*0.25) (600,0)
src/Dodge/CreatureActions.hs
+362
View File
@@ -0,0 +1,362 @@
{-# LANGUAGE BangPatterns #-}
module Dodge.CreatureActions where
-- imports {{{
import Dodge.Data
import Dodge.Base
import Dodge.SoundLogic
import Dodge.WorldActions
import Geometry
import Picture
import Control.Lens
import Control.Monad
import Control.Applicative
import Data.Maybe
import Data.List
import System.Random
import qualified Data.IntMap.Strict as IM
import qualified Data.Map as M
-- }}}
moveForwardSpeed :: Float -> Int -> World -> World
moveForwardSpeed x n w = over (creatures . ix n . crPos) (+.+ p) w
where p = (*.*) x $ unitVectorAtAngle $ _crDir $ _creatures w IM.! n
mvForward :: Float -> Int -> World -> World
mvForward speed cid w = stepForward cid speed $ over (creatures . ix cid . crPos) (+.+ p) w
where p = (*.*) (speed * equipFactor) $ unitVectorAtAngle $ _crDir $ _creatures w IM.! cid
equipFactor = product $ map equipSpeed $ IM.elems $ _crInv $ _creatures w IM.! cid
crStrafeLeft :: Float -> Creature -> Creature
crStrafeLeft speed cr = stepForward' s2 $ over crPos (+.+ p) cr
where p = (*.*) s2 $ unitVectorAtAngle $ (_crDir cr + pi/2)
equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr
s2 = (speed * equipFactor)
crStrafeRight :: Float -> Creature -> Creature
crStrafeRight speed cr = stepForward' s2 $ over crPos (+.+ p) cr
where p = (*.*) s2 $ unitVectorAtAngle $ (_crDir cr - pi/2)
equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr
s2 = (speed * equipFactor)
crMvForward :: Float -> Creature -> Creature
crMvForward speed cr = over crPos (+.+ p) cr
where p = (*.*) (speed * equipFactor) $ unitVectorAtAngle $ _crDir cr
equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr
crMvBy :: Point2 -> Creature -> Creature
crMvBy p' cr = stepForward' (magV p) $ over crPos (+.+ p) cr
where p = (*.*) (equipFactor * aimingFactor) $ rotateV (_crDir cr) p'
equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr
aimingFactor | (_posture $ _stance $ _crState cr) == Aiming
= fromMaybe 1 $ it ^? itAimingSpeed
| otherwise = 1
it = _crInv cr IM.! _crInvSel cr
stepForward :: Int -> Float -> World -> World
stepForward cid speed = over (creatures . ix cid . crState . stance . carriage) f
where f (w@Walking {}) = w {_stepToAdd = ceiling speed}
f s = s
stepForward' :: Float -> Creature -> Creature
stepForward' speed cr = over (crState . stance . carriage) f cr
where f (w@Walking {}) = w {_stepToAdd = ceiling speed}
f s = s
equipSpeed NoItem = 1
equipSpeed it | _itIdentity it == FrontArmour = 0.75
| _itIdentity it == FlameShield = 0.75
| otherwise = 1
turnTo :: Point2 -> Int -> World -> World
turnTo p n w = set (creatures . ix n . crDir) dirToTarget w
where cr = _creatures w IM.! n
dirToTarget = argV (p -.- _crPos cr)
turnToward :: Point2 -> Int -> World -> World
turnToward p n w | isLeftOfA dirToTarget (_crDir cr)
= f $ over (creatures . ix n . crDir)
(normalizeAngle . (+ (0.03 + r*m))) w
| otherwise = f $ over (creatures . ix n . crDir)
(\x->normalizeAngle (x - (0.03 + r*m))) w
where cr = _creatures w IM.! n
dirToTarget = argV (p -.- _crPos cr)
(r,g) = randomR (-0.1,0.1) (_randGen w)
m = diffAngles dirToTarget (_crDir cr)
f = set randGen g
turnTowardAngle :: Float -> Int -> World -> World
turnTowardAngle a n w
| isLeftOfA a (_crDir cr) = f $ over (creatures . ix n . crDir)
(normalizeAngle . (+ (0.03 + r*m))) w
| otherwise = f $ over (creatures . ix n . crDir)
(\x->normalizeAngle (x - (0.03 + r*m))) w
where cr = _creatures w IM.! n
(r,g) = randomR (-0.1,0.1) (_randGen w)
m = diffAngles a (_crDir cr)
f = set randGen g
turnToward'' :: Float -> Point2 -> Int -> World -> World
turnToward'' turnSpeed p n w
| isLeftOfA dirToTarget (_crDir cr)
= f $ over (creatures . ix n . crDir) (normalizeAngle. (+ (turnSpeed + r))) w
| otherwise = f $ over (creatures . ix n . crDir) (\x->normalizeAngle (x - (turnSpeed + r))) w
where cr = _creatures w IM.! n
dirToTarget = argV (p -.- _crPos cr)
(r,g) = randomR (-0.1,0.1) (_randGen w)
f = set randGen g
crTurnAndStrafeIn :: Float -> Float -> Point2 -> Creature -> Creature
crTurnAndStrafeIn strafeSpeed turnSpeed p cr
| vToTarg == (0,0) = cr -- this should deal with the angleVV error
| errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed
= set crDir dirToTarget cr
| isLeftOfA dirToTarget (_crDir cr)
= over crDir (normalizeAngle . (+ turnAmount ))
$ crStrafeLeft strafeSpeed cr
| otherwise = over crDir (\x->normalizeAngle (x - turnAmount))
$ crStrafeRight strafeSpeed cr
where vToTarg = p -.- _crPos cr
dirToTarget = argV vToTarg
turnAmount = turnSpeed
crTurnTo :: Point2 -> Creature -> Creature
crTurnTo p cr = set crDir dirToTarget cr
where dirToTarget = argV (p -.- _crPos cr)
crTurnTowardSpeed :: Float -> Point2 -> Creature -> Creature
crTurnTowardSpeed turnSpeed p cr
| vToTarg == (0,0) = cr -- this should deal with the angleVV error
| errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed
= set crDir dirToTarget cr
| isLeftOfA dirToTarget (_crDir cr)
= over crDir (normalizeAngle . (+ turnAmount )) cr
| otherwise = over crDir (\x->normalizeAngle (x - turnAmount)) cr
where vToTarg = p -.- _crPos cr
dirToTarget = argV vToTarg
turnAmount = turnSpeed
turnTowardSpeed :: Float -> Point2 -> Int -> World -> World
turnTowardSpeed turnSpeed p n w
| vToTarg == (0,0) = w -- this should deal with the angleVV error
| errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed
= set (creatures . ix n . crDir) dirToTarget w
| isLeftOfA dirToTarget (_crDir cr)
= over (creatures . ix n . crDir) (normalizeAngle . (+ turnAmount )) w
| otherwise = over (creatures . ix n . crDir) (\x->normalizeAngle (x - turnAmount)) w
where cr = _creatures w IM.! n
vToTarg = p -.- _crPos cr
dirToTarget = argV vToTarg
turnAmount = turnSpeed
turnLRS :: Int -> World -> World
turnLRS n w = f $ over (creatures . ix n . crDir) (+ (fromIntegral r * pi / 2)) w
where (r,g) = randomR (negate 1::Int,1) (_randGen w)
f = set randGen g
turnToward' :: Point2 -> Int -> World -> World
turnToward' p n w | isLeftOfA dirToTarget (_crDir cr)
= over (creatures . ix n . crDir) (+ 0.03) w
| otherwise = over (creatures . ix n . crDir) (\x-> x - 0.03) w
where cr = _creatures w IM.! n
dirToTarget = argV (p -.- _crPos cr)
overturnToward :: Point2 -> Int -> World -> World
overturnToward p n w
| isLeftOfA dirToTarget (_crDir cr)
= over (creatures . ix n . crDir) (normalizeAngle. (+ 0.03 )) w
| otherwise = over (creatures . ix n . crDir) (\x->normalizeAngle (x - 0.03 )) w
where cr = _creatures w IM.! n
dirToTarget = argV (p -.- _crPos cr)
moveForward :: Int -> World -> World
moveForward n w = over (creatures . ix n . crPos) (+.+ p) w
where p = unitVectorAtAngle $ _crDir $ _creatures w IM.! n
moveToward :: Point2 -> Int -> World -> World
moveToward p n w
| angle < 10 = moveForwardSpeed 0.1 n w
| angle < 20 = moveForwardSpeed 0.02 n w
| angle < 40 = moveForwardSpeed 0.01 n w
| otherwise = w
where angle = errorAngleVV 5 (p -.- curPos) (unitVectorAtAngle (_crDir (_creatures w IM.! n)))
curPos = _crPos (_creatures w IM.! n)
moveBy :: Int -> Point2 -> World -> World
moveBy n v = over (creatures . ix n . crPos) (+.+ v)
reloadWeapon :: Int -> World -> Maybe World
reloadWeapon cid w = if _unlimitedAmmo w then reloadWeaponUnlimited cid w
else reloadWeaponAmmoCheck cid w
reloadWeaponUnlimited :: Int -> World -> Maybe World
reloadWeaponUnlimited cid w =
let cr = _creatures w IM.! cid
it = _crInv cr IM.! _crInvSel cr
itRef = creatures . ix cid . crInv . ix (_crInvSel cr)
in case it of
Weapon {_wpMaxAmmo=maxA,_wpLoadedAmmo=lA,_wpReloadState=rS,_wpReloadTime=rT}
| lA < maxA && rS == 0 -> Just $ set ( itRef . wpLoadedAmmo) maxA
$ set ( itRef . wpReloadState) rT w
_ -> Nothing
reloadWeaponAmmoCheck :: Int -> World -> Maybe World
reloadWeaponAmmoCheck cid w =
let cr = _creatures w IM.! cid
it = _crInv cr IM.! _crInvSel cr
itRef = creatures . ix cid . crInv . ix (_crInvSel cr)
in case it of
Weapon {_wpMaxAmmo=maxA,_wpLoadedAmmo=lA,_wpAmmoType=aT
,_wpReloadState=rS ,_wpReloadTime=rT}
-> do guard $ lA < maxA && rS == 0 && M.findWithDefault 0 aT (_crAmmo cr) > 0
toAdd <- Just $ min (_crAmmo (you w) M.! aT) (maxA - lA)
return $ over (creatures . ix cid . crAmmo) (M.adjust (\x -> x - toAdd) aT)
$ over ( itRef . wpLoadedAmmo) (\x -> x + toAdd)
$ set ( itRef . wpReloadState) rT w
_ -> Nothing
useItemContinuous :: Int -> World -> World
useItemContinuous n w = case (_crInv cr IM.! _crInvSel cr) ^? itHammer of
Just HammerUp -> useItem1 n $ setHammerDown w
Just NoHammer -> useItem1 n w
_ -> setHammerDown w
where
cr = _creatures w IM.! n
setHammerDown = creatures . ix n . crInv . ix (_crInvSel cr) . itHammer .~ HammerDown
tryUseItem :: Int -> World -> World
tryUseItem cid w = case w ^? creatures . ix cid of
Just cr -> useItem2 cid (_crInv cr IM.! _crInvSel cr) w
Nothing -> w
useItem1 :: Int -> World -> World
useItem1 n w = useItem2 n it w
where c = (_creatures w IM.! n)
it = _crInv c IM.! _crInvSel c
useItem2 :: Int -> Item -> World -> World
useItem2 n (Consumable {_cnEffect=eff }) w = fromMaybe w $ fmap (rmInvItem n) $ eff n w
useItem2 n (Weapon {_wpFire=eff}) w = eff n w
useItem2 n (Throwable {_twFire = eff}) w = eff n w
useItem2 _ _ w = w
rmInvItem :: Int -> World -> World
rmInvItem n w =
let i = _crInvSel (_creatures w IM.! n)
item = _crInv (_creatures w IM.! n) IM.! i
itRef = creatures . ix n . crInv . ix i
in case item of
Consumable {_itAmount = 1} -> set itRef NoItem w
Craftable {_itAmount = 1} -> set itRef NoItem w
Equipment {_itAmount = 1} -> set itRef NoItem w
Throwable {_itAmount = 1} -> set itRef NoItem w
Consumable {_itAmount = x} -> over (itRef . itAmount) (\y-> y-1) w
Craftable {_itAmount = x} -> over (itRef . itAmount) (\y-> y-1) w
Equipment {_itAmount = x} -> over (itRef . itAmount) (\y-> y-1) w
Throwable {_itAmount = x} -> over (itRef . itAmount) (\y-> y-1) w
_ -> set itRef NoItem w
dropItem :: World -> World
dropItem w = case yourItem w of
NoItem -> w
it -> rmInvItem (_yourID w) $ over floorItems (IM.insert flid theflit)
$ updateLocation
$ soundOnce putDownSound
$ set randGen g w
where (rot, g) = randomR (-pi,pi) $ _randGen w
offset = _crRad (you w) *.* unitVectorAtAngle rot
updateLocation w = case it ^? itID of
Just (Just i) -> w & itemPositions . ix i .~ OnFloor flid
_ -> w
flid = newKey $ _floorItems w
theflit = FlIt {_flIt = set itAmount 1 it
,_flItPos = offset +.+ _crPos (you w)
,_flItRot = rot
,_flItID = flid}
useItemAmmoCheck :: Int -> World -> World
useItemAmmoCheck n w
| hasAmmo = useItem1 n w
| otherwise = w
where c = _creatures w IM.! n
hasAmmo = case _crInv c IM.! _crInvSel c of
Weapon {_wpLoadedAmmo=0, _wpAmmoType=ammoT}
-> case _crAmmo c M.!? ammoT of
Just x -> x > 0
_ -> False
Weapon {} -> True
_ -> False
closestItem :: World -> Maybe Int
closestItem w = fmap fst $ listToMaybe $ sortBy cf $ IM.toList
$ fmap (dist yourP . _flItPos) $ _floorItems w
where yourP = _crPos $ you w
cf (_,x) (_,y) = compare x y
pickUpItem' :: FloorItem -> World -> World
pickUpItem' flit w = case maybeInvSlot of
Nothing -> w
Just i -> soundOnce pickUpSound
$ updateItLocation i
$ w & floorItems %~ IM.delete (_flItID flit)
& creatures . ix 0 . crInv . ix i %~ addItem' it
where
it = _flIt flit
maybeInvSlot = checkInvSlots it (_crInv (_creatures w IM.! 0))
updateItLocation invid w'
= case _itID it of Nothing -> w'
Just j -> w' & itemPositions . ix j .~ InInv 0 invid
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'
addItem' :: Item -> Item -> Item
addItem' it NoItem = it
addItem' it it' = it' & itAmount +~ 1
numInventorySlots :: Int
numInventorySlots = 9
itNotFull :: Item -> Bool
itNotFull it = _itMaxStack it > _itAmount it
createItemAt :: Point2 -> FloorItem -> World -> World
createItemAt p it w = over floorItems (IM.insert i (set flItPos p
$ set flItID i it)) w
where i = newKey (_floorItems w)
blinkAction :: Int -> World -> World
blinkAction n w = soundOnce teleSound $ set (creatures . ix n . crPos) p3
$ blinkShockwave p3
$ inverseShockwaveAt cp 40 2 2 2
w
where p1 = _cameraPos w +.+ (1 / _cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w)
cp = _crPos $ _creatures w IM.! n
p2 = collidePointWalls 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)
blinkShockwave :: Point2 -> World -> World
blinkShockwave p = makeShockwaveAt p 40 1 2 cyan
moveAmountToward :: Point2 -> Float -> Point2 -> Point2
moveAmountToward p1 am p2
= p1 +.+ am *.* errorNormalizeV 44 (p2 -.- p1)
facePointAI :: Point2 -> Int -> World -> World
facePointAI p n w = set (creatures . ix n . crDir)
(argV (p -.- _crPos (_creatures w IM.! n)) )
w
reverseDir :: Int -> World -> World
reverseDir n = over (creatures . ix n . crDir) (+ pi)
turnBy :: Float -> Int -> World -> World
turnBy a n = over (creatures . ix n . crDir) (+ a)
src/Dodge/CreatureState.hs
+245
View File
@@ -0,0 +1,245 @@
module Dodge.CreatureState where
-- imports {{{
import Dodge.Data
import Dodge.Base
import Dodge.SoundLogic
import Dodge.RandomHelp
import Dodge.WorldActions
import Dodge.WallCreatureCollisions
import Dodge.CreatureActions
import Geometry
import Data.List
import Data.Char
import Data.Maybe
import Data.Function
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.PatriciaTree
import 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.Mixer as Mix
import System.Random
import qualified Data.Set as S
import qualified Data.IntMap.Strict as IM
import qualified Data.Map as M
import Foreign.ForeignPtr
import Control.Concurrent
---}
type CRUpdate = World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature)
-- 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
stateUpdate :: CRUpdate -> CRUpdate
stateUpdate u w (f,g) cr = case u w (f,g) (updateMovement g cr) of
((f',g') , maybeCr) -> ( (invSideEff cr . movementSideEff cr . dropifdead . f'
, g')
, fmap (updateReloadCounter . reducePastDamage . doDamage)
$ crOrCorpse =<< maybeCr
)
where
crOrCorpse cr | cr ^. crHP > 0 = Just cr
| otherwise = Nothing
dropifdead | cr ^.crHP > 0 = id
| otherwise = stopSoundFrom (CrWeaponSound (_crID cr))
. over decorations addCorpse
. insertIt
crBeforeDeath = colCrWall w $ cr
-- addCorpse = insertNewKey $ uncurry translateDrawing (_crPos crBeforeDeath)
addCorpse = insertNewKey $ uncurry translateDrawing (_crOldPos cr)
$ rotateDrawing (radToDeg (_crDir cr))
(_crCorpse cr)
maybeIt = evalState (maybeTakeOne $ IM.elems (_crInv cr)) (_randGen w)
insertIt = case maybeIt of
-- Just it -> createItemAt (offset +.+ _crPos crBeforeDeath)
Just it -> createItemAt (offset +.+ _crOldPos cr)
(FlIt {_flIt=it,_flItPos=(0,0),_flItRot=rot,_flItID=0})
Nothing -> id
offset = _crRad cr *.* unitVectorAtAngle rot
(rot,_) = randomR (-pi,pi) g
setOldPos :: Creature -> Creature
setOldPos cr = set crOldPos (_crPos cr) cr
doDamage :: Creature -> Creature
doDamage cr = set (crState . crDamage) [] $ over (crState . crPastDamage) (+ hpLost)
damagedCr
where dams = _crDamage $ _crState cr
startHP = _crHP cr
damagedCr = snd $ (_crApplyDamage (_crState cr)) dams cr
-- applyDamage (cr ^. crState . crDamage) cr
afterHP = _crHP damagedCr
hpLost = startHP - afterHP -- note this can be negative
-- applyDamage :: DamageType -> Creature -> Creature
-- applyDamage dt cr = snd $ (cr ^. crState . crApplyDamage) dt cr
sumDamage :: Creature -> DamageType -> Int -> Int
sumDamage cr dm x = x + _dmAmount dm
reducePastDamage :: Creature -> Creature
reducePastDamage = over (crState . crPastDamage) rdpdam
where rdpdam x | x > 500 = x - 55
| x > 200 = x - 25
| x > 20 = x - 5
| x > 0 = x - 1
| otherwise = 0
movementSideEff :: Creature -> World -> World
movementSideEff cr w
| hasJetPack
= case cr ^? crState . stance . carriage of
Just (Boosting v)
-> makeFlamelet (oldPos +.+ (_crRad cr + 3) *.* (unitVectorAtAngle $ _crDir cr + pi))
(momentum +.+ 1 *.* rotateV randDir (vInverse v))
66
Nothing
1
-- $ smokeGen v
$ set randGen g
w
_ -> w
| otherwise = case cr ^? crState . stance . carriage of
Just (Walking x y) -> takeStep x y w
_ -> w
where hasJetPack = any (\it -> it ^? itIdentity == Just JetPack) $ _crInv cr
oldPos = _crOldPos cr
momentum' = 0.97 *.* (_crPos cr -.- _crOldPos cr)
momentum'' | magV momentum' > 3 = 3 *.* normalizeV momentum'
| otherwise = momentum'
momentum = momentum'' +.+ 0.01 *.* unitVectorAtAngle randAng
(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:[])
(t1:t2:t3:_) = randomRs ( 15,20) $ _randGen w
(s1:s2:s3:_) = map (\s -> fromIntegral s * 0.1 - 1) (t3:t2:t1:[])
smokeGen v = makeSmokeAt'' v1 s1 t1
(r1 +.+ oldPos +.+ ((_crRad cr + 3) *.* vInverse (unitVectorAtAngle $ _crDir cr)))
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
| otherwise = id
footor = [FootstepSound 0,FootstepSound 1]
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'
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
_
-> w
where cid = _crID cr
updateMovement :: StdGen -> Creature -> Creature
updateMovement g cr
| isFrictionless cr = over crPos (+.+ momentum)
$ setOldPos
cr
| otherwise
= case cr ^? crState . stance . carriage of
Just (Walking x y)
-> set (crState . stance . carriage) (Walking ((x+y)`mod`120) 0)
$ setOldPos
cr
_ -> set (crState . stance . carriage) (Walking 0 0)
$ setOldPos
cr
where
momentum' = 0.97 *.* (_crPos cr -.- _crOldPos cr)
momentum'' | magV momentum' > 3 = 3 *.* normalizeV momentum'
| otherwise = momentum'
momentum = momentum'' +.+ 0.01 *.* unitVectorAtAngle randAng
(randAng,_) = randomR (0,2*pi) g
isFrictionless :: Creature -> Bool
isFrictionless cr = case cr ^? crState . stance . carriage of
Just (Boosting _) -> True
Just (Floating) -> True
_ -> False
updateReloadCounter :: Creature -> Creature
updateReloadCounter cr = over (crInv . ix iSel . wpFireState) decreaseToZero
. over (crInv . ix iSel . wpReloadState) decreaseToZero
$ cr
where iSel = _crInvSel cr
decreaseToZero :: Int -> Int
decreaseToZero x | x > 0 = x - 1
| otherwise = 0
updateBarrel ::
World -> (World -> World,StdGen) -> Creature -> ((World -> World , StdGen), Maybe Creature)
updateBarrel w (f,g) cr | _crHP cr > 0 = ((f, g), newCr)
| otherwise = ((f, g), Nothing)
-- | otherwise = ((makeExplosionAt (_crPos cr) . stopSounds , g'), Nothing)
where damages = _crDamage $ _crState cr
newCr = Just $ doDamage cr
-- it is easy to leave off the "f" here
-- should find some better way of doing all this that is less prone to error
updateExpBarrel ::
World -> (World -> World,StdGen) -> Creature -> ((World -> World , StdGen), Maybe Creature)
updateExpBarrel w (f,g) cr
| _crHP cr > 0 = ((f . foldr (.) id pierceSparks . hiss, g'), newCr)
| otherwise = ((f . makeExplosionAt (_crPos cr) . stopSounds , g'), Nothing)
where 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
(g',_) = split g
poss = _piercedPoints $ _crSpState $ _crState cr
--newCr = Just $ doDamage $ applyFuseDamage cr -- $ foldr perforate cr damages
newCr = Just $ applyFuseDamage $ set (crState . crDamage) [] $ damToExpBarrel damages cr
perforate :: DamageType -> Creature -> Creature
perforate (Piercing amount sp int ep) cr = over (crState . crSpState . piercedPoints)
((:) $ int -.- _crPos cr) cr
perforate _ cr = cr
applyFuseDamage cr = over crHP (\hp -> hp - length (_piercedPoints
$ _crSpState $ _crState cr))
cr
hiss | poss == [] = id
| otherwise = soundMultiFrom [BarrelHiss 0,BarrelHiss 1] 41 50 1
stopSounds = stopSoundFrom (BarrelHiss 0) . stopSoundFrom (BarrelHiss 1)
damToExpBarrel :: [DamageType] -> Creature -> Creature
damToExpBarrel ds cr = foldr damToExpBarrel' (foldr damToExpBarrel' cr pierceDam) otherDam
where (pierceDam,otherDam) = partition isPierce ds
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' dt cr = cr Control.Lens.& crHP -~ _dmAmount dt
src/Dodge/Critters.hs
+399
View File
@@ -0,0 +1,399 @@
module Dodge.Critters where
-- imports {{{
import Dodge.Data
import Dodge.Weapons
import Dodge.AIs
import Dodge.CreatureState
import Dodge.Prototypes
import Dodge.Base
import Dodge.Smoke
import Picture
import Geometry
import Data.List
import Data.Char
import Data.Maybe
import Data.Function
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.PatriciaTree
import Codec.BMP
import qualified Data.ByteString as B
import Control.Lens
import Control.Applicative
import Control.Monad.State
import Control.Monad
import System.Random
import qualified Data.Set as S
import qualified Data.IntMap.Strict as IM
import qualified Data.Map as M
import Foreign.ForeignPtr
import Control.Concurrent
---}
--colouredEnemy col = pictures [color (greyN 0.8) $ circleSolid 10, color col $ circLine 10]
colouredEnemy col = pictures [color col $ circleSolid 10, circLine 10]
-- armouredSwarmCrit :: Int -> Creature
-- armouredSwarmCrit n = (basicCreature n)
-- -- { _crUpdate = encircleAI' n
-- { _crUpdate = swarmAI lineOrth n
-- , _crHP = 30
-- , _crPict = equipOnTop goalPict
-- , _crState = basicState {_goals = [[]], _faction = EncircleFlock}
-- , _crInv = IM.fromList [(0,frontArmour)]
-- }
--
-- swarmCrit :: Int -> Creature
-- swarmCrit n = (basicCreature n)
-- -- { _crUpdate = encircleAI' n
-- { _crUpdate = swarmAI lineOrth n
-- , _crHP = 30
-- , _crPict = equipOnTop goalPict
-- , _crState = basicState {_goals = [[]], _faction = EncircleFlock}
-- , _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
-- }
--
-- encircleCrit :: Int -> Creature
-- encircleCrit n = (basicCreature n)
-- -- { _crUpdate = encircleAI' n
-- { _crUpdate = swarmAI lineOrth n
-- , _crHP = 30
-- , _crPict = equipOnTop goalPict
-- , _crState = basicState {_goals = [[]], _faction = EncircleFlock}
-- , _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
-- }
--
spawnerCrit :: Creature
spawnerCrit = basicCreature
{ _crUpdate = stateUpdate $ spawnerAI chaseCrit
, _crHP = 300
, _crPict = enemyPict blue
, _crState = basicState {_goals = [[WaitFor 0]]
}
, _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
}
--
-- guardMelee :: Int -> Creature
-- guardMelee n = (basicCreature n)
-- { _crUpdate = meleeAI' n
-- , _crHP = 30
-- , _crPict = equipOnTop goalPict
-- , _crState = basicState {_goals = [[InitGuard]]
-- ,_faction = ChaseCritters}
-- , _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
-- }
smallChaseCrit :: Creature
smallChaseCrit = basicCreature
{ _crUpdate = stateUpdate chaseAI
, _crHP = 1
, _crRad = 4
--, _crPict = equipOnTop goalPict
, _crPict = enemyPict green
, _crState = basicState {_goals = [[Wait]]
,_faction = ChaseCritters}
, _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
, _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ circleSolid 4
}
chaseCrit :: Creature
chaseCrit = basicCreature
{ _crUpdate = stateUpdate chaseAI
, _crHP = 300
-- , _crPict = goalPict -- enemyPict green
, _crPict = enemyPict green
, _crState = basicState {_goals = [[Wait]]
,_faction = ChaseCritters}
, _crInv = IM.empty
-- IM.fromList [(0,frontArmour)]
}
armourChaseCrit :: Creature
armourChaseCrit = basicCreature
{ _crUpdate = stateUpdate chaseAI
, _crHP = 300
, _crPict = enemyPict green
, _crState = basicState {_goals = [[Wait]]}
, _crInv = IM.fromList [(0,frontArmour)]
}
miniGunCrit :: Creature
miniGunCrit = basicCreature
{ _crPict = enemyPict red
--, _crUpdate = checkDeadStopSound n . shooterFootsteps n . makeStateAI autoShooterAI n
, _crUpdate = stateUpdate miniAI
--, _crUpdate = shooterFootsteps n . makeStateAI autoShooterAI n
, _crInv = IM.fromList [(0,miniGun)]
, _crInvSel = 0
, _crRad = 10
, _crAmmo = M.fromList [(PistolBullet, 1000)]
--, _crState = ShooterWait
, _crState = basicState {_goals = [[InitGuard]]}
, _crHP = 500
}
longCrit :: Creature
longCrit = basicCreature
{ _crPict = enemyPict red
--, _crUpdate = checkDeadStopSound n . shooterFootsteps n . makeStateAI autoShooterAI n
, _crUpdate = stateUpdate sniperAI
--, _crUpdate = shooterFootsteps n . makeStateAI autoShooterAI n
, _crInv = IM.fromList [(0,longGun),(1,medkit 100)]
, _crInvSel = 0
, _crRad = 10
, _crAmmo = M.fromList [(PistolBullet, 1000)]
--, _crState = ShooterWait
, _crState = basicState {_goals = [[InitGuard]]}
, _crHP = 300
}
multGunCrit :: Creature
multGunCrit = basicCreature
{ _crPict = enemyPict red
--, _crUpdate = checkDeadStopSound n . shooterFootsteps n . makeStateAI autoShooterAI n
, _crUpdate = stateUpdate (twitchMissAI 300 350)
--, _crUpdate = shooterFootsteps n . makeStateAI autoShooterAI n
, _crInv = IM.fromList [(0,multGun),(1,medkit 100)]
, _crInvSel = 0
, _crRad = 10
, _crAmmo = M.fromList [(PistolBullet, 1000)]
--, _crState = ShooterWait
, _crState = basicState {_goals = [[InitGuard]]}
, _crHP = 300
}
launcherCrit :: Creature
launcherCrit = basicCreature
{ _crPict = enemyPict red
--, _crUpdate = checkDeadStopSound n . shooterFootsteps n . makeStateAI autoShooterAI n
, _crUpdate = stateUpdate (launcherAI 150 200)
--, _crUpdate = shooterFootsteps n . makeStateAI autoShooterAI n
, _crInv = IM.fromList [(0,launcher),(1,medkit 100)]
, _crInvSel = 0
, _crRad = 10
, _crAmmo = M.fromList [(PistolBullet, 1000)]
--, _crState = ShooterWait
, _crState = basicState {_goals = [[Init]]}
, _crHP = 300
}
spreadGunCrit :: Creature
spreadGunCrit = basicCreature
{ _crPict = enemyPict red
--, _crUpdate = checkDeadStopSound n . shooterFootsteps n . makeStateAI autoShooterAI n
, _crUpdate = stateUpdate chargeAI
--, _crUpdate = shooterFootsteps n . makeStateAI autoShooterAI n
, _crInv = IM.fromList [(0,spreadGun),(1,medkit 100)]
, _crInvSel = 0
, _crRad = 10
, _crAmmo = M.fromList [(PistolBullet, 1000)]
--, _crState = ShooterWait
, _crState = basicState {_goals = [[Init]]}
, _crHP = 300
}
pistolCrit :: Creature
pistolCrit = basicCreature
{ _crPict = enemyPict red
--, _crUpdate = checkDeadStopSound n . shooterFootsteps n . makeStateAI autoShooterAI n
, _crUpdate = stateUpdate (dodgeAI 150 200)
--, _crUpdate = shooterFootsteps n . makeStateAI autoShooterAI n
, _crInv = IM.fromList [(0,pistol),(1,medkit 100)]
, _crInvSel = 0
, _crRad = 10
, _crAmmo = M.fromList [(PistolBullet, 1000)]
--, _crState = ShooterWait
, _crState = basicState {_goals = [[InitGuard]]}
, _crHP = 500
}
autoCrit :: Creature
autoCrit = basicCreature
{ _crPict = enemyPict red
--, _crUpdate = checkDeadStopSound n . shooterFootsteps n . makeStateAI autoShooterAI n
, _crUpdate = stateUpdate basicShooterAI
--, _crUpdate = shooterFootsteps n . makeStateAI autoShooterAI n
, _crInv = IM.fromList [(0,autoGun),(1,medkit 100)]
, _crInvSel = 0
, _crRad = 10
, _crAmmo = M.fromList [(PistolBullet, 1000)]
--, _crState = ShooterWait
, _crState = basicState {_goals = [[InitGuard]]}
, _crHP = 300
}
addArmour :: Creature -> Creature
addArmour = over crInv insarmour
where insarmour xs = IM.insert i frontArmour xs
where i = newKey xs
--closeShooterCrit :: Int -> Creature
--closeShooterCrit n = (basicCreature n)
-- { _crPos = startPos
-- , _crPict = equipOnTop goalPict
-- , _crUpdate = closeShooterAI n
-- , _crInv = IM.fromList [(0,ltAutoGun)]
-- , _crInvSel = 0
-- , _crRad = 10
-- , _crAmmo = M.fromList [(PistolBullet, 1000)]
-- , _crState = basicState {_goals = [[InitGuard]]}
-- , _crHP = 50
-- }
-- where startPos = (20*fromIntegral n-550,0)
barrel :: Creature
barrel = basicCreature
{ _crUpdate = updateBarrel
, _crHP = 500
, _crPict = \ _ -> onLayer CrLayer $ pictures [ color orange $ circleSolid 10
, color (greyN 0.5) $ circleSolid 8
]
, _crState = basicState {_goals = [[Wait]]
,_faction = ChaseCritters
,_crSpState = Barrel []
}
, _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
}
explosiveBarrel :: Creature
explosiveBarrel = basicCreature
{ _crUpdate = updateExpBarrel
, _crHP = 400
, _crPict = \ _ -> onLayer CrLayer $ pictures [ color orange $ circleSolid 10
, color red $ circleSolid 8
]
, _crState = basicState {_goals = [[Wait]]
,_faction = ChaseCritters
,_crSpState = Barrel []
,_crApplyDamage = \_ c -> (id, c)
}
, _crInv = IM.empty -- IM.fromList [(0,frontArmour)]
}
equipOnTop :: (Creature -> Picture) -> Creature -> Drawing
--equipOnTop f cr = onLayer CrLayer $ pictures $ fst (drawEquipment cr) ++ [f cr] ++ snd (drawEquipment cr)
equipOnTop f cr = onLayer CrLayer (f cr) <> drawEquipment cr
drawEquipment :: Creature -> Drawing
drawEquipment cr = mconcat $ map f $ IM.toList (_crInv cr)
where f (i,it) = case it ^? itEquipPict of
Just g -> g cr i
_ -> blank
--drawEquipment :: Creature -> ([Picture],[Picture])
--drawEquipment cr = (map fst p1, map fst p2)
-- where f (k,it) = join $ (it ^? itEquipPict) <*> (pure cr) <*> (pure k)
-- picts = sortBy (compare `on` snd) $ mapMaybe f $ IM.toList (_crInv cr)
-- (p1,p2) = partition (\ x -> snd x < 0) picts
frontArmouredPict = const $ pictures [ color (greyN 0.8) $ circleSolid 20
, color red $ circLine 20
-- ,color (greyN 0.1) $ thickArc 0 90 20 5
-- ,color (greyN 0.1) $ thickArc 270 360 20 5
]
--packCrits :: (Int -> World -> World) -> [Int] -> [Creature]
--packCrits ai is = [(basicCreature 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 = (basicCreature 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 = (basicCreature 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)]
-- ]
flamerPict = const $ pictures [color (light $ light $ light $ dim blue) $ circleSolid 10, circLine 10]
goalPict cr = let r = _crRad cr in case _crState cr of
CrSt {_goals = gls ,_crDamage = crDam }
-- | crDam > _crHP cr -> color white $ circleSolid r
| otherwise -> case head gls of
[] -> sizeColEnemy r white
(MoveToFor p i:_) -> dGoals $ sizeColEnemy r green
(WaitFor x:_) -> dGoals $ sizeColEnemy r yellow
(FireAt p:_) -> dGoals $ sizeColEnemy r red
(Reload:_) -> dGoals $ sizeColEnemy r orange
(PathTo p:_) -> dGoals $ sizeColEnemy r cyan
(SubPathTo p i _:_) -> dGoals $ sizeColEnemy r blue
(Search i:_) -> dGoals $ sizeColEnemy r black
_ -> dGoals $ sizeColEnemy r magenta
where dGoals p = pictures [p, rotate (radToDeg (_crDir cr)) $ scale 0.1 0.1 $ color white $ text $ show gls]
_ -> sizeColEnemy r (light $ dim green)
startCr :: Creature
startCr = basicCreature
{ _crPos = (0,0)
, _crOldPos = (0,0)
, _crDir = 0
, _crID = 0
, _crPict = basicCrPict $ greyN 0.8
, _crUpdate = stateUpdate yourControl
, _crRad = 10
, _crMass = 10
, _crHP = 10000
, _crMaxHP = 1500
, _crInv = IM.fromList (zip [0..20]
([pistol,autoGun,launcher,lasGun,grenade
,ltAutoGun,flamer,multGun,spreadGun,remoteLauncher
,longGun
,hvAutoGun
,teslaGun
,latchkey 0
]
++ repeat NoItem))
-- startInv
, _crAmmo = M.fromList [(PistolBullet, 0),(LiquidFuel, 100),(Battery, 20000),(Shell,200)]
, _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ pictures [color (greyN 0.8) $ circleSolid 10, circLine 10]
}
smokeGenGun = effectGun "smoke" $ \_ -> spawnSmokeAtCursor
enemyPict :: Color -> Creature -> Drawing
enemyPict col = equipOnTop $ sizeEnemy (light $ light $ light $ light col)
sizeEnemy col cr
| pdam > 200 = color red $ circleSolid $ _crRad cr
| pdam > 100 = color white $ circleSolid $ _crRad cr
| mod pdam 2 == 1 = color white $ circleSolid $ _crRad cr
| otherwise = pictures [color col $ circleSolid $ _crRad cr
, circLine $ _crRad cr ]
where pdam = _crPastDamage $ _crState cr
sizeColEnemy r col = pictures [color col $ circleSolid r, circLine r]
basicCrPict :: Color -> Creature -> Drawing
basicCrPict col cr = onLayer CrLayer naked <> drawEquipment cr
where naked | pdam > 200 = color red $ circleSolid $ _crRad cr
| pdam > 100 = color white $ circleSolid $ _crRad cr
| mod pdam 2 == 1 = color white $ circleSolid $ _crRad cr
-- | crDam > _crHP cr && odd (crDam - _crHP cr)
-- = [color white $ circleSolid $ _crRad cr]
| otherwise = pictures [color col $ circleSolid $ _crRad cr, circLine $ _crRad cr]
-- , rotate (radToDeg $ _crDir cr) $ scale 0.2 0.2 $ color white $ text $ show $ _crPos cr
pdam = _crPastDamage $ _crState cr
src/Dodge/Data.hs
+715
View File
@@ -0,0 +1,715 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleInstances #-}
--{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE StrictData #-}
module Dodge.Data
( module Dodge.Data
, Point2 (..)
)
where
-- imports {{{
import Picture.Data
import Geometry.Data
import Control.Lens
import Control.Monad.State
import System.Random
import Data.Graph.Inductive
import qualified Data.Set as S
import qualified Data.IntMap.Strict as IM
import qualified Data.Map as M
import qualified SDL.Mixer as Mix
import SDL (Keycode, MouseButton)
import Graphics.Rendering.OpenGL (PrimitiveMode (..),GLfloat,Program,VertexArrayObject,BufferObject)
import Codec.Picture (Image,PixelRGBA8)
import qualified Data.DList as DL
--}}}
-- datatypes {{{
data World = World
{ _keys :: !(S.Set Keycode)
, _mouseButtons :: !(S.Set MouseButton)
, _cameraPos :: !Point2
, _cameraAimTime :: Int
, _cameraRot :: !Float
, _cameraZoom :: !Float
, _cameraCenter :: !Point2
, _creatures :: IM.IntMap Creature
, _creaturesZone :: IM.IntMap (IM.IntMap (IM.IntMap Creature))
, _itemPositions :: IM.IntMap ItemPos
, _clouds :: IM.IntMap Cloud
, _cloudsZone :: IM.IntMap (IM.IntMap (IM.IntMap Cloud))
, _particles :: IM.IntMap Particle
, _particles' :: ![Particle']
, _afterParticles' :: ![Particle']
, _smoke :: [Smoke]
, _walls :: !(IM.IntMap Wall)
, _wallsZone :: (IM.IntMap (IM.IntMap (IM.IntMap Wall)))
, _forceFields :: IM.IntMap ForceField
, _floorItems :: IM.IntMap FloorItem
, _randGen :: StdGen
, _mousePos :: !(Float,Float)
, _testString :: String
, _yourID :: !Int
, _worldEvents :: !(World -> World)
, _pressPlates :: IM.IntMap PressPlate
, _buttons :: IM.IntMap Button
, _soundQueue :: [Int]
-- , _loadedSounds :: IM.IntMap Mix.Chunk
, _sounds :: M.Map SoundOrigin Sound
, _decorations :: IM.IntMap Drawing
, _corpses :: IM.IntMap (IM.IntMap [Corpse])
, _lbClickMousePos :: (Float,Float)
, _lbRotation :: Float
, _pathGraph :: ~(Gr Point2 Float)
, _pathGraph' :: ~[(Point2,Point2)]
, _pathPoints :: ~(IM.IntMap (IM.IntMap [(Int,Point2)]))
, _pathInc :: ~(M.Map Point2 [Point2])
, _unlimitedAmmo :: Bool
, _storedLevel :: Maybe World
, _menuState :: MenuState
, _worldState :: M.Map WorldState Bool
, _windowX :: Float
, _windowY :: Float
, _mapDisplay :: (Bool, Float)
, _lightSources :: !(IM.IntMap LightSource)
, _tempLightSources :: ![TempLightSource]
} --deriving (Show)
type Drawing = Picture
data Corpse = Corpse
{ _cpPos :: Point2
, _cpPict :: Drawing
, _cpRes :: Creature
}
data Layer = PtLayer | CrLayer | WlLayer | BgLayer | ShadowLayer
| FlItLayer | LabelLayer | InvLayer | MenuLayer
| PressPlateLayer | CorpseLayer
| UPtLayer
| HPtLayer
| GloomLayer
data Cloud = Cloud
{ _clID :: Int
, _clPos :: Point2
, _clVel :: Point2
, _clPict :: Cloud -> Drawing
, _clRad :: Float
, _clTimer :: Int
, _clEffect :: Cloud -> World -> World
}
data LightSource
= LS
{ _lsID :: !Int
, _lsPos :: !Point2
, _lsDir :: !Float
, _lsRad :: !Float
, _lsIntensity :: !Float
}
data TempLightSource =
TLS { _tlsPos :: !Point2
, _tlsRad :: !Float
, _tlsIntensity :: !Float
, _tlsUpdate :: World -> TempLightSource -> (World, Maybe TempLightSource)
}
data Creature = Creature
{ _crPos :: Point2
, _crOldPos :: Point2
, _crDir :: Float
, _crID :: Int
, _crPict :: Creature -> Drawing
, _crUpdate :: World -> (World -> World,StdGen) -> Creature
-> ((World -> World,StdGen), Maybe Creature)
, _crRad :: Float
, _crMass :: Float
, _crHP :: Int
, _crMaxHP :: Int
, _crInv :: IM.IntMap Item
, _crInvSel :: Int
, _crAmmo :: M.Map Ammo Int
, _crState :: CreatureState
, _crCorpse :: Drawing
}
data CreatureState
= CrSt { _goals :: [[Goal]]
, _stance :: Stance
, _faction :: Faction
, _crDamage :: [DamageType]
, _crPastDamage :: Int
, _crSpState :: CrSpState
, _crApplyDamage :: [DamageType] -> Creature -> (World -> World,Creature)
}
-- deriving (Eq,Show)
data CrSpState = Barrel { _piercedPoints :: [Point2]}
| GenCr
deriving (Eq,Show,Ord)
data Goal = 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
| GoalID Int Goal
| AtRange Float
| AtRanges Float Float
| RepeatAction Int Goal
| MakeJudgement
| SetPosture Posture
deriving (Eq,Show)
data Stance = Stance {_carriage :: Carriage
,_posture :: Posture
}
deriving (Eq,Show)
data Carriage = Walking {_stepCycle :: Int
,_stepToAdd :: Int
}
| Floating
| Boosting Point2
deriving (Eq,Show)
data Posture = Aiming
| AtEase
deriving (Eq,Show)
data Mind = ZombieMind
| HumanMind
deriving (Eq,Show)
data Faction = GenericFaction Int
| ZombieFaction
| EncircleFlock
| ChaseCritters
| SpawnedBy Int
| NoFaction
deriving (Eq,Show)
-- NOTE: walls must be drawn counterclockwise
data WorldState = DoorNumOpen Int
| CrNumAlive Int
deriving (Eq,Ord)
data MenuState
= LevelMenu Int
| PauseMenu
| GameOverMenu
| InGame
data Sound = Sound { _soundTime :: Int
, _soundFadeTime :: Int
, _soundChannel :: Maybe Int
, _soundPos :: Maybe Point2
, _soundType :: Int
}
deriving (Eq,Ord,Show)
data Button = Button
{ _btPict :: Drawing
, _btPos :: Point2
, _btRot :: Float
, _btEvent :: Button -> World -> World
, _btID :: Int
, _btText :: String
, _btState :: ButtonState
}
data ButtonState = BtOn | BtOff | BtNoLabel
deriving (Eq, Show)
data PressPlate = PressPlate { _ppPict :: Drawing
, _ppPos :: Point2
, _ppRot :: Float
, _ppEvent :: PressPlate -> World -> World
, _ppID :: Int
, _ppText :: String
}
data FloorItem = FlIt { _flIt :: Item , _flItPos :: Point2 , _flItRot :: Float, _flItID :: Int}
| FlAm { _flAm :: Ammo , _flItPos :: Point2 , _flAmNum :: Int , _flItID :: Int}
data ItemPos = InInv { _itCrId :: Int
, _itInvId :: Int
}
| OnFloor { _itFlID :: Int
}
data Item = Weapon
{ _itName :: String
, _wpMaxAmmo :: Int
, _wpLoadedAmmo :: Int
, _wpAmmoType :: Ammo
, _wpReloadTime :: Int
, _wpReloadState :: Int
, _wpFireRate :: Int
, _wpFireState :: Int
, _wpFire :: Int -> World -> World
, _wpSpread :: Float
, _wpRange :: Float
, _itHammer :: HammerPosition
, _itFloorPict :: Drawing
, _itMaxStack :: Int
, _itAmount :: Int
, _itAimingSpeed :: Float
, _itAimingRange :: Float
, _itZoom :: ItZoom
, _itEquipPict :: Creature -> Int -> Drawing
, _itScrollUp :: Int -> World -> World
, _itScrollDown :: Int -> World -> World
, _itIdentity :: ItemIdentity
, _itAttachment :: Maybe ItAttachment
, _itID :: Maybe Int
, _itEffect :: ItEffect
, _itInvDisplay :: Item -> String
, _itInvColor :: Color
}
| Consumable
{ _itName :: String
, _itMaxStack :: Int
, _itAmount :: Int
, _cnEffect :: Int -> World -> Maybe World
, _itFloorPict :: Drawing
, _itEquipPict :: Creature -> Int -> Drawing
, _itIdentity :: ItemIdentity
, _itID :: Maybe Int
, _itInvDisplay :: Item -> String
, _itInvColor :: Color
, _itEffect :: ItEffect
, _itHammer :: HammerPosition
}
| Craftable
{ _itName :: String
, _itMaxStack :: Int
, _itAmount :: Int
, _itFloorPict :: Drawing
, _itEquipPict :: Creature -> Int -> Drawing
, _itIdentity :: ItemIdentity
, _itID :: Maybe Int
, _itInvDisplay :: Item -> String
, _itInvColor :: Color
}
| Equipment
{ _itName :: String
, _itMaxStack :: Int
, _itAmount :: Int
, _itFloorPict :: Drawing
, _itEquipPict :: Creature -> Int -> Drawing
, _itIdentity :: ItemIdentity
, _itEffect :: ItEffect
, _itID :: Maybe Int
, _itAimingSpeed :: Float
, _itAimingRange :: Float
, _itZoom :: ItZoom
, _itInvDisplay :: Item -> String
, _itInvColor :: Color
, _itHammer :: HammerPosition
}
| Throwable
{ _itName :: String
, _itMaxStack :: Int
, _itAmount :: Int
, _itFloorPict :: Drawing
, _twMaxRange :: Float
, _twAccuracy :: Float
, _twFire :: Int -> World -> World
, _itAimingSpeed :: Float
, _itAimingRange :: Float
, _itZoom :: ItZoom
, _itEquipPict :: Creature -> Int -> Drawing
, _itIdentity :: ItemIdentity
, _itID :: Maybe Int
, _itAttachment :: Maybe ItAttachment
, _itInvDisplay :: Item -> String
, _itInvColor :: Color
, _itEffect :: ItEffect
, _itHammer :: HammerPosition
, _itScrollUp :: Int -> World -> World
, _itScrollDown :: Int -> World -> World
}
| NoItem
data ItAttachment
= ItScope {_scopePos :: Point2
,_scopeZoomChange :: Int
,_scopeZoom :: Float
,_scopeIsCamera :: Bool
}
| ItFuse {_itFuseTime :: Int}
| ItPhaseV {_itPhaseV :: Float}
| ItMode {_itMode :: Int}
data ItEffect = NoItEffect
| ItInvEffect {_itInvEffect :: Creature -> Int -> World -> World
,_itEffectCounter :: Int
}
| ItEffect {_itInvEffect :: Creature -> Int -> World -> World
,_itFloorEffect :: Int -> World -> World
,_itEffectCounter :: Int
}
data ItZoom = ItZoom {_itAimZoomMax :: Float
,_itAimZoomMin :: Float
,_itAimZoomFac :: Float
,_itZoomMax :: Float
,_itZoomMin :: Float
,_itZoomFac :: Float
}
data IntID a = IntID Int a
data HammerPosition = HammerDown
| HammerReleased
| HammerUp
| NoHammer
data ItemIdentity
= Pistol
| SpreadGun
| MultGun
| HvAutoGun
| AutoGun
| LtAutoGun
| MiniGun
| Medkit25
| MagShield
| FrontArmour
| JetPack
| FlameShield
| Generic
| SparkGun
| ShatterGun
| LongGun
| Flamethrower
| Blinker
| Grenade
| RemoteBomb
| TeslaGun
| LasGun
| ForceFieldGun
| GrapGun
| TractorGun
| Launcher
| RemoteLauncher
| LightningGun
| PoisonSprayer
deriving (Eq,Show,Ord,Enum)
data Particle' =
Particle' { _ptPict' :: Drawing
, _ptUpdate' :: World -> Particle' -> (World, Maybe Particle')
}
| Bul' { _ptPict' :: Drawing
, _ptUpdate' :: World -> Particle' -> (World, Maybe Particle')
, _btVel' :: Point2
, _btColor' :: Color
, _btTrail' :: [Point2]
, _btPassThrough' :: Maybe Int
, _btWidth' :: Float
, _btTimer' :: Int
, _btHitEffect' :: HitEffect'
}
| Pt' { _ptPict' :: Drawing
, _ptUpdate' :: World -> Particle' -> (World, Maybe Particle')
, _btVel' :: Point2
, _btColor' :: Color
, _btPos' :: Point2
, _btPassThrough' :: Maybe Int
, _btWidth' :: Float
, _btTimer' :: Int
, _btHitEffect' :: HitEffect'
}
| Shockwave'
{ _ptPict' :: Drawing
, _ptUpdate' :: World -> Particle' -> (World, Maybe Particle')
, _btColor' :: Color
, _btPos' :: Point2
, _btRad' :: Float
, _btDam' :: Int
, _btPush' :: Float
, _btMaxTime' :: Int
, _btTimer' :: Int
}
type HitEffect = Point2 -> Point2 -> (Point2, (Either3 Creature Wall ForceField)) -> World -> World
type HitEffect' = Particle' -> (Point2, (Either3 Creature Wall ForceField)) -> World -> World
data Particle =
Particle { _ptPos :: Point2
, _ptStartPos :: Point2
, _ptVel :: Point2
, _ptPict :: Drawing
, _ptID :: Int
, _ptUpdate :: World -> World
}
| Bullet { _ptPos :: Point2
, _ptVel :: Point2
, _ptPict :: Drawing
, _ptID :: Int
, _ptUpdate :: World -> World
, _btTrail :: [Point2]
, _btPassThrough :: Maybe Int
, _btColor :: Color
, _btWidth :: Float
-- , _btHitEffect :: Particle -> [(Point2, Either3 Creature Wall ForceField)] -> World -> World
}
| Bullet'
{ _ptPos :: Point2
, _ptVel :: Point2
, _ptPict :: Drawing
, _ptID :: Int
, _ptUpdate :: World -> World
}
data DamageType = Piercing {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 }
| Blunt {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 }
| SparkDam {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 }
| Flaming {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 }
| Lasering {_dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 }
| Concussive {_dmAmount :: Int , _dmFrom :: Point2 , _dmPush :: Float
, _dmPushExp :: Float
, _dmPushRadius :: Float}
| TorqueDam {_dmAmount :: Int , _dmTorque :: Float }
| PushDam {_dmAmount :: Int , _dmPushBack :: Point2 }
| PoisonDam {_dmAmount :: Int}
deriving (Eq,Ord,Show)
data Either3 a b c = E3x1 a | E3x2 b | E3x3 c
data Smoke =
Smoke
{ _smPos :: Point2
, _smRad :: Float
, _smColor :: Color
, _smUpdate :: Smoke -> Maybe Smoke
, _smPs :: [Point2]
, _smTime :: Int
}
data WLID = WLID { _wlIDx :: Int, _wlIDy :: Int, _wlIDid :: Int}
data Wall = Wall
{ _wlLine :: [Point2] , _wlID :: Int
, _wlColor :: Color
, _wlDraw :: Maybe (Wall -> Drawing)
, _wlSeen :: Bool
, _wlIsSeeThrough :: Bool
-- , _wlID' :: WLID
}
| BlockAutoDoor
{ _wlLine :: [Point2]
, _wlID :: Int
, _doorMech :: World -> World
, _wlColor :: Color
, _wlDraw :: Maybe (Wall -> Drawing)
, _wlSeen :: Bool
, _blIDs :: [Int]
, _blHP :: Int
, _wlIsSeeThrough :: Bool
-- , _wlID' :: WLID
}
| AutoDoor
{ _wlLine :: [Point2] , _wlID :: Int
, _doorMech :: World -> World
, _wlColor :: Color
, _wlDraw :: Maybe (Wall -> Drawing)
, _wlSeen :: Bool
, _wlIsSeeThrough :: Bool
-- , _wlID' :: WLID
-- , _doorLine :: [Point2]
}
| Door
{ _wlLine :: [Point2] , _wlID :: Int
, _doorMech :: World -> World
, _wlColor :: Color
, _wlDraw :: Maybe (Wall -> Drawing)
, _wlSeen :: Bool
, _wlIsSeeThrough :: Bool
-- , _wlID' :: WLID
-- , _doorLine :: [Point2]
}
| Block
{ _wlLine :: [Point2]
, _wlID :: Int
, _wlColor :: Color
, _wlDraw :: Maybe (Wall -> Drawing)
, _wlSeen :: Bool
, _blIDs :: [Int]
, _blHP :: Int
, _wlIsSeeThrough :: Bool
, _blVisible :: Bool
, _blShadows :: [Int]
, _blDegrades :: [Int]
-- , _wlID' :: WLID
}
data Block' = Block'
{ _blPoly :: [Point2]
, _blLines :: [[Point2]]
, _blColor :: Color
, _blSeen :: Bool
, _blHP' :: [Int]
, _blVisible' :: Bool
, _blShadows' :: [Int]
, _blID :: Int
}
data ForceField = FF { _ffLine :: [Point2] , _ffID :: Int
, _ffColor :: Color
, _ffDeflect :: Maybe (StdGen -> Point2 -> ForceField -> (Point2,StdGen))
, _ffState :: FFState
}
data FFState = FFDestroyable { _ffsHP :: Int }
data Ammo = PistolBullet | LiquidFuel | Battery | Shell
deriving (Eq,Ord,Enum)
data SoundOrigin = InventorySound
| BackgroundSound
| OnceSound
| CrSound Int
| CrWeaponSound Int
| WallSound Int
| CrReloadSound Int
| Flamer
| ShellSound Int
| Flame
| LasSound
| FootstepSound Int
| BlockDegradeSound Int
| CrHitSound Int
| BarrelHiss Int
deriving (Eq,Ord,Show)
type Poly = [Point2]
data PSType = PutCrit Creature
| PutLS LightSource Drawing
| PutButton Button
| PutFlIt FloorItem
| PutPressPlate PressPlate
| PutAutoDoor Point2 Point2
| PutBlock [Int] Color [Point2]
| PutWindowBlock Point2 Point2
| PutTriggerDoor Color (World -> Bool) Point2 Point2
| PutBtDoor Color Point2 Float Point2 Point2
| PutSwitchDoor Color Point2 Float Point2 Point2
| RandPS (State StdGen PSType)
| PutNothing
| CollectivePS
{ _collectiveID :: Int
, _collectiveNum :: Int
, _collectiveFunction :: [Int] -> State StdGen [PSType]
}
| LabelPS { _psLabel :: Int, _ps :: PSType}
| PutWindow { _pwPoly :: [Point2]
, _pwColor :: Color
}
data PlacementSpot = PS
{ _psPos :: Point2
, _psRot :: Float
, _psType :: PSType
}
data Room = Room
{ _rmPolys :: [Poly]
, _rmLinks :: [(Point2,Float)]
, _rmPath :: [(Point2, Point2)]
, _rmPS :: [PlacementSpot]
, _rmBound :: Poly
}
data SubNode a = SN a | InLink | OutLink
data RoomLink = RL {_rlPos :: Point2, _rlRot :: Float}
makeLenses ''RoomLink
makeLenses ''World
makeLenses ''Cloud
makeLenses ''Creature
makeLenses ''CreatureState
makeLenses ''CrSpState
makeLenses ''Goal
makeLenses ''LightSource
makeLenses ''TempLightSource
makeLenses ''Stance
makeLenses ''Carriage
makeLenses ''Posture
makeLenses ''Item
makeLenses ''ItemPos
makeLenses ''ItEffect
makeLenses ''ItAttachment
makeLenses ''ItZoom
makeLenses ''FloorItem
makeLenses ''Particle
makeLenses ''Particle'
makeLenses ''Wall
makeLenses ''Smoke
makeLenses ''ForceField
makeLenses ''FFState
makeLenses ''PressPlate
makeLenses ''Button
makeLenses ''PSType
makeLenses ''PlacementSpot
makeLenses ''Room
makeLenses ''Sound
--
-- }}}
numColor :: Int -> Color
numColor 0 = (1,0,0,1)
numColor 1 = (0,1,0,1)
numColor 2 = (0,0,1,1)
numColor 3 = (1,1,0,1)
numColor 4 = (0,1,1,1)
numColor 5 = (1,0,1,1)
numColor 6 = (1,0,0.5,1)
numColor 7 = (0.5,0,1,1)
numColor 8 = (0,0.5,1,1)
numColor 9 = (0,1,0.5,1)
numColor 10 = (0.5,1,0,1)
numColor 11 = (1,0.5,0,1)
numColor 12 = (1,1,1,1)
src/Dodge/Debug.hs
+50
View File
@@ -0,0 +1,50 @@
module Dodge.Debug where
import Dodge.Data
import Dodge.Base
import Geometry.Data
import Picture
import Control.Lens
import qualified Data.IntMap.Strict as IM
drawCircleAtFor :: Point2 -> Int -> World -> World
drawCircleAtFor p t w =
let n = newParticleKey w
in over particles ( IM.insert n
Particle { _ptPos = p
, _ptStartPos = p
, _ptVel = (0,0)
, _ptPict = onLayer PtLayer $ uncurry translate p $ color white $ circleSolid 20
, _ptID = n
, _ptUpdate = ptTimer t n
} ) w
drawCircleAtForCol :: Point2 -> Int -> Color -> World -> World
drawCircleAtForCol p t col w =
let n = newParticleKey w
in over particles ( IM.insert n
Particle { _ptPos = p
, _ptStartPos = p
, _ptVel = (0,0)
, _ptPict = onLayer PtLayer $ uncurry translate p $ color col $ circleSolid 20
, _ptID = n
, _ptUpdate = ptTimer t n
} ) w
drawLineForCol :: [Point2] -> Int -> Color -> World -> World
drawLineForCol ps t col w =
let n = newParticleKey w
in over particles ( IM.insert n
Particle { _ptPos = head ps
, _ptStartPos = head ps
, _ptVel = (0,0)
, _ptPict = onLayer PtLayer $ color col $ lineOfThickness 5 ps
, _ptID = n
, _ptUpdate = ptTimer t n
} ) w
ptTimer :: Int -> Int -> World -> World
ptTimer 0 i = over particles (IM.delete i)
ptTimer time i = set (particles . ix i . ptUpdate) $ ptTimer (time - 1) i
src/Dodge/Initialisation.hs
+68
View File
@@ -0,0 +1,68 @@
module Dodge.Initialisation where
-- imports {{{
import Dodge.Prototypes
import Dodge.Data
import Dodge.Critters
import Dodge.Base
import Data.List
import Data.Char
import Data.Maybe
import Data.Function
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.PatriciaTree
import Codec.BMP
import qualified Data.ByteString as B
import Control.Lens
import Control.Applicative
import Control.Monad.State
import Control.Monad
import System.Random
import qualified Data.Set as S
import qualified Data.IntMap.Strict as IM
import qualified Data.Map as M
--import Graphics.Gloss
--import Graphics.Gloss.Interface.IO.Game
--import Graphics.Gloss.Geometry.Angle
--import Graphics.Gloss.Geometry.Line
--import qualified Graphics.Gloss.Data.Point.Arithmetic as PA
--import Graphics.Gloss.Data.Vector
--import Graphics.Gloss.Data.Point
import Foreign.ForeignPtr
import Control.Concurrent
import Data.Tree
initializeWorld :: World -> World
initializeWorld w = w
initialWorld = basicWorld
{ _keys = S.empty
, _cameraPos = (0,0)
, _cameraRot = 0
, _cameraZoom = 1
, _creatures = IM.fromList [(0,startCr)]
, _particles = IM.empty
, _walls = IM.empty
, _forceFields = IM.empty
, _floorItems = IM.empty
, _randGen = mkStdGen 2
, _mousePos = (0,0)
, _testString = []
, _yourID = 0
, _worldEvents = id
, _pressPlates = IM.empty
, _buttons = IM.empty
, _soundQueue = []
-- , _loadedSounds = IM.empty
, _sounds = M.empty
, _decorations = IM.empty
, _unlimitedAmmo = True
, _storedLevel = Nothing
, _menuState = LevelMenu 1
, _worldState = M.empty
, _windowX = 800
, _windowY = 840
}
src/Dodge/KeyEvents.hs
+190
View File
@@ -0,0 +1,190 @@
module Dodge.KeyEvents where
-- imports {{{
import Dodge.Data
import Dodge.Base
import Dodge.CreatureActions
import Dodge.SoundLogic
import Geometry
import Control.Lens
import Data.Maybe
import Data.Char
import Data.List
import Data.Function
import qualified Data.Set as S
import qualified Data.IntMap.Strict as IM
import SDL
--import Graphics.Gloss
--import Graphics.Gloss.Interface.IO.Game
-- }}}
pauseGame :: World -> World
pauseGame w = w {_menuState = PauseMenu}
handleEvent :: World -> Event -> Maybe World
handleEvent w e = case eventPayload e of
KeyboardEvent kev -> handleKeyEvent w kev
MouseMotionEvent mmev -> handleMouseMotionEvent w mmev
MouseButtonEvent mbev -> handleMouseButtonEvent w mbev
MouseWheelEvent mwev -> handleMouseWheelEvent w mwev
WindowSizeChangedEvent sev -> handleResizeEvent w sev
_ -> Just w
handleKeyEvent :: World -> KeyboardEventData -> Maybe World
handleKeyEvent w kev = case keyboardEventKeyMotion kev of
Released -> Just $ over keys (S.delete $ getKeycode kev) w
_ -> handlePressedKeyEvent (addKey (getKeycode kev) w) (keyboardEventRepeat kev) (getKeycode kev)
where getKeycode :: KeyboardEventData -> Keycode
getKeycode = keysymKeycode . keyboardEventKeysym
addKey :: Keycode -> World -> World
addKey k = over keys $ S.insert k
handlePressedKeyEvent :: World -> Bool -> Keycode -> Maybe World
handlePressedKeyEvent w True _ = Just w
handlePressedKeyEvent w _ keycode
= case keycode of
KeycodeEscape -> Nothing
-- KeycodeEscape -> Just $ pauseGame $ escapeMap w
KeycodeC -> Just $ pauseGame $ escapeMap w
KeycodeF -> Just $ dropItem w
KeycodeM -> Just $ toggleMap w
KeycodeP -> Just $ pauseGame $ escapeMap w
KeycodeR -> Just $ fromMaybe w $ reloadWeapon (_yourID w) w
KeycodeT -> Just $ testEvent w
KeycodeSpace -> Just $ spaceAction w
KeycodeQ -> Just $ w {_cameraRot = _cameraRot w + 0.01}
KeycodeE -> Just $ w {_cameraRot = _cameraRot w - 0.01}
_ -> Just w
handleMouseMotionEvent :: World -> MouseMotionEventData -> Maybe World
handleMouseMotionEvent w mmev
= Just $ set mousePos (fromIntegral x - 0.5*_windowX w
,0.5*_windowY w - fromIntegral y
) w
where P (V2 x y) = mouseMotionEventPos mmev
handleMouseButtonEvent :: World -> MouseButtonEventData -> Maybe World
handleMouseButtonEvent w mbev = case mouseButtonEventMotion mbev of
Released -> Just $ over mouseButtons (S.delete but) w
Pressed -> handlePressedMouseButton but $ over mouseButtons (S.insert but) w
where but = mouseButtonEventButton mbev
handlePressedMouseButton :: MouseButton -> World -> Maybe World
handlePressedMouseButton ButtonMiddle w = Just $ set lbClickMousePos (_mousePos w) w
handlePressedMouseButton _ w = Just w
handleMouseWheelEvent :: World -> MouseWheelEventData -> Maybe World
handleMouseWheelEvent w mwev =
case mouseWheelEventPos mwev of
V2 x y | y > 0 -> Just $ wheelUpEvent w
| y < 0 -> Just $ wheelDownEvent w
| otherwise -> Just $ w
-- case mouseWheelEventDirection mwev of
-- ScrollNormal -> Just $ wheelUpEvent w
-- ScrollFlipped -> Just $ wheelDownEvent w
handleResizeEvent :: World -> WindowSizeChangedEventData -> Maybe World
handleResizeEvent w sev = Just $ set windowX (fromIntegral x)
$ set windowY (fromIntegral y) w
where V2 x y = windowSizeChangedEventSize sev
toggleMap w = w & mapDisplay . _1 %~ not
escapeMap w = w & mapDisplay . _1 .~ False
wheelUpEvent :: World -> World
wheelUpEvent w
= case _mapDisplay w of
(True,z) -> w & mapDisplay . _2 .~ min 0.3 (z+(0.1*z))
_ | rbPressed -> fromMaybe w $ (yourItem w ^? itScrollUp) <*> pure (_crInvSel (you w))
<*> pure w
| lbPressed -> w {_cameraZoom = _cameraZoom w + 0.1}
| otherwise -> upInvPos w
where lbPressed = ButtonLeft `S.member` mbs
rbPressed = ButtonRight `S.member` mbs
mbs = _mouseButtons w
wheelDownEvent :: World -> World
wheelDownEvent w
= case _mapDisplay w of
(True,z) -> w & mapDisplay . _2 .~ max 0.05 (z-(0.1*z))
_ | rbPressed -> fromMaybe w $ (yourItem w ^? itScrollDown) <*> pure (_crInvSel (you w))
<*> pure w
| lbPressed -> w {_cameraZoom = max (_cameraZoom w - 0.1) 0.01}
| otherwise -> downInvPos w
where lbPressed = ButtonLeft `S.member` mbs
rbPressed = ButtonRight `S.member` mbs
mbs = _mouseButtons w
upInvPos :: World -> World
--upInvPos w = soundOnce 3 $ stopSoundFrom (CrReloadSound 0) $ set (creatures . ix (_yourID w) . crInvSel) x w
upInvPos w = stopSoundFrom (CrReloadSound 0) $ set (creatures . ix (_yourID w) . crInvSel) x w
where is = IM.keys $ _crInv $ _creatures w IM.! _yourID w
isis = is ++ is
x = before (_crInvSel (you w)) isis
downInvPos :: World -> World
--downInvPos w = playSoundFromFor InventorySound 3 2 $ stopSoundFrom (CrReloadSound 0) $ set (creatures . ix (_yourID w) . crInvSel) x w
downInvPos w = stopSoundFrom (CrReloadSound 0) $ set (creatures . ix (_yourID w) . crInvSel) x w
where is = IM.keys $ _crInv $ _creatures w IM.! _yourID w
isis = is ++ is
x = after (_crInvSel (you w)) isis
-- these are incomplete: should put in error case here!
before y (x:z:ys) | y == z = x
| otherwise = before y (z:ys)
after y (x:z:ys) | y == x = z
| otherwise = after y (z:ys)
mouseActionsCr :: S.Set MouseButton -> Creature -> Creature
mouseActionsCr keys cr
| rbPressed
= set ( crState . stance . posture) Aiming cr
| otherwise
= set ( crState . stance . posture) AtEase cr
where lbPressed = ButtonLeft `S.member` keys
rbPressed = ButtonRight `S.member` keys
-- wUp = MouseButton WheelUp `S.member` keys
-- -- wUp = Char 'q' `S.member` keys
-- wDown = MouseButton WheelDown `S.member` keys
mouseActionsWorld :: S.Set MouseButton -> World -> World
mouseActionsWorld keys w
| lbPressed && rbPressed
= useItemContinuous (_yourID w) w
| mbPressed
= set lbClickMousePos (_mousePos w) $ over cameraRot (\r-> r - rotation) w
| otherwise
= w
where lbPressed = ButtonLeft `S.member` keys
rbPressed = ButtonRight `S.member` keys
mbPressed = ButtonMiddle `S.member` keys
---wUp = MouseButton WheelUp `S.member` keys
---wDown = MouseButton WheelDown `S.member` keys
---theItem = _crInv (you w) IM.! _crInvSel (you w)
rotation = angleBetween (_mousePos w) (_lbClickMousePos 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) ++ map Right (IM.elems $ _buttons w)
pos (Right x) = _btPos x
pos (Left x) = _flItPos x
spaceAction :: World -> World
spaceAction w = case closestActiveObject w of
Just (Left flit) -> pickUpItem' flit w
Just (Right but) -> _btEvent but but w
Nothing -> w
testEvent :: World -> World
testEvent w = w
src/Dodge/Layout.hs
+187
View File
@@ -0,0 +1,187 @@
module Dodge.Layout where
-- imports {{{
import Dodge.Data
import Dodge.Weapons
import Dodge.Critters
import Dodge.LevelGen
import Dodge.Base
import Dodge.RandomHelp
import Dodge.Prototypes
import Dodge.Path
import Geometry
--
--import Graphics.Gloss
--import Graphics.Gloss.Data.Vector
--import Graphics.Gloss.Geometry.Line
--import Graphics.Gloss.Geometry.Angle
--
import Control.Monad.State
--import Control.Monad.Loops
import Control.Lens
import System.Random
import Data.List
import Data.Maybe
import Data.Tree
import Data.Either
import Data.Function
import qualified Data.Map as M
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Basic
import Data.Graph.Inductive.PatriciaTree
import Data.Graph.Inductive.NodeMap
import qualified Data.IntMap.Strict as IM
-- }}}
generateFromTree :: State StdGen (Tree Room) -> World -> World
generateFromTree t w = zoning $ placeSpots plmnts
$ w {_walls = wallsFromTree tr, _randGen = g
-- ,_loadedSounds = lSounds
,_pathGraph = path
,_pathGraph' = pairGraph
,_pathPoints = foldr insertPoint IM.empty (labNodes path)
,_pathInc = pinc}
where tr = evalState t $ _randGen w
plmnts = concatMap _rmPS $ flatten tr
g = _randGen w
-- lSounds = _loadedSounds w
path = pairsToGraph dist pairGraph
pairGraph = makePath tr
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
pinc = M.fromList $ pairsToIncidence pairGraph
zoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w))
w
wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize
= insertIMInZone x y wlid wl
| otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips
where (x,y) = zoneOfPoint $ (pHalf (_wlLine wl !! 0) (_wlLine wl !! 1))
wlid = _wlID wl
ips = map zoneOfPoint $ divideLine (2*zoneSize) (_wlLine wl !! 0) (_wlLine wl !! 1)
makePath :: Tree Room -> [(Point2,Point2)]
makePath = concat . map _rmPath . flatten
wallsFromTree :: Tree Room -> IM.IntMap Wall
wallsFromTree t = divideWalls $ foldr cutWalls IM.empty (concatMap _rmPolys $ flatten t)
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)
divideWallIn :: Wall -> IM.IntMap Wall -> IM.IntMap Wall
divideWallIn wl wls =
let (wl':newWls) = divideWall wl
k = newKey wls
newWls' = zipWith (\i w -> w {_wlID = i}) [k..] newWls
in foldr (\w -> IM.insert (_wlID w) w) wls (wl':newWls')
divideWalls :: IM.IntMap Wall -> IM.IntMap Wall
divideWalls wls = IM.foldr divideWallIn wls wls
collapseTree :: Tree (Tree (Either Room Room)) -> Tree (Either Room Room)
collapseTree = g . expandTreeBy f
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
g (Node (Right x) []) = Node (Right x) []
g (Node (Right x) xs) = Node (Left x) $ map g xs
g (Node y ys) = Node y $ map g ys
insertInZone :: Int -> Int -> a -> IM.IntMap (IM.IntMap a) -> IM.IntMap (IM.IntMap a)
insertInZone x y obj = IM.insertWith f x $ IM.singleton y obj
where f _ = IM.insert y obj
allPairs :: Eq a => [a] -> [(a,a)]
allPairs xs = [(x,y) | x <- xs, y <- xs, x /= y]
treePost :: [a] -> a -> Tree a
treePost [] y = Node y []
treePost (x:xs) y = Node x [treePost xs y]
randomiseLinks :: RandomGen g => Room -> State g (Tree (Either Room Room))
randomiseLinks r = do
newLinks <- shuffle $ init $ _rmLinks r
return $ connectRoom $ r {_rmLinks = newLinks ++ [last $ _rmLinks r]}
randLinks :: RandomGen g => Room -> State g Room
randLinks r = do
newLinks <- shuffle $ init $ _rmLinks r
return $ r {_rmLinks = newLinks ++ [last $ _rmLinks r]}
filterLinks :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room
filterLinks cond r = do
newLinks <- shuffle $ filter cond $ init $ _rmLinks r
return $ r {_rmLinks = newLinks ++ [last $ _rmLinks r]}
changeLinkTo :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room
changeLinkTo cond r = do
l <- takeOne $ filter cond $ _rmLinks r
let newLinks = delete l (_rmLinks r) ++ [l]
return $ r {_rmLinks = newLinks}
-- Left elements get new children, Right elements inherit the children from the
-- mapped over node
composeTreeWith :: (a -> Tree (Either b b)) -> Tree a -> Tree (Either b b)
composeTreeWith f (Node x []) = f x
composeTreeWith f (Node x xs) = paste xs $ f x
where paste xs (Node (Right y) _) = Node (Left y) (map (composeTreeWith f) xs)
paste xs (Node (Left y) ys) = Node (Left y) (map (paste xs) ys)
doPolysIntersect :: [Point2] -> [Point2] -> Bool
doPolysIntersect (p:ps) (q:qs)
= any isJust $ (\(a,b) (c,d) -> intersectSegSeg' a b c d) <$> pair1s <*> pair2s
where pair1s = zip (p:ps) (ps++[p])
pair2s = zip (q:qs) (qs++[q])
doPolysIntersect [] _ = False
doPolysIntersect _ [] = False
boundClip :: Tree Room -> Bool
boundClip t = or $ map (uncurry doPolysIntersect) [(x,y) | x<- xs, y<-xs, x>y]
++ map f [(ps,qs) | ps <- xs, qs <-xs, ps/=qs]
where xs = map _rmBound $ flatten t
f ([],qs) = False
f ((p:_),qs) = pointInPolygon p qs
noBoundClip :: Tree Room -> Bool
noBoundClip = not . boundClip
connectRoom :: a -> Tree (Either a a)
connectRoom r = Node (Right r) []
deadRoom :: a -> Tree (Either a a)
deadRoom r = Node (Left r) []
onRoot :: (a -> a) -> Tree a -> Tree a
onRoot f (Node t ts) = Node (f t) ts
shiftRoomTree :: Tree Room -> Tree Room
shiftRoomTree (Node t []) = Node t []
shiftRoomTree (Node t ts) = Node t $ zipWith (\l -> shiftRoomTree . onRoot (shiftRoomBy l . f))
(_rmLinks t)
ts
where f r = shiftRoomBy ((0,0) -.- (rotateV (pi-a) p),0) $ shiftRoomBy ((0,0),pi-a) r
where (p,a) = last $ _rmLinks r
shiftRoomBy :: (Point2,Float) -> Room -> Room
shiftRoomBy shift@(pos,rot) r =
over rmPolys (fmap (map (shiftPointBy shift)))
$ over rmLinks (fmap (shiftLinkBy shift))
$ over rmPath (map (shiftPathPointBy shift))
$ over rmPS (fmap (shiftPSBy shift))
$ over rmBound (map (shiftPointBy shift))
r
shiftPathPointBy s (p1,p2) = (shiftPointBy s p1, shiftPointBy s p2)
shiftLinkBy (pos,rot) (p,r) = (shiftPointBy (pos,rot) p, r + rot)
shiftPSBy (pos,rot) ps = case ps of
PS {} -> over psPos (shiftPointBy (pos,rot))
$ over psRot (+rot)
ps
src/Dodge/LevelGen.hs
+756
View File
@@ -0,0 +1,756 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
module Dodge.LevelGen where
-- imports {{{
import Dodge.Data
import Dodge.Base
import Dodge.SoundLogic
import Dodge.Prototypes
import Dodge.Block
import Geometry
import Picture
import System.Random
--import Graphics.Gloss
--import Graphics.Gloss.Geometry.Line
--import Graphics.Gloss.Geometry.Angle
--import Graphics.Gloss.Data.Vector
import Control.Monad.State
import Data.List
import Data.Function
import Control.Applicative
import Control.Lens
import Data.Maybe
import qualified Data.IntMap.Strict as IM
import qualified Data.Set as S
import qualified Data.Map as M
import Data.Graph.Inductive
import Data.Graph.Inductive.NodeMap
import Data.Tree
-- }}}
inSegSeg p1 p2 a1 a2 = myIntersectSegSeg p1' p2' a1' a2'
where p1' = p1 +.+ normalizeV (p1 -.- p2)
p2' = p2 +.+ normalizeV (p2 -.- p1)
a1' = a1 +.+ normalizeV (a1 -.- a2)
a2' = a2 +.+ normalizeV (a2 -.- a1)
--
--supposes that the quadrilateral points are given in anticlockwise order
-- cutOutQuad :: Point -> Point -> Point -> Point -> IM.IntMap Wall -> IM.IntMap Wall
-- cutOutQuad p1 p2 p3 p4 walls = cutLine p4 p1 . cutLine p3 p4 . cutLine p2 p3 . cutLine p1 p2 $ walls
collidePointAllWalls :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
collidePointAllWalls p1 p2 walls = IM.filter f walls
where f wall
= case myIntersectSegSeg p1 p2 (_wlLine wall !! 0) (_wlLine wall !! 1)
of Nothing -> False
_ -> True
-- returns walls that collide with lines, and the point of collision
collidePointAllWallsPoints :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Wall,Point2)
collidePointAllWallsPoints p1 p2 walls = IM.mapMaybe f walls
where f wall
= case myIntersectSegSeg p1 p2 (_wlLine wall !! 0) (_wlLine wall !! 1)
of Nothing -> Nothing
Just p -> Just (wall,p)
collidePointAllWallsPoints' :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Wall,[Point2])
collidePointAllWallsPoints' p1 p2 walls = IM.mapMaybe f walls
where f wall
= case myIntersectSegSeg p1 p2 (_wlLine wall !! 0) (_wlLine wall !! 1)
of Nothing -> Nothing
Just p -> Just (wall,[p])
collidePolygonWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap (Wall,[Point2])
collidePolygonWalls (p:ps) walls
= IM.unionsWith f (fmap g (zip (p:ps) (ps ++ [p])))
-- = fmap ($ walls) $ zipWith collidePointAllWallsPoints' (init ps) (tail ps)
--where f (x,xs) (_,ys) = (x,xs++ys)
where f (x,xs) (_,ys) = (x,xs++ys)
g (p1,p2) = collidePointAllWallsPoints' p1 p2 walls
-- -- assumes that walls meet in corners
-- there appears to be an issue when one wall point is inside and the other exactly on the polygon
-- this is probably an issue with collidePolygonwalls
existingWallChanges :: [Point2] -> (Wall,[Point2]) -> [Wall]
existingWallChanges poly (wall,ps) = catMaybes [w1,w2]
where wp1 = _wlLine wall !! 0
wp2 = _wlLine wall !! 1
c1 = head $ sortBy (compare `on` dist wp1) ps
c2 = head $ sortBy (compare `on` dist wp2) ps
--c1 = last ps
--c2 = last ps
w1 = if errorPointInPolygon 5 wp1 poly || wp1 == c1
then Nothing
else Just $ wall {_wlLine = [ wp1, c1 ] }
w2 = if errorPointInPolygon 6 wp2 poly || wp2 == c2
then Nothing
else Just $ wall {_wlLine = [ c2, wp2 ] }
removeWallsInPolygon :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
removeWallsInPolygon ps walls = IM.filter (not . cond) walls
-- where cond wall = pointInsidePolygon (_wlLine wall !! 0) ps
-- && pointInsidePolygon (_wlLine wall !! 1) ps
where cond wall = pointInsidePolygon (_wlLine wall !! 0) ps
&& pointInsidePolygon (_wlLine wall !! 1) ps
pointInsidePolygon :: Point2 -> [Point2] -> Bool
pointInsidePolygon p (x:xs) = all (\l -> not (uncurry isRHS l (p +.+ normalizeV s))) pairs
|| any (\l -> uncurry isOnLine l p) pairs
where pairs = zip (x:xs) (xs ++ [x])
s = ((1/fromIntegral (length (x:xs))) *.* (foldr1 (+.+) (x:xs)))
-.- p
-- ok, now to find out which new walls need to be drawn
drawCutWall :: (Point2, Point2) -> IM.IntMap Wall -> IM.IntMap Wall
drawCutWall (p1,p2) walls =
case maybeW of Just w -> if errorIsLHS 200 (_wlLine w !! 0) (_wlLine w !! 1) p3
then walls
else IM.insert k newWall walls
Nothing -> IM.insert k newWall walls
where p3 = 0.5 *.* (p1 +.+ p2)
p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
maybeW = wallOnLine p3 p4 walls
k = case IM.lookupMax walls
of Nothing -> 0
Just (j,_) -> j + 1
newWall = basicWall {_wlLine = [p1,p2], _wlID = k}
drawCutWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
drawCutWalls (q:qs) walls = foldr drawCutWall walls (zip (q:qs) (qs++[q]))
-- where (q:qs) = reverse $ orderPolygon
-- -- $ intersectPolygonWalls ps walls
-- $ maybeToList $ intersectSegSeg (20,0) (100,900) (-200,400) (200,400)
-- -- $ (++) ps $ nub $ concat $ IM.elems $ fmap snd $ collidePolygonWalls ps walls
-- I have no idea why collidePolygonWalls is sometimes dropping an intersection
-- point between the walls and the polygon
-- Trying a workaround
intersectPolygonWalls :: [Point2] -> IM.IntMap Wall -> [Point2]
intersectPolygonWalls ps walls = nub $ concat $ IM.elems $ IM.map (intersectSegsWall ps) walls
--intersectPolygonWalls (p:ps) walls = nub $ concat [intersectSegWalls s1 s2 walls | (s1,s2) <- segs]
-- where segs = zip (p:ps) (ps ++ [p])
intersectSegWalls s1 s2 ws = concatMap (intersectSegWall s1 s2) $ IM.elems ws
intersectSegsWall (p:ps) wall = concat [intersectSegWall s1 s2 wall | (s1,s2) <- zip (p:ps) (ps++[p])]
-- finds intersection, or any segment points contained in the wall
intersectSegWall s1 s2 w = catMaybes [myIntersectSegSeg s1 s2 w1 w2
-- ,intersectSegPoint w1 w2 s1
-- ,intersectSegPoint w1 w2 s2
]
where w1 = _wlLine w !! 0
w2 = _wlLine w !! 1
intersectSegPoint s1 s2 p = if isOnLine s1 s2 p then Just p else Nothing
-- new procedure: line by line
-- then remove all walls inside the polygon
-- abuses the list nature of wlLine
cutWall1 :: Point2 -> Point2 -> Wall -> Wall
cutWall1 p1 p2 wall = case maybeCP of
Nothing -> wall
Just cp -> wall {_wlLine = [cp,w0,w1]}
where wl = _wlLine wall
w0 = wl !! 0
w1 = wl !! 1
w0' = w0 +.+ normalizeV (w0 -.- w1)
w1' = w1 +.+ normalizeV (w1 -.- w0)
p1' = p1 +.+ normalizeV (p1 -.- p2)
p2' = p2 +.+ normalizeV (p2 -.- p1)
pT = p1' +.+ vNormal (normalizeV (p1 -.- p2))
pB = p1' -.- vNormal (normalizeV (p1 -.- p2))
--maybeCP = intersectSegSeg p1' p2' w0' w1'-- <|> intersectSegSeg w0 w1 pT pB
--maybeCP = inSegSeg p1 p2 w0 w1-- <|> intersectSegSeg w0 w1 pT pB
maybeCP = inSegSeg p1 p2 w0 w1-- <|> intersectSegSeg w0 w1 pT pB
--maybeCP = intersectSegSeg p1 p2 w0 w1-- <|> intersectSegSeg w0 w1 pT pB
cutWalls1 :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
cutWalls1 p1 p2 ws = foldr splitAndAdd ws $ IM.map (cutWall1 p1 p2) ws
where splitAndAdd w ws
= case _wlLine w of
(cp:w0:w1:[]) -> IM.insert (newKey ws) (w {_wlLine = [cp,w1]
,_wlID = newKey ws})
$ IM.insert (_wlID w) (w {_wlLine = [w0,cp]}) ws
(x:y:[]) -> ws
cutWallsPoints :: Point2 -> Point2 -> IM.IntMap Wall -> [Point2]
cutWallsPoints p1 p2 ws = map head $ filter (\xs -> length xs > 2)
$ IM.elems $ IM.map (_wlLine . cutWall1 p1 p2) ws
cutWallsProcess :: [Point2] -> IM.IntMap Wall -> ([Point2], IM.IntMap Wall)
cutWallsProcess (p:ps) ws = foldr f ([],ws) (zip (p:ps) (ps++[p]))
where f (p1,p2) (as,ws') = (as ++ cutWallsPoints p1 p2 ws', cutWalls1 p1 p2 ws')
cutWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
cutWalls qs walls = -- IM.filter (not . wallIsZeroLength) $ fuseWalls $
drawCutWalls rs $ IM.filter (not.wallIsZeroLength)
$ removeWallsInPolygon ps -- cwals
(fuseWallsWith zs cwals)
where (zs,cwals) = cutWallsProcess ps walls
ps = orderPolygon qs
--ps = orderPolygon $ map perturbToWallPoints qs
rs = orderPolygon $ nub $ zs ++ qs
-- perturbToWallPoints p = fromMaybe p $ find (\p1 -> dist p p1 < 1) wps
fusePoint :: [Point2] -> Point2 -> Maybe Point2
fusePoint ps p = find (\q -> dist p q < 5) ps
pointIfNotClose :: [Point2] -> Point2 -> Maybe Point2
pointIfNotClose ps p = case fusePoint ps p of
Nothing -> Just p
_ -> Nothing
fuseWall :: ([Point2], Wall) -> ([Point2], Wall)
fuseWall (ps, w) = (qs, w {_wlLine = newLine})
where wp0 = _wlLine w !! 0
wp0' = fromMaybe wp0 $ fusePoint ps wp0
ps0 = maybeToList (pointIfNotClose ps wp0) ++ ps
wp1 = _wlLine w !! 1
wp1' = fromMaybe wp1 $ fusePoint ps0 wp1
newLine = [wp0',wp1']
qs = catMaybes [pointIfNotClose ps wp0, pointIfNotClose ps0 wp1] ++ ps
fuseWalls :: IM.IntMap Wall -> IM.IntMap Wall
fuseWalls ws = snd $ IM.foldr fuseWalls' ([], IM.empty) ws
where fuseWalls' w (ps, ws) = let (qs, w') = fuseWall (ps, w)
in (qs, IM.insert (_wlID w') w' ws)
fuseWallsWith :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall
fuseWallsWith zs ws = snd $ IM.foldr fuseWalls' (zs, IM.empty) ws
where fuseWalls' w (ps, ws) = let (qs, w') = fuseWall (ps, w)
in (qs, IM.insert (_wlID w') w' ws)
wallIsZeroLength w = l !! 0 == l !! 1
where l = _wlLine w
treeTrunk :: [a] -> Tree a -> Tree a
treeTrunk [] t = t
treeTrunk (x:xs) t = Node x [treeTrunk xs t]
applyToRoot :: (a -> a) -> Tree a -> Tree a
applyToRoot f (Node x xs) = Node (f x) xs
placeSpots :: [PlacementSpot] -> World -> World
placeSpots pss w = foldr placeSpot w basicPlacements
where (collectivePlacements,basicPlacements) = partition typeIsCollective pss
typeIsCollective (ps@PS {}) = case _psType ps of CollectivePS {} -> True
_ -> False
typeIsCollective _ = False
groupedPlacements = groupBy ((==) `on` _collectiveID . _psType)
$ sortBy (compare `on` _collectiveID . _psType) collectivePlacements
placeSpot :: PlacementSpot -> World -> World
placeSpot ps w = case ps of
PS {_psPos = p, _psRot = rot, _psType = PutButton bt}
-> placeBt bt p rot w
PS {_psPos = p, _psRot = rot, _psType = PutFlIt fi}
-> placeFlIt fi p rot w
PS {_psPos = p, _psRot = rot, _psType = PutCrit cr}
-> placeCr cr p rot w
PS {_psPos = p, _psRot = rot, _psType = PutLS ls dec}
-> placeLS ls dec p rot w
PS {_psPos = p, _psRot = rot, _psType = PutPressPlate pp}
-> placePressPlate pp p rot w
PS {_psType = RandPS rgen}
-> placeSpot (set psType evaluatedType ps) (set randGen g w)
where (evaluatedType, g) = runState rgen (_randGen w)
PS {_psPos = p, _psRot = rot, _psType = PutTriggerDoor col f a b}
-> addTriggerDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
PS {_psPos = p, _psRot = rot, _psType = PutAutoDoor a b}
-> addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
PS {_psPos = p, _psRot = rot, _psType = PutBlock (hp:hps) col ps}
-> putBlock (map (shiftPointBy (p,rot)) ps) hp col False hps w
PS {_psPos = p, _psRot = rot, _psType = PutBtDoor c bp f a b}
-> addButtonDoor c (shiftPointBy (p,rot) bp) (f + rot)
(shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
PS {_psPos = p, _psRot = rot, _psType = PutSwitchDoor c bp f a b}
-> addSwitchDoor c (shiftPointBy (p,rot) bp) (f + rot)
(shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
PS {_psPos = p, _psRot = rot, _psType = PutWindowBlock a b}
-> putWindowBlock (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
PS {_psPos = p, _psRot = rot, _psType = PutWindow { _pwPoly = ps, _pwColor = c }}
-> rmCrossPaths $ over walls (addWindow (q:qs) c) w
where (q:qs) = translateS p $ rotateS rot ps
rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ zip (q:qs) (qs++[q])
_ -> w
class Shiftable a where
translateS :: Point2 -> a -> a
rotateS :: Float -> a -> a
instance {-# OVERLAPPING #-} Shiftable Point2 where
translateS = (+.+)
rotateS = rotateV
instance (Shiftable a,Shiftable b) => Shiftable (a, b) where
translateS p (x,y) = (translateS p x,translateS p y)
rotateS r (x,y) = ( rotateS r x, rotateS r y)
instance (Shiftable a) => Shiftable [a] where
translateS p x = map (translateS p) x
rotateS r x = map (rotateS r) x
instance Shiftable RoomLink where
translateS q (RL p r) = RL (p +.+ q) r
rotateS s (RL p r) = RL (rotateV s p) (r+s)
instance Shiftable PlacementSpot where
translateS p' (PS p r x) = PS (p +.+ p') r x
rotateS r' (PS p r x) = PS (rotateV r' p) (r + r') x
pairsToGraph :: (Ord a, Eq a, Eq b) => (a -> a -> b) -> [(a,a)] -> Gr a b
pairsToGraph f pairs = let nodes = nub (map fst pairs ++ map snd pairs)
pairs' = map (\(x,y)->(x,y,f x y)) pairs
in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM nodes >> insMapEdgesM pairs'
makeButton :: Color -> (World -> World) -> Button
makeButton c eff = Button
{ _btPict = onLayer WlLayer $ color c $ polygon $ rectNSEW 5 (-5) 10 (-10)
, _btPos = (0,0)
, _btRot = 0
, _btEvent = \b w -> eff . over buttons (IM.adjust turnOn (_btID b))
-- . set (buttons . ix (_btID b) . btPict)
-- (onLayer WlLayer $ color c $ polygon $ rectNSEW (-3) (-5) 10 (-10))
-- . set (buttons . ix (_btID b) . btState) BtNoLabel
-- . set (buttons . ix (_btID b) . btEvent) (\b -> return)
. soundOnce 1 $ w
, _btID = 0
, _btText = "Button"
--, _btText = "Button"
, _btState = BtOff
}
where
turnOn bt = bt {_btState = BtNoLabel, _btPict = onPict, _btEvent = (\_ -> id)}
onPict = (onLayer WlLayer $ color c $ polygon $ rectNSEW (-3) (-5) 10 (-10))
makeSwitch :: Color -> (World -> World) -> (World -> World) -> Button
makeSwitch c effOn effOff = Button
{ _btPict = offPict
, _btPos = (0,0)
, _btRot = 0
, _btEvent = flipSwitch
, _btID = 0
, _btText = "Switch"
, _btState = BtOff
}
where
flipSwitch b w = switchEffect b . soundOnce 1 $ w
switchEffect b = case _btState b of
BtOff -> effOn . over buttons (IM.adjust turnOn (_btID b))
BtOn -> effOff . over buttons (IM.adjust turnOff (_btID b))
offPict = onLayer WlLayer $ color c $ pictures [--translate (-8) 4 $ circleSolid 5
polygon $ rectNSEW (-2) (-5) (-10) (10)
,polygon [(-2,-5),(-10,4),(-6,4),(2,-5)]
]
onPict = onLayer WlLayer $ color c $ pictures [--translate (8) 4 $ circleSolid 5
polygon $ rectNSEW (-2) (-5) (-10) (10)
,polygon [(-2,-5), (6,4),( 10,4),(2,-5)]
]
turnOn :: Button -> Button
turnOn bt = bt {_btState = BtOn, _btPict = onPict}
turnOff :: Button -> Button
turnOff bt = bt {_btState = BtOff, _btPict = offPict}
-- probably don't have to rebuild the entire graph, oh well
addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> World -> World
addButtonDoor c btp btr a b w = over buttons (IM.insert bid bt)
$ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
$ set pathGraph newGraph
$ set pathGraph' newGraphPairs
$ addTriggerDoor c cond a b w
where bid = newKey $ _buttons w
cond w = BtNoLabel == (_btState $ _buttons w IM.! bid)
bt = (makeButton c eff) {_btPos = btp, _btRot = btr, _btID = bid}
(newGraphPairs,removedPairs) = partition (not . isJust . uncurry (intersectSegSeg' a b))
$ _pathGraph' w
newGraph = pairsToGraph dist newGraphPairs
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
eff w' = over pathGraph' (removedPairs ++)
. over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
f (x,y) = (x,y,dist x y)
addSwitchDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> World -> World
addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt)
$ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
$ set pathGraph newGraph
$ set pathGraph' newGraphPairs
$ addTriggerDoor c cond a b w
where bid = newKey $ _buttons w
cond w = BtOn == (_btState $ _buttons w IM.! bid)
bt = (makeSwitch c openDoor closeDoor) {_btPos = btp, _btRot = btr, _btID = bid}
(newGraphPairs,removedPairs) = partition (not . isJust . uncurry (intersectSegSeg' a b))
$ _pathGraph' w
newGraph = pairsToGraph dist newGraphPairs
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
openDoor w' = over pathGraph' (removedPairs ++)
. over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
f (x,y) = (x,y,dist x y)
closeDoor w' = over pathGraph' (\pg -> pg \\ removedPairs)
. over pathGraph (flip run_ $ delMapEdgesM removedPairs) $ w'
addTriggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> World -> World
addTriggerDoor c cond a b = over walls (triggerDoor c cond a b)
triggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
triggerDoor c cond a b wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoor c cond a b is
where i = newKey wls
is = [i..]
mkTriggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> [Int] -> [Wall]
mkTriggerDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPane c cond)
xs
[ [pld,hwd]
, [hwd,hwu]
, [hwu,plu]
, [plu,pld]
, [pru,hwu]
, [hwu,hwd]
, [hwd,prd]
, [prd,pru]
]
[ [plld,pld]
, [pld,plu]
, [plu,pllu]
, [pllu,plld]
, [prru,pru]
, [pru,prd]
, [prd,prrd]
, [prrd,prru]
]
where norm = 10 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
hw = 0.5 *.* (pl +.+ pr)
perp = 20 *.* normalizeV (pl -.- pr)
--perp = pl -.- hw
plu = pl +.+ norm
pld = pl -.- norm
pru = pr +.+ norm
prd = pr -.- norm
hwu = hw +.+ norm
hwd = hw -.- norm
pllu = plu +.+ perp
plld = pld +.+ perp
prru = pru -.- perp
prrd = prd -.- perp
addSound (x:xs) = f x : xs
f wl = over doorMech g wl
g dm w | dist wp pld > 2 && dist wp hwd > 2 = soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0
$ dm w
| otherwise = dm w
where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1
triggerDoorPane :: Color -> (World -> Bool) -> Int -> [Point2] -> [Point2] -> Wall
triggerDoorPane c cond n [a,b] [a',b'] = Door
{ _wlLine = [a,b]
, _wlID = n
, _doorMech = dm
, _wlColor = c
, _wlDraw = Nothing
, _wlSeen = False
, _wlIsSeeThrough = False
-- , _doorLine = [a,b,a',b']
}
where
dm w | cond w = flip (foldr changeZonedWall) zoneps
$ over walls (IM.adjust openDoor n) w -- . wlLine . ix 0) (mvPointToward a')
| otherwise = flip (foldr changeZonedWall') zoneps
$ over walls (IM.adjust closeDoor n) w -- . wlLine . ix 0) (mvPointToward a)
zoneps | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
| otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b
openDoor :: Wall -> Wall
openDoor wl = case _wlLine wl of
((!pa):(!pb):_) -> wl {_wlLine = [mvPointToward a' pa, mvPointToward b' pb]}
closeDoor :: Wall -> Wall
closeDoor wl = case _wlLine wl of
((!pa):(!pb):_) -> wl {_wlLine = [mvPointToward a pa, mvPointToward b pb]}
changeZonedWall (!x,!y)
= over wallsZone $ adjustIMZone openDoor x y n
changeZonedWall' (!x,!y)
= over wallsZone $ adjustIMZone closeDoor x y n
addAutoDoor :: Point2 -> Point2 -> World -> World
addAutoDoor a b = over walls (autoDoorAt a b)
removePathsCrossing :: Point2 -> Point2 -> World -> World
removePathsCrossing a b w = set pathGraph newGraph $ set pathGraph' pg'
$ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
w
where pg' = filter (not . isJust . uncurry (intersectSegSeg' a b)) $ _pathGraph' w
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
newGraph = pairsToGraph dist pg'
putBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World
putBlock (p:ps) i c b is w = foldr (uncurry removePathsCrossing) wWithBlock pairs
where pairs = zip (p:ps) (ps ++ [p])
wWithBlock = addBlock (p:ps) i c b is w
putWindowBlock :: Point2 -> Point2 -> World -> World
--putWindowBlock a b w = foldr makeBlockAt w $ zip ps ns
putWindowBlock a b w = removePathsCrossing a b $ foldr makeBlockAt w $ zip ps ns
where d = dist a b
rot = argV (b -.- a)
numPoints' = floor (d / 20)
numPoints = numPoints'*2
ns = take (numPoints+1) [0..]
ps = map (\i -> a +.+ i/ (fromIntegral numPoints) *.* (b -.- a))
$ map fromIntegral ns
k = newKey $ _walls w
ksAtN i = [k+i*4,k+i*4 + 1 ,k+i*4 +2, k+i*4+3]
bSide = d / (fromIntegral numPoints)
ds = [(-bSide,-10),(-bSide,10),(bSide,10),(bSide,-10)]
polyAtP p = map ((+.+) p . rotateV rot) ds
hp = 1
degradeHP = [5,5]
winCol = withAlpha 0.5 cyan
makeBlockAt :: (Point2,Int) -> World -> World
makeBlockAt (p,i) w =
let (k0:k1:k2:k3:_) = ksAtN i
(bl:tl:tr:br:_) = polyAtP p
shadows | i == 0 = ksAtN 1
| i == numPoints - 1 = ksAtN $ numPoints - 2
| otherwise = ksAtN (i-1) ++ ksAtN (i+1)
seen | even i = True
| otherwise = False
isLeftmost | i == 0 = True
| otherwise = False
isRightmost | i == numPoints = True
| otherwise = False
l = Block
{ _wlLine = [bl,tl]
, _wlID = k0
, _wlColor = winCol
, _wlDraw = Nothing
, _wlSeen = False
, _blIDs = ksAtN i
, _blHP = hp
, _wlIsSeeThrough = True
--, _blVisible = False
, _blVisible = isLeftmost
, _blShadows = shadows
, _blDegrades = degradeHP
}
t = Block
{ _wlLine = [tl,tr]
, _wlID = k1
, _wlColor = winCol
, _wlDraw = Nothing
, _wlSeen = False
, _blIDs = ksAtN i
, _blHP = hp
, _wlIsSeeThrough = True
, _blVisible = seen
, _blShadows = shadows
, _blDegrades = degradeHP
}
r = Block
{ _wlLine = [tr,br]
, _wlID = k2
, _wlColor = winCol
, _wlDraw = Nothing
, _wlSeen = False
, _blIDs = ksAtN i
, _blHP = hp
, _wlIsSeeThrough = True
--, _blVisible = False
, _blVisible = isRightmost
, _blShadows = shadows
, _blDegrades = degradeHP
}
b = Block
{ _wlLine = [br,bl]
, _wlID = k3
, _wlColor = winCol
, _wlDraw = Nothing
, _wlSeen = False
, _blIDs = ksAtN i
, _blHP = hp
, _wlIsSeeThrough = True
, _blVisible = seen
, _blShadows = shadows
, _blDegrades = degradeHP
}
f = IM.insert k0 l . IM.insert k1 t . IM.insert k2 r . IM.insert k3 b
in over walls f w
autoDoorAt :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
autoDoorAt a b wls = IM.union wls $ IM.fromList $ zip is $ mkAutoDoor a b is
where i = newKey wls
is = [i..]
mkAutoDoor :: Point2 -> Point2 -> [Int] -> [Wall]
mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane [pl,pr])
xs
[ [pld,hwd]
, [hwd,hwu]
, [hwu,plu]
, [pru,hwu]
, [hwu,hwd]
, [hwd,prd]
]
[ [plld,pld]
, [pld,plu]
, [plu,pllu]
, [prru,pru]
, [pru,prd]
, [prd,prrd]
]
where norm = 10 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
hw = 0.5 *.* (pl +.+ pr)
perp = 20 *.* normalizeV (pl -.- pr)
plu = pl +.+ norm
pld = pl -.- norm
pru = pr +.+ norm
prd = pr -.- norm
hwu = hw +.+ norm
hwd = hw -.- norm
pllu = plu +.+ perp
plld = pld +.+ perp
prru = pru -.- perp
prrd = prd -.- perp
addSound (x:xs) = f x : xs
f wl = over doorMech g wl
g dm w | dist wp pld > 1 && dist wp hwd > 1 = soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0
$ dm w
| otherwise = dm w
where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1
mvPointTowardAtSpeed :: Float -> Point2 -> Point2 -> Point2
mvPointTowardAtSpeed speed !ep !p
| dist p ep < speed = ep
| otherwise = p +.+ speed *.* normalizeV (ep -.- p)
mvPointToward :: Point2 -> Point2 -> Point2
mvPointToward ep p | dist p ep < 1 = ep
| otherwise = p +.+ normalizeV (ep -.- p)
drawAutoDoor :: Wall -> Drawing
drawAutoDoor wl = onLayerL [levLayer WlLayer, layer2]
$ pictures [color c $ polygon [x,x +.+ n2,y +.+ n2, y]
,color (dark c) $ line [x,y]
]
where
(x:y:_) = _wlLine wl
c = _wlColor wl
nm = errorNormalizeV 543 (y -.- x)
t = 5 *.* nm
n = vNormal t
n2 = 3 *.* n
layer2 | _wlIsSeeThrough wl = 0
| isJust $ wl ^? doorMech = 1
| otherwise = 2
autoDoorPane :: [Point2] -> Int -> [Point2] -> [Point2] -> Wall
autoDoorPane trigL n [a,b] [a',b'] = AutoDoor
{ _wlLine = [a,b]
, _wlID = n
, _doorMech = dm
, _wlColor = dim $ yellow
, _wlDraw = Just drawAutoDoor
, _wlSeen = False
, _wlIsSeeThrough = False
-- , _doorLine = [a,b,a',b']
}
where
dm w | crsNearLine 40 trigL w
= flip (foldr changeZonedWall) zoneps
$ over walls (IM.adjust openDoor n) w
| otherwise = flip (foldr changeZonedWall') zoneps
$ over walls (IM.adjust closeDoor n) w
mvP !ep !p = mvPointTowardAtSpeed 2 ep p
openDoor :: Wall -> Wall
openDoor wl = case _wlLine wl of
((!pa):(!pb):_) -> wl {_wlLine = [mvP a' pa, mvP b' pb]}
closeDoor :: Wall -> Wall
closeDoor wl = case _wlLine wl of
((!pa):(!pb):_) -> wl {_wlLine = [mvP a pa, mvP b pb]}
zoneps | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
| otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b
changeZonedWall (!x,!y)
= over wallsZone $ adjustIMZone openDoor x y n
changeZonedWall' (!x,!y)
= over wallsZone $ adjustIMZone closeDoor x y n
shiftPointBy (pos,rot) p = pos +.+ rotateV rot p
addWindow :: [Point2] -> Color -> IM.IntMap Wall -> IM.IntMap Wall
addWindow qs c wls = foldr (addPane c) wls pairs
where (p:ps) = orderPolygon qs
pairs = zip (ps ++ [p]) (p:ps)
addPane :: Color -> (Point2,Point2) -> IM.IntMap Wall -> IM.IntMap Wall
addPane c (p0,p1) wls = IM.insert (newKey wls) (Wall { _wlLine = [p0,p1]
, _wlID = newKey wls
, _wlColor = c
, _wlDraw = Nothing
, _wlSeen = False
, _wlIsSeeThrough = True
}
) wls
placeBt bt p rot w = over buttons addBT w
where addBT bts = IM.insert (newKey bts) (bt {_btPos = p, _btRot = rot, _btID = newKey bts}) bts
placeFlIt fi p rot w = over floorItems addFI w
where addFI fis = IM.insert (newKey fis) (fi {_flItPos = p, _flItRot = rot, _flItID = newKey fis}) fis
placePressPlate pp p rot w = over pressPlates addPP w
where addPP pps = IM.insert (newKey pps) (pp {_ppPos = p,_ppRot = rot}) pps
-- Left elements get new children, Right elements inherit the children from the
-- mapped over node
expandTreeBy :: (a -> Tree (Either b b)) -> Tree a -> Tree b
expandTreeBy f (Node x []) = fmap removeEither (f x)
where removeEither (Left y) = y
removeEither (Right y) = y
expandTreeBy f (Node x xs) = appendAndRemove $ f x
where appendAndRemove (Node (Left y) ys) = Node y (map appendAndRemove ys)
appendAndRemove (Node (Right y) _ ) = Node y (map (expandTreeBy f) xs)
expandTreeRand :: RandomGen g =>
(a -> State g (Tree (Either b b))) -> Tree a -> State g (Tree b)
expandTreeRand f (Node x []) = fmap (fmap removeEither) (f x)
where removeEither (Left y) = y
removeEither (Right y) = y
expandTreeRand f (Node x xs) = do
root <- f x
branches <- sequence $ map (expandTreeRand f) xs
return (appendAndRemove branches root)
where appendAndRemove :: [Tree a] -> Tree (Either a a) -> Tree a
appendAndRemove bran (Node (Left y) ys) = Node y (map (appendAndRemove bran) ys)
appendAndRemove bran (Node (Right y) _) = Node y bran
placeCr :: Creature -> Point2 -> Float -> World -> World
placeCr crF p rot w = over creatures addCr w
where addCr crs = IM.insert (newKey crs)
(crF {_crPos = p,_crOldPos = p,_crDir = rot,_crID = newKey crs})
crs
placeLS :: LightSource -> Drawing -> 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 (radToDeg rot) dec)
decs
src/Dodge/LightSources.hs
+25
View File
@@ -0,0 +1,25 @@
module Dodge.LightSources where
import Dodge.Data
import Dodge.Base
import Geometry
import Picture
--import Graphics.Gloss
--import Graphics.Gloss.Data.Vector
--import Graphics.Gloss.Geometry.Line
--import Graphics.Gloss.Geometry.Angle
import qualified Data.IntMap.Strict as IM
lightAt p i =
LS {_lsID = i
,_lsPos = p
,_lsDir = 0
,_lsRad = 300
,_lsIntensity = 0.25
}
basicLS = PutLS ls dec
where ls = lightAt (0,0) 0
dec = onLayer PtLayer $ color white $ circleSolid 8
src/Dodge/LoadSound.hs
+137
View File
@@ -0,0 +1,137 @@
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
-- pFireSound <- Mix.load "./data/sound/tap3.wav"
pFireSound <- Mix.load "./data/sound/tap3.wav"
click <- Mix.load "./data/sound/click1.wav"
reloadSound' <- Mix.load "./data/sound/reload1.wav"
tone440 <- Mix.load "./data/sound/tone440.wav"
pickupSound' <- Mix.load "./data/sound/pickUp.wav"
putdownSound' <- Mix.load "./data/sound/whiteNoiseFadeOut.wav"
fireSound' <- Mix.load "./data/sound/fire1.wav"
grenadeBang' <- Mix.load "./data/sound/grenade.wav"
tapQuiet' <- Mix.load "./data/sound/tapQuiet.wav"
twoStep' <- Mix.load "./data/sound/twoStep.wav"
healSound' <- Mix.load "./data/sound/heal.wav"
doorSound' <- Mix.load "./data/sound/slideDoor.wav"
twoStepSlow' <- Mix.load "./data/sound/twoStepSlow.wav"
knifeSound' <- Mix.load "./data/sound/knife.wav"
buzzSound' <- Mix.load "./data/sound/buzz.wav"
hitSound' <- Mix.load "./data/sound/hit1.wav"
autoGunSound' <- Mix.load "./data/sound/autoGun.wav"
shotgunSound' <- Mix.load "./data/sound/shotgun.wav"
teleSound' <- Mix.load "./data/sound/tele.wav"
longGunSound' <- Mix.load "./data/sound/longTap.wav"
launcherSound' <- Mix.load "./data/sound/tap4.wav"
smokeTrailSound' <- Mix.load "./data/sound/missileLaunch.wav"
foot1Sound' <- Mix.load "./data/sound/foot1.wav"
foot2Sound' <- Mix.load "./data/sound/foot2.wav"
lasSound' <- Mix.load "./data/sound/tone440sawtooth.wav"
teslaSound' <- Mix.load "./data/sound/Electrical-Welding.wav"
crankSlow' <- Mix.load "./data/sound/crankSlow.wav"
autoB' <- Mix.load "./data/sound/autoB.wav"
mini' <- Mix.load "./data/sound/mini1.wav"
impactA' <- Mix.load "./data/sound/Impact-A.wav"
impactB' <- Mix.load "./data/sound/Impact-B.wav"
impactC' <- Mix.load "./data/sound/Impact-C.wav"
impactD' <- Mix.load "./data/sound/Impact-D.wav"
glassShat1' <- Mix.load "./data/sound/Glass-Bottle-Shattering-A1.wav"
glassShat2' <- Mix.load "./data/sound/Glass-Bottle-Shattering-A2.wav"
glassShat3' <- Mix.load "./data/sound/Glass-Bottle-Shattering-A3.wav"
glassShat4' <- Mix.load "./data/sound/Glass-Bottle-Shattering-A4.wav"
glass1' <- Mix.load "./data/sound/Small-Piece-Of-Glass-Shattering-A1.wav"
glass2' <- Mix.load "./data/sound/Small-Piece-Of-Glass-Shattering-A2.wav"
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..]
$ [ pFireSound
, click
, reloadSound'
, tone440
, pickupSound'
, putdownSound'
, fireSound'
, grenadeBang'
, tapQuiet'
, twoStep'
, healSound'
, doorSound'
, twoStepSlow'
, knifeSound'
, buzzSound'
, hitSound' --15
, autoGunSound'
, shotgunSound'
, teleSound'
, longGunSound'
, launcherSound'
, smokeTrailSound'
, foot1Sound'
, foot2Sound'
, lasSound'
, teslaSound' --25
, crankSlow'
, autoB'
, mini'
, impactA'
, impactB' --30
, impactC'
, impactD'
, glassShat1' --33
, glassShat2'
, glassShat3'
, glassShat4'
, glass1' --37
, glass2'
, glass3'
, glass4' --40
, foamSpray'
]
-- updateSound :: World -> IO World
-- updateSound w
-- = do forM_ (_soundQueue w) (\n -> Mix.playOn (-1) 0 (_loadedSounds w IM.! n))
-- fmap (set soundQueue creatureSounds) $ stepSoundTimers $ w
-- -- = return $ set soundQueue creatureSounds w
-- -- = do forM_ (_soundQueue w) (\n -> Mix.playOn (-1) (_loadedSounds w IM.! n) 0)
-- -- fmap (set soundQueue creatureSounds) $ return w
-- where creatureSounds = []
soundOnce :: Int -> World -> World
soundOnce i = over soundQueue ((:) i)
--stepSoundTimers :: World -> IO World
--stepSoundTimers w = M.foldrWithKey stepSoundTimer (return w) (_sounds w)
-- ok, this is hard to reason about-- bugs can occur because I am unsure when
-- everything is evaluated
--stepSoundTimer :: SoundOrigin -> Sound -> IO World -> IO World
--stepSoundTimer so s w =
-- case _soundChannel s of
-- Nothing -> do w1 <- w
-- let soundChunk = _loadedSounds w1 IM.! _soundType s
---- n <- Mix.playingCount
-- channel <- Mix.playOn (-1) (-1) soundChunk
-- -- w2 <- w -- Note that using w2 instead of w1 in the
-- -- final return breaks the sound sometimes, must be
-- -- something to do with order of evaluation
-- return $ set (sounds . ix so . soundChannel) (Just $ fromIntegral channel) w1
-- Just channel -> case _soundTime s of
-- x | x > 0 -> fmap (set (sounds . ix so . soundTime) (x-1)) w
-- | x <= 0 -> do Mix.fadeOut channel (fromIntegral $ _soundFadeTime s+ 1)
-- fmap (over sounds (M.delete so)) w
-- the sound fade doesn't seem to like being 0
src/Dodge/Menu.hs
+103
View File
@@ -0,0 +1,103 @@
module Dodge.Menu where
-- imports {{{
import Dodge.Data
import Dodge.Rooms
import Dodge.Initialisation
import Dodge.SoundLogic
import Data.Tree
import Data.Maybe
import qualified Data.Set as S
import Control.Lens
import Control.Monad
import Control.Monad.State
import System.Exit
import System.Random
--import Graphics.Gloss.Interface.IO.Game
import SDL
-- }}}
keyPressedDown :: Event -> Maybe Keycode
keyPressedDown e = case eventPayload e of
KeyboardEvent (KeyboardEventData _ Pressed False keysym) -> Just $ keysymKeycode keysym
_ -> Nothing
menuEvents :: (Event -> World -> Maybe World) -> Event -> World -> Maybe World
menuEvents f e w = case _menuState w of
LevelMenu _ -> case keyPressedDown e of
Just KeycodeEscape -> Nothing
Just _ -> startLevel w >>= f e
_ -> Just w
PauseMenu -> case keyPressedDown e of
Just KeycodeEscape -> Nothing
Just KeycodeR -> return $ fromMaybe w $ _storedLevel w
Just KeycodeN -> Just $ putSound $ generateLevel 1
$ initialWorld {_randGen = _randGen w}
Just _ -> unpause w >>= f e
_ -> Just w
GameOverMenu -> case keyPressedDown e of
Just KeycodeEscape -> Nothing
Just KeycodeR -> Just $ fromMaybe w $ _storedLevel w
Just KeycodeN -> Just $ putSound $ generateLevel 1
$ initialWorld
{_randGen = _randGen w}
_ -> return w
_ -> f e w
where unpause w' = Just $ resumeSound $
w' {_menuState = InGame,_keys = S.empty}
startLevel = unpause . storeLevel
putSound = id -- set loadedSounds (_loadedSounds w)
--- menuCheckKeyEvents :: (Event -> World -> IO World) -> Event -> World -> IO World
--- menuCheckKeyEvents f e w = case _menuState w of
--- LevelMenu _ -> case e of
--- (EventKey (SpecialKey KeyEsc) Down _ _)
--- -> exitSuccess
--- (EventKey _ Down _ _) -> startLevel w >>= f e
--- _ -> return w
--- PauseMenu -> case e of
--- (EventKey (SpecialKey KeyEsc) Down _ _)
--- -> exitSuccess
--- (EventKey (Char 'r') Down _ _) -> return $ fromMaybe w $ _storedLevel w
--- (EventKey (Char 'n') Down _ _) -> fmap putSound $ generateLevel 1
--- $ initialWorld
--- {_randGen = _randGen w}
--- -- (EventKey (Char 'c') Down _ _) -> unpaused
--- -- (EventKey (Char 'p') Down _ _) -> unpaused
--- -- (EventKey (SpecialKey KeySpace) Down _ _) -> unpaused
--- (EventKey _ Down _ _) -> unpause w >>= f e
--- _ -> return w
--- GameOverMenu -> case e of
--- (EventKey (SpecialKey KeyEsc) Down _ _)
--- -> exitSuccess
--- (EventKey (Char 'r') Down _ _) -> return $ fromMaybe w $ _storedLevel w
--- (EventKey (Char 'n') Down _ _) -> fmap putSound $ generateLevel 1
--- $ initialWorld
--- {_randGen = _randGen w}
--- -- (EventKey (Char 'c') Down _ _) -> unpaused
--- _ -> return w
--- _ -> f e w
--- where unpause w' = do Mix.resume (-1)
--- return w' {_menuState = InGame,_keys = S.empty}
--- startLevel = unpause . storeLevel
--- putSound = set loadedSounds (_loadedSounds w)
--- -- there might be a better way to pass the loaded sounds around
updateRandGen :: World -> World
updateRandGen = over randGen (fst . split)
menuCheckUpdate :: (Float -> World -> IO World) -> Float -> World -> IO World
menuCheckUpdate f t w = case _menuState w of
InGame -> f t w
_ -> return w
storeLevel :: World -> World
storeLevel w = case _storedLevel w of
Nothing -> set storedLevel (Just w) w
_ -> w
src/Dodge/Path.hs
+171
View File
@@ -0,0 +1,171 @@
module Dodge.Path where
import Dodge.Data
import Dodge.Base
import Geometry
import Control.Monad
import Data.List
import Data.Maybe
import Data.Function
import Data.Graph.Inductive.Graph
import qualified Data.HashSet as HS
import qualified Data.Heap as HP
import qualified Data.Map as M
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.PatriciaTree
import Data.Graph.Inductive.Query.SP
worldGraph :: World -> Point2 -> HS.HashSet Point2
worldGraph w p = HS.unions $ fmap (\q -> HS.fromList $ pointsAlong w p (p +.+ q))
[(200,0),(-200,0),(0,200),(0,-200)]
pointsAlong :: World -> Point2 -> Point2 -> [Point2]
pointsAlong w p q = divideLineFixed 50 p p'
where p' = furthestPointWalkable p q $ wallsAlongLine p q w
divideLineFixed :: Float -> Point2 -> Point2 -> [Point2]
divideLineFixed x a b = fmap (\i -> a +.+ i * x *.* normalizeV (b -.- a))
$ fmap fromIntegral ns
where numPoints = floor $ dist a b / x
ns = [1 .. numPoints]
-- ok, astar or something like it
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'
makePath' :: (Point2 -> [Point2]) -> Point2 -> Point2 -> [Point2]
makePath' f s e = stepPath' f e $ (HP.singleton (0,(0,[s])) , [])
makeNode :: Point2 -> SearchedNodes
makeNode e = (HP.singleton (0,(0,[e])) , [])
tp1,tp2,tp3 :: Point2
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)]
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
----
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
ezipWith :: Monoid a => (b -> c -> d) -> Either a b -> Either a c -> Either a d
ezipWith f (Right x) (Right y) = Right (f x y)
ezipWith f (Left x) (Right _) = Left x
ezipWith f (Right _) (Left y) = Left y
ezipWith f (Left x) (Left y) = Left (mappend x y)
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
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' :: Point2 -> Point2 -> World -> Either String [Point2]
makePathBetweenPs' a b w = fmap (mapMaybe (lab g)) $ makePathBetween' a b w
where g = _pathGraph w
pointTowardsGoal :: Point2 -> Point2 -> World -> Maybe Point2
pointTowardsGoal a b w = join $ fmap (listToMaybe . filter (flip (isWalkable a) w))
-- $ pathBetween a b w
$ makePathBetweenPs a b w
--
pointTowardsGoal' :: Point2 -> Point2 -> World -> Either String Point2
pointTowardsGoal' a b w = join $ fmap (maybeToEither "NOSEEPATH" . listToMaybe . filter (flip (isWalkable a) w))
$ makePathBetweenPs' b a w
maybeToEither :: a -> Maybe b -> Either a b
maybeToEither _ (Just x) = Right x
maybeToEither y Nothing = Left y
pairsToIncidence :: (Eq a,Ord a) => [(a,a)] -> [(a,[a])]
pairsToIncidence = map ((\(xs,ys) -> (head xs,ys)) . unzip)
. groupBy ( (==) `on` fst)
. sort
incidenceToFunction :: Eq a => [(a,[a])] -> a -> [a]
incidenceToFunction xs a = case lookup a xs of Just ys -> ys
Nothing -> []
src/Dodge/Prototypes.hs
+250
View File
@@ -0,0 +1,250 @@
{-# LANGUAGE BangPatterns #-}
module Dodge.Prototypes where
import Dodge.Data
import Dodge.SoundLogic
import Dodge.Base
import Geometry
import Picture
import Control.Lens
import System.Random
import qualified Data.IntMap.Strict as IM
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Graph.Inductive.Graph hiding ((&))
import Data.List
--import Graphics.Gloss
--import Graphics.Gloss.Data.Vector
-- defalt datatypes / prototypes {{{
basicWall = Wall { _wlLine = [(0,0),(50,0)]
, _wlID = 0
, _wlColor = greyN 0.6
, _wlDraw = Nothing
, _wlSeen = False
, _wlIsSeeThrough = False
}
basicAutoDoor = AutoDoor { _wlLine = [(0,0),(50,0)]
, _wlID = 0
, _doorMech = id
, _wlColor = light $ dim $ dim $ dim $ yellow
, _wlDraw = Nothing
, _wlSeen = False
, _wlIsSeeThrough = False
}
basicDoor = Door { _wlLine = [(0,0),(50,0)]
, _wlID = 0
, _doorMech = id
, _wlColor = light $ dim $ dim $ dim $ yellow
, _wlDraw = Nothing
, _wlSeen = False
, _wlIsSeeThrough = False
}
basicCreature :: Creature
basicCreature = Creature
{ _crPos = (0,0)
, _crOldPos = (0,0)
, _crDir = 0
, _crID = 1
, _crPict = const $ onLayer CrLayer $ circleSolid 10
, _crUpdate = \ w f cr -> (f , Just cr)
, _crRad = 10
, _crMass = 10
, _crHP = 100
, _crMaxHP = 150
, _crInv = IM.empty
, _crInvSel = 0
, _crAmmo = M.empty
, _crState = basicState
, _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ circleSolid 10
}
basicState = CrSt { _goals = []
, _stance = Stance {_carriage=Walking 0 0,_posture=AtEase}
, _faction = NoFaction
, _crDamage = []
, _crPastDamage = 0
, _crSpState = GenCr
, _crApplyDamage = basicApplyDamage'
}
basicEquipment = Equipment
{ _itIdentity = Generic
, _itName = "genericEquipment"
, _itMaxStack = 1
, _itAmount = 1
, _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
, _itEquipPict = \cr _ -> blank
, _itEffect = NoItEffect
, _itHammer = HammerUp
, _itID = Nothing
, _itAimingSpeed = 1
, _itAimingRange = 0
, _itZoom = basicItZoom
, _itInvColor = yellow
, _itInvDisplay = _itName
}
basicItZoom = ItZoom 20 0.2 1 20 0.2 1
basicConsumable :: Item
basicConsumable = Consumable
{ _itIdentity = Generic
, _itName = "genericConsumable"
, _itMaxStack = 9
, _itAmount = 1
, _cnEffect = \_ _ -> Nothing
, _itFloorPict = onLayer FlItLayer $ color blue $ circleSolid 3
, _itEquipPict = \_ _ -> blank
, _itID = Nothing
, _itInvColor = blue
, _itInvDisplay = \it -> _itName it ++ " x" ++ show (_itAmount it)
, _itEffect = wpRecock
, _itHammer = HammerUp
}
basicApplyDamage' :: [DamageType] -> Creature -> (World -> World, Creature)
basicApplyDamage' ds cr = (id, doPoisonDam $ foldr (\d c -> snd $ basicApplyDamage d c) cr ds')
where (ps,ds') = partition isPoison ds
isPoison (PoisonDam {}) = True
isPoison _ = False
poisonDam = quot (max 0 (sum (map _dmAmount ps) - 0)) 10
doPoisonDam = over crHP (\hp -> hp - poisonDam)
basicApplyDamage :: DamageType -> Creature -> (World -> World, Creature)
basicApplyDamage (Concussive amount from push pushexp pushRad) cr
= ( id
, over crHP (\hp -> hp - amount)
$ over crPos (+.+ (pushAmount *.* safeNormalizeV (_crPos cr -.- from)))
cr
)
where pushAmount | dist (_crPos cr) from == 0
= 0
| otherwise = min 5 $
(push*5*pushRad / (dist (_crPos cr) from * _crMass cr))**pushexp
basicApplyDamage (TorqueDam amount rot) cr
= ( id
, over crHP (\hp -> hp - amount) $ over crDir (+ rot) cr)
basicApplyDamage (PushDam amount pback) cr
= ( id
, over crHP (\hp -> hp - amount) $ over crPos (+.+ ((1/_crMass cr) *.* pback )) cr
)
basicApplyDamage dt cr
= ( id , over crHP (\hp -> hp - _dmAmount dt) cr )
basicFlIt = FlIt {_flItRot=0,_flIt = basicIt, _flItPos = (0,0), _flItID = 0}
basicIt = Consumable
{ _itIdentity = Medkit25
, _itName = "basicIt"
, _itMaxStack = 3
, _itAmount = 2
, _cnEffect = \ _ -> return
, _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
, _itEquipPict = \cr _ -> blank
, _itID = Nothing
, _itInvDisplay = _itName
, _itInvColor = blue
, _itEffect = NoItEffect
, _itHammer = HammerUp
}
basicButton = 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
, _btID = 0
, _btText = "Button"
, _btState = BtOff
}
basicPT = Particle
{ _ptPos = (0,0)
, _ptStartPos = (0,0)
, _ptVel = (0,0)
, _ptPict = blank
, _ptID = 0
, _ptUpdate = id
}
basicPP = PressPlate
{ _ppPict = onLayer PressPlateLayer $ color (dim $ dim $ bright $ blue) $ circleSolid 5
, _ppPos = (0,0)
, _ppRot = 0
, _ppEvent = \pp -> id
, _ppID = -1
, _ppText = "Pressure plate"
}
-- }}}
basicWorld = World
{ _keys = S.empty
, _mouseButtons = S.empty
, _cameraPos = (0,0)
, _cameraAimTime = 0
, _cameraRot = 0
, _cameraZoom = 1
, _cameraCenter = (0,0)
, _creatures = IM.empty
, _creaturesZone = IM.empty
, _clouds = IM.empty
, _cloudsZone = IM.empty
, _itemPositions = IM.empty
, _particles = IM.empty
, _particles' = []
, _afterParticles' = []
, _walls = IM.empty
, _wallsZone = IM.empty
, _forceFields = IM.empty
, _floorItems = IM.empty
, _randGen = mkStdGen 2
, _mousePos = (0,0)
, _testString = []
, _yourID = 0
, _worldEvents = id
, _pressPlates = IM.empty
, _buttons = IM.empty
, _soundQueue = []
-- , _loadedSounds = IM.empty
, _sounds = M.empty
, _corpses = IM.empty
, _decorations = IM.empty
, _unlimitedAmmo = True
, _storedLevel = Nothing
, _menuState = LevelMenu 1
, _worldState = M.empty
, _lbClickMousePos = (0,0)
, _lbRotation = 0
, _pathGraph = Data.Graph.Inductive.Graph.empty
, _pathGraph' = []
, _pathPoints = IM.empty
, _pathInc = M.empty
, _windowX = 800
, _windowY = 840
, _smoke = []
, _mapDisplay = (False, 0.2)
, _lightSources = IM.empty
, _tempLightSources = [youLight]
}
youLight =
-- LS {_lsEff = \w _ p -> (logistic 1 1 1 (d p w * 0.01) )
TLS { _tlsPos = (0,0)
,_tlsRad = 300
,_tlsIntensity = 0.1
,_tlsUpdate = \w _ -> (w, Just (youLight {_tlsPos = _crPos (you w)}))
}
wpRecock :: ItEffect
--wpRecock = NoItEffect
wpRecock = ItInvEffect {_itInvEffect = f
,_itEffectCounter = 0
}
where f cr i = creatures . ix (_crID cr) . crInv
-- . ix i . itHammer %~ ($!) (fmap $! (moveHammerUp `seq` moveHammerUp))
-- . ix i . itHammer %~ ($!) (fmap $! moveHammerUp)
-- . ix i . itHammer . _Just %~ ($!) moveHammerUp
%~ IM.adjust fOnIt i
moveHammerUp !HammerDown = HammerReleased
moveHammerUp !HammerReleased = HammerUp
moveHammerUp !HammerUp = HammerUp
fOnIt it = it & itHammer %~ moveHammerUp
src/Dodge/RandomHelp.hs
+66
View File
@@ -0,0 +1,66 @@
module Dodge.RandomHelp where
import Geometry
import Geometry.Data
import System.Random
import Control.Monad.State
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 _ = []
takeOne :: RandomGen g => [a] -> State g a
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)))
where i y (z:zs) | y <= z = 0
| otherwise = 1 + i (y-z) zs
i y _ = 0
takeOneMore :: RandomGen g => ([a],[a]) -> State g ([a],[a])
takeOneMore (xs,ys) = do
i <- state $ randomR (0,length ys - 1)
let (zs, w:ws) = splitAt i ys
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]
takeN :: RandomGen g => Int -> [a] -> State g [a]
takeN i xs = fmap fst $ takeNMore i ([],xs)
-- to randomly shuffle a list
shuffle :: RandomGen g => [a] -> State g [a]
shuffle xs = do
let l = length xs
rands <- forM [0..l-1] $ \i -> state $ randomR (0,i)
let f ys rand = let (as,b:bs) = splitAt rand ys
in (as ++ bs, b)
let (_,zs) = mapAccumR f xs rands
return zs
randomSelectionFromList :: RandomGen g => Float -> [a] -> State g [a]
randomSelectionFromList p = filterM $ const $ randProb p
randProb :: RandomGen g => Float -> State g Bool
randProb p = do p1 <- state $ randomR (0,1)
return (p1 < p)
randInCirc :: RandomGen g => Float -> State g Point2
randInCirc maxRad = do rad <- state $ randomR (0,maxRad)
ang <- state $ randomR (0,2*pi)
return $ rad *.* unitVectorAtAngle ang
randInRect :: RandomGen g => Float -> Float -> State g Point2
randInRect w h = do x <- state $ randomR (0,w)
y <- state $ randomR (0,h)
return (x,y)
maybeTakeOne :: RandomGen g => [a] -> State g (Maybe a)
maybeTakeOne [] = return Nothing
maybeTakeOne xs = state (randomR (0,length xs - 1)) >>= (\i -> return (Just (xs !! i)))
src/Dodge/Rendering.hs
+512
View File
@@ -0,0 +1,512 @@
module Dodge.Rendering where
-- imports {{{
import Dodge.Data
import Dodge.Base
import Geometry
import Picture
import Data.Graph.Inductive.Query.DFS
import Data.Graph.Inductive.Graph
import Control.Monad.State
import Data.List
import Data.Bifunctor
import Data.Function
import Control.Applicative
import Control.Lens
import Data.Maybe
import qualified Data.IntMap.Strict as IM
import qualified Data.Map as M
import qualified Data.Set as S
-- }}}
--
drawTest :: World -> Picture
drawTest w = screenT $ color red $ circle 200
where (x,y) = (_windowX w,_windowY w)
screenT = scale (1/x) (1/y)
draw' :: Picture -> World -> ([((Float,Float),(Float,Float))]
,[((Float,Float),Float,Float)]
,Picture,Picture)
draw' p w = (\(x,y) -> (wallsForGloom w,lightsForGloom w,x,y)) (draw'' p w)
draw :: Picture -> World -> Picture
draw p w = (\(x,y) -> f $ pictures [x,y]) $ draw'' p w
where f = scale (2/_windowX w) (2/_windowY w)
draw'' :: Picture -> World -> (Picture , Picture)
draw'' b w-- | (Char 'm') `S.member` _keys w
-- = let a = (-500,30)
-- b = (200,0)
-- in pictures [ color white $ polygon screenBox
-- , color blue $ circleSolid 40
-- , line [a,b]
-- , uncurry translate (ssaTriPoint a (0,0) b 40)
-- $ color red $ circleSolid 5
-- ]
= case _mapDisplay w of
(True, z) -> (blank
,pictures [color white $ circleSolid 3
,scale z z $ rotate (radToDeg (_cameraRot w))
$ uncurry translate ((0,0) -.- _cameraCenter w)
$ pictures $ mapMaybe mapWall $ IM.elems $ _walls w]
)
_ -> ( blank
--,pictures $ map fst pics
,collectDrawings w
)
-- ++ map screenShift (pathsTest ++ map drawNode (labNodes $ _pathGraph w))
where yourPos = _crPos $ you w
backgroundTile = [screenShift $ translate (5*512*x) (5*512*y) $ scale 5 5 b | x <- [x1..x2] , y <- [y1..y2] ]
where (x',y') = yourPos
(x'',y'') = (fromIntegral $ round (x'/(512*5)), fromIntegral $ round (y'/(512*5)))
x1 = (x''-1)
x2 = (x''+1)
y1 = (y''-1)
y2 = (y''+1)
screenShift = scale zoom zoom . rotate (radToDeg (_cameraRot w) )
. uncurry translate ((0,0) -.- _cameraPos w)
zoom = _cameraZoom w
pathsTest = map drawPair $ _pathGraph' w
drawPair (x,y) = color cyan $ pictures [line [x,y]
-- , uncurry translate x $ scale 0.05 0.05 $ text $ show x
]
drawNode (i,x) = color yellow $ uncurry translate x $ scale 0.05 0.05 $ text $ show i
collectDrawings :: World -> Picture
collectDrawings w = screenShift (decPicts <> ppPicts <> itFloorPicts
<> crPicts
<> clPicts
<> buttonPicts <> ptPicts
<> ptPicts'
<> afterPtPicts'
<> wlPicts
<> wallShadows
<> smokeShadows
)
<> onLayer LabelLayer
(itLabels <> ppLabels <> btLabels)
<> hudDrawings w
<> onLayer MenuLayer menuScreen
-- <> [onLayer GloomLayer $ theLighting w]
where
screenShift = scale zoom zoom . rotate (radToDeg (_cameraRot w) )
. uncurry translate ((0,0) -.- _cameraPos w)
rotPicts = map (scale zoom zoom . rotate (radToDeg (_cameraRot w)))
zoom = _cameraZoom w
decPicts :: Picture
decPicts = mconcat $ IM.elems $ _decorations w
ptPicts = mconcat $ map _ptPict (IM.elems (_particles w))
ptPicts' = mconcat $ map _ptPict' $ _particles' w
afterPtPicts' = mconcat $ map _ptPict' $ _afterParticles' w
buttonPicts = mconcat $ map btDraw (IM.elems (_buttons w))
ppPicts = mconcat $ map ppDraw (IM.elems (_pressPlates w))
crPicts :: Picture
crPicts = mconcat $ map crDraw $ IM.elems $ _creatures w
clPicts = mconcat $ map clDraw $ IM.elems $ _clouds w
wallShadows = mconcat $ map (drawWallShadow w) $ wallShadowsToDraw w
smokeShadows = mconcat $ map (drawSmokeShadow w) $ _smoke w
wlPicts = mconcat $ map drawWall (wallsToDraw w)
yourPos = _crPos $ you w
yourRot = _crDir $ you w
yourRad = _crRad $ you w
-- itFloorPicts = zipWith (uncurry translate) (map _flItPos (IM.elems (_floorItems w)))
-- (map (_itFloorPict . _flIt) (IM.elems (_floorItems w)))
itFloorPicts = mconcat $ map (drawItem) (IM.elems (_floorItems w))
itLabels = mconcat $ map (drawItemName w) (IM.elems (_floorItems w))
ppLabels = mconcat $ map (drawPPText w) (IM.elems (_pressPlates w))
btLabels = mconcat $ map (drawButText w) (IM.elems (_buttons w))
menuScreen :: Picture
menuScreen = case _menuState w of
InGame -> blank
LevelMenu x ->
mconcat [color (withAlpha 0.5 black) $ polygon $ screenBox w
,tst (-100) 100 0.4 ("LEVEL "++show x)
] <> controlsList
PauseMenu -> mconcat [color (withAlpha 0.5 black) $ polygon $ screenBox w
,tst (-100) 100 0.4 "PAUSED"
,tst (-100) 50 0.2 "n - new level"
,tst (-100) 0 0.2 "r - restart"
] <> controlsList
GameOverMenu -> mconcat [color (withAlpha 0.5 black) $ polygon $ screenBox w
,tst (-100) 100 0.4 "GAME OVER"
,tst (-100) 50 0.2 "n - new level"
,tst (-100) 0 0.2 "r - restart"
]
<> controlsList
where tst x y sc t = translate x y $ scale sc sc $ color white $ text t
hudDrawings :: World -> Picture
hudDrawings w = (onLayer InvLayer)
$ displayInv 0 w
<> mconcat
[ dShadCol white $ displayHP 0 w
, dShadCol (itCol (yourItem w))
$ drawCursor w, translate (-390) 20
$ scale 0.05 0.05 $ dShadCol white $ text (_testString w)
]
where itCol = fromMaybe (greyN 0.5) . (^? itInvColor)
crDraw :: Creature -> Drawing
crDraw c = uncurry translateDrawing (_crPos c) $ rotateDrawing (- radToDeg (_crDir c)) (_crPict c c)
ppDraw :: PressPlate -> Drawing
ppDraw c = uncurry translateDrawing (_ppPos c) $ rotateDrawing (- radToDeg (_ppRot c)) (_ppPict c)
btDraw :: Button -> Drawing
btDraw c = uncurry translateDrawing (_btPos c) $ rotateDrawing (- radToDeg (_btRot c)) (_btPict c)
clDraw :: Cloud -> Drawing
clDraw c = uncurry translateDrawing (_clPos c) $ (_clPict c c)
drawCursor :: World -> Picture
drawCursor w = translate (105-halfWidth w)
(halfHeight w - (25* (fromIntegral iPos)) - 20
)
-- $ rectangleWire 200 25
$ line [(200,12.5),(-100,12.5),(-100,-12.5),(200,-12.5)]
where iPos = _crInvSel $ _creatures w IM.! _yourID w
controlsList = mconcat [tst (-250) (-130) 0.15 "controls:"
,tst (-150) (-130) 0.15 "wasd"
,tst 0 (-130) 0.15 "movement"
,tst (-150) (-160) 0.15 "[rmb]"
,tst 0 (-160) 0.15 "aim"
,tst (-150) (-190) 0.15 "[rmb+lmb]"
,tst 0 (-190) 0.15 "shoot or use item"
,tst (-150) (-220) 0.15 "[wheelscroll]"
,tst 0 (-220) 0.15 "select item"
,tst (-150) (-250) 0.15 "[space]"
,tst 0 (-250) 0.15 "pickup item"
,tst (-150) (-280) 0.15 "f"
,tst 0 (-280) 0.15 "drop item"
,tst (-150) (-310) 0.15 "cp[esc]"
,tst 0 (-310) 0.15 "pause"
,tst (-150) (-340) 0.15 "qe[lmb]"
,tst 0 (-340) 0.15 "rotate camera"
]
where tst x y sc t = translate x y $ scale sc sc $ color white $ text t
screenBox w = [ (halfWidth w, halfHeight w)
, (-halfWidth w, halfHeight w)
, (-halfWidth w,-halfHeight w)
, ( halfWidth w,-halfHeight w)
]
mapWall :: Wall -> Maybe Picture
mapWall wl =
case _wlSeen wl of
False -> Nothing
True -> Just $ color c $ polygon [x,x +.+ n2,y +.+ n2, y]
where t = 5 *.* errorNormalizeV 68 (y -.- x)
n = vNormal t
n2 = 4 *.* n
(x:y:_) = _wlLine wl
c = _wlColor wl
wallsToDraw :: World -> [Wall]
wallsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w
where onScreen wall = lineOnScreen w (_wlLine wall)
isVisible wl | wl ^? blVisible == Just False = False
| otherwise = onScreen wl
wallsOnScreen :: World -> IM.IntMap Wall
wallsOnScreen w = wallsNearZones (zoneOfScreen w) w
drawSmokeShadow :: World -> Smoke -> Drawing
drawSmokeShadow w sm@(Smoke {_smPos = p, _smRad = r', _smColor = c, _smPs = ps, _smTime = t})
= (
onLayerL [74,0] $ color col $
pictures [uncurry translate p $ circle r'
,line $ (\(x,y) -> [x,y]) $ smokePerpLine (_cameraPos w) p sm
,line [_cameraPos w, mouseWorldPos w]
,trap' p
]
)
<>
(onLayerL [74] $ color (withAlpha 0.1 c) $ pictures
$ concatMap (f . (+.+ p)) p's
)
where
r = r'/2
col | smokeLOS (_cameraPos w) (mouseWorldPos w) w = red
| otherwise = green
orth p' = r *.* (safeNormalizeV $ vNormal $ p' -.- _cameraCenter w)
pa p' = p' +.+ orth p'
pb p' = p' -.- orth p'
pao p' = pa p' +.+ l *.* safeNormalizeV (pa p' -.- _cameraCenter w)
pbo p' = pb p' +.+ l *.* safeNormalizeV (pb p' -.- _cameraCenter w)
semiCirc p' = uncurry translate p' $ rotate (radToDeg (a p')) $ arcSolid 0 180 r
a p' = pi - argV (orth p')
trap p' = polygon [pa p', pb p', pbo p', pao p']
f p' = [semiCirc p', trap p']
p's = zipWith (\x p -> rotateV (x * fromIntegral t / 60) p) xs ps
xs = concat $ repeat [-1,-0.5,0,0.5,1]
l = _windowX w + _windowY w + magV (_cameraPos w -.- _cameraCenter w)
-- cenpic = color (withAlpha 0.5 c) $ pictures $ f p
orth' p' = r' *.* (safeNormalizeV $ vNormal $ p' -.- _cameraCenter w)
pa' p' = p' +.+ orth' p'
pb' p' = p' -.- orth' p'
pao' p' = pa' p' +.+ l *.* safeNormalizeV (pa' p' -.- _cameraCenter w)
pbo' p' = pb' p' +.+ l *.* safeNormalizeV (pb' p' -.- _cameraCenter w)
trap' p' = line [pa' p', pb' p', pbo' p', pao' p',pa' p']
semiCirc' p' = uncurry translate p' $ rotate (radToDeg (a p')) $ arcSolid 0 180 r'
drawWall :: Wall -> Drawing
drawWall wl = case _wlDraw wl of
Nothing -> onLayerL [levLayer WlLayer, layer2] $ color c $ polygon [x,x +.+ n2,y +.+ n2, y]
Just d -> d wl
where
(x:y:_) = _wlLine wl
c = _wlColor wl
t = 5 *.* errorNormalizeVDR (y -.- x)
n = vNormal t
n2 = 3 *.* n
layer2 | _wlIsSeeThrough wl = 0
| isJust $ wl ^? doorMech = 1
| otherwise = 2
-- wallOrdering wl = (not $ _wlIsSeeThrough wl, not $ isJust $ wl ^? doorMech)
errorNormalizeVDR :: Point2 -> Point2
errorNormalizeVDR (0,0) = error $ "problem with function: errorNormalizeVDR in DodgeRendering"
errorNormalizeVDR p = normalizeV p
printPoint :: Point2 -> Picture
printPoint p = color white $ uncurry translate p $ pictures [circle 3 ,scale 0.05 0.05 $ text (show p)]
printRotPoint :: Float -> Point2 -> Picture
printRotPoint r p = color white $ uncurry translate p $ pictures [circle 3
, rotate r $ scale 0.1 0.1 $ text (show p)]
outsideScreenPolygon :: World -> [Point2]
outsideScreenPolygon w = [tr,tl,bl,br]
where scRot = rotateV (_cameraRot w)
scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p
scTran p = p +.+ _cameraPos w
tr = scTran $ scRot $ scZoom ( 3*halfWidth w , 3* halfHeight w)
tl = scTran $ scRot $ scZoom (- (3*halfWidth w), 3* halfHeight w)
br = scTran $ scRot $ scZoom ( 3*halfWidth w ,- (3* halfHeight w))
bl = scTran $ scRot $ scZoom (- (3*halfWidth w),- (3* halfHeight w))
x = halfWidth w + halfHeight w
-- wallShadowsToDrawOnScreen :: World -> [Wall]
-- wallShadowsToDrawOnScreen w = --IM.elems $ _walls w
-- sortBy (compare `on` not . _wlIsSeeThrough) $ filter isVisible $ IM.elems
-- $ _walls w
-- -- $ wallsOnScreen w
-- -- should really sort this out
-- where onScreen wall = lineOnScreen w (_wlLine wall)
-- isVisible wl | wl ^? blVisible == Just False = False
-- | otherwise = onScreen wl
wallShadowsToDraw :: World -> [Wall]
wallShadowsToDraw w = --IM.elems $ _walls w
filter isVisible $ IM.elems -- $ _walls w
$ wallsNearZones (zoneOfSight w) w
-- should really sort this out
where onScreen wall = True -- lineOnScreenCone w (_wlLine wall)
isVisible wl | wl ^? blVisible == Just False = False
| otherwise = onScreen wl
-- cannot only test if walls are on screen, but also if they are on the cone
-- towards the center of sight
lineOnScreenCone :: World -> [Point2] -> Bool
lineOnScreenCone w (p1:p2:_) = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9 p2 sp
|| any (isJust . uncurry (intersectSegSeg' p1 p2)) sps
where sp' = screenPolygon w
vp = _cameraCenter w
sp | pointInPolygon vp sp' = sp'
| otherwise = orderPolygon $ (_cameraCenter w : sp')
sps = zip sp (tail sp ++ [head sp])
lineOnScreen :: World -> [Point2] -> Bool
lineOnScreen w (p1:p2:_) = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9 p2 sp
|| any (isJust . uncurry (intersectSegSeg' p1 p2)) sps
where sp = screenPolygon w
sps = zip sp (tail sp ++ [head sp])
drawWallShadow :: World -> Wall -> Drawing
drawWallShadow w wall
| isRHS sightFrom x y = blank
| otherwise = onLayerL l $ color shadCol $ polygon $ points
where
l | _wlIsSeeThrough wall = [levLayer ShadowLayer]
| otherwise = [levLayer ShadowLayer, 0]
(x:y:_) = _wlLine wall
ps = linePointsBetween x y
ds = map (\p -> safeNormalizeV (p -.- sightFrom)) ps
p's = zipWith (\d x -> (15 *.* d) +.+ x) ds ps
sightFrom = _cameraCenter w
shadCol = if _wlIsSeeThrough wall then withAlpha 0.2 $ _wlColor wall
else black
corns = screenPolygon w
borders = filter g $ zip corns (tail corns ++ [head corns])
g (a,b) = isLHS a b sightFrom
borderps = mapMaybe f borders ++ mapMaybe f' borders ++ shadowedCorners
coneTop = nub $ concatMap (\(a,b) -> [a,b]) $ borders
shadowedCorners = filter isShadowed coneTop
isShadowed p = isLHS sightFrom x p && isRHS sightFrom y p
f (bpa,bpb) = intersectSegLineFrom' bpa bpb x (head p's)
f' (bpa,bpb) = intersectSegLineFrom' bpa bpb y (last p's)
points = orderPolygon (borderps ++ p's)
linePointsBetween :: Point2 -> Point2 -> [Point2]
linePointsBetween p p' | d > 99 = map (\m -> p +.+ fromIntegral m *.* p'') [0..n-1] ++ [p']
| otherwise = [p,p']
where d = dist p p'
n = ceiling $ d / 50
p'' = (1/fromIntegral n) *.* (p' -.- p)
displayInv :: Int -> World -> Picture
displayInv n w = mconcat $ zipWith (translate (10-halfWidth w))
(map (\x-> halfHeight w-(25*(fromIntegral x+1))) ns) $ map dItem' is
where (ns,is) = unzip $ IM.toList $ _crInv $ _creatures w IM.! n
dItem' NoItem = scale 0.15 0.15 $ dShadCol (greyN 0.5) $ text "----"
dItem' i = scale 0.15 0.15 $ pictures [dropShadow t, color (_itInvColor i) t]
where t = text $ _itInvDisplay i i
displayAmount :: Int -> String
displayAmount n | n > 1 = "-x" ++show n
| otherwise = []
rectangleSolid x y = polygon [(x,y),(x,-y),(-x,-y),(-x,y)]
drawItem :: FloorItem -> Drawing
drawItem (FlAm {_flItPos = p}) = uncurry translateDrawing p $ onLayer FlItLayer $ rectangleSolid 5 5
drawItem flIt = uncurry translateDrawing (_flItPos flIt)
$ rotateDrawing (radToDeg $ _flItRot flIt) (_itFloorPict (_flIt flIt))
drawButText :: World -> Button -> Picture
drawButText w bt | magV (_crPos (you w) -.- _btPos bt) < 100
&& hasLOS (_btPos bt) (_crPos (you w)) w
&& _btState bt /= BtNoLabel
= t $ rotate (radToDeg (-_cameraRot w))
$ pictures $ [ scLine [(-8,10),(-15,10),(-15,-10),(-8,-10)]
, scLine [( 8,10),( 15,10),( 15,-10),( 8,-10)]
,translate (-15) (-10*sqrt zoom - 5) $ dShadCol white
$ scale 0.1 0.1 $ text $ _btText bt
]
| otherwise = blank
where t = rotate (radToDeg (_cameraRot w)) . uncurry translate (zoom *.* (_btPos bt -.- _cameraPos w))
zoom = _cameraZoom w
scLine = dShadCol white . line . fmap (sqrt zoom *.*)
drawPPText :: World -> PressPlate -> Picture
drawPPText w pp | magV (_crPos (you w) -.- _ppPos pp) < 100
&& hasLOS (_ppPos pp) (_crPos (you w)) w
= t $ rotate (radToDeg (-_cameraRot w))
$ pictures $ [ scLine [(-8,10),(-15,10),(-15,-10),(-8,-10)]
, scLine [( 8,10),( 15,10),( 15,-10),( 8,-10)]
,translate (-15) (-10*sqrt zoom - 5) $ dShadCol white
$ scale 0.1 0.1 $ text $ _ppText pp
]
| otherwise = blank
where t = rotate (radToDeg (_cameraRot w)) . uncurry translate (zoom *.* (_ppPos pp -.- _cameraPos w))
zoom = _cameraZoom w
scLine = dShadCol white . line . fmap (sqrt zoom *.*)
drawItemName :: World -> FloorItem -> Picture
drawItemName w flIt | magV (_crPos (you w) -.- _flItPos flIt) < 100
&& hasLOS (_flItPos flIt) (_crPos (you w)) w
= t $ rotate (radToDeg (-_cameraRot w))
$ pictures $ [ scLine [(-8,10),(-15,10),(-15,-10),(-8,-10)]
, scLine [( 8,10),( 15,10),( 15,-10),( 8,-10)]
,translate (-15) (-10*sqrt zoom - 5) $ dShadCol white
$ scale 0.1 0.1 $ text $ nameOfItem
]
| otherwise = blank
where t = rotate (radToDeg (_cameraRot w)) . uncurry translate (zoom *.* (_flItPos flIt -.- _cameraPos w))
nameOfItem = case flIt of FlIt {} -> _itName $ _flIt flIt
FlAm {_flAm = PistolBullet} -> "Bullets"
FlAm {_flAm = LiquidFuel} -> "Liquid Fuel"
zoom = _cameraZoom w
scLine = dShadCol white . line . fmap (sqrt zoom *.*)
ringPict :: Drawing
ringPict = onLayer LabelLayer $ dShadCol white $ pictures [line [(-8,10),(-15,10),(-15,-10),(-8,-10)]
,line [( 8,10),( 15,10),( 15,-10),( 8,-10)]
]
dShadCol :: Color -> Picture -> Picture
dShadCol c p = pictures $
map (flip (uncurry translate) p) [(0.2,-0.2)
,(0.4,-0.4)
,(0.6,-0.6)
,(0.8,-0.8)
,( 1,- 1)
,(1.2,-1.2)
] ++ [color c p]
dropShadow :: Picture -> Picture
dropShadow p = pictures [ translate 5 (-5) p
, translate 1 (-1) p
, translate 2 (-2) p
, translate 3 (-3) p
, translate 4 (-4) p
, translate 6 (-6) p
, translate 7 (-7) p
, translate 8 (-8) p
, translate 9 (-9) p
]
ffToDraw :: World -> [ForceField]
ffToDraw w = filter (lineOnScreen w . _ffLine) $
IM.elems $ fmap (over ffLine (map (\p->p -.- _cameraPos w))) $
_forceFields w
drawFF :: ForceField -> Picture
drawFF (FF {_ffLine = l, _ffColor = col}) = pictures [color white $ line l, color col
$ lineOfThickness 6 l ]
drawFFShadow :: World -> ForceField -> [Picture]
drawFFShadow w ff
| youOnFF = []
| otherwise = map (rotate (radToDeg (- _cameraRot w)) . pane)
[0,0.05..0.25]
where p = rotateV (-_cameraRot w) $ ypShift
x = rotateV (-_cameraRot w) x'
y = rotateV (-_cameraRot w) y'
yp = _crPos $ you w
(x1:y1:_) = _ffLine ff
(x':y':_) | isRHS x1 y1 yp = (y1:x1:[])
| otherwise = (x1:y1:[])
fCol = color (_ffColor ff)
col = _ffColor ff
ypShift = yp -.- _cameraPos w
youOnFF = circOnLine' x' y' ypShift (_crRad $ you w)
pane j = color (withAlpha 0.1 col)
$ polygon
$ [ x
, x +.+ ((0.1 + j) *.* (x -.- ypShift))
, y +.+ ((0.1 + j) *.* (y -.- ypShift))
, y]
displayHP :: Int -> World -> Picture
displayHP n w = translate (halfWidth w-70) (halfHeight w-40) $
scale 0.2 0.2 $ text $ show
$ _crHP $ _creatures w IM.! n
testPic w = blank
wallsForGloom :: World -> [(Point2,Point2)]
wallsForGloom w = map (\(x:y:_) -> (screenShift x,screenShift y)) $
map _wlLine $ filter (not . _wlIsSeeThrough)
$ IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
where screenShift x = zoom *.* rotateV (0 - _cameraRot w) (x -.- _cameraPos w)
zoom = _cameraZoom w
lightsForGloom :: World -> [(Point2,Float,Float)]
lightsForGloom w = map getLS (IM.elems $ _lightSources w) ++ map getTLS (_tempLightSources w)
where getLS ls = (screenShift $ _lsPos ls, _lsRad ls * zoom, _lsIntensity ls)
getTLS ls = (screenShift $ _tlsPos ls, _tlsRad ls * zoom, _tlsIntensity ls)
screenShift x = zoom *.* rotateV (0 - _cameraRot w) (x -.- _cameraPos w)
zoom = _cameraZoom w
src/Dodge/Rooms.hs
+874
View File
@@ -0,0 +1,874 @@
module Dodge.Rooms where
-- imports {{{
import Dodge.Data
import Dodge.Weapons
import Dodge.Critters
import Dodge.LevelGen
import Dodge.Base
import Dodge.RandomHelp
import Dodge.Prototypes
import Dodge.Path
import Dodge.Layout
import Dodge.LightSources
import Dodge.SoundLogic
import Geometry
import Picture
import qualified SDL.Mixer as Mix
import Control.Monad.State
import Control.Monad.Loops
import Control.Lens
import System.Random
import Data.List
import Data.Maybe
import Data.Tree
import Data.Either
import Data.Function
import qualified Data.Map as M
import Data.Graph.Inductive.Graph hiding ((&))
import Data.Graph.Inductive.Basic
import Data.Graph.Inductive.PatriciaTree
import Data.Graph.Inductive.NodeMap
import qualified Data.IntMap.Strict as IM
-- }}}
lev1 :: RandomGen g => State g (Tree Room)
lev1 = do
firstWeapon <- takeOne $ [[branchRectWith weaponRoom,blockedCorridor]] ++ replicate 5 [weaponRoom]
iterateWhile boundClip $ fmap (shiftRoomTree . expandTreeBy id)
$ sequence $ treePost
(
-- [randomiseLinks =<< pistolerRoom]
[return $ return $ Right deadEndRoom
]
++ [return $ connectRoom corridor
,return $ connectRoom door]
-- ++ [randomiseLinks =<< longRoom]
++ [randomiseLinks =<< pistolerRoom]
-- ++ [randomiseLinks =<< shooterRoom]
++ [return $ connectRoom door]
-- ++ [return $ connectRoom $ set rmPS [PS (100,100) 0 $ PutCrit explosiveBarrel
-- ,PS (105,110) 0 $ PutCrit explosiveBarrel
-- ,PS (115,110) 0 $ PutCrit autoCrit
-- ,PS (135,110) 0 $ PutCrit explosiveBarrel
-- ,PS (105,140) 0 $ PutCrit explosiveBarrel
-- ]
-- $ roomRect 300 300]
++ [randomiseLinks =<< shooterRoom]
++ (replicate 3 $ randomiseLinks corridor)
++ [return $ connectRoom corridor]
-- ++ [randomiseLinks =<< longRoom]
++ [return $ connectRoom corridor]
++ firstWeapon
++ (replicate 3 $ randomiseLinks corridor)
++ [return $ connectRoom corridor]
++[return $ connectRoom corridor,return $ connectRoom door]
++ [shootingRange]
++ (replicate 3 $ randomiseLinks corridor)
++[roomMiniIntro]
++ (replicate 3 $ randomiseLinks corridor)
++ [return $ connectRoom corridor
,return $ connectRoom door
,slowDoorRoom]
++ [return $ connectRoom corridor
,spawnerRoom
,return $ connectRoom corridor
]
)
$ randomiseLinks corridor
generateLevel :: Int -> World -> World
generateLevel i w =
do haltSound $ ((generateFromTree $ levelTree i) w)
levelTree :: Int -> State StdGen (Tree Room)
levelTree 1 = lev1
levelPortalAt :: Point2 -> Int -> PressPlate
levelPortalAt p x
= PressPlate
{ _ppPict = onLayer PressPlateLayer $ color blue $ circle 10
, _ppPos = p
, _ppRot = 0
, _ppEvent = \pp w -> if dist (_crPos (you w)) (_ppPos pp) < 10
then generateLevel x w
else w
, _ppID = -1
, _ppText = "Portal to level "++ show x
}
airlockOneWay :: Int -> Room
airlockOneWay n = Room
{ _rmPolys = [rectNSWE 90 0 0 40]
, _rmLinks = lnks
, _rmPath = []
, _rmPS = [PS (0,15) 0 $ PutTriggerDoor col (not . cond) (0,0) (0,40)
,PS (0,75) 0 $ PutTriggerDoor col (cond) (0,0) (0,40)
,PS (35,45) (pi/2) $ PutButton $ makeButton col (over worldState
(M.insert (DoorNumOpen n) True))
]
--, _rmBound = rectNSWE 90 30 (-30) 30
, _rmBound = rectNSWE 75 15 0 40
}
where lnks = [((0,85),0)
,((0, 5),pi)
]
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
col = dim $ dim $ bright red
airlock :: Int -> Room
airlock n = Room
{ _rmPolys = [rectNSWE 90 0 0 40]
, _rmLinks = lnks
, _rmPath = [((20,85),(20,45))
,((20,45),(20, 5))
]
, _rmPS = [PS (0,15) 0 $ PutTriggerDoor col (not . cond) (0,0) (40,0)
,PS (0,75) 0 $ PutTriggerDoor col (cond) (0,0) (40,0)
,PS (35,45) (pi/2) $ PutButton $ makeSwitch col
(over worldState (M.insert (DoorNumOpen n) True))
(over worldState (M.insert (DoorNumOpen n) False))
]
, _rmBound = rectNSWE 75 15 0 40
}
where lnks = [((20,85),0)
,((20, 5),pi)
]
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
col = dim $ dim $ bright red
corridor :: Room
corridor = Room
{ _rmPolys = [rectNSWE 80 0 0 40
,[(0,80), (0,80) +.+ rotateV (pi/3) (40,0),(40,80)]
,[(40,0), (0,0) +.+ rotateV (0-pi/3) (40,0),( 0, 0)]
]
, _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (20,60)) $ map fst lnks
, _rmPS = []
, _rmBound = rectNSWE 50 30 0 40
}
where lnks = [((20,70) ,0)
,((20,80) +.+ rotateV (0-pi/3) (-20,0), pi/6)
,((20,80) +.+ rotateV ( pi/3) ( 20,0),0-pi/6)
-- ,((40,0) +.+ rotateV ( pi/3) (-20,0), 2*pi/3)
-- ,(( 0,0) +.+ rotateV (0-pi/3) ( 20,0),0-2*pi/3)
,((20,10) ,pi)
]
corridorN :: Room
corridorN = Room
{ _rmPolys = [rectNSWE 80 0 0 40
]
, _rmLinks = lnks
, _rmPath = pth
, _rmPS = []
, _rmBound = rectNSWE 50 30 0 40
}
where lnks = [((20,70) ,0)
,((20,10) ,pi)
]
pth = doublePair ((20,70),(20,10))
tEast :: Room
tEast = Room
{ _rmPolys = [rectNSWE 80 0 (-20) (20)
,rectNSWE 80 40 (-40) 40
]
, _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (0,60)) $ map fst lnks
, _rmPS = []
, _rmBound = rectNSWE 70 10 0 40
}
where lnks = [(( 30,60),-pi/2)
,((-30,60),pi/2)
,((0,10),pi)
]
tWest :: Room
tWest = Room
{ _rmPolys = [rectNSWE 80 0 (-20) (20)
,rectNSWE 80 40 (-40) 40
]
, _rmLinks = lnks
, _rmPath = concatMap (doublePair . (,) (0,60)) $ map fst lnks
, _rmPS = []
, _rmBound = rectNSWE 70 10 0 40
}
where lnks = [((-30,60),pi/2)
,(( 30,60),-pi/2)
,((0,10),pi)
]
roomC :: Float -> Float -> Room
roomC x y = Room
{ _rmPolys = [rectNSWE y 0 0 x]
, _rmLinks = lnks
, _rmPath = []
, _rmPS = [PS (0,0) 0 $ PutWindowBlock (x/2,0) (x/2,y-60)
]
--, _rmBound = rectNSWE y 0 0 x
, _rmBound = []
}
where lnks = [( (x-20, 0),pi)
,( ( 20, 0),pi)
,( ( 0, 20),pi/2)
]
makeRect :: Float -> Float -> [(Point2,Point2)]
makeRect x y = [((0,0),(x,0))
,((0,0),(0,y))
,((x,y),(x,0))
,((x,y),(0,y))
]
gridPoints :: Float -> Int -> Float -> Int -> [Point2]
gridPoints x nx y ny = [(a,b) | a <- take nx $ scanl (+) 0 $ repeat x
, b <- take ny $ scanl (+) 0 $ repeat y
]
makeGrid :: Float -> Int -> Float -> Int -> [(Point2,Point2)]
makeGrid x nx y ny = nub $ concatMap doublePair
$ concatMap (\p -> map (\(a,b) -> (p +.+ a,p +.+ b)) $ makeRect x y)
$ gridPoints x nx y ny
roomPadCut :: [Point2] -> Point2 -> Room
roomPadCut ps p = Room
{ _rmPolys = [ps]
, _rmLinks = [(p,0),((0,0),pi)]
, _rmPath = [((0,0),p)]
, _rmPS = []
, _rmBound = []
}
roomRect' :: Float -> Float -> Int -> Int -> Room
roomRect' x y a b = Room
{ _rmPolys = [rectNSWE y 0 0 x ]
, _rmLinks = lnks
, _rmPath = concatMap doublePair pth
, _rmPS = [PS (x/2,y/2) 0 $ basicLS]
, _rmBound = rectNSWE (y+5) (-5) (-5) (x+5)
}
where yn,xn :: Int
yn = b
yd = (y - 40) / fromIntegral yn
xn = a
xd = (x - 40) / fromIntegral xn
elnks = flip zip (repeat ( pi/2)) $ translateS (0,20) $ gridPoints 0 1 yd (yn+1)
wlnks = flip zip (repeat (-pi/2)) $ translateS (x,20) $ gridPoints 0 1 yd (yn+1)
nlnks = flip zip (repeat ( 0)) $ translateS (20,y) $ gridPoints xd (xn+1) 0 1
slnks = flip zip (repeat ( pi)) $ translateS (20,0) $ gridPoints xd (xn+1) 0 1
lnks = nlnks ++ elnks ++ wlnks ++ slnks
pth = linksAndPath lnks $ translateS (20,20) (makeGrid xd xn yd yn)
roomRect :: Float -> Float -> Room
roomRect x y = roomRect' x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60)
linksAndPath :: [(Point2,Float)] -> [(Point2,Point2)] -> [(Point2,Point2)]
linksAndPath lnks subpth = subpth ++ concatMap linkClosest lnks
where linkClosest (p,_) = doublePair (p, head $ sortBy (compare `on` dist p) $ map fst subpth)
door :: Room
door = Room
{ _rmPolys = [rectNSWE 30 0 0 40]
, _rmLinks = lnks
, _rmPath = [((20,25),(20,5))]
, _rmPS = [PS (0,15) 0 $ PutAutoDoor (0,0) (40,0)]
, _rmBound = []
}
where lnks = [((20,25),0)
,((20, 5),pi)
]
roomPillars :: Room
roomPillars = over rmLinks init $ set rmPS plmnts $ roomRect' 240 240 2 2
where plmnts = g 180 150 90 60
f a x b y = putBlockRect a x b y
-- putWallBlocks (a,b) (a,y)
-- ++ putWallBlocks (a,y) (x,y)
-- ++ putWallBlocks (x,y) (x,b)
-- ++ putWallBlocks (x,b) (a,b)
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
putBlockRect a x b y = putWallBlocks (a,b) (a,y)
++ putWallBlocks (a,y) (x,y)
++ putWallBlocks (x,y) (x,b)
++ putWallBlocks (x,b) (a,b)
putBlockV a x b y = putWallBlocks (a,b) (a,y)
++ putWallBlocks (x,b) (a,b)
putBlockC a x b y = putWallBlocks (a,b) (a,y)
++ putWallBlocks (x,b) (a,b)
++ putWallBlocks (a,y) (x,y)
putBlockN a x b y = putWallBlocks (a,b) (a,y)
++ putWallBlocks (x,b) (a,b)
++ putWallBlocks (x,y) (x,b)
branchWith :: Room -> [Tree Room] -> Tree (Either Room Room)
branchWith r ts = Node (Left r) $ [return $ Right door] ++ fmap (fmap Left) ts
glassSwitchBack :: RandomGen g => State g Room
glassSwitchBack = do
wth <- state $ randomR (200,400)
hgt <- state $ randomR (400,600)
wllen <- state $ randomR (60,wth/2-40)
let hf = hgt/5
let plmnts = [PS (0,0) 0 $ PutWindowBlock (wth-60, hf) (wllen,hf)
,PS (0,0) 0 $ PutWindowBlock (wth-wllen,2*hf) (60, 2*hf)
,PS (0,0) 0 $ PutWindowBlock (wth-60, 3*hf) (wllen,3*hf)
,PS (0,0) 0 $ PutWindowBlock (wth-wllen,4*hf) (60, 4*hf)
]
++ putWallBlocks ( 0, 1*hf) (wllen,1*hf)
++ putWallBlocks (wth-wllen, 2*hf) ( wth,2*hf)
++ putWallBlocks ( 0, 3*hf) (wllen,3*hf)
++ putWallBlocks (wth-wllen, 4*hf) ( wth,4*hf)
return $ set rmPS plmnts $ roomRect' wth hgt 2 6
manyDoors :: Int -> Tree (Either Room Room)
manyDoors i = treePost (replicate i (Left door)) $ Right door
glassLesson :: RandomGen g => State g (Tree (Either Room Room))
glassLesson = do
corridors <- sequence $ replicate 3 $ fmap Left $ randLinks corridor
return $ Node (Left $ botRoom) [deadRoom door,uppers, treePost (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 = [PS (0,0) 0 $ PutWindow (rectNSWE (200) 0 (90) (110))
$ withAlpha 0.5 aquamarine
,PS (50,100) 0 $ PutCrit miniGunCrit
]
topplmnts = [PS (0,0) 0 $ PutWindowBlock (100,200) (100,0)
,PS (50,100) 0 $ PutCrit miniGunCrit
]
miniRoom1 :: RandomGen g => State g Room
miniRoom1 = do
wth <- state $ randomR (200,400)
hgt <- state $ randomR (400,600)
wllen <- state $ randomR (60,wth/2-40)
let hf = hgt/5
cry <- randomRanges [--50+2*hf,30+3*hf
50+3*hf,30+4*hf
,50+4*hf,30+5*hf
]
crx <- state $ randomR (wllen,wth-(wllen+40))
let plmnts = [PS (0,0) 0 $ PutWindowBlock (wth-60, 40+hf) (wllen,40+hf)
,PS (0,0) 0 $ PutWindowBlock (wth-wllen,40+2*hf) (60,40+2*hf)
,PS (0,0) 0 $ PutWindowBlock (wth-60, 40+3*hf) (wllen,40+3*hf)
,PS (0,0) 0 $ PutWindowBlock (wth-wllen,40+4*hf) (60,40+4*hf)
,PS (crx,cry) 0 $ PutCrit miniGunCrit
,PS (wth-20,hgt/2+40) 0 $ randC
]
++ putWallBlocks ( 0, 40+1*hf) (wllen,40+1*hf)
++ putWallBlocks (wth-wllen, 40+2*hf) ( wth,40+2*hf)
++ putWallBlocks ( 0, 40+3*hf) (wllen,40+3*hf)
++ putWallBlocks (wth-wllen, 40+4*hf) ( wth,40+4*hf)
return $ set rmPS plmnts $ shiftRoomBy ((0,40),0) $ roomRect' wth hgt 2 4
miniTree2 :: RandomGen g => State g (Tree (Either Room Room))
miniTree2 = miniRoom1 >>= randLinks >>= changeLinkTo (\p -> (snd . fst) p < 70)
>>= return . flip branchWith (replicate 3 $ treePost [door,corridor]
critInDeadEnd )
miniRoom3 :: RandomGen g => State g (Tree (Either Room Room))
miniRoom3 = do
w <- state $ randomR (300,400)
h <- state $ randomR (300,400)
let l = -70
let r = 70
let cp = (0,h/2+40)
let f = rot90Around cp
let f2 = f . f
let f3 = f . f .f
let cpa p = p +.+ cp
let bl = putWallBlocks (cpa (-20,-40)) (cpa (-20,-80))
let br = putWallBlocks (cpa (20,-40)) (cpa (20,-80))
let bm = putWallBlocks (cpa (25,-35)) (cpa (35,-25))
let b = PutBlock [5,20,20] (greyN 0.5) [(-10,-60)
,( 10,-60)
,( 10,-80)
,(-10,-80)
]
let plmnts = [PS cp 0 $ PutCrit miniGunCrit
,PS cp 0 $ PutWindowBlock (0,-40) (0,-80)
,PS cp (1*pi/4) $ PutWindowBlock (0,-40) (0,-80)
,PS cp (2*pi/4) $ PutWindowBlock (0,-40) (0,-80)
,PS cp (3*pi/4) $ PutWindowBlock (0,-40) (0,-80)
,PS cp (4*pi/4) $ PutWindowBlock (0,-40) (0,-80)
,PS cp (5*pi/4) $ PutWindowBlock (0,-40) (0,-80)
,PS cp (6*pi/4) $ PutWindowBlock (0,-40) (0,-80)
,PS cp (7*pi/4) $ PutWindowBlock (0,-40) (0,-80)
,PS cp (pi/8) b
,PS cp (pi/8+1*pi/4) b
,PS cp (pi/8+2*pi/4) b
,PS cp (pi/8+3*pi/4) b
,PS cp (pi/8+4*pi/4) b
,PS cp (pi/8+5*pi/4) b
,PS cp (pi/8+6*pi/4) b
,PS cp (pi/8+7*pi/4) b
]
randomiseLinks $ set rmPS plmnts $ roomRect w h
rot90Around :: Point2 -> Point2 -> Point2
rot90Around cen p = cen +.+ vNormal (p -.- cen)
-- So, the idea is to attach outer children to the bottommost right nodes
-- inside an inner tree
roomMiniIntro :: RandomGen g => State g (Tree (Either Room Room))
roomMiniIntro = fmap (g . expandTreeBy f) $ sequence $ treePost
[return $ connectRoom door
,join $ takeOne [miniTree2,glassLesson]
-- ,join $ takeOne [miniRoom1]
]
$ randomiseLinks 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
g (Node (Right x) []) = Node (Right x) []
g (Node (Right x) xs) = Node (Left x) $ map g xs
g (Node y ys) = Node y $ map g ys
putWallBlocks :: Point2 -> Point2 -> [PlacementSpot]
putWallBlocks a b = map (\p -> PS p rot $ PutBlock [5,20,20] (greyN 0.5)
$ reverse $ rectNSWE 10 (-10) (-10) 10)
ps
where d = dist a b
rot = argV (b -.- a)
numPoints' = floor (d / 20)
numPoints = numPoints'*2 + 1
ns = take (numPoints + 1) [0..]
ps = map (\i -> a +.+ i/ (fromIntegral numPoints) *.* (b -.- a))
$ map fromIntegral ns
roomCenterPillar :: RandomGen g => State g Room
roomCenterPillar = changeLinkTo ((\p -> dist p (120,0) < 10) . fst)
$ set rmPS plmnts $ roomRect' 240 240 2 2
where plmnts = putWallBlocks (110,110) (110,130)
++ putWallBlocks (130,110) (130,130)
roomOctogon :: Room
roomOctogon = Room
{ _rmPolys = [[(-20,40),(20,40),(50,70),(50,110),(20,140),(-20,140),(-50,110),(-50,70)]
]
, _rmLinks = lnks
, _rmPath = allPairs $ map fst lnks
, _rmPS = []
, _rmBound = [(-20,30),(20,30),(60,70),(60,110),(20,150),(-20,150),(-60,110),(-60,70)]
}
where lnks = [((0,140),0)
,((35,125),0-pi/4)
,((-35,125),pi/4)
,( (50,90),0-pi/2)
,( (-50,90),pi/2)
,((35,55),0-3*pi/4)
,((-35,55),3*pi/4)
,( (0,40),pi)
]
randomCorridorFrom :: RandomGen g => [a] -> State g (Tree (Either a a))
randomCorridorFrom xs = do
rooms <- sequence $ replicate 5 $ takeOne xs
return $ treeTrunk (map Left $ init rooms) (Node (Right (last rooms)) [])
--splitWall :: Float -> Wall -> [[Point]]
--splitWall x wl =
sWalls g = wallsFromTree $ evalState (iterateWhile boundClip lev1) $ g
randFirstWeapon :: State StdGen PSType
randFirstWeapon = do
r <- state $ randomR (-pi,pi)
takeOne $ map PutFlIt
[ basicFlIt {_flItRot=r,_flIt = pistol}
, basicFlIt {_flItRot=r,_flIt = ltAutoGun}
-- , basicFlIt {_flItRot=r,_flIt = autoGun}
, basicFlIt {_flItRot=r,_flIt = spreadGun}
, basicFlIt {_flItRot=r,_flIt = multGun}
, basicFlIt {_flItRot=r,_flIt = launcher}
-- , basicFlIt {_flItRot=r,_flIt = lasGun}
-- , basicFlIt {_flItRot=r,_flIt = flamer}
]
--randC1 :: State StdGen PSType
randC1 = RandPS $ takeOne $ map PutCrit $ (armourChaseCrit : replicate 50 chaseCrit)
randC = randC1
-- randSwarmCrit = RandPS $ takeOne $ map PutCrit $ (armouredSwarmCrit : replicate 100 swarmCrit)
weaponEmptyRoom :: RandomGen g => State g (Tree (Either Room Room))
weaponEmptyRoom = do
w <- state $ randomR (220,300)
h <- state $ randomR (220,300)
let plmnts = [PS (w/2,h-40) 0 $ RandPS randFirstWeapon
,PS (20,20) (pi/2) $ randC1
,PS (w-20,20) (pi/2) $ randC1
]
randomiseLinks =<< (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 = [PS (0,0) 0 $ RandPS randFirstWeapon
-- ,PS (-5,0) (0-pi/2) $ randC1
-- ,PS (5,20) (0-pi/2) $ randC1
-- ]
-- let continuationRoom = treeTrunk [Left corridorN,Left corridorN]
-- (connectRoom (set rmPS plmnts $ corridorN))
-- deadEndRoom <- takeOne [roomSquare,roomPillars,roomVs,roomCenterPillar]
-- junctionRoom <- takeOne [Left corridorE,Left corridorW]
-- return $ treeTrunk [Left corridorN,Left corridorN]
-- $ Node junctionRoom
-- [continuationRoom
-- ,deadRoom deadEndRoom
-- ]
weaponBehindPillar :: RandomGen g => State g (Tree (Either Room Room))
weaponBehindPillar = do
crPos <- takeOne $ [(x,y) | x <- [20,220], y <- [20,220]] ++ [(120,160),(120,200)]
let d p = argV $ (120,80) -.- p
let plmnts1 = [PS (120,160) 0 $ RandPS randFirstWeapon
,PS crPos (d crPos) $ randC1
]
rcp <- roomCenterPillar
return $ treeTrunk [Left door
,Left $ over rmLinks tail $ over rmPS (++ plmnts1) rcp]
(connectRoom $ set rmPS [PS (20,60) (0-pi/2) $ randC1]
$ corridorN)
weaponBetweenPillars :: RandomGen g => State g (Tree (Either Room Room))
weaponBetweenPillars = do
wpPos <- takeOne [(x,y) | x <- [20,120,220], y <- [20,120,220]]
(ps,_) <- takeNMore 2 ([], [(x,y) | x <- [20,220], y <- [20,120,220]])
let crPos1 = ps !! 0
let crPos2 = ps !! 1
let d p = argV $ (120,120) -.- p
let plmnts = [PS wpPos 0 $ RandPS randFirstWeapon
,PS crPos1 (d crPos1) $ randC1
,PS crPos2 (d crPos2) $ randC1
]
randomiseLinks =<< (filterLinks f $ over rmPS (++plmnts) $ roomPillars)
where f (_,a) = a == 0
blockedCorridor :: RandomGen g => State g (Tree (Either Room Room))
blockedCorridor = do
r <- state $ randomR (0,pi)
n <- state $ randomR (0,3)
let plmnts = [PS (20,40) r $ PutBlock [5,5,5] (150/256, 75/256, 0, 250/256)
$ reverse $ rectNSWE 10 (-10) (-10) 10
]
sequence $ treePost (replicate n $ fmap Left $ randLinks corridor)
$ fmap Right $ return $ set rmPS plmnts corridor
-- weaponBehindV :: RandomGen g => State g (Tree (Either Room Room))
-- weaponBehindV = do
-- wpPos <- takeOne [(x,y) | x <- [70,-70], y <- [90,230]]
-- (ps,_) <- takeNMore 2 ([], [(x,y) | x <- [60,-60], y <- [100,220]])
-- r <- state $ randomR (0,pi)
-- let crPos1 = ps !! 0
-- let crPos2 = ps !! 1
-- let d p = argV $ (0,160) -.- p
-- let plmnts = [PS wpPos 0 $ RandPS randFirstWeapon
-- ,PS crPos1 (d crPos1) $ randC1
-- ,PS crPos2 (d crPos2) $ randC1
-- ,PS (0,295) r $ PutBlock [5,5,5] (makeColorI 150 75 0 250)
-- $ reverse $ rectNSWE 10 (-10) (-10) 10
-- ]
-- return $ connectRoom $ set rmPS plmnts $ roomVs
weaponLongCorridor :: RandomGen g => State g (Tree (Either Room Room))
weaponLongCorridor = do
root <- takeOne $ [tEast, tWest]
connectingRoom <- takeOne [tEast,tWest]
i1 <- state $ randomR (2,5)
i2 <- state $ randomR (2,5)
let branch1 = treeTrunk (replicate i1 $ Left corridor) (connectRoom $ putCrs connectingRoom)
let branch2 = treeTrunk (replicate i2 $ Left corridor) (deadRoom $ putWp corridorN)
return $ Node (Left root) [branch1,branch2]
where putCrs = set rmPS [PS (10,40) (-pi/2) $ randC
,PS (-10,40) (-pi/2) $ randC
]
putWp = set rmPS [PS (20,40) 0 $ RandPS randFirstWeapon]
critInDeadEnd :: Room
critInDeadEnd = set rmPS [PS (0,0) 0 $ randC] deadEndRoom
deadEndRoom :: Room
deadEndRoom = Room
{ _rmPolys = [rectNSWE 40 (-20) (-20) 20
]
, _rmLinks = lnks
, _rmPath = []
, _rmPS = []
, _rmBound = rectNSWE 20 (-20) (-30) 30
}
where lnks = [((0,30) ,0)
]
weaponRoom :: RandomGen g => State g (Tree (Either Room Room))
weaponRoom = do
x <- takeOne [weaponEmptyRoom
--, weaponUnderCrits
, weaponBehindPillar
, weaponBetweenPillars
, weaponLongCorridor
]
x
roomCCrits :: RandomGen g => State g (Tree (Either Room Room))
roomCCrits = do
ps <- sequence $ replicate 25 $ randInCirc 9
let plmnts = map (\p -> PS p 0 $ randC)
$ zipWith (+.+) [(x,y) | x<-[110,130,150,170,190], y<- [70,90,110,130,150]] ps
return $ connectRoom $ over rmPS (++plmnts) $ roomC 200 200
--
-- roomSwarm :: RandomGen g => State g (Tree (Either Room Room))
-- roomSwarm = do
-- ps <- sequence $ replicate 25 $ randInCirc 200
-- let plmnts = map (\p -> PS ((500,500) +.+ p) 0 $ PutCrit swarmCrit) ps
-- return $ connectRoom $ set rmPS plmnts $ roomRect 1000 1000
--
roomToLevel2 :: RandomGen g => State g (Tree (Either Room Room))
roomToLevel2 = join $ takeOne
[ portalRoom1
]
portalRoom1 :: RandomGen g => State g (Tree (Either Room Room))
portalRoom1 = return $ connectRoom $ (roomRect 300 300) { _rmPS = plmnts}
where plmnts = [PS (0,0) (0-pi/2) $ PutPressPlate (levelPortalAt (200,120) 1)
,PS (60,100) pi $ PutCrit autoCrit
]
branchRectWith :: RandomGen g => State g (Tree (Either Room Room)) -> State g (Tree (Either Room Room))
branchRectWith t = do
x <- state $ randomR (100,200)
y <- state $ randomR (100,200)
b <- t
root <- randLinks $ roomRect x y
return $ Node (Left root) [Node (Right door) [], fmap rToL $ treeTrunk [Left door] b]
where rToL :: Either a a -> Either a a
rToL (Right r) = Left r
rToL (Left r) = Left r
slowDoorRoom :: RandomGen g => State g (Tree (Either Room Room))
slowDoorRoom = do
x <- state $ randomR (400,800)
y <- state $ randomR (400,800)
h <- state $ randomR (200,min (y-100) 500)
(butPos,butRot) <- takeOne [( (x/2-50,5),0)
,( (x/2+50,5),0)
]
let n = 25
xs <- sequence $ replicate n $ state $ randomR (10,x-10)
ys <- sequence $ replicate n $ state $ randomR (h+20,y)
rs <- sequence $ replicate n $ state $ randomR (0,2*pi)
let ps = zip xs ys
xs' <- sequence $ replicate 5 $ state $ randomR (10,x-10)
ys' <- sequence $ replicate 5 $ state $ randomR (h+20,y)
let crits = zipWith (\p r -> PS p r randC1) ps rs
let barrels = zipWith (\x y -> PS (x,y) 0 $ PutCrit explosiveBarrel) xs' ys'
let pillarsa = []
let pillarsb = putBlockRect (x/5-20) (x/5+20) (h/2-20) (h/2+20)
++ putBlockRect (2*x/5-20) (2*x/5+20) (h/2-20) (h/2+20)
++ putBlockRect (3*x/5-20) (3*x/5+20) (h/2-20) (h/2+20)
++ putBlockRect (4*x/5-20) (4*x/5+20) (h/2-20) (h/2+20)
let pillarsc = putBlockRect (x/3-20) (x/3+20) (h/2-20) (h/2+20)
++ putBlockRect (2*x/3-20) (2*x/3+20) (h/2-20) (h/2+20)
pillars <- takeOne [pillarsa, pillarsb, pillarsc]
let cond x = (snd . fst) x > h + 40
let cond2 x = (snd . fst) x < h - 40
but <- takeOne [PutBtDoor (dim $ light red) butPos butRot (0,h) (x,h)
-- ,PutSwitchDoor (dim $ light red) butPos butRot (0,h) (x,h)
]
fmap connectRoom (filterLinks cond =<< (changeLinkTo cond2
$ set rmPS ([PS (0,0) 0 but] ++ crits ++ pillars ++ barrels)
$ roomRect x y
))
longRoom :: RandomGen g => State g Room
longRoom = do
h <- state $ randomR (1500,1500)
let w = 75
let cond x = (snd . fst) x < h - 40
-- let solidBlocks = putWallBlocks (12.5,h-25) (12.5,h-265)
-- ++putWallBlocks (37.5,h-25) (37.5,h-265)
-- ++putWallBlocks (62.5,h-25) (62.5,h-265)
-- ++putWallBlocks (87.5,h-25) (87.5,h-265)
-- let wBlocks = [PS (0,0) 0 $ PutWindowBlock (12.5,h-50) (12.5,h-265)
-- ,PS (0,0) 0 $ PutWindowBlock (37.5,h-50) (37.5,h-265)
-- ,PS (0,0) 0 $ PutWindowBlock (62.5,h-50) (62.5,h-265)
-- ,PS (0,0) 0 $ PutWindowBlock (87.5,h-50) (87.5,h-265)
-- ]
let ws = map (\ps -> PS (0,0) 0 $ PutWindow ps $ withAlpha 0.5 aquamarine)
[rectNSWE (h-35) (h-135) (-10) 10
,rectNSWE (h-35) (h-135) 15 35
,rectNSWE (h-35) (h-135) 40 60
,rectNSWE (h-35) (h-135) 65 85
]
let wsDefense = map (\ps -> PS (0,0) 0 $ PutWindow ps $ withAlpha 0.5 aquamarine)
[rectNSWE (95) (70) 0 25
,rectNSWE (95) (70) 50 75
]
brls <- fmap (map (\p -> PS (p +.+ (10,200)) 0 $ PutCrit explosiveBarrel) )
$ sequence $ replicate 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 ++
[PS ( 12.5,h-25) 0 $ PutCrit longCrit
,PS ( 37.5,h-25) 0 $ PutCrit longCrit
,PS ( 62.5,h-25) 0 $ PutCrit longCrit
]
)
$ rm
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 ( putWallBlocks (50,50) (50,h) ++
[PS ( 25,h-25) 0 $ PutCrit $ addArmour autoCrit
,PS ( 75,h-30) 0 $ PutCrit explosiveBarrel
,PS ( 75,h-60) 0 $ PutCrit explosiveBarrel
,PS ( 85,h-10) 0 $ PutCrit explosiveBarrel
,PS ( 85,h-45) 0 $ PutCrit explosiveBarrel
]
)
$ roomRect' 100 h 1 1
shootersRoom1 :: RandomGen g => State g Room
shootersRoom1 = do
w <- state $ randomR (200,300)
x1 <- state $ randomR (20,w/3-20)
x2 <- state $ randomR (w/3+20,2*w/3-20)
x3 <- state $ randomR (2*w/3+20,w-20)
y1 <- state $ randomR (250,560)
y2 <- state $ randomR (250,560)
y3 <- iterateWhile (\y' -> abs (y1 - y2) < 60 && abs (y2 - y') < 60) $ state $ randomR (250,560)
x4 <- state $ randomR (60,w-60)
y4 <- state $ randomR (40,180)
p <- takeOne [(x1,y1-10),(x2,y2-10),(x3,y3-10)]
let bln x y = putBlockN (x+25) (x-25) (y+10) (y)
let blv x y = putBlockV (x+25) (x-25) (y+10) (y)
let plmnts = bln x1 y1 ++ bln x2 y2 ++ bln x3 y3 ++ blv x4 y4
++ [PS p (-pi/2) $ PutCrit autoCrit
]
return $ set rmPS plmnts $ roomRect w 600
shootersRoom :: RandomGen g => State g Room
shootersRoom = do
w <- state $ randomR (200,300)
x1 <- state $ randomR (20,w/3-20)
x2 <- state $ randomR (w/3+20,2*w/3-20)
x3 <- state $ randomR (2*w/3+20,w-20)
y1 <- state $ randomR (250,560)
y2 <- state $ randomR (250,560)
y3 <- iterateWhile (\y' -> abs (y1 - y2) < 60 && abs (y2 - y') < 60) $ state $ randomR (250,560)
x4 <- state $ randomR (60,w-60)
y4 <- state $ randomR (40,180)
let bln x y = putBlockN (x+25) (x-25) (y+10) (y)
let blv x y = putBlockV (x+25) (x-25) (y+10) (y)
let plmnts = bln x1 y1 ++ bln x2 y2 ++ bln x3 y3 ++ blv x4 y4
++ [PS (x1,y1-10) (-pi/2) $ PutCrit autoCrit
,PS (x2,y2-10) (-pi/2) $ PutCrit autoCrit
,PS (x3,y3-10) (-pi/2) $ PutCrit autoCrit
]
return $ set rmPS plmnts $ roomRect w 600
pistolerRoom :: RandomGen g => State g Room
pistolerRoom = do
let f2 x y = putWallBlocks (x,y) (x,y)
-- let f2 x y = [PS (x,y) 0 $ PutWindow (rectNSEW 40 0 0 40) $ withAlpha 0.5 aquamarine]
f3 x y = putWallBlocks (x-20,y) (x+20,y)
++ putWallBlocks (x,y-20) (x,y+20)
f4 x y = putWallBlocks (x-20,y-20) (x+20,y+20)
++ putWallBlocks (x+20,y-20) (x-20,y+20)
--f <- takeOne [f2,f3,f4]
f <- takeOne [f2]
h <- state $ randomR (400,800)
let w = h
i <- takeOne [2,4,6,8]
let j = fromIntegral (i+1)
-- the 20+etc here is to correct for the pathfinding grid, which matches up to
-- edges based on the size of doors (i.e. the line next to the wall is 20
-- away from it)
xs = take i [20+0.5*(w-40)/(j-1),20+1.5*(w-40)/(j-1)..]
ys = take i [20+0.5*(h-40)/(j-1),20+1.5*(h-40)/(j-1)..]
gap = 0.5 * h / j
ps <- takeN 3 $ zip (map (+gap) xs) ys
aa <- state $ randomR (0,2*pi)
ab <- state $ randomR (0,2*pi)
ac <- state $ randomR (0,2*pi)
let plmnts = [PS (ps !! 0) aa $ PutCrit pistolCrit
,PS (ps !! 1) ab $ PutCrit pistolCrit
,PS (ps !! 2) ac $ PutCrit pistolCrit
-- ,PS (w-5,h/2) 0 $ basicLS
-- ,PS (5,h/2) 0 $ basicLS
-- ,PS (w/2,h-5) 0 $ basicLS
-- ,PS (w/2,5) 0 $ basicLS
-- ,PS (w-50,h/2) 0 $ basicLS
-- ,PS (50,h/2) 0 $ basicLS
,PS (w/2,h-50) 0 $ basicLS
,PS (w/2,50) 0 $ basicLS
,PS (w-5,h-5) 0 $ basicLS
,PS (5,h-5) 0 $ basicLS
,PS (w-5,5) 0 $ basicLS
,PS (5,5) 0 $ basicLS
,PS (w/2,h/2) 0 $ basicLS
]
++
-- f (w*0.25) (h*0.5)
concat [f x y | x<-xs,y<-ys]
return
$ set rmPS plmnts $ roomRect' w h (max i 2) (max i 2)
shootingRange :: RandomGen g => State g (Tree (Either Room Room))
shootingRange = do
rm1 <- shootersRoom1 >>= changeLinkTo (\((_,y),_) -> y < 40)
>>= filterLinks (\((_,y),r) -> y > 200 && r /= 0)
rm2 <- shootersRoom >>= changeLinkTo (\((x,y),_) -> y < 10 && x > 20 && x < 180)
>>= filterLinks (\((_,y),r) -> y > 200 && r /= 0)
rm3 <- shootersRoom >>= changeLinkTo (\((x,y),_) -> y < 10 && x > 20 && x < 180)
>>= filterLinks (\(_,r) -> r == 0)
return $ treePost [Left rm1
,Left $ roomPadCut (rectNSWE 20 (-20) (-80) 80) (0,20)
,Left rm2
,Left $ roomPadCut (rectNSWE 20 (-20) (-80) 80) (0,20)
]
(Right rm3)
spawnerRoom :: RandomGen g => State g (Tree (Either Room Room))
spawnerRoom = do
x <- state $ randomR (250,300)
y <- state $ randomR (300,400)
wl <- takeOne [PS (0,0) 0 $ PutWindow (rectNSWE (y-60) 0 (x/2-10) (x/2+10))
$ withAlpha 0.5 aquamarine
,PS (0,0) 0 $ PutWindowBlock (x/2,0) (x/2,y-60)
]
let plmnts = [PS (x/4, y/4) (pi/2) $ PutCrit spawnerCrit
-- ,PS (0,0) 0 $ PutWindowBlock (x/2,0) (x/2,y-60)
,wl
]
let f ((lx,_),_) = lx < x/2-5
roomWithSpawner <- randomiseLinks =<< (filterLinks f $ set rmPS plmnts $ roomRect' x y 2 2)
return $ treeTrunk [Left (airlock 0)] roomWithSpawner
src/Dodge/Smoke.hs
+33
View File
@@ -0,0 +1,33 @@
module Dodge.Smoke where
import Dodge.Data
import Dodge.Base
import Dodge.RandomHelp
import Geometry.Data
import Picture
import Control.Lens
import Control.Monad.State
spawnSmokeAt :: Point2 -> World -> World
spawnSmokeAt p w =
w & smoke %~ (:) thesmoke
& randGen .~ g
where
thesmoke = Smoke
{_smPos = p
,_smRad = 20
,_smColor = white
,_smUpdate = f
,_smPs = ps
,_smTime = 500
}
f s = case s ^. smPs of
[] -> Nothing
_ -> case s ^. smTime of
0 -> Just $ s & smPs %~ init
t -> Just $ s & smTime .~ t-1
(ps,g) = runState (sequence $ replicate 60 $ randInCirc 20) $ _randGen w
spawnSmokeAtCursor :: World -> World
spawnSmokeAtCursor w = spawnSmokeAt (mouseWorldPos w) w
src/Dodge/SoundLogic.hs
+86
View File
@@ -0,0 +1,86 @@
module Dodge.SoundLogic where
-- imports {{{
import Dodge.Data
import Control.Lens
import qualified Data.Map as M
-- }}}
--
-- PLACEHOLDERS:
haltSound :: World -> World
haltSound w = w
pauseSound :: World -> World
pauseSound w = w
resumeSound :: World -> World
resumeSound w = w
soundOnce :: Int -> World -> World
soundOnce i = over soundQueue ((:) i)
continueSoundFrom :: SoundOrigin -> Int -> Int -> Int -> World -> World
continueSoundFrom so sType time fadeTime w
= over sounds (M.insertWith f so sound) w
where sound = Sound { _soundType = sType
, _soundTime = time
, _soundFadeTime = fadeTime
, _soundChannel = Nothing
, _soundPos = Nothing
}
f _ s = s {_soundTime = time, _soundFadeTime = fadeTime}
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 = time
, _soundFadeTime = fadeTime
, _soundChannel = Nothing
, _soundPos = Nothing
}
f _ s = s {_soundTime = time, _soundFadeTime = fadeTime}
soundMultiFrom :: [SoundOrigin] -> Int -> Int -> Int -> World -> World
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 = time
, _soundFadeTime = fadeTime
, _soundChannel = Nothing
, _soundPos = Nothing
}
stopSoundFrom :: SoundOrigin -> World -> World
stopSoundFrom so = over (sounds . ix so . soundTime) (min 0)
-- idea: pass the id of the sound to the world and send it to some queue for
-- playback
reloadSound,putDownSound,pickUpSound,fireSound,grenadeBang,healSound,teleSound,twoStepSlowSound :: Int
clickSound = 1
reloadSound = 2
pickUpSound = 4
putDownSound = 5
fireSound = 6
grenadeBang = 7
tapQuiet = 8
twoStepSound = 9
healSound = 10
doorSound = 11
twoStepSlowSound = 12
knifeSound = 13
buzzSound = 14
hitSound = 15
autoGunSound = 16
shotgunSound = 17
teleSound = 18
longGunSound = 19
launcherSound = 20
smokeTrailSound = 21
foot1Sound = 22
foot2Sound = 23
src/Dodge/Update.hs
+190
View File
@@ -0,0 +1,190 @@
module Dodge.Update where
-- imports {{{
import Dodge.Data
import Dodge.Base
import Dodge.WallCreatureCollisions
import Dodge.Block
import Dodge.Camera
import Dodge.SoundLogic
import Geometry
import Data.List
import Data.Maybe
import Data.Function
import qualified Data.Set as S
import qualified Data.IntMap.Strict as IM
import qualified Data.Map as M
import Control.Lens
-- }}}
update :: World -> World
update w = let w1 = updateParticles' $ updateParticles
$ updateLightSources
$ zoneClouds
$ updateClouds
$ updateSmoke
$ updateCreatures
$ updateBlocks -- $ zoning
$ updateSeenWalls
w
w2 = -- updateWeaponCounters $
simpleCrSprings
$ zoneCreatures $ wallEvents
$ set worldEvents id $ _worldEvents w1
w1
w3 = updateCamera
$ updateAfterParticles'
$ colCrsWalls
w2
in checkEndGame $ ppEvents w3
where -- zoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w))
-- w
-- wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize
-- = insertIMInZone x y wlid wl
-- | otherwise = flip (foldr (\(a,b) -> insertIMInZone a b wlid wl)) ips
-- where (x,y) = zoneOfPoint $ (pHalf (_wlLine wl !! 0) (_wlLine wl !! 1))
-- wlid = _wlID wl
-- ips = map zoneOfPoint $ divideLine (2*zoneSize) (_wlLine wl !! 0) (_wlLine wl !! 1)
zoneCreatures = set creaturesZone (IM.foldr creatureInZone IM.empty (_creatures w))
creatureInZone cr = insertIMInZone x y cid cr
where (x,y) = zoneOfPoint $ _crPos cr
cid = _crID cr
zoneClouds = set cloudsZone (IM.foldr cloudInZone IM.empty (_clouds w))
cloudInZone cr = insertIMInZone x y cid cr
where (x,y) = zoneOfPoint $ _clPos cr
cid = _clID cr
updateLightSources w = set tempLightSources (catMaybes tlss) w'
where (w',tlss) = mapAccumR (\a b -> _tlsUpdate b a b) w $ _tempLightSources w
updateParticles w = IM.foldr' _ptUpdate w $ _particles w
updateSmoke :: World -> World
updateSmoke w = w & smoke %~ mapMaybe (\s -> _smUpdate s s)
updateParticles' :: World -> World
updateParticles' w = set particles' (catMaybes ps) w'
where (w',ps) = mapAccumR (\a b -> _ptUpdate' b a b) w $ _particles' w
updateAfterParticles' :: World -> World
updateAfterParticles' w = set afterParticles' (catMaybes ps) w'
where (w',ps) = mapAccumR (\a b -> _ptUpdate' b a b) w $ _afterParticles' w
updateCreatures :: World -> World
updateCreatures w = f $ set randGen newG $ set creatures (IM.mapMaybe id crs) w
where ((f,newG),crs) = IM.mapAccum (\g' cr -> _crUpdate cr w g' cr) (id,_randGen w) $ _creatures w
wallEvents :: World -> World
wallEvents w = IM.foldr (_doorMech) w ( IM.filter (\d -> case d of
Door {} -> True
AutoDoor {} -> True
BlockAutoDoor {} -> True
_ -> False) ( _walls w))
ppEvents :: World -> World
ppEvents w = IM.foldr' (\pp w -> _ppEvent pp pp w) w $ _pressPlates w
updateSeenWalls :: World -> World
updateSeenWalls w = foldr markSeen w wallsToUpdate
where yPos = _crPos $ _creatures w IM.! 0
wallsToUpdate = map _wlID $ IM.elems $ wallsNearPoint yPos w
-- wallsToUpdate = concatMap (\p -> collidePointFindWalls yPos (yPos +.+p) $ wallsAlongLine yPos (yPos +.+ p) w)
-- $ nRays 60
markSeen i = set (walls . ix i . wlSeen) True
setTestStringIO :: IO World -> IO World
setTestStringIO = fmap (\ w -> set testString (show $ s w) w)
where s w = (-.-) <$> (w ^? creatures . ix 0 . crPos) <*> (w ^? creatures . ix 0 . crOldPos)
-- w --do numC <- Mix.numChannelsPlaying
-- w' <- w
-- let ycr = _creatures w' IM.! 0
-- let st = _stance $ _crState ycr
-- let vel = magV $ _crPos ycr -.- _crOldPos ycr
-- let (x,y) = zoneOfPoint $ _crPos ycr
-- --fmap (set testString $ show (map _wlLine $ IM.elems $ _wallsZone w' IM.! x IM.! y)) w
-- fmap (set testString $ show $ last $ show $ pairsToIncidence' $ _pathGraph' w') w
-- update logic: creature old position set, creatures perform actions including movement,
-- creatures collided with each other, camera updated, particles updated, creatures
-- collided with walls
checkEndGame :: World -> World
checkEndGame w | _crHP (you w) < 1 = haltSound $ w {_menuState = GameOverMenu}
| otherwise = w
updateClouds :: World -> World
updateClouds w = IM.foldr' updateCloud w $ _clouds w
updateCloud :: Cloud -> World -> World
updateCloud c w | _clTimer c < 1 = w & clouds %~ IM.delete (_clID c)
| otherwise = moveCloud c w
moveCloud :: Cloud -> World -> World
moveCloud c w = _clEffect c c . theUpdate $ w
where newVel = 0.99 *.* springVels
springVels = IM.foldr' (clClSpringVel c w) (_clVel c) (cloudsNearPoint oldPos 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)
theUpdate w' = w' & clouds . ix (_clID c) . clTimer %~ (\t -> t - 1)
& clouds . ix (_clID c) . clVel .~ finalVel
& clouds . ix (_clID c) . clPos .~ finalPos
clClSpringVel :: Cloud -> World -> Cloud -> Point2 -> Point2
clClSpringVel a w b v
| ida == idb = v
| dist pa pb < 5 = v +.+ 0.1 *.* (safeNormalizeV (pa -.- pb))
| otherwise = v
where ida = _clID a
idb = _clID b
pa = _clPos a
pb = _clPos b
simpleCrSprings :: World -> World
simpleCrSprings w = IM.foldr' crSpring w $ _creatures w
crSpring :: Creature -> World -> World
crSpring c w = IM.foldr' (crCrSpring c) w $ cs
where cs = creaturesNearPoint (_crPos c) w
crCrSpring :: Creature -> Creature -> World -> World
crCrSpring c1 c2 w
| id1 == id2 = w
| vec == (0,0) = w
| diff < comRad = over (creatures . ix id1 . crPos) (+.+ overlap1)
$ over (creatures . ix id2 . crPos) (-.- overlap2) w
| otherwise = w
where id1 = _crID c1
id2 = _crID c2
vec = _crPos c1 -.- _crPos c2
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
massT = _crMass c1 + _crMass c2
collidePointFindWall :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Int
collidePointFindWall p1 p2 ws = fmap fst $ listToMaybe $ sortBy f
$ IM.toList
$ IM.mapMaybe ((\(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine) ws
where f (_,a) (_,b) = compare (magV (p1 -.- a)) (magV (p1 -.- b))
collidePointFindWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Int]
collidePointFindWalls p1 p2 ws
-- = map fst . takeWhileAnd g . map snd . sortBy (compare `on` (dist p1 . fst . fromJust)) . filter ((/=) Nothing . fst) . map f $ IM.toList ws
= map fst . takeWhileAnd g . map snd . sortBy (compare `on` (dist p1 . fromJust . fst)) . filter ((/=) Nothing . fst) . map f $ IM.toList ws
where f (i,wl) = (intersectSegSeg' (_wlLine wl !! 0) (_wlLine wl !! 1) p1 p2, (i,wl))
g (_,wl) = _wlIsSeeThrough wl
takeWhileAnd h xs = let (ys,zs) = span h xs
in ys ++ tf zs
where tf (x:_) = [x]
tf _ = []
src/Dodge/WallCreatureCollisions.hs
+95
View File
@@ -0,0 +1,95 @@
module Dodge.WallCreatureCollisions where
-- imports {{{
import Dodge.Data
import Dodge.Base
import Geometry
import Data.List
import Data.Maybe
import Data.Function
import Control.Lens
import qualified Data.IntMap.Strict as IM
colCrsWalls :: World -> World
colCrsWalls w = over creatures (fmap (colCrWall w)) w
colCrWall :: World -> Creature -> Creature
colCrWall w c = pushOutFromWall w c
pushOutFromWall :: World -> Creature -> Creature
pushOutFromWall w c
| p1 == p2 = c
| otherwise = over crPos (
collideCorners rad p1 wallPoints
.
collideWalls rad p1 ls
. checkPushThroughs rad p1 ls
)
c
where rad = _crRad c + wallBuffer
p1 = _crOldPos c
p2 = _crPos c
ls = IM.elems $ fmap _wlLine $ wallsNearPoint p2 w
wallPoints = nub $ concat ls
-- colCrPushThrough :: World -> Creature -> Creature
-- colCrPushThrough w cr = set crPos (checkPushThroughs rad p1 p2 ls) cr
-- where rad = _crRad cr + wallBuffer
-- p1 = _crOldPos cr
-- p2 = _crPos cr
-- ls = IM.elems $ fmap _wlLine $ wallsNearPoint p2 w
-- -- probably best to push check pushing through walls before creature springs
-- the amount to push creatures out from walls, extra to their radius
wallBuffer = 3
-- the following tests whether a moving circle crosses a list of walls, and
-- places the circle accordingly.
-- It supposes that the circle will only interact with at most two walls.
-- the reverse prevents the collision from happening again with the first wall,
-- when two walls are collided with
collideWalls :: Float -> Point2 -> [[Point2]] -> Point2 -> Point2
collideWalls rad cp1 walls cp2
= case (listToMaybe.mapMaybe (collideWall rad cp1 cp2)) walls of
Nothing -> cp2
Just cp3 -> case (listToMaybe.reverse.mapMaybe (collideWall rad cp1 cp3)) walls of
Nothing -> cp3
Just cp4 -> cp4
-- assumes that the wall is orientated
-- assumes wall points are different
collideWall :: Float -> Point2 -> Point2 -> [Point2] -> Maybe (Point2)
collideWall rad cp1 cp2 (wp1:wp2:_)
| isOnWall = Just newP -- +.+ (1 *.* norm))
| otherwise = Nothing
where norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2)
wp1' = (rad *.* norm) +.+ wp1
wp2' = (rad *.* norm) +.+ wp2
newP = errorClosestPointOnLine 5 wp1' wp2' cp2
isOnWall = circOnLine' wp1 wp2 cp2 rad
isJust Nothing = False
isJust _ = True
collideCorners :: Float -> Point2 -> [Point2] -> Point2 -> Point2
collideCorners rad p1 ps p2 = foldr (intersectCirclePoint rad) p2 ps
-- collide circles with points (outer corners)
intersectCirclePoint :: Float -> Point2 -> Point2 -> Point2
intersectCirclePoint rad p cCen | dist cCen p > rad = cCen
| otherwise = p +.+ (rad *.* errorNormalizeV 65 (cCen -.- p))
checkPushThroughs :: Float -> Point2 -> [[Point2]] -> Point2 -> Point2
checkPushThroughs rad cp1 walls cp2
= fromMaybe cp2 $ (listToMaybe.mapMaybe (checkPushThrough rad cp1 cp2)) walls
checkPushThrough :: Float -> Point2 -> Point2 -> [Point2] -> Maybe (Point2)
checkPushThrough rad cp1 cp2 (wp1:wp2:_)
| isPushedThrough = intersectSegSeg' cp1 cp2 wp1 wp2
| otherwise = Nothing
where norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2)
wp1' = (rad *.* norm) +.+ wp1
wp2' = (rad *.* norm) +.+ wp2
newP = errorClosestPointOnLine 5 wp1' wp2' cp2
isPushedThrough = isRHS wp1 wp2 cp2 && isJust (intersectSegSeg' cp1 cp2 wp1 wp2)
isJust Nothing = False
isJust _ = True
src/Dodge/Weapons.hs
+2764
View File
File diff suppressed because it is too large Load Diff
src/Dodge/WorldActions.hs
+901
View File
@@ -0,0 +1,901 @@
module Dodge.WorldActions where
import Dodge.Data
import Dodge.Base
import Dodge.SoundLogic
import Dodge.RandomHelp
import Geometry
import Picture
import Control.Lens
import Control.Monad.State
import System.Random
import Data.Maybe
import Data.Function
import Data.List
import qualified Data.IntMap.Strict as IM
makeExplosionAt :: Point2 -> World -> World
makeExplosionAt p w = soundOnce grenadeBang
$ over tempLightSources ((:) $ tLightFade 20 150 intensityF p)
$ fs
$ over particles (IM.insert n exp)
w
where n = newParticleKey w
exp = Particle
{ _ptPos = p
, _ptStartPos = p
, _ptVel = (0,0)
, _ptPict = blank
, _ptID = n
, _ptUpdate = explosionWaveDamage 6 p n
}
fVs = fst $ runState ((sequence . take 75 . repeat . randInCirc) 1) $ _randGen w
fPs' = evalState ((sequence . take 75 . repeat . randInCirc) 15) $ _randGen w
fPs = map (pushAgainstWalls . (+.+) p . (*.*) 0.5)
--fPs = map (pushAgainstWalls . (+.+) p . (*.*) 5)
fPs'
inversePushOut v = (15 - magV v) * 0.01 *.* v
fVs' = zipWith (+.+) fVs $ map inversePushOut fPs'
sizes = randomRs (2,6) $ _randGen w
times = randomRs (20,25) $ _randGen w
mF q v size time = makeFlameletTimed q v (levLayer GloomLayer - 1) Nothing size time
newFs = zipWith4 mF fPs (fmap (3 *.*) fVs') sizes times
fs w = foldr ($) w newFs
pushAgainstWalls q = fromMaybe q $ fmap (\(x,y)-> x +.+ y)
$ collidePointWalls p q $ wallsNearPoint q w
fadeFac x | x > 10 = 0
| otherwise = 1 - fromIntegral x / 10
intensityF x | x < 10 = 1 / (10 - fromIntegral x)
| otherwise = 1
explosionWaveDamage :: Int -> Point2 -> Int -> World -> World
explosionWaveDamage 0 p ptid = over particles (IM.delete ptid)
explosionWaveDamage time p ptid
= set (particles . ix ptid . ptUpdate) (explosionWaveDamage (time-1) p ptid)
. shockWaveDamage p rad 20
. set (particles . ix ptid . ptPict) shockwavePic
. lowLightRadAt white 0.3 75 150 p
where shockwavePic = onLayer PtLayer $ uncurry translate p $ color (withAlpha 0.9 white)
$ thickCircle rad (thickness*2)
thickness = max 0 $ sqrt $ (fromIntegral time - 2) * 8
rad = 40 - thickness
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
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'
{ _ptPict' = 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 ptPict' 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 ptPict' (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
inverseShockwaveAt :: Point2 -> Float -> Int -> Float -> Float -> World -> World
inverseShockwaveAt p rad dam push pushexp = over particles' ((:) theShockwave)
where theShockwave
= Particle'
{ _ptPict' = 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 ptPict' (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
-- makeTremorAt :: Int -> Point -> Float -> Particle
-- makeTremorAt i pos d = Particle
-- { _ptPos = (0,0)
-- , _ptStartPos = (0,0)
-- , _ptVel = (0,0)
-- , _ptPict = Line [(0,0),(0,0)]
-- , _ptID = i
-- , _ptUpdate = moveTremor [pos] 200 pos d i
-- }
--
-- moveTremor :: [Point] -> Int -> Point -> Float -> Int -> World -> World
-- moveTremor ps t p1 d i w
-- | t <= -30 = over particles (IM.delete i) . over partUnder (IM.delete i) $ w
-- | t <= 0 = set (particles . ix i . ptUpdate) (moveTremor ps (t-1) p1 d i)
-- . over partUnder
-- (IM.insert i (lineOfThickness (0.1*(fromIntegral t + 30)) ps)) $ w
-- | otherwise = case hitWall of
-- Nothing -> upUndPict . set randGen g . shakeCrs .
-- shatterAt p1 pl $ shatterAt p1 pr
-- $ set (particles . ix i . ptUpdate) (moveTremor (p3:ps) (t-1) p3 d i)
-- $ damCrsOnLine 10 p1 p3 w
-- Just (pw,pRef) -> set (particles . ix i . ptUpdate) (moveTremor ps (t-1) p1 (argV pRef) i) w
-- where p2 = p1 +.+ 5 *.* unitVectorAtAngle d
-- pl = p1 +.+ rotateV (d + pi/4) (75,0)
-- pr = p1 +.+ rotateV (d - pi/4) (75,0)
-- hitWall = collidePointWalls p1 p3 $ wallsAlongLine p1 p3 w
-- (d1,g) = randomR (0,2*pi) $ _randGen w
-- v = unitVectorAtAngle d1
-- p3 = p2 +.+ 5 *.* v
-- shakeCrs = over creatures (IM.map shCr)
-- shCr cr | dist p1 (_crPos cr) < 75 = over crPos (+.+ v) cr
-- | otherwise = cr
-- upUndPict = over partUnder (IM.insert i pic)
-- pic = pictures [color white $ lineOfThickness 3 [p3,head ps]
-- ,lineOfThickness 3 ps]
--
-- makeTremorAt' :: Int -> Point -> Particle
-- makeTremorAt' i pos = Particle
-- { _ptPos = (0,0)
-- , _ptStartPos = (0,0)
-- , _ptVel = (0,0)
-- , _ptPict = Line [(0,0),(0,0)]
-- , _ptID = i
-- , _ptUpdate = rotateTremorAround 10 pos i
-- }
--
-- rotateTremorAround :: Int -> Point -> Int -> World -> World
-- rotateTremorAround 0 p i w = over particles (IM.delete i) w
-- rotateTremorAround t p i w = set (particles . ix i . ptUpdate) (rotateTremorAround (t-1) p i)
-- $ foldr ($) w shatters
-- where rot d = rotateV $ d + fromIntegral t * pi / 7
-- ds = fmap (\x -> fromIntegral x * pi / 2.5) [0..4]
-- shatters = map (\d -> shatterAt p (p +.+ rot d (300,0))) ds
--
-- shatterAt :: Point -> Point -> World -> World
-- shatterAt p1 p2 w = case wlHit of
-- Just (p,v,col) -> makeFallingBlock col (f1 p) (f2 v)
-- $ set randGen g w
-- _ -> w
-- where wlHit = collidePointWallsNormCol p1 p2 $ wallsNearPoint p2 w
-- f1 q = q +.+ 5 *.* errorNormalizeV 10 (p2 -.- p1)
-- (d,g) = randomR (-0.5,0.5) $ _randGen w
-- f2 v' = rotateV d $ 3 *.* errorNormalizeV 11 v'
--
-- fallingWall :: Int -> Color -> Point -> Float -> Particle
-- fallingWall pid col p d
-- = Particle
-- { _ptPos = p
-- , _ptStartPos = p
-- , _ptVel = rotateV d (3,0)
-- , _ptPict = Line [(0,0),(0,0)]
-- , _ptID = pid
-- , _ptUpdate = moveFallingWall 10 p d col pid
-- }
--
-- moveFallingWall :: Int -> Point -> Float -> Color -> Int -> World -> World
-- moveFallingWall 0 p d col i w = over particles (IM.delete i) $ b1 $ b2 w
-- where b1 = makeFallingBlock col (p +.+ ( 3, 3)) (rotateV d (0,5))
-- b2 = makeFallingBlock col (p +.+ (-3,-3)) (rotateV d (0,1))
-- moveFallingWall t p d col i w
-- = set (particles . ix i . ptUpdate) (moveFallingWall (t-1) np d col i)
-- $ set (particles . ix i . ptPict) pic
-- w
-- where np = p +.+ 1 *.* unitVectorAtAngle d
-- pic = uncurry translate p $ rotate (-radToDeg d)
-- $ color col $ polygon [(-6,-6)
-- ,(-6, 6)
-- ,( 6, 6)
-- ,( 6,-6)
-- ]
--
-- makeFallingBlock :: Color -> Point -> Point -> World -> World
-- makeFallingBlock col p v w
-- = over particles (IM.insert i $ fallingBlock i col p v) w
-- where i = newParticleKey w
--
-- fallingBlock :: Int -> Color -> Point -> Point -> Particle
-- fallingBlock pid col p v
-- = Particle
-- { _ptPos = p
-- , _ptStartPos = p
-- , _ptVel = v
-- , _ptPict = Line [(0,0),(0,0)]
-- , _ptID = pid
-- , _ptUpdate = moveFallingBlock 10 p v col pid
-- }
--
-- moveFallingBlock :: Int -> Point -> Point -> Color -> Int -> World -> World
-- moveFallingBlock 0 p v col i w = over particles (IM.delete i) w
-- moveFallingBlock t p v col i w
-- = case hitCr of
-- Nothing -> set (particles . ix i . ptUpdate) (moveFallingBlock (t-1) np v col i)
-- $ set (particles . ix i . ptPict) pic
-- w
-- Just (p1,v1,crID) -> over particles (IM.delete i)
-- $ over (creatures . ix crID . crHP) (\hp -> hp - 1) w
-- where np = p +.+ v
-- pic = uncurry translate p $ rotate (-radToDeg (argV v))
-- $ color col $ polygon [(-3,-3)
-- ,(-3, 3)
-- ,( 3, 3)
-- ,( 3,-3)
-- ]
-- hitCr = reflectCircCreatures 4 p np $ _creatures w
-- if the spark is created by another Particle', it cannot be directly added to
-- the list, hence the redirect through worldEvents
createSpark :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World
createSpark time colid pos dir maycid w = over worldEvents
((.) $ ( over particles' ((:) spark)
. flareAt' white 0.02 0.05 pos')
-- . lowLightAt' pos)
) w
where spark = Bul' { _ptPict' = blank
, _ptUpdate' = mvGenBullet'
, _btVel' = rotateV dir (5,0)
, _btColor' = numColor colid
, _btTrail' = [pos]
, _btPassThrough' = maycid
, _btWidth' = 1
, _btTimer' = time
, _btHitEffect' = threeEff' 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 :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World
createBarrelSpark time colid pos dir maycid w = over worldEvents
((.) $ ( over particles' ((:) spark)
. flareAt' white 0.005 0.03 pos')
-- . lowLightAt' pos)
) w
where spark = Bul' { _ptPict' = blank
, _ptUpdate' = mvGenBullet'
, _btVel' = rotateV dir (5,0)
, _btColor' = numColor colid
, _btTrail' = [pos]
, _btPassThrough' = maycid
, _btWidth' = 1
, _btTimer' = time
, _btHitEffect' = threeEff' 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
flareAt :: Color -> Point2 -> World -> World
flareAt c p = flareAt' c 0.02 0.5 p
flareAt' :: Color -> Float -> Float -> Point2 -> World -> World
flareAt' col alphax alphay p
= over particles' ((:) (flashColAt col alphax p))
. lowLightColAt col alphay p
tLightFade :: Int -> Float -> (Int -> Float) -> Point2 -> TempLightSource
tLightFade 0 rmax intensityF p =
TLS { _tlsPos = p
, _tlsRad = rmax
, _tlsIntensity = intensityF 0
, _tlsUpdate = \w _ -> (w, Nothing)
}
tLightFade i rmax intensityF p =
TLS { _tlsPos = p
, _tlsRad = rmax
, _tlsIntensity = intensityF i
, _tlsUpdate = \w _ -> (w, Just $ tLightFade (i-1) rmax intensityF p)
}
tLightRad :: Int -> Float -> Float -> Point2 -> TempLightSource
tLightRad 0 rmax rmin p =
TLS { _tlsPos = p
, _tlsRad = rmax
, _tlsIntensity = 0.5
, _tlsUpdate = \w _ -> (w, Nothing)
}
tLightRad i rmax rmin p =
TLS { _tlsPos = p
, _tlsRad = rmax
, _tlsIntensity = 0.5
, _tlsUpdate = \w _ -> (w, Just $ tLightRad (i-1) rmax rmin p)
}
tLightAt i p = tLightRad i 100 0 p
flareWidth :: Float -> Float -> Float -> Int -> Color -> Float -> Float -> Point2 -> World -> World
flareWidth len wdth rad rays col ax ay p
= over particles' ((:) (flashRadAt rad col ax p))
. lowLightWidthAt len wdth col ay rays rad p
flareRad :: Float -> Int -> Color -> Float -> Float -> Point2 -> World -> World
flareRad rad rays col ax ay p
= over particles' ((:) (flashRadAt rad col ax p))
. lowLightRadAt col ay rays rad p
flashRadAt :: Float -> Color -> Float -> Point2 -> Particle'
flashRadAt rad col alphax (x,y) =
Particle'
{ _ptPict' = mconcat $
map (\i -> onLayerL [levLayer PtLayer]
$ color (withAlpha alphax col) $ translate x y $ circleSolid i
)
[rad/5,2*rad/5,3*rad/5,4*rad/5,rad]
, _ptUpdate' = ptTimer' 1
}
flashColAt :: Color -> Float -> Point2 -> Particle'
flashColAt col alphax (x,y) =
Particle'
{ _ptPict' = mconcat $
map (\i -> onLayerL [levLayer PtLayer]
$ color (withAlpha alphax col) $ translate x y $ circleSolid i
)
[20,25,30,35,40,45,50]
, _ptUpdate' = ptTimer' 1
}
lowLightWidthAt :: Float -> Float -> Color -> Float -> Int -> Float -> Point2 -> World -> World
lowLightWidthAt len wdth col alphay rays rad p w = foldr (lowLightWidthHit len wdth col alphay p) w ps
where ps = map ((+.+) p) $ nRaysRad rays rad
lowLightRadAt :: Color -> Float -> Int -> Float -> Point2 -> World -> World
lowLightRadAt col alphay rays rad p w = foldr (lowLightColHit col alphay p) w ps
where ps = map ((+.+) p) $ nRaysRad rays rad
lowLightColAt :: Color -> Float -> Point2 -> World -> World
lowLightColAt col alphay p w = foldr (lowLightColHit col alphay p) w ps
where ps = map ((+.+) p) $ nRaysRad 20 30
lowLightDirected :: Color -> Float -> Point2 -> Point2 -> [Float] -> World -> World
lowLightDirected col alpha a b angles w
= foldr (\angle w' -> lowLightColHit col alpha a (a +.+ rotateV angle b) w') w angles
lowLightColHit :: Color -> Float -> Point2 -> Point2 -> World -> World
lowLightColHit col alphay a b w
= case thingsHitLongLine a b w of
((p, E3x2 wall):_)
-> over particles' ((:) (wallGlareCol col alphay p wall)) w
((p, E3x1 cr):_)
-> over afterParticles' ((:) (crGlareCol col alphay p cr)) w
_ -> w
wallGlareCol :: Color -> Float -> Point2 -> Wall -> Particle'
wallGlareCol col alphay p wl = wallGlareWidth 10 5 col alphay p wl
crGlareCol :: Color -> Float -> Point2 -> Creature -> Particle'
crGlareCol col alphay p cr = crGlareWidth 5 col alphay p cr
lowLightWidthHit :: Float -> Float -> Color -> Float -> Point2 -> Point2 -> World -> World
lowLightWidthHit len wdth col alphay a b w
= case thingsHitLongLine a b w of
((p, E3x2 wall):_)
-> over particles' ((:) (wallGlareWidth len wdth col alphay p wall)) w
((p, E3x1 cr):_)
-> over afterParticles' ((:) (crGlareWidth wdth col alphay p cr)) w
_ -> w
wallGlareWidth :: Float -> Float -> Color -> Float -> Point2 -> Wall -> Particle'
wallGlareWidth len wdth col alphay p wl =
Particle'
{ _ptPict' = onLayerL [levLayer GloomLayer + 2] $ l
, _ptUpdate' = ptTimer' 1
}
where l = color (withAlpha alphay col) $ lineOfThickness wdth $ [p +.+ x, p -.- x]
x = len *.* ( normalizeV $ a -.- b)
(a:b:_) = _wlLine wl
crGlareWidth :: Float -> Color -> Float -> Point2 -> Creature -> Particle'
crGlareWidth wdth col alphay p cr =
Particle'
{ _ptPict' = onLayerL [levLayer GloomLayer + 2] $ l cp
--{ _ptPict' = [(blank, [levLayer WlLayer + 2])]
, _ptUpdate' = \w pt -> (w, Just $ pt {_ptPict' = onLayerL [levLayer GloomLayer + 2] $ upp cid w
,_ptUpdate' = ptTimer' 0
}
)
}
where l x = uncurry translate x
$ rotate (90 - (radToDeg $ argV (p -.- x)))
$ color (withAlpha alphay col)
$ thickArc 0 180 (_crRad cr) wdth
-- where l = rotate (radToDeg $ argV (cp -.- p)) $ uncurry translate cp $ color (withAlpha 0.5 white) $ thickArc 0 25 (_crRad cr) 5
cp = _crPos cr
cid = _crID cr
upp cid' w' = case w' ^? creatures . ix cid . crPos of
Just y -> l y
--Just p -> uncurry translate p $ circleSolid 5
_ -> blank
muzFlareAt :: Point2 -> World -> World
muzFlareAt p = over particles' ((:) (muzzleFlareAt p))
. lowLightAt p
muzzleFlareAt :: Point2 -> Particle'
muzzleFlareAt (x,y) =
Particle'
{ _ptPict' = mconcat
$ map (\i -> onLayer PtLayer $ color (withAlpha 0.02 white) $ translate x y $ circleSolid i
)
[20,25,30,35,40,45,50]
, _ptUpdate' = ptTimer' 1
}
ptTimer' :: Int -> World -> Particle' -> (World, Maybe Particle')
ptTimer' 0 w pt = (w, Nothing)
ptTimer' n w pt = (w, Just $ pt {_ptUpdate' = ptTimer' (n-1)})
lowLightAt :: Point2 -> World -> World
lowLightAt p w = lowLightWidthAt 10 5 white 0.5 20 30 p w
lowLightHit :: Point2 -> Point2 -> World -> World
lowLightHit a b w
= case thingsHitLongLine a b w of
((p, E3x2 wall):_)
-> over particles' ((:) (wallGlare p wall)) w
((p, E3x1 cr):_)
-> over afterParticles' ((:) (crGlare p cr)) w
_ -> w
wallGlare :: Point2 -> Wall -> Particle'
wallGlare p wl = wallGlareWidth 10 5 white 0.5 p wl
crGlare :: Point2 -> Creature -> Particle'
crGlare = crGlareCol white 0.5
-- crGlare p cr =
-- Particle'
-- { _ptPict' = [(l, [levLayer WlLayer + 2])]
-- , _ptUpdate' = ptTimer' 1
-- }
-- where l = uncurry translate cp
-- $ rotate (90 - (radToDeg $ argV (p -.- cp)))
-- $ color (withAlpha 0.5 white)
-- $ thickArc 0 180 (_crRad cr) 5
-- -- where l = rotate (radToDeg $ argV (cp -.- p)) $ uncurry translate cp $ color (withAlpha 0.5 white) $ thickArc 0 25 (_crRad cr) 5
-- cp = _crPos cr
lowLightAt' :: Point2 -> World -> World
lowLightAt' p w = foldr (lowLightHit' p) w ps
where ps = map ((+.+) p) $ nRaysRad 20 30
lowLightHit' :: Point2 -> Point2 -> World -> World
lowLightHit' a b w
= case thingsHitLongLine a b w of
((p, E3x2 wall):_)
-> over particles' ((:) (wallGlare' p wall)) w
_ -> w
wallGlare' :: Point2 -> Wall -> Particle'
wallGlare' p wl = wallGlareWidth 5 5 white 0.1 p wl
noEff _ _ _ = id
threeEff' ::
( Particle' -> Point2 -> Creature -> World -> World ) ->
( Particle' -> Point2 -> Wall -> World -> World ) ->
( Particle' -> Point2 -> ForceField -> World -> World ) ->
Particle' -> (Point2, Either3 Creature Wall ForceField) -> World -> World
threeEff' crEff wlEff ffEff pt thing w = case thing of
(p,E3x1 cr) -> crEff pt p cr w
(p,E3x2 wl) -> wlEff pt p wl w
(p,E3x3 ff) -> ffEff pt p ff w
mvGenBullet' :: World -> Particle' -> (World, Maybe Particle')
mvGenBullet' w bt
| t <= 0 = (w, Nothing)
| t < 4 = (w, Just $ set btPassThrough' Nothing
$ set btTrail' (p:p:ps)
$ set ptPict' (bulLine col wth (p:p:ps))
$ set btTimer' (t-1) bt
)
| otherwise = case thingsHitExceptCr mcr p (p +.+ vel) w of
[] -> (w, Just $ set btPassThrough' Nothing
$ set btTrail' (p +.+ vel :p:ps)
$ set ptPict' (bulLine col wth (p +.+ vel:p:ps))
$ set btTimer' (t-1) bt
)
((hitp,thing):_)
-> ( hiteff bt (hitp,thing) w
, Just $ set btPassThrough' Nothing
$ set btTrail' (hitp:p:ps)
$ set ptPict' (bulLine col wth (hitp:p:ps))
$ set btTimer' 3 bt
)
where mcr = _btPassThrough' bt
col = _btColor' bt
(p:ps) = _btTrail' bt
vel = _btVel' bt
hiteff = _btHitEffect' bt
wth = _btWidth' bt
t = _btTimer' bt
bulLine :: Color -> Float -> [Point2] -> Drawing
bulLine col width (a:b:[])
= onLayer HPtLayer $ pictures
[color (withAlpha 0.5 col) $ lineOfThickness (width+1.5) [a,b]
,color white $ wedgeOfThickness width a b
-- ,color white $ lineOfThickness width [a,b]
-- ,color (withAlpha 0.3 white) $ lineOfThickness width [a3,b]
-- ,color (withAlpha 0.7 white) $ lineOfThickness width [a2,a3]
]
-- where a2 = (0.7 *.* a) +.+ (0.3 *.* b)
-- a3 = (0.3 *.* a) +.+ (0.7 *.* b)
bulLine col width (a:b:c:_)
= onLayer HPtLayer $ pictures
[color (withAlpha 0.5 col) $ lineOfThickness (width+1.5) [a,c]
,color white $ wedgeOfThickness width a c
-- ,color white $ lineOfThickness width [a,b]
-- ,color (withAlpha 0.3 white) $ lineOfThickness (width-1) [a3,c]
-- ,color (withAlpha 0.7 white) $ lineOfThickness width [a2,a3]
-- ,color white $ lineOfThickness width [a,a2]
]
-- where a2 = b
-- a3 = (0.5 *.* b) +.+ (0.5 *.* c)
-- where a2 = (0.7 *.* a) +.+ (0.3 *.* b)
-- a3 = (0.3 *.* a) +.+ (0.7 *.* b)
--bulLine col width (a:b:c:d:_)
-- = onLayer HPtLayer $ pictures
-- [color (withAlpha 0.5 col) $ lineOfThickness (width+1) [a,c]
-- ,color (withAlpha 0.3 white) $ lineOfThickness width [a3,b]
-- ,color (withAlpha 0.7 white) $ lineOfThickness width [a2,a3]
-- ,color white $ lineOfThickness width [a,a2]
-- ]
-- where a2 = (0.7 *.* a) +.+ (0.3 *.* b)
-- a3 = (0.3 *.* a) +.+ (0.7 *.* b)
thingsHitExceptCr :: Maybe Int -> Point2 -> Point2 -> World
-> [(Point2, (Either3 Creature Wall ForceField))]
thingsHitExceptCr Nothing sp ep = thingsHit sp ep
thingsHitExceptCr (Just cid) sp ep = filter crNotCid . thingsHit sp ep
where crNotCid (_,(E3x1 cr)) = _crID cr /= cid
crNotCid _ = True
thingsHit :: Point2 -> Point2 -> World -> [(Point2, (Either3 Creature Wall ForceField))]
thingsHit sp ep w = sortBy (compare `on` dist sp . fst) (crs ++ walls ++ ffs)
where hitCrs = IM.elems $ IM.filter (\cr -> circOnLine sp ep (_crPos cr) (_crRad cr))
$ creaturesAlongLine sp ep w
crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs
crs = zip crPs (map E3x1 hitCrs)
-- hitWls = wallsOnLine sp ep (f y $ f x $ _wallsZone w)
hitWls = wallsOnLine sp ep (IM.unions [f b $ f a $ _wallsZone w | a<-[x-1,x,x+1]
, b<-[y-1,y,y+1]])
(x,y) = zoneOfPoint (0.5 *.* (sp +.+ ep))
f i m = case IM.lookup i m of Just val -> val
_ -> IM.empty
walls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls)
hitPoint w = intersectSegSeg' sp ep (_wlLine w !! 0) (_wlLine w !! 1)
hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w)
ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs
thingsHitExceptCrLongLine :: Maybe Int -> Point2 -> Point2 -> World
-> [(Point2, (Either3 Creature Wall ForceField))]
thingsHitExceptCrLongLine Nothing sp ep = thingsHitLongLine sp ep
thingsHitExceptCrLongLine (Just cid) sp ep = filter crNotCid . thingsHitLongLine sp ep
where crNotCid (_,(E3x1 cr)) = _crID cr /= cid
crNotCid _ = True
thingsHitLongLine :: Point2 -> Point2 -> World -> [(Point2, (Either3 Creature Wall ForceField))]
--thingsHitLongLine sp ep w = crs ++ walls
thingsHitLongLine sp ep w = sortBy (compare `on` dist sp . fst) (crs ++ walls ++ ffs)
where hitCrs = IM.elems $ IM.filter (\cr -> circOnLine sp ep (_crPos cr) (_crRad cr))
-- $ _creatures w
$ creaturesAlongLine sp ep w
crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs
--crPs = map _crPos hitCrs
crs = zip crPs (map E3x1 hitCrs)
-- hitWls = wallsOnLine sp ep (f y $ f x $ _wallsZone w)
hitWls = wallsOnLine sp ep $ wallsAlongLine sp ep w
--hitWls = wallsOnLine sp ep $ _walls w
f i m = case IM.lookup i m of Just val -> val
_ -> IM.empty
--walls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls)
walls = zip (map (fromJust . hitPoint) hitWls) (map E3x2 hitWls)
hitPoint w = intersectSegSeg' sp ep (_wlLine w !! 0) (_wlLine w !! 1)
-- hitPoint w = intersectSegSeg' sp ep (_wlLine w !! 0) (_wlLine w !! 1)
hitFFs = mapMaybe (collidePointFF sp ep (_randGen w)) (IM.elems $ _forceFields w)
ffs = map (\(p,(_,i)) -> (p, E3x3 $ _forceFields w IM.! i)) hitFFs
cr = _creatures w IM.! 0
makeFlameletTimed :: Point2 -> Point2 -> Int -> Maybe Int -> Float -> Int -> World -> World
makeFlameletTimed pos vel levelInt maycid size time w
= set randGen g $ over particles' ((:) theFlamelet)
$ flareAt' white 0.01 0.1 pos w
where theFlamelet =
Pt' { _ptPict' = blank
, _ptUpdate' = moveFlamelet levelInt rot
, _btVel' = vel
, _btColor' = red
, _btPos' = pos
, _btPassThrough' = maycid
, _btWidth' = size
, _btTimer' = time
, _btHitEffect' = threeEff' (doFlameDam 1) noEff noEff
}
(rot ,g) = randomR (0,3) $ _randGen w
makeFlamelet :: Point2 -> Point2 -> Int -> Maybe Int -> Float -> World -> World
makeFlamelet pos vel levelInt maycid size w = set randGen g $ over particles' ((:) theFlamelet) w
where theFlamelet =
Pt' { _ptPict' = blank
, _ptUpdate' = moveFlamelet levelInt rot
, _btVel' = vel
, _btColor' = red
, _btPos' = pos
, _btPassThrough' = maycid
, _btWidth' = size
, _btTimer' = 20
, _btHitEffect' = threeEff' (doFlameDam 1) noEff noEff
}
(rot ,g) = randomR (0.5,1.5) $ _randGen w
moveFlamelet :: Int -> Float -> World -> Particle' -> (World, Maybe Particle')
moveFlamelet levelInt rot w pt =
case _btTimer' pt of
time | time <= 0 -> (w, Nothing)
| otherwise -> (damcrs, mvPt)
where sp = _btPos' pt
vel = _btVel' pt
ep = sp +.+ vel
size = _btWidth' pt
siz2 = size + 0.2
mvPt = Just $ pt {_btTimer' = time - 1, _btPos' = ep, _ptPict' = thepicture
, _btPassThrough' = Nothing
,_btVel' = 0.8 *.* vel}
damcrs = foldr ($) w $ map dodam $ filter closeCrs $ IM.elems $ _creatures w
closeCrs cr = dist ep (_crPos cr) < _crRad cr + size
dodam cr = over (creatures . ix (_crID cr) . crState . crDamage)
((:) $ Flaming 3 sp ep ep)
pic = onLayerL [levelInt,3] $ uncurry translate ep
$ color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
white (dark red)
)
$ rotate (radToDeg ( 0.1 * fromIntegral time + rot))
$ scale sc sc
$ polygon [(-size,-size),(size,-size),(size,size),(-size,size)]
piu = onLayerL [levelInt,1] $ uncurry translate ep
$ color (dark red) $ rotate (radToDeg (rot - 0.1 * fromIntegral time))
$ scale s1 s1
$ polygon $ rectNSWE (siz2) (-siz2) (-siz2) (siz2)
glow = onLayerL [levelInt,0] $ uncurry translate ep
$ color (withAlpha 0.01 red)
$ circleSolid 30
sc = (*) 2 $ log $ 1 + fromIntegral time / 20
s1 = (*) 2 $ log $ 2 + fromIntegral time / 40
s2 = 0.5 * (sc + s1)
thepicture = pic <> piu <> pi2 <> glow
pi2 = onLayerL [levelInt,2] $ uncurry translate ep
$ color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
orange (dark red)
)
$ rotate (radToDeg $ rot + 0.2 * fromIntegral time)
$ scale s2 s2
$ polygon $ rectNSWE (siz2) (-siz2) (-siz2) (siz2)
doFlameDam :: Int -> Particle' -> Point2 -> Creature -> World -> World
doFlameDam amount pt p cr = over (creatures . ix (_crID cr) . crState . crDamage)
((:) $ Flaming amount sp p ep)
where sp = _btPos' pt
ep = sp +.+ _btVel' pt
makeSmokeAt :: Point2 -> World -> World
makeSmokeAt p w = over particles (IM.insert n smP) w
where n = newParticleKey w
smP = Particle
{ _ptPos = p
, _ptStartPos = p
, _ptVel = (0,0)
, _ptPict = onLayer PtLayer $ uncurry translate p $ color black $ circleSolid 1
--, _ptPict = uncurry translate p $ color white $ circleSolid 30
, _ptID = n
, _ptUpdate = moveSmoke p 20 n
}
moveSmoke :: Point2 -> Int -> Int -> World -> World
moveSmoke p time i | time > 0 =
set (particles . ix i . ptPict) pic . set (particles . ix i . ptUpdate) (moveSmoke p (time-1) i)
| time > -50 =
set (particles . ix i . ptPict) pi1 . set (particles . ix i . ptUpdate) (moveSmoke p (time-1) i)
| otherwise =
over particles (IM.delete i)
where pic = onLayer PtLayer $ uncurry translate p $ color (greyN 0.5) $ circleSolid $ 21 - fromIntegral time
pi1 = onLayer PtLayer $ uncurry translate p
$ color (withAlpha (1 + fromIntegral time /50) (greyN 0.5))
$ circleSolid $ 21
makeSmokeAt' :: Float -> Int -> Point2 -> World -> World
makeSmokeAt' scal time p w = over particles (IM.insert n smP) w
where n = newParticleKey w
smP = Particle
{ _ptPos = p
, _ptStartPos = p
, _ptVel = (0,0)
, _ptPict = onLayer PtLayer $ uncurry translate p $ color black $ circleSolid 1
, _ptID = n
, _ptUpdate = moveSmoke' scal p time n
}
moveSmoke' :: Float -> Point2 -> Int -> Int -> World -> World
moveSmoke' scal p time i
| time > 0
= set (particles . ix i . ptPict) pic
. set (particles . ix i . ptUpdate) (moveSmoke' scal p (time-1) i)
| time > -50
= set (particles . ix i . ptPict) pi1
. set (particles . ix i . ptUpdate) (moveSmoke' scal p (time-1) i)
| otherwise
= over particles (IM.delete i)
where pic = onLayer PtLayer $ uncurry translate p $ color (greyN 0.5) $ circleSolid $ (21 - fromIntegral time) * scal
pi1 = onLayer PtLayer $ uncurry translate p
$ color (withAlpha (1 + fromIntegral time /50) (greyN 0.5))
$ circleSolid $ 21 * scal
makeSmokeAt'' :: Point2 -> Float -> Int -> Point2 -> World -> World
makeSmokeAt'' vel scal time p w = over particles' ((:) smokeP) w
where smokeP = Particle'
{ _ptPict' = onLayerL [levLayer PtLayer - 1] $ uncurry translate p $ color black $ circleSolid 1
, _ptUpdate' = moveSmoke'' scal time p vel
}
moveSmoke'' :: Float -> Int -> Point2 -> Point2 -> World -> Particle' -> (World, Maybe Particle')
moveSmoke'' scal time p vel w pt
| time > 0 = (w, Just $ pt { _ptPict' = pic
, _ptUpdate' = moveSmoke'' scal (time-1) pNew vel
})
| time > -50 = (w, Just $ pt { _ptPict' = pi1
, _ptUpdate' = moveSmoke'' scal (time-1) pNew vel
})
| otherwise = (w, Nothing)
where pNew = p +.+ vel
pic = onLayerL [levLayer PtLayer - 1]
$ uncurry translate pNew
$ color (greyN 0.5) $ circleSolid $ (21 - fromIntegral time) * scal
pi1 = (onLayerL [levLayer PtLayer]
$ uncurry translate pNew
$ color (withAlpha (0.3 * (1 + fromIntegral time /50)) (greyN 0.5))
$ circleSolid $ 21 * scal)
<> (onLayerL [levLayer BgLayer+1]
$ uncurry translate pNew
$ color (withAlpha (1 + fromIntegral time /50) (greyN 0.5))
$ circleSolid $ 21 * scal)
makeColorSmokeAt :: Color -> Point2 -> Float -> Int -> Point2 -> World -> World
makeColorSmokeAt col vel scal time p w = over particles (IM.insert n smP) w
where n = newParticleKey w
smP = Particle
{ _ptPos = p
, _ptStartPos = p
, _ptVel = vel
, _ptPict = onLayer PtLayer $ uncurry translate p $ color col $ circleSolid 1
, _ptID = n
, _ptUpdate = moveColorSmoke col scal time n
}
moveColorSmoke :: Color -> Float -> Int -> Int -> World -> World
moveColorSmoke col scal time i w
| time > 0
= set (particles . ix i . ptPict) pic
. set (particles . ix i . ptUpdate) (moveColorSmoke col scal (time-1) i)
. set (particles . ix i . ptPos) newPos
. setVel
$ w
| time > -50
= set (particles . ix i . ptPict) pi1
. set (particles . ix i . ptUpdate) (moveColorSmoke col scal (time-1) i)
. set (particles . ix i . ptPos) newPos
. setVel
$ w
| otherwise
= over particles (IM.delete i) w
where oldPos = _ptPos $ _particles w IM.! i
newPos = oldPos +.+ (_ptVel $ _particles w IM.! i)
setVel = over (particles . ix i . ptVel) $ (*.*) 0.99
pic = onLayer PtLayer $ uncurry translate newPos $ color col $ circleSolid $ (21 - fromIntegral time) * scal
pi1 = onLayer PtLayer $ uncurry translate newPos
$ color (withAlpha (1 + fromIntegral time /50) col)
$ circleSolid $ 21 * scal
thingHit :: Point2 -> Maybe (Point2,a,b) -> Maybe (Point2,c) -> Maybe (Either (Point2,a,b) (Point2,c))
thingHit p Nothing Nothing = Nothing
thingHit p (Just x) Nothing = Just (Left x)
thingHit p Nothing (Just x) = Just (Right x)
thingHit p (Just x@(p1,_,_)) (Just y@(p2,_))
| magV (p -.- p1) > magV (p -.- p2) = Just (Right y)
| otherwise = Just (Left x)
damCrsOnLine :: Int -> Point2 -> Point2 -> World -> World
damCrsOnLine dam p1 p2 = over creatures (IM.map damIfOnLine)
where damIfOnLine cr | circOnLine p1 p2 (_crPos cr) (_crRad cr)
= over crHP (\hp -> hp - dam) cr
| otherwise = cr
src/EventHelper.hs
+11
View File
@@ -0,0 +1,11 @@
module EventHelper where
import SDL
stripTimestamp :: (world -> EventPayload -> Maybe world)
-> world -> Event -> Maybe world
stripTimestamp f w e = f w (eventPayload e)
test :: world -> EventPayload -> Maybe world
test w e = case e of
KeyboardEvent (KeyboardEventData _ Pressed _ (Keysym _ KeycodeReturn _)) -> Nothing
_ -> Just w
src/Geometry.hs
+576
View File
@@ -0,0 +1,576 @@
{-# LANGUAGE BangPatterns #-}
module Geometry
( module Geometry
, module Geometry.Data
)
where
import Geometry.Data
import Data.Function
import Data.List
import Data.Maybe
import Control.Applicative
zeroZ :: Point2 -> Point3
zeroZ (x,y) = (x,y,0)
infixl 6 +.+, -.-
infixl 7 *.*
(+.+) :: Point2 -> Point2 -> Point2
{-# INLINE (+.+) #-}
(x1, y1) +.+ (x2, y2) =
let
!x = x1 + x2
!y = y1 + y2
in (x, y)
(-.-) :: Point2 -> Point2 -> Point2
{-# INLINE (-.-) #-}
(x1, y1) -.- (x2, y2) =
let
!x = x1 - x2
!y = y1 - y2
in (x, y)
(*.*) :: Float -> Point2 -> Point2
{-# INLINE (*.*) #-}
a *.* (x2, y2) =
let
!x = a * x2
!y = a * y2
in (x, y)
infixl 6 +.+.+, -.-.-
infixl 7 *.*.*
(+.+.+) :: Point3 -> Point3 -> Point3
{-# INLINE (+.+.+) #-}
(x1, y1, z1) +.+.+ (x2, y2, z2) =
let
!x = x1 + x2
!y = y1 + y2
!z = z1 + z2
in (x, y, z)
(-.-.-) :: Point3 -> Point3 -> Point3
{-# INLINE (-.-.-) #-}
(x1, y1, z1) -.-.- (x2, y2, z2) =
let
!x = x1 - x2
!y = y1 - y2
!z = z1 - z2
in (x, y, z)
(*.*.*) :: Point3 -> Point3 -> Point3
{-# INLINE (*.*.*) #-}
(x1, y1, z1) *.*.* (x2, y2, z2) =
let
!x = x1 * x2
!y = y1 * y2
!z = z1 * z2
in (x, y, z)
normalizeV :: Point2 -> Point2
{-# INLINE normalizeV #-}
normalizeV p = (1 / magV p) *.* p
angleVV :: Point2 -> Point2 -> Float
{-# INLINE angleVV #-}
angleVV a b = let ma = magV a
mb = magV b
d = a `dotV` b
in acos $ d / (ma * mb)
dotV :: Point2 -> Point2 -> Float
{-# INLINE dotV #-}
dotV (x,y) (z,w) = x*z + y*w
closestPointOnLine :: Point2 -> Point2 -> Point2 -> Point2
{-# INLINE closestPointOnLine #-}
closestPointOnLine a b p
= a +.+ u *.* (b -.- a)
where u = closestPointOnLineParam a b p
closestPointOnLineParam :: Point2 -> Point2 -> Point2 -> Float
{-# INLINE closestPointOnLineParam #-}
closestPointOnLineParam a b p
= (p -.- a) `dotV` (b -.- a) / (b -.- a) `dotV` (b -.- a)
argV :: Point2 -> Float
{-# INLINE argV #-}
argV (x,y) = normalizeAngle $ atan2 y x
detV :: Point2 -> Point2 -> Float
{-# INLINE detV #-}
detV (x1, y1) (x2, y2)
= x1 * y2 - y1 * x2
-- | Angle in radians, anticlockwise from +ve x-axis.
unitVectorAtAngle :: Float -> Point2
{-# INLINE unitVectorAtAngle #-}
unitVectorAtAngle r
= (cos r, sin r)
-- | Rotate a vector by an angle (in radians). +ve angle is counter-clockwise.
rotateV :: Float -> Point2 -> Point2
rotateV r (x, y)
= ( x * cos r - y * sin r
, x * sin r + y * cos r)
{-# INLINE rotateV #-}
-- | Convert degrees to radians
degToRad :: Float -> Float
degToRad d = d * pi / 180
{-# INLINE degToRad #-}
-- | Convert radians to degrees
radToDeg :: Float -> Float
radToDeg r = r * 180 / pi
{-# INLINE radToDeg #-}
-- | Normalize an angle to be between 0 and 2*pi radians
normalizeAngle :: Float -> Float
normalizeAngle f = f - 2 * pi * floor' (f / (2 * pi))
where floor' :: Float -> Float
floor' x = fromIntegral (floor x :: Int)
{-# INLINE normalizeAngle #-}
-- the following helper draws 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)
]
rectNSEW n s e w = rectNESW n e s w
rectNSWE :: Float -> Float -> Float -> Float -> [Point2]
rectNSWE n s w e = [ (w,n), (w,s), (e,s), (e,n)]
-- -- the following filters points in a polygon: 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])
pointInPolygon :: Point2 -> [Point2] -> Bool
pointInPolygon p [] = False
pointInPolygon p (x:xs) = all (\l -> uncurry (errorIsLHS 1) l p) $ zip (x:xs) (xs ++ [x])
errorPointInPolygon :: Int -> Point2 -> [Point2] -> Bool
errorPointInPolygon i p xs | length xs == 1 = error "one point polygon"
| length xs == 2 = error "two point polygon"
| nub xs == xs = pointInPolygon p xs
| otherwise = error $ "errorPointInPolygon "++ show i
errorNormalizeV :: Int -> Point2 -> Point2
errorNormalizeV i (0,0) = error $ "problem with function: errorNormalizeV "++show i
errorNormalizeV i p = normalizeV p
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'
errorIsLHS :: Int -> Point2 -> Point2 -> Point2 -> Bool
errorIsLHS i x y | x == y = error $ "problem with function: errorIsLHS "
++show i
| otherwise = isLHS x y
errorClosestPointOnLine :: Int -> Point2 -> Point2 -> Point2 -> Point2
errorClosestPointOnLine i x y | x == y = error $ "problem with function: errorClosestPointOnLine "
++show i
| otherwise = closestPointOnLine x y
errorClosestPointOnLineParam :: Int -> Point2 -> Point2 -> Point2 -> Float
errorClosestPointOnLineParam i x y z | x == y = dist x z
-- error $ "problem with function: errorClosestPointOnLineParam " ++show i
| otherwise = closestPointOnLineParam x y z
safeNormalizeV :: Point2 -> Point2
safeNormalizeV (0,0) = (0,0)
safeNormalizeV p = normalizeV p
-- tests whether a point is on the LHS of a line
-- this has been called somewhere with l1 == l2
isLHS :: Point2 -> Point2 -> Point2 -> Bool
{-# INLINE isLHS #-}
isLHS' l1 l2 p | l1 == l2 = False
| otherwise = closestPointOnLineParam l1 (l1 +.+ vNormal (l2 -.- l1)) p < 0
isLHS (x,y) (x',y') (x'',y'')
| (x,y) == (x',y') = False
| otherwise = a1 * b2 - a2 * b1 > 0
where a1 = x' - x
a2 = y' - y
b1 = x'' - x
b2 = y'' - y
isRHS :: Point2 -> Point2 -> Point2 -> Bool
{-# INLINE isRHS #-}
isRHS (x,y) (x',y') (x'',y'')
| (x,y) == (x',y') = False
| otherwise = a1 * b2 - a2 * b1 < 0
where a1 = x' - x
a2 = y' - y
b1 = x'' - x
b2 = y'' - y
--isRHS l1 l2 p = closestPointOnLineParam l1 (l1 +.+ vNormal (l2 -.- l1)) p > 0
-- reorders 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
vNormal :: Point2 -> Point2
{-# INLINE vNormal #-}
vNormal (x,y) = (y,-x)
vInverse :: Point2 -> Point2
vInverse (x,y) = (-x,-y)
dist :: Point2 -> Point2 -> Float
{-# INLINE dist #-}
dist p1 p2 = magV (p2 -.- p1)
normV :: Point2 -> Point2
{-# INLINE normV #-}
normV (0,0) = (0,0)
normV p = (1/magV p ) *.* p
magV :: Point2 -> Float
{-# INLINE magV #-}
magV (x,y) = sqrt $ x^2 + y^2
pHalf :: Point2 -> Point2 -> Point2
pHalf a b = 0.5 *.* (a +.+ b)
linGrad :: (Eq a,Fractional a) => (a,a) -> (a,a) -> Maybe a
linGrad (x,y) (a,b) | x-a == 0 = Nothing
| otherwise = Just $ (y-b)/(x-a)
axisInt :: (Eq a,Fractional a) => (a,a) -> (a,a) -> Maybe a
axisInt p (a,b) = pure b ^-^ (pure a ^*^ linGrad p (a,b))
where (^-^) = liftA2 (-)
(^*^) = liftA2 (*)
-- intersectSegSeg is sometimes broken-- the following fixes at least some of
-- the cases
-- it is, however, slow
myIntersectSegSeg a@(ax,ay) b@(bx,by) c@(cx,cy) d@(dx,dy) = case ratIntersectLineLine a b c d of
Nothing -> Nothing
Just (x,y) -> if inbetween x && inbetween' y
then Just (x,y)
else Nothing
where inbetween x = ((ax <= x && x <= bx) || (bx <= x && x <= ax)) &&
((cx <= x && x <= dx) || (dx <= x && x <= cx))
inbetween' y = ((ay <= y && y <= by) || (by <= y && y <= ay)) &&
((cy <= y && y <= dy) || (dy <= y && y <= cy))
crossV :: Point2 -> Point2 -> Float
crossV (ax,ay) (bx,by) = ax*by - ay*bx
myIntersectLineLine :: (Eq a,Fractional a) => (a,a) -> (a,a) -> (a,a) -> (a,a) -> Maybe (a,a)
myIntersectLineLine a@(ax,ay) b c@(cx,cy) d
| linGrad a b == Nothing = fmap ((,) ax) $ axisInt (c *-* (ax,0)) (d *-* (ax,0))
| linGrad c d == Nothing = fmap ((,) cx) $ axisInt (a *-* (cx,0)) (b *-* (cx,0))
| otherwise
= case linGrad a b ^-^ linGrad c d of
Just 0 -> Nothing
_ -> liftA2 (,) newx
((linGrad a b ^*^ newx) ^+^ axisInt a b)
where (^-^) = liftA2 (-)
(^+^) = liftA2 (+)
(^/^) = liftA2 (/)
(^*^) = liftA2 (*)
newx = (axisInt c d ^-^ axisInt a b) ^/^ (linGrad a b ^-^ linGrad c d)
(*-*) (ax,ay) (bx,by) = (ax-bx,ay-by)
ratIntersectLineLine :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
ratIntersectLineLine a b c d = fmap toNumPoint2 $ myIntersectLineLine (toRatPoint2 a) (toRatPoint2 b) (toRatPoint2 c) (toRatPoint2 d)
where toRatPoint2 (x,y) = (toRational x, toRational y)
toNumPoint2 (x,y) = (fromRational x, fromRational y)
f = toRatPoint2 . roundPoint2
roundPoint2 :: Point2 -> Point2
roundPoint2 (x,y) = (fromIntegral $ round x,fromIntegral $ round y)
circOnLine' :: Point2 -> Point2 -> Point2 -> Float -> Bool
circOnLine' p1 p2 c rad = isJustTrue (fmap (\p -> magV (p -.- c) < rad) y)
where y = intersectSegLine' p1 p2 c (c +.+ vNormal (p1 -.- p2))
isJustTrue (Just True) = True
isJustTrue _ = False
circOnLine :: Point2 -> Point2 -> Point2 -> Float -> Bool
circOnLine p1 p2 c rad = magV (p1 -.- c) <= rad || magV (p2 -.- c) <= rad
|| isJustTrue (fmap (\p -> magV (p -.- c) < rad) y)
where y = intersectSegLine' p1 p2 c (c +.+ vNormal (p1 -.- p2))
isJustTrue (Just True) = True
isJustTrue _ = False
difference x y | x > y = x - y
| otherwise = y - x
reflectIn :: Point2 -> Point2 -> Point2
reflectIn line vec = let angle = 2 * angleBetween line vec
in rotateV angle vec
angleBetween v1 v2 = argV v1 - argV v2
doublePair :: (a,a) -> [(a,a)]
doublePair (x,y) = [(x,y),(y,x)]
polysIntersect :: [Point2] -> [Point2] -> Bool
polysIntersect (p:ps) (q:qs)
= any isJust $ (\(a,b) (c,d) -> myIntersectSegSeg a b c d) <$> pairs1 <*> pairs2
where pairs1 = zip (p:ps) (ps++[p])
pairs2 = zip (q:qs) (qs++[q])
anyPolyssIntersect :: [[Point2]] -> [[Point2]] -> Bool
anyPolyssIntersect x y = or $ polysIntersect <$> x <*> y
nRays :: Int -> [Point2]
nRays n = take n $ iterate (rotateV (2*pi/fromIntegral n)) $ (600,0)
nRaysRad :: Int -> Float -> [Point2]
nRaysRad n x = take n $ iterate (rotateV (2*pi/fromIntegral n)) $ (x,0)
-- angles go from 0 to 2pi, need to work out what is left of another
isLeftOfA :: Float -> Float -> Bool
isLeftOfA angle1 angle2 = (angle1 - angle2 < pi && angle1 > angle2)
|| (angle2 - angle1 > pi && angle2 > angle1)
isLeftOf :: Point2 -> Point2 -> Bool
isLeftOf x y = isLeftOfA (argV x) (argV y)
-- diffAngles has an issue...
diffAngles :: Float -> Float -> Float
diffAngles x y | diff > pi = diffAngles (x - 2*pi) y
| diff >= 0 = diff
| diff > -pi = -diff
| otherwise = diffAngles (x + 2*pi) y
where diff = 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
-- not this doesn't necessarily find ALL solutions, asin is a map not a function
ssaTri :: Float -> Float -> Float -> Float
ssaTri ab bc a
| sin a == 0 = 0
| bc == 0 = ab
| otherwise = let c = asin ( (ab * (sin a))/bc)
b = pi - (a + c)
in sin b * bc / sin a
-- fix points: we now fix the triangle in the coordinate system, and return a
-- third unknown point:
-- the point which lies between pa and pc' on a line from b of length bc
-- note that there are likely two such points, this seems to return the point
-- closer to pc'
ssaTriPoint :: Point2 -> Point2 -> Point2 -> Float -> Point2
ssaTriPoint pa pb pc' bc
= let ab = magV (pa -.- pb)
a = errorAngleVV 6 (pb -.- pa) (pc' -.- pa)
ac = ssaTri ab bc a
in pa +.+ (ac *.* errorNormalizeV 47 (pc' -.- pa))
-- the above SHOULD return a Maybe Point...
ssaTriPoint' :: Point2 -> Point2 -> Point2 -> Float -> Maybe Point2
ssaTriPoint' pa pb pc' bc
| dist pb (closestPointOnSeg pa pc' pb) >= bc
= Nothing
| otherwise
= Just $ ssaTriPoint pa pb pc' bc
ssaTriPointCorrect :: Point2 -> Point2 -> Point2 -> Float -> Maybe Point2
ssaTriPointCorrect pa pb pc' bc
| param <= 1 && param >= 0 = Just p
| otherwise = Nothing
where p = ssaTriPoint pa pb pc' bc
param = closestPointOnLineParam pa pc' p
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
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
-- 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)
--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
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
heron x y z | x == y = 0
| otherwise = let a = magV $ x -.- y
b = magV $ y -.- z
c = magV $ z -.- x
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 = let angle = 2 * angleBetween 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)
isOnLine :: Point2 -> Point2 -> Point2 -> Bool
isOnLine l1 l2 p = errorClosestPointOnLineParam 10 l1 (l1 +.+ vNormal (l2 -.- l1)) p == 0
&& errorClosestPointOnLineParam 11 l1 l2 p <= 1
&& errorClosestPointOnLineParam 12 l1 l2 p >= 0
-- 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 $ map (\i -> a +.+ (i / (fromIntegral numPoints) *.* (b -.- a)) )
$ map fromIntegral ns
where d = dist a b
numPoints = max 1 $ ceiling $ d / x
ns = [0 .. numPoints]
-- pulled the following from the haskell wiki
bresenham :: (Int,Int) -> (Int,Int) -> [(Int,Int)]
{-# INLINE bresenham #-}
bresenham pa@(xa,ya) pb@(xb,yb) = map maySwitch . unfoldr go $ (x1,y1,0)
where
steep = abs (yb - ya) > abs (xb - xa)
maySwitch = if steep then (\(x,y) -> (y,x)) else id
[(x1,y1),(x2,y2)] = sort [maySwitch pa, maySwitch pb]
deltax = x2 - x1
deltay = abs (y2 - y1)
ystep = if y1 < y2 then 1 else -1
go (xTemp, yTemp, error)
| xTemp > x2 = Nothing
| otherwise = Just ((xTemp, yTemp), (xTemp + 1, newY, newError))
where
tempError = error + deltay
(newY, newError) = if (2*tempError) >= deltax
then (yTemp+ystep,tempError-deltax)
else (yTemp,tempError)
divideCircle :: Float -> Point2 -> Float -> [Point2]
divideCircle x cen rad = map (cen +.+) $ nPointsOnCirc n rad
where n = ceiling $ rad * 2 * pi / x
nPointsOnCirc :: Int -> Float -> [Point2]
nPointsOnCirc n rad = take n $ iterate (rotateV (2*pi/fromIntegral n)) $ (rad,0)
lineInPolygon :: Point2 -> Point2 -> [Point2] -> Bool
lineInPolygon a b ps = pointInPolygon a ps || pointInPolygon b ps
|| any (isJust . uncurry (intersectSegSeg' a b)) pss
where pss = zip ps (tail ps ++ [head ps])
--intersectSegLineFrom :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
--intersectSegLineFrom a b c d
-- = case intersectSegLine a b c d of
-- Just p | closestPointOnLineParam c d p >= 0 -> Just p
-- | otherwise -> Nothing
-- Nothing -> Nothing
intersectSegSeg' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
{-# INLINE intersectSegSeg' #-}
intersectSegSeg' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
-- | t' < 0 || u' < 0 || t' > den || u' > den || den == 0
-- = Nothing
| den == 0 = Nothing
| den > 0 && (t' < 0 || u' < 0 || t' > den || u' > den)
= Nothing
| den < 0 && (t' > 0 || u' > 0 || t' < den || u' < den)
= Nothing
-- | den > 0 && (t' < 0 || t' > den)
-- = Nothing
-- | den < 0 && (t' > 0 || t' < 0-den)
-- = Nothing
| otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den)
where
den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
intersectSegLineFrom' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
{-# INLINE intersectSegLineFrom' #-}
intersectSegLineFrom' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
-- | t' < 0 || u' < 0 || t' > den || u' > den || den == 0
-- = Nothing
| den == 0 = Nothing
| den > 0 && ( t' < 0 || u' < 0 || t' > den )
= Nothing
| den < 0 && ( t' > 0 || u' > 0 || t' < den )
= Nothing
-- | den > 0 && (t' < 0 || t' > den)
-- = Nothing
-- | den < 0 && (t' > 0 || t' < 0-den)
-- = Nothing
| otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den)
where
den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
intersectSegLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
{-# INLINE intersectSegLine' #-}
intersectSegLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
-- | t' < 0 || u' < 0 || t' > den || u' > den || den == 0
-- = Nothing
| den == 0 = Nothing
| den > 0 && (t' < 0 || t' > den)
= Nothing
| den < 0 && (t' > 0 || t' < den)
= Nothing
-- | den > 0 && (t' < 0 || t' > den)
-- = Nothing
-- | den < 0 && (t' > 0 || t' < 0-den)
-- = Nothing
| otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den)
where
den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
intersectLineLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
{-# INLINE intersectLineLine' #-}
intersectLineLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
| den == 0 = Nothing
| otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den)
where
den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
src/Geometry/Data.hs
+8
View File
@@ -0,0 +1,8 @@
module Geometry.Data
( Point2 (..)
, Point3 (..)
)
where
type Point2 = (Float,Float)
type Point3 = (Float,Float,Float)
src/Loop.hs
+120
View File
@@ -0,0 +1,120 @@
module Loop
( setupLoop
-- , withExits
) where
import SDL
import qualified Data.Text as T
import Control.Concurrent
import Control.Exception
import qualified Graphics.Rendering.OpenGL as GL
import Control.Monad
import System.Mem
import Foreign.C
import Geometry
winConfig x y = defaultWindow
{ windowGraphicsContext
= OpenGLContext (defaultOpenGL { glProfile = Core Normal 4 3
, glColorPrecision = V4 8 8 8 8
}
)
, windowInitialSize = V2 x y
, windowResizable =True
}
setupLoop :: String
-> CInt
-> CInt
-> IO setupParams
-> (setupParams -> IO ())
-> world
-> (setupParams -> world -> IO ())
-> (world -> Event -> Maybe world)
-> (world -> Maybe world)
-> IO ()
setupLoop wName xSize ySize
customInit initCleanup startWorld sideEffects eventFn worldFn = do
initializeAll
bracket (createWindow (T.pack wName) (winConfig xSize ySize)) destroyWindow
(\window ->
do bracket (glCreateContext window) (\con -> GL.finish >> glDeleteContext con)
(\_ -> bracket customInit initCleanup $ \setup -> do -- setup <- customInit
-- swapInterval $= ImmediateUpdates
GL.blend $= GL.Enabled
GL.blendEquation $= GL.FuncAdd
GL.blendFunc $= (GL.SrcAlpha,GL.OneMinusSrcAlpha)
GL.clearColor $= GL.Color4 0 0.5 0 0
doLoop setup window startWorld
sideEffects eventFn worldFn
)
)
--doLoop :: setupParams -> Window -> WorldView world0
-- -> (setupParams -> WorldView world0 -> IO ())
-- -> (world0 -> Event -> Maybe world0)
-- -> (world0 -> Maybe world0)
-- -> IO ()
doLoop setup window startWorld
worldSideEffects
eventFn
worldUpdate
= do
startLoopTicks <- ticks
events <- pollEvents
--let-- maybeUpdatedWorld :: Maybe (WorldView world0)
-- maybeUpdatedWorld = applyEvents eventFn startWorld events worldUpdate
maybeUpdatedWorld <- applyEventsIO eventFn startWorld events
case maybeUpdatedWorld >>= worldUpdate of
Just updatedWorld -> do
GL.clear [GL.ColorBuffer,GL.DepthBuffer]
worldSideEffects setup updatedWorld
glSwapWindow window
--GL.flush
performGC
endLoopTicks <- ticks -- it might be better to use System.Clock (monotonic)
let delay = max 0 (10 + fromIntegral startLoopTicks - fromIntegral endLoopTicks)
threadDelay (delay * 1000)
doLoop setup window updatedWorld worldSideEffects eventFn worldUpdate
Nothing -> return ()
applyEvents :: (world0 -> Event -> Maybe world0)
-> world0
-> [Event]
-> (world0 -> Maybe world0)
-> Maybe world0
applyEvents eventFn startWorld events worldUpdate =
case foldM (applyH eventFn) startWorld events of
Just w -> fmap (\w' -> w') $ worldUpdate w
Nothing -> Nothing
where
applyH :: (world0 -> Event -> Maybe world0) -> world0 -> Event -> Maybe world0
applyH f w e
= case eventPayload e of
QuitEvent -> Nothing
WindowClosedEvent _ -> Nothing
_ -> f w e
-- applyResizeExits :: (world -> Event -> Maybe world) -> (world -> Event -> Maybe world)
-- applyResizeExits f w e
-- = case eventPayload e of
-- QuitEvent -> Nothing
-- WindowClosedEvent _ -> Nothing
-- WindowSizeChangedEvent
-- (WindowSizeChangedEventData {windowSizeChangedEventWindow = V2 x y})
-- -> GL.viewport
-- _ -> f w e
applyEventIO :: (world -> Event -> Maybe world) -> Maybe world -> Event -> IO (Maybe world)
applyEventIO fn mw e = case eventPayload e of
QuitEvent -> return Nothing
WindowClosedEvent _ -> return Nothing
WindowSizeChangedEvent
(WindowSizeChangedEventData {windowSizeChangedEventSize = V2 x y})
-> GL.viewport $= (GL.Position 0 0,GL.Size x y) >> return (mw >>= \w -> fn w e)
_ -> return $ mw >>= flip fn e
applyEventsIO :: (world0 -> Event -> Maybe world0)
-> world0
-> [Event]
-> IO (Maybe world0)
applyEventsIO fn w es = foldM (applyEventIO fn) (Just w) es
src/Picture.hs
+249
View File
@@ -0,0 +1,249 @@
--{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE Strict #-}
module Picture
( module Picture.Data
, polygon
, arc
, arcSolid
, thickArc
, thickCircle
, circleSolid
, circle
, line
, text
, pictures
, translate
, rotate
, rotateRad
, scale
, blank
, color
, withAlpha
, greyN
, red
, green
, blue
, yellow
, cyan
, magenta
, rose
, violet
, azure
, aquamarine
, chartreuse
, orange
, white
, black
, dim
, light
, dark
, bright
, mixColors
, zeroZ
, setDepth
)
where
import Geometry
import Geometry.Data
import Picture.Data
import Data.Bifunctor
import qualified Data.DList as DL
import Graphics.Rendering.OpenGL (lineWidth, ($=),PrimitiveMode (..))
import Control.Lens
black :: RGBA
black = (0,0,0,1)
polygonD :: Float -> [Point2] -> Picture
{-# INLINE polygonD #-}
polygonD d (a:b:c:ps) = blank
{ _scPosTri = DL.fromList $ map (\(x,y) -> (x,y,d)) tris
, _scColTri = DL.fromList $ map (const black) tris
}
where twoPs = zip (b:c:ps) (c:ps)
tris = concatMap (\(x,y)-> [a,x,y]) twoPs
polygonD _ _ = blank
polygon :: [Point2] -> Picture
{-# INLINE polygon #-}
polygon (a:b:c:ps) = blank
{ _scPosTri = DL.fromList $ map zeroZ tris
, _scColTri = DL.fromList $ map (const black) tris
}
where twoPs = zip (b:c:ps) (c:ps)
tris = concatMap (\(x,y)-> [a,x,y]) twoPs
polygon _ = blank
color :: RGBA -> Picture -> Picture
{-# INLINE color #-}
color c = over scColTri (DL.map $ const c) . over scColChar (DL.map $ const c)
translate3 :: Float -> Float -> Point3 -> Point3
{-# INLINE translate3 #-}
translate3 a b (x,y,z) = (x+a,y+b,z)
translate :: Float -> Float -> Picture -> Picture
{-# INLINE translate #-}
translate x y = over scPosTri (DL.map $ translate3 x y) . over scPosChar (DL.map $ translate3 x y)
setDepth :: Float -> Picture -> Picture
setDepth d = over scPosTri (DL.map $ (\(x,y,z)->(x,y,d)))
. over scPosChar (DL.map $ (\(x,y,z)->(x,y,d)))
--overVs' :: (CPoint2 -> CPoint) -> Picture -> Picture
----{-# INLINE overVs' #-}
--overVs' f !(Scene a b) = let !a' = map f a
-- !b' = map g b
-- in Scene a' b'
-- where g !(x,y,z) = let !(x',y') = f (x,y)
-- in (x',y',z)
scale3 :: Float -> Float -> Point3 -> Point3
{-# INLINE scale3 #-}
scale3 a b (x,y,z) = (x*a,y*b,z)
scale :: Float -> Float -> Picture -> Picture
{-# INLINE scale #-}
scale x y = over scPosTri (DL.map $ scale3 x y) . over scPosChar (DL.map $ scale3 x y)
rotate3 :: Float -> Point3 -> Point3
{-# INLINE rotate3 #-}
rotate3 a (x,y,z) = (x',y',z)
where (x',y') = rotateV a (x,y)
rotate :: Float -> Picture -> Picture
{-# INLINE rotate #-}
rotate a = over scPosTri (DL.map $ rotate3 (0 - degToRad a))
. over scPosChar (DL.map $ rotate3 (0 - degToRad a))
-- -- this rotation uses radians, and is anticlockwise
rotateRad :: Float -> Picture -> Picture
{-# INLINE rotateRad #-}
rotateRad a = over scPosTri (DL.map $ rotate3 a)
. over scPosChar (DL.map $ rotate3 a)
pictures :: [Picture] -> Picture
{-# INLINE pictures #-}
pictures = mconcat
makeArc :: Float -> (Float,Float) -> [Point2]
{-# INLINE makeArc #-}
makeArc rad (a,b) = zipWith rotateV as $ repeat (0,rad)
where as = [a,a+step.. b]
step = pi * 0.1
circleSolidD :: Float -> Float -> Picture
circleSolidD d r = polygonD d $ makeArc r (0,2*pi)
circleSolid :: Float -> Picture
{-# INLINE circleSolid #-}
circleSolid rad = polygon $ makeArc rad (0,2*pi)
circle :: Float -> Picture
{-# INLINE circle #-}
circle rad = line $ makeArc rad (0,2*pi)
--text :: String -> Picture
--text s = zipWith (\x -> overVs $ first $ translate3 x 0)
-- [0,0.25..]
-- $ map charToShape s
text :: String -> Picture
{-# INLINE text #-}
text s = mconcat $ zipWith (\x -> translate x (0-dimText))
[0,0.9*dimText..]
(map charToScene s)
charToScene :: Char -> Picture
charToScene c = Scene
{_scPosTri = DL.empty
,_scColTri = DL.empty
,_scPosChar = DL.fromList [(0.0 ,0.0 ,0)
,(dimText,0.0 ,0)
,(dimText,dimText*2,0)
,(0.0 ,0.0 ,0)
,(dimText,dimText*2,0)
,(0.0 ,dimText*2,0)
]
,_scColChar = DL.fromList $ take 6 $ repeat white
,_scTexChar = DL.fromList $ [(s,1) ,(e,1) ,(e,0) ,(s,1) ,(e,0) ,(s,0)]
}
where x = 1/128
s = offset * x
e = s + x
offset = fromIntegral (fromEnum c) - 32
dimText = 100
line :: [Point2] -> Picture
{-# INLINE line #-}
line ps = thickLine ps 1
thickLine :: [Point2] -> Float -> Picture
{-# INLINE thickLine #-}
thickLine ps x = blank
thickCircle :: Float -> Float -> Picture
{-# INLINE thickCircle #-}
thickCircle rad wdth = thickLine (makeArc rad (0,2*pi)) wdth
arcSolid :: Float -> Float -> Float -> Picture
{-# INLINE arcSolid #-}
arcSolid startA endA rad
= polygon $ (0,0) : makeArc rad (startA,endA)
arc startA endA rad = thickArc startA endA rad 1
{-# INLINE arc #-}
thickArc :: Float -> Float -> Float -> Float -> Picture
{-# INLINE thickArc #-}
thickArc startA endA rad wdth
= thickLine (makeArc rad (startA,endA)) wdth
withAlpha :: Float -> RGBA -> RGBA
{-# INLINE withAlpha #-}
withAlpha a (x,y,z,a') = (x,y,z,a*a')
red,green,blue,yellow,cyan,magenta,rose,violet,azure,aquamarine,chartreuse,orange,white::Color
red = (1,0,0,1)
green = (0,1,0,1)
blue = (0,0,1,1)
yellow = (1,1,0,1)
cyan = (0,1,1,1)
magenta = (1,0,1,1)
rose = (1,0,0.5,1)
violet = (0.5,0,1,1)
azure = (0,0.5,1,1)
aquamarine= (0,1,0.5,1)
chartreuse= (0.5,1,0,1)
orange = (1,0.5,0,1)
white = (1,1,1,1)
mixColors :: Float -> Float -> Color -> Color -> Color
mixColors rata ratb (r0,g0,b0,a0) (r2,g2,b2,a2) =
let fullrat = rata + ratb
normrata = rata / fullrat
normratb = ratb / fullrat
f x y = sqrt $ normrata * x^2 + normratb * y^2
in (f r0 r2 , f g0 g2 , f b0 b2 , normrata * a0 + normratb * a2)
light :: Color -> Color
light (r,g,b,a) = (r+0.2,g+0.2,b+0.2,a)
dark :: Color -> Color
dark (r,g,b,a) = (r-0.2,g-0.2,b-0.2,a)
dim :: Color -> Color
dim (r,g,b,a) = (r/1.2,g/1.2,b/1.2,a)
bright :: Color -> Color
bright (r,g,b,a) = (r*1.2,g*1.2,b*1.2,a)
greyN :: Float -> Color
greyN x = (x,x,x,1)
src/Picture/Data.hs
+43
View File
@@ -0,0 +1,43 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE Strict #-}
module Picture.Data
where
import Data.Monoid
import qualified Data.DList as DL
import Geometry.Data
import Control.Lens
type RGBA = (Float,Float,Float,Float)
type Color = (Float,Float,Float,Float)
data Picture = Scene
{ _scPosTri :: DL.DList Point3
, _scColTri :: DL.DList RGBA
, _scPosChar :: DL.DList Point3
, _scColChar :: DL.DList RGBA
, _scTexChar :: DL.DList Point2
}
blank :: Picture
{-# INLINE blank #-}
blank = Scene DL.empty DL.empty DL.empty DL.empty DL.empty
combineScenes :: Picture -> Picture -> Picture
{-# SCC combineScenes #-}
--{-# INLINE combineScenes #-}
combineScenes sa sb = Scene
{ _scPosTri = _scPosTri sa <> _scPosTri sb
, _scColTri = _scColTri sa <> _scColTri sb
, _scPosChar = _scPosChar sa <> _scPosChar sb
, _scColChar = _scColChar sa <> _scColChar sb
, _scTexChar = _scTexChar sa <> _scTexChar sb
}
instance Semigroup Picture where
(<>) = combineScenes
instance Monoid Picture where
mempty = blank
--mappend = combineScenes
makeLenses ''Picture
src/Picture/Preload.hs
+156
View File
@@ -0,0 +1,156 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE Strict #-}
module Picture.Preload
where
import Codec.Picture
import Graphics.Rendering.OpenGL hiding (Point (..),translate,scale,imageHeight,imageWidth)
import qualified Graphics.Rendering.OpenGL as GL
import qualified Data.Vector.Storable as V
import Control.Lens
import Foreign
import Shaders
data PreloadData = PreloadData
{ _charMap :: Image PixelRGBA8
-- , _textures :: [Image PixelRGBA8]
, _basicShader :: Program
, _textShader :: Program
, _fadeCircleShader :: Program
, _basicVAO :: VertexArrayObject
, _textVAO :: VertexArrayObject
, _posVBO :: BufferObject
, _colVBO :: BufferObject
, _texVBO :: BufferObject
, _ptrPosVBO :: Ptr Float
, _ptrColVBO :: Ptr Float
, _ptrTexVBO :: Ptr Float
}
makeLenses ''PreloadData
loadTextures :: IO [Image PixelRGBA8]
loadTextures = do
-- echarMap <- readImage "data/texture/smudgedDirt.png"
echarMap <- readImage "data/texture/charMap.png"
case echarMap of
Left err -> do
putStrLn err
return []
Right charMap ->
return [convertRGBA8 charMap]
bufferOffset :: Integral a => a -> Ptr b
bufferOffset = plusPtr nullPtr . fromIntegral
doPreload' :: IO PreloadData
doPreload' = do
-- compile shader programs
bs <- makeBasicShader
ts <- makeTextureShader
fcs <- makeFadeShader
--setup vbos
--need to be bound before assigning the vertex attribute pointers
posVBO <- genObjectName
colVBO <- genObjectName
texVBO <- genObjectName
-- load charmap as texture
-- Right cmap <- readImage "data/texture/smudgedDirt.png"
Right cmap <- readImage "data/texture/charMap.png"
let tex = convertRGBA8 cmap
texo <- genObjectName
textureBinding Texture2D $= Just texo
let texData = V.toList $ imageData tex
wtex = fromIntegral $ imageWidth tex
htex = fromIntegral $ imageHeight tex
withArray texData $ \ptr -> do
texImage2D Texture2D NoProxy 0 RGBA8 (TextureSize2D wtex htex) 0
(PixelData RGBA UnsignedByte ptr)
generateMipmap' Texture2D
textureFilter Texture2D $= ((Linear',Just Linear') , Nearest)
let vertexSize = sizeOf (0.5 :: GLfloat)
firstIndex = 0
-- setup VAOs: basic vao
basicVAO <- genObjectName
bindVertexArrayObject $= Just basicVAO
-- let posAttrib = AttribLocation 0
-- colAttrib = AttribLocation 1
bindBuffer ArrayBuffer $= Just posVBO
vertexAttribPointer (AttribLocation 0) $=
( ToFloat
, VertexArrayDescriptor 3 Float (fromIntegral $ vertexSize * 3)
(bufferOffset (firstIndex * vertexSize))
)
vertexAttribArray (AttribLocation 0) $= Enabled
bindBuffer ArrayBuffer $= Just colVBO
vertexAttribPointer (AttribLocation 1) $=
( ToFloat
, VertexArrayDescriptor 4 Float (fromIntegral $ vertexSize * 4)
(bufferOffset (firstIndex * vertexSize) )
)
vertexAttribArray (AttribLocation 1) $= Enabled
-- setup second vao
textVAO <- genObjectName
bindVertexArrayObject $= Just textVAO
bindBuffer ArrayBuffer $= Just posVBO
vertexAttribPointer (AttribLocation 0) $=
( ToFloat
, VertexArrayDescriptor 3 Float (fromIntegral $ vertexSize * 3)
(bufferOffset (firstIndex * vertexSize))
)
vertexAttribArray (AttribLocation 0) $= Enabled
bindBuffer ArrayBuffer $= Just colVBO
vertexAttribPointer (AttribLocation 1) $=
( ToFloat
, VertexArrayDescriptor 4 Float (fromIntegral $ vertexSize * 4)
(bufferOffset (firstIndex * vertexSize) )
)
vertexAttribArray (AttribLocation 1) $= Enabled
bindBuffer ArrayBuffer $= Just texVBO
vertexAttribPointer (AttribLocation 2) $=
( ToFloat
, VertexArrayDescriptor 2 Float (fromIntegral $ vertexSize * 2)
(bufferOffset (firstIndex * vertexSize) )
)
vertexAttribArray (AttribLocation 2) $= Enabled
-- allocate memory for vertex attributes
ptrPosVBO <- mallocArray (3*3*5000)
ptrColVBO <- mallocArray (3*4*5000)
ptrTexVBO <- mallocArray (3*2*5000)
return $ PreloadData
{ _charMap = convertRGBA8 cmap
, _basicShader = bs
, _textShader = ts
, _fadeCircleShader = fcs
, _basicVAO = basicVAO
, _textVAO = textVAO
, _posVBO = posVBO
, _colVBO = colVBO
, _texVBO = texVBO
, _ptrPosVBO = ptrPosVBO
, _ptrColVBO = ptrColVBO
, _ptrTexVBO = ptrTexVBO
}
cleanUpPreload :: PreloadData -> IO ()
cleanUpPreload pd = do
free (_ptrPosVBO pd)
free (_ptrColVBO pd)
free (_ptrTexVBO pd)
src/Picture/Render.hs
+96
View File
@@ -0,0 +1,96 @@
{-# LANGUAGE Strict #-}
module Picture.Render
where
import Control.Lens
import Picture
import Geometry
import Picture.Preload
--import Control.Lens
import Foreign
import Codec.Picture
import Graphics.Rendering.OpenGL hiding (translate,scale,imageHeight,imageWidth)
import qualified Graphics.Rendering.OpenGL as GL
import Data.Foldable
import qualified Data.Vector.Storable as V
import qualified Data.DList as DL
import Control.DeepSeq
concat34 :: (Point3,RGBA) -> [Float]
concat34 ((x,y,z),(r,g,b,a)) = [x,y,z,r,g,b,a]
toVec2 (x,y) = Vector2 x y
toVec3 (x,y,z) = Vector3 x y z
toVec4 (x,y,z,w) = Vector4 x y z w
flat2 (x,y) = DL.fromList [x,y]
flat3 (x,y,z) = DL.fromList [x,y,z]
flat4 (x,y,z,w) = DL.fromList [x,y,z,w]
mapFlat :: (NFData b) => (a -> DL.DList b) -> DL.DList a -> [b]
mapFlat f = force . DL.toList . foldMap f
--marshallVs = V.unsafeWith . V.fromList
--marshallVs = withArray
renderPicture' :: PreloadData -> Picture -> IO ()
renderPicture' pdata (Scene posTri' colTri' posChar' colChar' texChar') = do
let posTri = DL.toList posTri'
colTri = DL.toList colTri'
posChar = DL.toList posChar'
colChar = DL.toList colChar'
texChar = DL.toList texChar'
currentProgram $= Just (_basicShader pdata)
bindVertexArrayObject $= Just (_basicVAO pdata)
bindBuffer ArrayBuffer $= Just (_posVBO pdata)
let firstIndex = 0
let vertices :: [Float]
vertices = mapFlat flat3 posTri'
numVertices = length vertices
vertexSize = sizeOf (head vertices)
pokeArray (_ptrPosVBO pdata) vertices
bufferData ArrayBuffer $= (fromIntegral (numVertices * vertexSize), _ptrPosVBO pdata, StreamDraw)
-- marshallVs vertices $ \ptr -> do
-- bufferData ArrayBuffer $= (fromIntegral (numVertices * vertexSize), ptr, StreamDraw)
bindBuffer ArrayBuffer $= Just (_colVBO pdata)
let colVs = mapFlat flat4 colTri'
colVsize = sizeOf $ head colVs
pokeArray (_ptrColVBO pdata) colVs
bufferData ArrayBuffer $= (fromIntegral (div (4 * numVertices * colVsize) 3), _ptrColVBO pdata, StreamDraw)
-- marshallVs colVs $ \ptr -> do
-- bufferData ArrayBuffer $= (fromIntegral (div (4 * numVertices * colVsize) 3), ptr, StreamDraw)
drawArrays Triangles (fromIntegral firstIndex) (fromIntegral $ numVertices)
-- currentProgram $= Just (_textShader pdata)
-- bindVertexArrayObject $= Just (_textVAO pdata)
-- bindBuffer ArrayBuffer $= Just (_posVBO pdata)
-- let vertices' = mapFlat flat3 posChar'
-- numVertices' = length vertices'
-- vertexSize' = sizeOf $ head vertices'
-- withArray vertices' $ \ptr -> do
-- bufferData ArrayBuffer $= (fromIntegral (numVertices' * vertexSize'), ptr, StreamDraw)
-- bindBuffer ArrayBuffer $= Just (_colVBO pdata)
-- let colVsT = mapFlat flat4 colChar'
-- colVsTsize = sizeOf $ head colVsT
-- withArrayLen colVsT $ \numV' ptr -> do
-- bufferData ArrayBuffer $= (fromIntegral (numVertices' * colVsTsize), ptr, StreamDraw)
-- bindBuffer ArrayBuffer $= Just (_texVBO pdata)
-- let texVsT = mapFlat flat2 texChar'
-- texVsTsize = sizeOf $ head texVsT
-- withArrayLen texVsT $ \numV' ptr -> do
-- bufferData ArrayBuffer $= (fromIntegral (numVertices' * texVsTsize), ptr, StreamDraw)
-- drawArrays Triangles (fromIntegral firstIndex) (fromIntegral $ numVertices')
bufferOffset :: Integral a => a -> Ptr b
bufferOffset = plusPtr nullPtr . fromIntegral
zeroZ :: Point2 -> Point3
zeroZ (x,y) = (x,y,0)
src/Render.hs
+108
View File
@@ -0,0 +1,108 @@
module Render where
import Shapes
import Graphics.Rendering.OpenGL hiding (imageHeight,imageWidth)
import Foreign
import Loop
import Codec.Picture
import qualified Data.Vector.Storable as V
render :: [Program] -> b -> Shape -> IO ()
render progs _ (Shape primitiveMode vs) = do
currentProgram $= Just (progs !! 0)
let vertices = flattenVertices vs
numVertices = length vertices
vertexSize = sizeOf (head vertices)
-- setup VBO
shape <- genObjectName
bindVertexArrayObject $= Just shape
-- setup VBA
arrayBuffer <- genObjectName
bindBuffer ArrayBuffer $= Just arrayBuffer
withArray vertices $ \ptr -> do
bufferData ArrayBuffer $= (fromIntegral (numVertices * vertexSize), ptr, StaticDraw)
let firstIndex = 0
vPosition = AttribLocation 0
vColor = AttribLocation 1
vertexAttribPointer vPosition $=
( ToFloat
, VertexArrayDescriptor 3 Float (fromIntegral $ vertexSize * 7)
(bufferOffset (firstIndex * vertexSize))
)
vertexAttribArray vPosition $= Enabled
vertexAttribPointer vColor $=
( ToFloat
, VertexArrayDescriptor 4 Float (fromIntegral $ vertexSize * 7)
(bufferOffset ((firstIndex + 3) * vertexSize) )
)
vertexAttribArray vColor $= Enabled
-- clear [ColorBuffer,DepthBuffer]
bindVertexArrayObject $= Just shape
drawArrays primitiveMode (fromIntegral firstIndex) (fromIntegral $ div numVertices 2)
render (_:prog:_) _ (Fade ps) = do
currentProgram $= Just prog
let vertices = flatten2 ps
numVertices = length vertices
vertexSize = sizeOf (head vertices)
-- -- setup uniform
-- location <- get $ uniformLocation prog "winSize"
-- uniform location $= winSizeVec
-- setup VBO
arrayBuffer <- genObjectName
bindBuffer ArrayBuffer $= Just arrayBuffer
withArray vertices $ \ptr -> do
bufferData ArrayBuffer $= (fromIntegral (numVertices * vertexSize), ptr, StreamDraw)
-- setup VAO
shape <- genObjectName
bindVertexArrayObject $= Just shape
let firstIndex = 0
inPosition = AttribLocation 0
inColor = AttribLocation 1
inRad = AttribLocation 2
vertexAttribPointer inPosition $=
( ToFloat
, VertexArrayDescriptor 3 Float (fromIntegral $ vertexSize * 8)
(bufferOffset (firstIndex * vertexSize))
)
vertexAttribArray inPosition $= Enabled
vertexAttribPointer inColor $=
( ToFloat
, VertexArrayDescriptor 4 Float (fromIntegral $ vertexSize * 8)
(bufferOffset ((firstIndex + 3) * vertexSize) )
)
vertexAttribArray inColor $= Enabled
vertexAttribPointer inRad $=
( ToFloat
, VertexArrayDescriptor 1 Float (fromIntegral $ vertexSize * 8)
(bufferOffset ((firstIndex + 7) * vertexSize) )
)
vertexAttribArray inRad $= Enabled
-- bindVertexArrayObject $= Just shape
drawArrays Points (fromIntegral firstIndex) (2)
flattenVertices :: [CPoint] -> [GLfloat]
flattenVertices = map realToFrac . concatMap (\(CPoint (x,y,z) (r,b,g,a)) -> [x,y,z,r,b,g,a])
flatten2 :: [((Float,Float,Float),(Float,Float,Float,Float),Float)] -> [GLfloat]
flatten2 = map realToFrac . concatMap f
where f ((x,y,z),(r,g,b,a),rad) = [x,y,z,r,g,b,a,rad]
bufferOffset :: Integral a => a -> Ptr b
bufferOffset = plusPtr nullPtr . fromIntegral
src/Rendering/Picture/Color.hs
+21
View File
@@ -0,0 +1,21 @@
module Rendering.Picture.Color
where
import Geometry.Data
type RGBA = (Float,Float,Float,Float)
black,red,green,blue,yellow,cyan,magenta,rose,violet,azure,aquamarine,chartreuse,orange,white::RGBA
black = (0,0,0,1)
red = (1,0,0,1)
green = (0,1,0,1)
blue = (0,0,1,1)
yellow = (1,1,0,1)
cyan = (0,1,1,1)
magenta = (1,0,1,1)
rose = (1,0,0.5,1)
violet = (0.5,0,1,1)
azure = (0,0.5,1,1)
aquamarine= (0,1,0.5,1)
chartreuse= (0.5,1,0,1)
orange = (1,0.5,0,1)
white = (1,1,1,1)
src/Shaders.hs
+86
View File
@@ -0,0 +1,86 @@
{-# LANGUAGE QuasiQuotes #-}
module Shaders
(setupBasicShader
,setupFadeShader
,setupShaders
,makeTextureShader
,makeBasicShader
,makeFadeShader
)
where
import Graphics.Rendering.OpenGL
import Control.Monad (when)
import Text.RawString.QQ
import qualified Data.ByteString as BS
setupShaders :: IO [Program]
setupShaders = do
basicShader <- makeBasicShader
fadeShader <- makeFadeShader
textureShader <- makeTextureShader
return [basicShader,fadeShader,textureShader]
makeBasicShader :: IO Program
makeBasicShader = do
vsSource <- BS.readFile "shader/basic.vert"
fsSource <- BS.readFile "shader/basic.frag"
makeShaderProgram [(VertexShader, vsSource)
,(FragmentShader, fsSource)
]
setupBasicShader :: IO ()
setupBasicShader = do
shaderProgram <- makeBasicShader
currentProgram $= (Just shaderProgram)
makeFadeShader :: IO Program
makeFadeShader = do
vsSource <- BS.readFile "shader/fadeCircle.vert"
gsSource <- BS.readFile "shader/fadeCircle.geom"
fsSource <- BS.readFile "shader/fadeCircle.frag"
makeShaderProgram [(VertexShader, vsSource )
,(GeometryShader, gsSource )
,(FragmentShader, fsSource )
]
setupFadeShader :: IO Program
setupFadeShader = do
shaderProgram <- makeFadeShader
currentProgram $= (Just shaderProgram)
return shaderProgram
makeTextureShader :: IO Program
makeTextureShader = do
vsSource <- BS.readFile "shader/basicTexture.vert"
fsSource <- BS.readFile "shader/basicTexture.frag"
makeShaderProgram [(VertexShader, vsSource )
,(FragmentShader, fsSource )
]
makeShaderProgram :: [(ShaderType,BS.ByteString)] -> IO Program
makeShaderProgram sources = do
shaderProgram <- createProgram
shaders <- mapM compileAndCheckShader sources
mapM_ (attachShader shaderProgram) shaders
linkProgram shaderProgram
linkingSuccess <- linkStatus shaderProgram
when (not linkingSuccess) $ do
infoLog <- get (programInfoLog shaderProgram)
putStrLn $ "Program Linking" ++ infoLog
return shaderProgram
compileAndCheckShader :: (ShaderType,BS.ByteString) -> IO Shader
compileAndCheckShader (shaderType,sourceCode) = do
theShader <- createShader shaderType
shaderSourceBS theShader $= sourceCode
compileShader theShader
success <- compileStatus theShader
when (not success) $ do
infoLog <- get (shaderInfoLog theShader)
putStrLn $ "Shader compile: " ++ show shaderType ++ " : " ++ show infoLog
return theShader
src/Shapes.hs
+28
View File
@@ -0,0 +1,28 @@
module Shapes where
import Geometry
import Graphics.Rendering.OpenGL
type RGBA = (Float,Float,Float,Float)
data CPoint = CPoint
{cpPoint :: Point3
,cpColor :: RGBA
}
data Shape = Shape PrimitiveMode [CPoint]
| Fade [(Point3,RGBA,Float)]
| Shape' PrimitiveMode [GLfloat]
egTri = Shape TriangleStrip [CPoint (-1,0,0) (1,1,1,1)
,CPoint (0,1,0) (1,1,0,1)
,CPoint (1,0,0) (1,0,1,0)
,CPoint (0.5,-0.5,0) (1,0,1,0)
,CPoint (0.5,-0.5,0) (1,0,1,0)
,CPoint (0.5,-0.5,0) (1,0,1,0)
]
egFade = Fade [((-0.2,-0.2,0),(1,1,1,1),500)
,((0.2,0.2,0),(1,1,1,1),500)
-- ,((0.5,0.5,0),(1,1,1,1),0.5)
-- ,((0.5,0.5,0),(1,1,1,1),0.5)
]