Add no weapon start
This commit is contained in:
+13
-10
@@ -195,10 +195,12 @@ wallsNearPoint p w = IM.unions [f b $ f a $ _wallsZone w | a<-[x-1,x,x+1] , b<-
|
||||
wallsAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Wall
|
||||
{-# INLINE wallsAlongLine #-}
|
||||
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
|
||||
where
|
||||
g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _wallsZone w) s))
|
||||
kps = zoneOfLineIntMap 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' #-}
|
||||
@@ -235,7 +237,7 @@ creaturesAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Creature
|
||||
-- _ -> 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
|
||||
kps = zoneOfLineIntMap a b
|
||||
f i m = case IM.lookup i m of Just val -> val
|
||||
_ -> IM.empty
|
||||
|
||||
@@ -281,9 +283,9 @@ zoneOfLine (aa,ab) (ba,bb) = nub $ concatMap f
|
||||
$ digitalLine (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' :: Point2 -> Point2 -> IM.IntMap IS.IntSet
|
||||
{-# INLINE zoneOfLine' #-}
|
||||
zoneOfLine' a b = expandLine $ digitalLine (x-1,y-1) (x'-1,y'-1)
|
||||
zoneOfLineIntMap :: Point2 -> Point2 -> IM.IntMap IS.IntSet
|
||||
{-# INLINE zoneOfLineIntMap #-}
|
||||
zoneOfLineIntMap a b = expandLine $ digitalLine (x-1,y-1) (x'-1,y'-1)
|
||||
where (x,y) = zoneOfPoint a
|
||||
(x',y') = zoneOfPoint b
|
||||
--zoneOfLine (aa,ab) (ba,bb) = nub $ concatMap f
|
||||
@@ -391,11 +393,12 @@ furthestPointWalkable p1 p2 ws = head $ (sortBy (compare `on` dist p1) $ IM.elem
|
||||
) ++ [p2]
|
||||
|
||||
collidePointIndirect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
|
||||
collidePointIndirect p1 p2 ws = listToMaybe $ sortBy (compare `on` dist p1) $ IM.elems
|
||||
collidePointIndirect p1 p2 ws = listToMaybe $ sortOn (dist p1) $ IM.elems
|
||||
$ IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y)
|
||||
. _wlLine
|
||||
) notWindows
|
||||
where notWindows = IM.filter (not . _wlIsSeeThrough) ws
|
||||
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
|
||||
|
||||
+227
-155
@@ -1,4 +1,4 @@
|
||||
{- Actions performed by creatures within the world
|
||||
{- | Actions performed by creatures within the world
|
||||
-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
module Dodge.Creature.Action
|
||||
@@ -27,94 +27,139 @@ import System.Random
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import qualified Data.Map as M
|
||||
|
||||
moveForwardSpeed :: Float -> Int -> World -> World
|
||||
moveForwardSpeed
|
||||
:: Float -- ^ Speed
|
||||
-> Int -- ^ Creature id
|
||||
-> World
|
||||
-> World
|
||||
moveForwardSpeed x n w = over (creatures . ix n . crPos) (+.+ p) w
|
||||
where p = (*.*) x $ unitVectorAtAngle $ _crDir $ _creatures w IM.! n
|
||||
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 -- ^ Speed
|
||||
-> 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)
|
||||
|
||||
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)
|
||||
crStrafeRight
|
||||
:: Float -- ^ Speed
|
||||
-> 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
|
||||
:: Float -- ^ Speed
|
||||
-> Creature
|
||||
-> Creature
|
||||
crMvForward speed cr = over crPos (+.+ p) cr
|
||||
where p = (*.*) (speed * equipFactor) $ unitVectorAtAngle $ _crDir cr
|
||||
equipFactor = product $ map equipSpeed $ IM.elems $ _crInv 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
|
||||
crMvBy
|
||||
:: Point2 -- ^ Movement translation vector
|
||||
-> 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
|
||||
stepForward
|
||||
:: Float -- ^ Speed
|
||||
-> Creature
|
||||
-> Creature
|
||||
stepForward speed cr = over (crState . stance . carriage) f cr
|
||||
where
|
||||
f (w@Walking {}) = w {_stepToAdd = ceiling speed}
|
||||
f s = s
|
||||
|
||||
{- Determine the speed modifier of an item. -}
|
||||
equipSpeed :: Item -> Float
|
||||
equipSpeed NoItem = 1
|
||||
equipSpeed it | _itIdentity it == FrontArmour = 0.75
|
||||
| _itIdentity it == FlameShield = 0.75
|
||||
| otherwise = 1
|
||||
|
||||
turnTo :: Point2 -> Int -> World -> World
|
||||
turnTo
|
||||
:: Point2 -- ^ Target point
|
||||
-> Int -- ^ Creature id
|
||||
-> World
|
||||
-> World
|
||||
turnTo p n w = set (creatures . ix n . crDir) dirToTarget w
|
||||
where cr = _creatures w IM.! n
|
||||
dirToTarget = argV (p -.- _crPos cr)
|
||||
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
|
||||
turnTowardRandomise
|
||||
:: Point2 -- ^ Target point
|
||||
-> Int -- ^ Creature id
|
||||
-> World
|
||||
-> World
|
||||
turnTowardRandomise 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
|
||||
:: Float -- ^ Angle
|
||||
-> Int -- ^ Creature id
|
||||
-> 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
|
||||
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
|
||||
turnTowardWithSpeed
|
||||
:: Float -- ^ Turn speed
|
||||
-> Point2 -- ^ Target point
|
||||
-> Int -- ^ Creature id
|
||||
-> World
|
||||
-> World
|
||||
turnTowardWithSpeed 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
|
||||
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
|
||||
:: Float -- ^ Strafe speed
|
||||
-> Float -- ^ Turn speed
|
||||
-> Point2 -- ^ Target position
|
||||
-> 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
|
||||
@@ -124,15 +169,23 @@ crTurnAndStrafeIn strafeSpeed turnSpeed p cr
|
||||
$ crStrafeLeft strafeSpeed cr
|
||||
| otherwise = over crDir (\x->normalizeAngle (x - turnAmount))
|
||||
$ crStrafeRight strafeSpeed cr
|
||||
where vToTarg = p -.- _crPos cr
|
||||
dirToTarget = argV vToTarg
|
||||
turnAmount = turnSpeed
|
||||
where
|
||||
vToTarg = p -.- _crPos cr
|
||||
dirToTarget = argV vToTarg
|
||||
turnAmount = turnSpeed
|
||||
|
||||
crTurnTo :: Point2 -> Creature -> Creature
|
||||
crTurnTo
|
||||
:: Point2 -- ^ Target position
|
||||
-> Creature
|
||||
-> Creature
|
||||
crTurnTo p cr = set crDir dirToTarget cr
|
||||
where dirToTarget = argV (p -.- _crPos cr)
|
||||
|
||||
crTurnTowardSpeed :: Float -> Point2 -> Creature -> Creature
|
||||
crTurnTowardSpeed
|
||||
:: Float -- ^ Turn speed
|
||||
-> Point2 -- ^ Target position
|
||||
-> Creature
|
||||
-> Creature
|
||||
crTurnTowardSpeed turnSpeed p cr
|
||||
| vToTarg == (0,0) = cr -- this should deal with the angleVV error
|
||||
| errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed
|
||||
@@ -144,7 +197,12 @@ crTurnTowardSpeed turnSpeed p cr
|
||||
dirToTarget = argV vToTarg
|
||||
turnAmount = turnSpeed
|
||||
|
||||
turnTowardSpeed :: Float -> Point2 -> Int -> World -> World
|
||||
turnTowardSpeed
|
||||
:: Float -- ^ Turn speed
|
||||
-> Point2 -- ^ Target position
|
||||
-> Int -- ^ Creature id
|
||||
-> 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
|
||||
@@ -157,43 +215,54 @@ turnTowardSpeed turnSpeed p n w
|
||||
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 -- ^ Target position
|
||||
-> Int -- ^ Creature id
|
||||
-> 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)
|
||||
|
||||
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
|
||||
{- Move a creature forward in the direction it is facing. -}
|
||||
moveForward
|
||||
:: Int -- ^ Creature id
|
||||
-> World
|
||||
-> World
|
||||
moveForward n w = over (creatures . ix n . crPos) (+.+ p) w
|
||||
where p = unitVectorAtAngle $ _crDir $ _creatures w IM.! n
|
||||
where
|
||||
p = unitVectorAtAngle $ _crDir $ _creatures w IM.! n
|
||||
|
||||
moveToward :: Point2 -> Int -> World -> World
|
||||
{- Move a creature forward, faster if it is facing a target point -}
|
||||
moveToward
|
||||
:: Point2 -- ^ Target point
|
||||
-> Int -- ^ Creature id
|
||||
-> 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)
|
||||
where
|
||||
angle = errorAngleVV 5 (p -.- curPos) (unitVectorAtAngle (_crDir (_creatures w IM.! n)))
|
||||
curPos = _crPos (_creatures w IM.! n)
|
||||
|
||||
moveBy :: Int -> Point2 -> World -> World
|
||||
{- Translate a creature. -}
|
||||
moveBy
|
||||
:: Int -- ^ Creature id
|
||||
-> Point2 -- ^ Translation
|
||||
-> World
|
||||
-> World
|
||||
moveBy n v = over (creatures . ix n . crPos) (+.+ v)
|
||||
|
||||
reloadWeapon :: Int -> World -> Maybe World
|
||||
reloadWeapon
|
||||
:: Int -- ^ Creature id
|
||||
-> World
|
||||
-> Maybe World
|
||||
reloadWeapon cid w =
|
||||
let cr = _creatures w IM.! cid
|
||||
it = _crInv cr IM.! _crInvSel cr
|
||||
@@ -204,24 +273,32 @@ reloadWeapon cid w =
|
||||
$ set ( itRef . wpReloadState) rT w
|
||||
_ -> Nothing
|
||||
|
||||
{- Start reloading if clip is empty. -}
|
||||
crAutoReload :: Creature -> Creature
|
||||
crAutoReload cr = case cr ^? crInv . ix (_crInvSel cr) . wpLoadedAmmo of
|
||||
Just 0 -> cr & crInv . ix (_crInvSel cr) . wpReloadState %~ (`fromMaybe` reloadT)
|
||||
& crInv . ix (_crInvSel cr) . wpLoadedAmmo %~ (`fromMaybe` maxA)
|
||||
_ -> cr
|
||||
where reloadT = cr ^? crInv . ix (_crInvSel cr) . wpReloadTime
|
||||
maxA = cr ^? crInv . ix (_crInvSel cr) . wpMaxAmmo
|
||||
Just 0 -> cr & crInv . ix (_crInvSel cr) . wpReloadState %~ (`fromMaybe` reloadT)
|
||||
& crInv . ix (_crInvSel cr) . wpLoadedAmmo %~ (`fromMaybe` maxA)
|
||||
_ -> cr
|
||||
where
|
||||
reloadT = cr ^? crInv . ix (_crInvSel cr) . wpReloadTime
|
||||
maxA = cr ^? crInv . ix (_crInvSel cr) . wpMaxAmmo
|
||||
|
||||
blinkAction :: Int -> World -> World
|
||||
blinkAction n w = soundOnce teleSound $ set (creatures . ix n . crPos) p3
|
||||
$ blinkShockwave n p3
|
||||
$ inverseShockwaveAt cp 40 2 2 2
|
||||
w
|
||||
where p1 = _cameraCenter 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)
|
||||
{- Teleport a creature to the mouse position -}
|
||||
blinkAction
|
||||
:: Int -- ^ Creature id
|
||||
-> World
|
||||
-> World
|
||||
blinkAction n w = soundOnce teleSound
|
||||
$ set (creatures . ix n . crPos) p3
|
||||
$ blinkShockwave n p3
|
||||
$ inverseShockwaveAt cp 40 2 2 2
|
||||
w
|
||||
where
|
||||
p1 = _cameraCenter 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
|
||||
:: Int -- ^ Blinking creature ID.
|
||||
@@ -230,19 +307,25 @@ blinkShockwave
|
||||
-> World
|
||||
blinkShockwave i p = makeShockwaveAt [i] p 60 1 2 cyan
|
||||
|
||||
moveAmountToward :: Point2 -> Float -> Point2 -> Point2
|
||||
moveAmountToward
|
||||
:: Point2 -- ^ Start point
|
||||
-> Float -- ^ Fraction to move along
|
||||
-> Point2 -- ^ End point
|
||||
-> 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
|
||||
:: Int -- ^ Creature id
|
||||
-> World
|
||||
-> World
|
||||
reverseDir n = over (creatures . ix n . crDir) (+ pi)
|
||||
|
||||
turnBy :: Float -> Int -> World -> World
|
||||
turnBy
|
||||
:: Float -- ^ Angle change
|
||||
-> Int -- ^ Creature id
|
||||
-> World
|
||||
-> World
|
||||
turnBy a n = over (creatures . ix n . crDir) (+ a)
|
||||
|
||||
{-
|
||||
@@ -251,60 +334,49 @@ Get your creature to drop the item under the cursor.
|
||||
youDropItem :: World -> World
|
||||
youDropItem w = case yourItem w of
|
||||
NoItem -> w
|
||||
it -> rmSelectedInvItem (_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}
|
||||
it -> rmSelectedInvItem (_yourID w)
|
||||
. copyItemToFloor (you w) (_crInvSel $ you w)
|
||||
$ soundOnce putDownSound
|
||||
w
|
||||
|
||||
{- Drop an item silently. -}
|
||||
dropItem
|
||||
:: Int -- ^ Creature id
|
||||
{- Copy an inventory item to the floor. -}
|
||||
copyItemToFloor
|
||||
:: Creature
|
||||
-> Int -- ^ Inventory position
|
||||
-> World
|
||||
-> World
|
||||
dropItem cid i w = case _crInv cr IM.! i of
|
||||
NoItem -> w
|
||||
it -> rmInvItem cid i
|
||||
. over floorItems (IM.insert flid theflit)
|
||||
copyItemToFloor cr i w = case _crInv cr IM.! i of
|
||||
NoItem -> w
|
||||
it -> over floorItems (IM.insert flid theflit)
|
||||
. updateLocation
|
||||
$ set randGen g w
|
||||
where
|
||||
(rot, g) = randomR (-pi,pi) $ _randGen w
|
||||
offset = _crRad cr *.* unitVectorAtAngle rot
|
||||
offset = (_crRad cr + 2) *.* 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
|
||||
{_flIt = it
|
||||
,_flItPos = offset +.+ _crPos cr
|
||||
,_flItRot = rot
|
||||
,_flItID = flid
|
||||
}
|
||||
where
|
||||
cr = _creatures w IM.! cid
|
||||
|
||||
pickUpItem' :: FloorItem -> World -> World
|
||||
pickUpItem' flit w = case maybeInvSlot of
|
||||
{- Pick up a specific item. -}
|
||||
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 = checkInvSlotsYou it w
|
||||
updateItLocation invid w'
|
||||
= case _itID it of Nothing -> w'
|
||||
Just j -> w' & itemPositions . ix j .~ InInv 0 invid
|
||||
Just i -> w
|
||||
& soundOnce pickUpSound
|
||||
& updateItLocation i
|
||||
& floorItems %~ IM.delete (_flItID flit)
|
||||
& creatures . ix 0 . crInv . ix i %~ addItem it
|
||||
where
|
||||
it = _flIt flit
|
||||
maybeInvSlot = checkInvSlotsYou it w
|
||||
updateItLocation invid w' = case _itID it of
|
||||
Nothing -> w'
|
||||
Just j -> w' & itemPositions . ix j .~ InInv 0 invid
|
||||
|
||||
|
||||
@@ -22,8 +22,8 @@ lamp :: Creature
|
||||
lamp = defaultInanimate
|
||||
{ _crUpdate = initialiseLamp
|
||||
, _crHP = 500
|
||||
, _crPict = \ _ -> onLayer CrLayer $ color white $ circleSolid 5
|
||||
, _crRad = 5
|
||||
, _crPict = \ _ -> onLayer CrLayer $ color white $ circleSolid 3
|
||||
, _crRad = 3
|
||||
}
|
||||
|
||||
initialiseLamp :: CRUpdate
|
||||
|
||||
@@ -67,31 +67,6 @@ dropByState cr w = foldr (copyItemToFloor cr) w is
|
||||
DropSpecific xs -> xs
|
||||
DropAmount n -> take n $ evalState (shuffle $ IM.keys $ _crInv cr) (_randGen w)
|
||||
|
||||
{- Copy an inventory item to the floor. -}
|
||||
copyItemToFloor
|
||||
:: Creature
|
||||
-> Int -- ^ Inventory position
|
||||
-> World
|
||||
-> World
|
||||
copyItemToFloor cr i w = case _crInv cr IM.! i of
|
||||
NoItem -> w
|
||||
it -> over floorItems (IM.insert flid theflit)
|
||||
. updateLocation
|
||||
$ set randGen g w
|
||||
where
|
||||
(rot, g) = randomR (-pi,pi) $ _randGen w
|
||||
offset = _crRad cr *.* 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 = it
|
||||
,_flItPos = offset +.+ _crPos cr
|
||||
,_flItRot = rot
|
||||
,_flItID = flid
|
||||
}
|
||||
|
||||
|
||||
setOldPos :: Creature -> Creature
|
||||
setOldPos cr = set crOldPos (_crPos cr) cr
|
||||
|
||||
@@ -57,13 +57,13 @@ wasdWithAiming w speed aimSpeed i cr
|
||||
= set (crState . stance . carriage) Floating
|
||||
cr
|
||||
| isAiming
|
||||
= stepForward' aimSpeed
|
||||
= stepForward aimSpeed
|
||||
$ over crPos (+.+ (aimSpeed *.* mov))
|
||||
$ set crDir mouseDir
|
||||
$ set (crState . stance . carriage) (Walking 0 0)
|
||||
cr
|
||||
| isMoving
|
||||
= stepForward' speed
|
||||
= stepForward speed
|
||||
$ over ( crPos) (+.+ (speed *.* mov))
|
||||
$ over ( crDir) (flip fromMaybe dir)
|
||||
$ set (crState . stance . carriage) (Walking 0 0)
|
||||
|
||||
@@ -76,7 +76,7 @@ spaceAction w = if _carteDisplay w
|
||||
w & carteCenter .~ theLoc
|
||||
else
|
||||
case listToMaybe $ _closeActiveObjects w of
|
||||
Just (Left flit) -> pickUpItem' flit w
|
||||
Just (Left flit) -> pickUpItem flit w
|
||||
Just (Right but) -> updateTopCloseObject (_btID but) $ _btEvent but but w
|
||||
Nothing -> w
|
||||
where
|
||||
@@ -90,22 +90,14 @@ toggleMap w = w & carteDisplay %~ not
|
||||
escapeMap w = w & carteDisplay .~ False
|
||||
|
||||
dropLight :: World -> World
|
||||
dropLight w = placeLS ls dec pos 0
|
||||
-- $ over creatures IM.insert i (lamp)
|
||||
$ w
|
||||
--case yourItem w of
|
||||
--NoItem -> w
|
||||
--it -> rmInvItem (_yourID w) $ over floorItems (IM.insert flid theflit)
|
||||
-- gg $ updateLocation
|
||||
-- $ soundOnce putDownSound
|
||||
-- $ set randGen g w
|
||||
where --(rot, g) = randomR (-pi,pi) $ _randGen w
|
||||
i = newCrKey w -- to give different lights different keys
|
||||
pos = _crPos(you w)
|
||||
ls = lightAt pos 0
|
||||
dec = onLayer PtLayer $ color white $ circleSolid 8
|
||||
dropLight w = placeLS ls dec pos 0 w
|
||||
where --(rot, g) = randomR (-pi,pi) $ _randGen w
|
||||
i = newCrKey w -- to give different lights different keys
|
||||
pos = _crPos(you w)
|
||||
ls = lightAt pos 0
|
||||
dec = onLayer PtLayer $ color white $ circleSolid 8
|
||||
|
||||
dropLight' :: World -> World
|
||||
dropLight' w = placeCr lamp pos 0 w
|
||||
where
|
||||
pos = _crPos(you w)
|
||||
where
|
||||
pos = _crPos(you w)
|
||||
|
||||
+3
-1
@@ -42,6 +42,8 @@ roomTreex = do
|
||||
t = treeFromTrunk
|
||||
[[StartRoom]
|
||||
,[Corridor]
|
||||
,[SpecificRoom $ fmap (pure . Right) $ randomiseAllLinks =<< centerVaultRoom 1 200 200 50]
|
||||
,[SpecificRoom blockedCorridor]
|
||||
,[OrAno [[DoorAno]
|
||||
,[Corridor]
|
||||
,[DoorNumAno 0,AirlockAno]]
|
||||
@@ -68,7 +70,7 @@ levx = untilJust roomTreex
|
||||
|
||||
lev1' :: RandomGen g => State g (Tree Room)
|
||||
lev1' = do
|
||||
firstWeapon <- takeOne $ [[branchRectWith weaponRoom,blockedCorridor]] ++ replicate 5 [weaponRoom]
|
||||
firstWeapon <- takeOne $ [[branchRectWith weaponRoom,longBlockedCorridor]] ++ replicate 5 [weaponRoom]
|
||||
iterateWhile boundClip $ fmap (shiftRoomTree . expandTreeBy id)
|
||||
$ sequence $ treeFromPost
|
||||
(
|
||||
|
||||
@@ -9,6 +9,7 @@ import Dodge.Layout.Tree.Polymorphic
|
||||
import Dodge.Layout.Tree.Either
|
||||
import Dodge.Room.Procedural
|
||||
import Dodge.Room.Branch
|
||||
import Dodge.Room.RoadBlock
|
||||
import Dodge.Room.Door
|
||||
import Dodge.Room.Boss
|
||||
import Dodge.Room.Treasure
|
||||
@@ -66,7 +67,7 @@ annoToRoomTree [DoorAno] = roomThenCorridor door
|
||||
annoToRoomTree [DoorNumAno i,AirlockAno] = roomThenCorridor (airlock i)
|
||||
annoToRoomTree [FirstWeapon] = do
|
||||
branchWP <- branchRectWith weaponRoom
|
||||
blockedC <- blockedCorridor
|
||||
blockedC <- longBlockedCorridor
|
||||
firstWeapon <- takeOne $ [return $ appendEitherTree branchWP [blockedC]] ++ replicate 5 weaponRoom
|
||||
firstWeapon
|
||||
annoToRoomTree [EndRoom] = fmap (pure . Right) (telRoomLev 1)
|
||||
|
||||
@@ -23,7 +23,7 @@ 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'
|
||||
|
||||
where
|
||||
pg' = filter (isNothing . uncurry (intersectSegSeg' a b)) $ _pathGraph' w
|
||||
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
|
||||
newGraph = pairsToGraph dist pg'
|
||||
|
||||
@@ -35,26 +35,26 @@ nearCollinear (a,b) (x,y)
|
||||
-- | Remove inverse walls.
|
||||
removeInverseWalls :: [WallP] -> [WallP]
|
||||
removeInverseWalls ((a,b):ps)
|
||||
| elem (b,a) ps = removeInverseWalls $ delete (b,a) ps
|
||||
| otherwise = (a,b) : (removeInverseWalls ps)
|
||||
| (b,a) `elem` ps = removeInverseWalls $ delete (b,a) ps
|
||||
| otherwise = (a,b) : removeInverseWalls ps
|
||||
removeInverseWalls ps = ps
|
||||
|
||||
-- | Cut out a polygon from a set of walls, and check for errors in the
|
||||
-- created walls.
|
||||
-- If created walls are not consistent, expand poly and retry.
|
||||
cutWalls :: [Point2] -> [WallP] -> [WallP]
|
||||
cutWalls ps wls = case mapMaybe (flip checkWallRight newWalls) newWalls of
|
||||
cutWalls ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
|
||||
[] -> newWalls
|
||||
_ -> cutWalls (expandPolyBy 0.01 ps) wls
|
||||
where
|
||||
newWalls = cutWalls' ps wls
|
||||
errsL = mapMaybe (flip checkWallLeft newWalls) newWalls
|
||||
errsL = mapMaybe (`checkWallLeft` newWalls) newWalls
|
||||
|
||||
-- | Cut out a polygon from a set of walls, and check for errors in the
|
||||
-- created walls.
|
||||
-- Give error if created walls are not consistent.
|
||||
cutWalls'' :: [Point2] -> [WallP] -> [WallP]
|
||||
cutWalls'' ps wls = case mapMaybe (flip checkWallRight newWalls) newWalls of
|
||||
cutWalls'' ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
|
||||
[] -> newWalls
|
||||
errs -> error $ "during level generation function cutWalls: when cutting poly:\n" ++ show ps
|
||||
++ "\nRight corner errors:\n"
|
||||
@@ -67,7 +67,7 @@ cutWalls'' ps wls = case mapMaybe (flip checkWallRight newWalls) newWalls of
|
||||
++ unlines (map show newWalls)
|
||||
where
|
||||
newWalls = cutWalls' ps wls
|
||||
errsL = mapMaybe (flip checkWallLeft newWalls) newWalls
|
||||
errsL = mapMaybe (`checkWallLeft` newWalls) newWalls
|
||||
|
||||
-- | Given a specific wall and list of walls, checks that the number of walls leaving the
|
||||
-- second point is the same as the number of walls entering the second point of
|
||||
@@ -126,7 +126,7 @@ cutWalls' qs walls =
|
||||
expandPolyBy :: Float -> [Point2] -> [Point2]
|
||||
expandPolyBy x ps = map f ps
|
||||
where
|
||||
cp = (1/(fromIntegral (length ps))) *.* (foldr (+.+) (0,0) ps)
|
||||
cp = 1/(fromIntegral (length ps)) *.* foldr (+.+) (0,0) ps
|
||||
f p = p +.+ x *.* (p -.- cp)
|
||||
|
||||
-- | Given a polygon expressed as a list of points and a collection of walls,
|
||||
@@ -144,7 +144,7 @@ cutWallsWithPoints (p:ps) ws = foldr f ([],ws) (zip (p:ps) (ps++[p]))
|
||||
-- | List the points of intersection between a segment and collection of walls.
|
||||
cutWallsPoints :: Point2 -> Point2 -> [WallP] -> [Point2]
|
||||
--cutWallsPoints p1 p2 ws = mapMaybe (\(x:y:_) -> intersectExtendedSegSeg p1 p2 x y)
|
||||
cutWallsPoints p1 p2 ws = mapMaybe (uncurry $ myIntersectSegSeg p1 p2) ws
|
||||
cutWallsPoints p1 p2 = mapMaybe (uncurry $ myIntersectSegSeg p1 p2)
|
||||
|
||||
-- | Given a segment and a wall, split the wall into two if it crosses the segment.
|
||||
cutWall :: Point2 -> Point2 -> WallP -> [WallP]
|
||||
@@ -171,9 +171,7 @@ addPolyWall (p1,p2) walls =
|
||||
where
|
||||
p3 = 0.5 *.* (p1 +.+ p2)
|
||||
p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
|
||||
maybeWs = -- listToMaybe .
|
||||
fmap (fst . unzip)
|
||||
-- . fmap unzip
|
||||
maybeWs = fmap (map fst)
|
||||
. listToMaybe
|
||||
$ groupBy ((==) `on` (dist p3 . snd))
|
||||
wlsP
|
||||
@@ -224,10 +222,6 @@ wallIsZeroLength (x,y) = x == y
|
||||
|
||||
-- | Given a polygon and list of walls, removes walls inside the polygon.
|
||||
removeWallsInPolygon :: [Point2] -> [WallP] -> [WallP]
|
||||
removeWallsInPolygon ps walls = filter (not . cond) walls
|
||||
removeWallsInPolygon ps = filter (not . cond)
|
||||
where
|
||||
cond wall =
|
||||
pointInOrOnPolygon (0.5 *.* (fst wall +.+ snd wall)) ps
|
||||
-- pointInOrOnPolygon (fst wall) ps
|
||||
-- && pointInOrOnPolygon (snd wall) ps
|
||||
|
||||
cond wall = pointInOrOnPolygon (0.5 *.* uncurry (+.+) wall) ps
|
||||
|
||||
@@ -29,10 +29,14 @@ makeButton c eff = Button
|
||||
, _btState = BtOff
|
||||
}
|
||||
where
|
||||
turnOn bt = bt {_btState = BtNoLabel, _btPict = onPict, _btEvent = (\_ -> id)}
|
||||
turnOn bt = bt {_btState = BtNoLabel, _btPict = onPict, _btEvent = const id}
|
||||
onPict = onLayer WlLayer (color c $ polygon $ rectNSEW (-3) (-5) 10 (-10))
|
||||
|
||||
makeSwitch :: Color -> (World -> World) -> (World -> World) -> Button
|
||||
makeSwitch
|
||||
:: Color
|
||||
-> (World -> World) -- ^ Switch on effect
|
||||
-> (World -> World) -- ^ Switch off effect
|
||||
-> Button
|
||||
makeSwitch c effOn effOff = Button
|
||||
{ _btPict = offPict
|
||||
, _btPos = (0,0)
|
||||
@@ -42,28 +46,28 @@ makeSwitch c effOn effOff = Button
|
||||
, _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
|
||||
, _btText = "SWITCH\\"
|
||||
}
|
||||
turnOff :: Button -> Button
|
||||
turnOff bt = bt
|
||||
{ _btState = BtOff
|
||||
, _btPict = offPict
|
||||
, _btText = "SWITCH/"
|
||||
}
|
||||
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
|
||||
, _btText = "SWITCH\\"
|
||||
}
|
||||
turnOff :: Button -> Button
|
||||
turnOff bt = bt
|
||||
{ _btState = BtOff
|
||||
, _btPict = offPict
|
||||
, _btText = "SWITCH/"
|
||||
}
|
||||
|
||||
@@ -88,7 +88,7 @@ mkTriggerDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPane c cond)
|
||||
]
|
||||
shiftRight = map (+.+ (0.5 *.* (pr -.- pl)))
|
||||
shiftLeft = map (+.+ (0.5 *.* (pl -.- pr)))
|
||||
norm = 14 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
|
||||
norm = 9 *.* errorNormalizeV 49 ( vNormal (pr -.- pl))
|
||||
hw = 0.5 *.* (pl +.+ pr)
|
||||
perp = 5 *.* normalizeV (pl -.- pr)
|
||||
plu = pl +.+ norm
|
||||
@@ -99,12 +99,12 @@ mkTriggerDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPane c cond)
|
||||
hwd = hw -.- norm
|
||||
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
|
||||
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 closedPos openPos = Door
|
||||
|
||||
@@ -210,7 +210,7 @@ wallsForShadows w = map (linePairs . _wlLine)
|
||||
. IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
|
||||
where linePairs (x:y:_) = (x,y)
|
||||
|
||||
lightsForGloom' :: World -> [(Point4)]
|
||||
lightsForGloom' :: World -> [Point4]
|
||||
lightsForGloom' w = map getLS (IM.elems $ _lightSources w) ++ map getTLS (_tempLightSources w)
|
||||
where getLS ls = ( fst $ _lsPos ls, snd $ _lsPos ls, _lsRad ls , _lsIntensity ls)
|
||||
getTLS ls = ( fst $ _tlsPos ls,snd $ _tlsPos ls, _tlsRad ls, _tlsIntensity ls)
|
||||
|
||||
+13
-19
@@ -65,7 +65,10 @@ airlockOneWay n = Room
|
||||
]
|
||||
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
|
||||
col = dim $ dim $ bright red
|
||||
airlock :: Int -> Room
|
||||
|
||||
airlock
|
||||
:: Int -- ^ Door id
|
||||
-> Room
|
||||
airlock n = Room
|
||||
{ _rmPolys =
|
||||
[ rectNSWE 100 0 0 40
|
||||
@@ -85,11 +88,13 @@ airlock n = Room
|
||||
]
|
||||
, _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
|
||||
where
|
||||
lnks = [((20,85),0)
|
||||
,((20, 5),pi)
|
||||
]
|
||||
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
|
||||
col = dim $ dim $ bright red
|
||||
|
||||
roomC :: Float -> Float -> Room
|
||||
roomC x y = Room
|
||||
{ _rmPolys = [rectNSWE y 0 0 x]
|
||||
@@ -312,8 +317,8 @@ randFirstWeapon = do
|
||||
++ replicate 5 multGun
|
||||
++ replicate 2 autoGun
|
||||
++ [launcher]
|
||||
++ [lasGun]
|
||||
++ [flamer]
|
||||
-- ++ [lasGun]
|
||||
-- ++ [flamer]
|
||||
|
||||
--randC1 :: State StdGen PSType
|
||||
randC1 = RandPS $ takeOne $ map PutCrit $ (armourChaseCrit : replicate 50 chaseCrit)
|
||||
@@ -381,17 +386,6 @@ weaponBetweenPillars = do
|
||||
(fmap connectRoom . randomiseOutLinks) =<< (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
|
||||
,PS (20,15) 0 $ putLamp
|
||||
]
|
||||
sequence $ treeFromPost (replicate n $ fmap Left $ randomiseOutLinks corridor)
|
||||
$ fmap Right $ return $ set rmPS plmnts corridor
|
||||
|
||||
weaponLongCorridor :: RandomGen g => State g (Tree (Either Room Room))
|
||||
weaponLongCorridor = do
|
||||
root <- takeOne $ [tEast, tWest]
|
||||
|
||||
@@ -1,10 +1,11 @@
|
||||
{-
|
||||
Procedural creation of rooms.
|
||||
Procedural creation of rooms and subroom parts.
|
||||
-}
|
||||
module Dodge.Room.Procedural
|
||||
( roomRect
|
||||
, roomRectAutoLinks
|
||||
, testRoom
|
||||
, centerVaultRoom
|
||||
) where
|
||||
import Dodge.Data
|
||||
import Dodge.Room.Data
|
||||
@@ -18,9 +19,11 @@ import Dodge.LevelGen.Data
|
||||
import Dodge.Creature
|
||||
import Dodge.Default
|
||||
import Geometry
|
||||
import Picture
|
||||
|
||||
import Data.List (nub,nubBy,sortBy,minimumBy)
|
||||
import Data.Function (on)
|
||||
import qualified Data.Map as M
|
||||
import Control.Lens
|
||||
import Control.Monad
|
||||
import Control.Monad.State
|
||||
@@ -220,9 +223,55 @@ testRoom = do
|
||||
nCrits <- state $ randomR (1,3)
|
||||
crits <- takeN nCrits $ fmap PutCrit $ [spreadGunCrit,pistolCrit,autoCrit,armourChaseCrit]
|
||||
++ replicate 20 chaseCrit
|
||||
randomiseAllLinks . (fillNothingPlacements $ crits ++ itms) =<<
|
||||
randomiseAllLinks . fillNothingPlacements (crits ++ itms) =<<
|
||||
( shufflePlacements
|
||||
. foldr1 combineRooms
|
||||
$ zipWith (\r a -> shiftRoomBy ((0,0),a) r) corners [0,pi/2,pi,3*pi/2]
|
||||
)
|
||||
|
||||
{- | Creates room with a central vault with doors around it.
|
||||
-}
|
||||
centerVaultRoom
|
||||
:: RandomGen g
|
||||
=> Int -- ^ Door id
|
||||
-> Float -- ^ Width
|
||||
-> Float -- ^ Height
|
||||
-> Float -- ^ Vault dimensions
|
||||
-> State g Room
|
||||
centerVaultRoom n w h d = do
|
||||
let northPoly = rectNSWE h d (-w) w
|
||||
nsDoors = rectNSWE (d + 20) (negate (d +20)) (-20) 20
|
||||
weDoors = rectNSWE 20 (-20) (d + 20) (negate (d +20))
|
||||
centerPoly = rectWdthHght (d - 20) (d - 20)
|
||||
polys = centerPoly : nsDoors : weDoors : (take 4 $ iterate (map vNormal) northPoly)
|
||||
cr <- takeOne [miniGunCrit, autoCrit]
|
||||
return $ Room
|
||||
{ _rmPolys = polys
|
||||
, _rmLinks =
|
||||
[((0,h),0)
|
||||
,((w,0),-pi/2)
|
||||
,((-w,0),pi/2)
|
||||
,((0,-h),pi)
|
||||
]
|
||||
, _rmPath = []
|
||||
, _rmPS =
|
||||
[PS (d-25,d-25) 0 putLamp
|
||||
,PS (w-5,h-5) 0 putLamp
|
||||
,PS (w-5,5-h) 0 putLamp
|
||||
,PS (5-w,h-5) 0 putLamp
|
||||
,PS (5-w,5-h) 0 putLamp
|
||||
,PS (0,0) 0 $ PutCrit (cr & crState . crDropsOnDeath .~ DropAll)
|
||||
]
|
||||
++ concat (zipWith (\i r -> map (shiftPSBy ((0,0),r)) $ theDoor i)
|
||||
[n, n+1, n+2, n+3] [0,pi/2,pi,3*pi/2])
|
||||
, _rmBound = rectNSWE h (-h) (-w) w
|
||||
}
|
||||
where
|
||||
col = dim $ dim $ bright red
|
||||
theDoor i =
|
||||
[ PS (0,d-10) 0 $ PutTriggerDoor col (cond i) (-19,0) (19,0)
|
||||
, PS (35,d+4) 0 $ PutButton $ makeSwitch col
|
||||
(over worldState (M.insert (DoorNumOpen i) True))
|
||||
(over worldState (M.insert (DoorNumOpen i) False))
|
||||
]
|
||||
cond i w = or $ M.lookup (DoorNumOpen i) (_worldState w)
|
||||
|
||||
@@ -7,12 +7,15 @@ import Geometry
|
||||
import Dodge.Room.Data
|
||||
import Dodge.Room.Link
|
||||
import Dodge.Room.Placement
|
||||
import Dodge.Room.Corridor
|
||||
import Dodge.LevelGen.Data
|
||||
import Dodge.RandomHelp
|
||||
import Dodge.Creature
|
||||
import Dodge.Layout.Tree.Polymorphic
|
||||
|
||||
import Data.Tree
|
||||
import Control.Monad.State
|
||||
import Control.Lens
|
||||
import System.Random
|
||||
|
||||
armouredCorridor :: RandomGen g => State g Room
|
||||
@@ -46,3 +49,30 @@ litCorridor90 = do
|
||||
]
|
||||
, _rmBound = poly
|
||||
}
|
||||
|
||||
noWeaponTest :: RandomGen g => State g (Tree (Either Room Room))
|
||||
noWeaponTest = do
|
||||
undefined
|
||||
|
||||
-- | A random length corridor with a descrutible block blocking it.
|
||||
longBlockedCorridor :: RandomGen g => State g (Tree (Either Room Room))
|
||||
longBlockedCorridor = 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
|
||||
,PS (20,15) 0 $ putLamp
|
||||
]
|
||||
sequence $ treeFromPost (replicate n $ fmap Left $ randomiseOutLinks corridor)
|
||||
$ fmap Right $ return $ set rmPS plmnts corridor
|
||||
|
||||
-- | A single corridor with a descrutible block blocking it.
|
||||
blockedCorridor :: RandomGen g => State g (Tree (Either Room Room))
|
||||
blockedCorridor = do
|
||||
r <- state $ randomR (0,pi)
|
||||
let plmnts = [PS (20,40) r $ PutBlock [5,5,5] (150/256, 75/256, 0, 250/256)
|
||||
$ reverse $ rectNSWE 10 (-10) (-10) 10
|
||||
,PS (20,15) 0 $ putLamp
|
||||
]
|
||||
sequence $ treeFromPost []
|
||||
$ fmap Right $ return $ set rmPS plmnts corridor
|
||||
|
||||
@@ -28,7 +28,7 @@ telRoomLev i = do
|
||||
h <- state $ randomR (200,300)
|
||||
return $ roomRectAutoLinks w h & rmPS .~
|
||||
[ PS (w/2,h/2) 0 $ PutPressPlate telPP
|
||||
, PS (w/2,h/2+ 30) 0 $ putLamp
|
||||
, PS (w/2,h/2+ 30) 0 putLamp
|
||||
]
|
||||
where
|
||||
telPP = PressPlate
|
||||
|
||||
+23
-21
@@ -118,11 +118,11 @@ 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
|
||||
where
|
||||
vPos = _cameraViewFrom w
|
||||
wallsToUpdate = concatMap (\p -> visibleWalls vPos (vPos +.+p) $ wallsAlongLine vPos (vPos +.+ p) w)
|
||||
$ nRays 20
|
||||
markSeen i = set (walls . ix i . wlSeen) True
|
||||
|
||||
setTestStringIO :: IO World -> IO World
|
||||
setTestStringIO = fmap (\ w -> set testString (show $ s w) w)
|
||||
@@ -186,20 +186,22 @@ crCrSpring c1 c2 w
|
||||
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 _ = []
|
||||
{-
|
||||
Finds the IDs of visible walls from a point to another point.
|
||||
-}
|
||||
visibleWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Int]
|
||||
visibleWalls p1 p2 ws
|
||||
= map fst
|
||||
. takeUntil (_wlIsSeeThrough . snd)
|
||||
. map snd
|
||||
. sortOn (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))
|
||||
takeUntil h xs = let (ys,zs) = span h xs
|
||||
in ys ++ tf zs
|
||||
where tf (x:_) = [x]
|
||||
tf _ = []
|
||||
|
||||
|
||||
@@ -68,6 +68,11 @@ 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)]
|
||||
|
||||
rectWdthHght :: Float -> Float -> [Point2]
|
||||
rectWdthHght w h = rectNSWE h (-h) (-w) w
|
||||
|
||||
-- | Draw a rectangle around the origin with given height and width
|
||||
|
||||
-- | Test whether a point is in a polygon or on the polygon border.
|
||||
-- Supposes the points in the
|
||||
-- polygon are listed in anticlockwise order.
|
||||
@@ -423,6 +428,7 @@ divideLineOddNumPoints x a b = take 5000
|
||||
-- | Given two pairs of Ints, returns a list of pairs of Ints that form
|
||||
-- a digital line between them.
|
||||
digitalLine :: (Int,Int) -> (Int,Int) -> [(Int,Int)]
|
||||
{-# INLINE digitalLine #-}
|
||||
digitalLine (x1,y1) (x2,y2)
|
||||
| abs (x1-x2) > abs (y1-y2) = [ (x,( (y1-y2) * x + x1*y2 - x2*y1) `rdiv` (x1-x2) )
|
||||
| x <- intervalList x1 x2 ]
|
||||
@@ -431,6 +437,17 @@ digitalLine (x1,y1) (x2,y2)
|
||||
where
|
||||
rdiv a b = round $ fromIntegral a / fromIntegral b
|
||||
|
||||
-- | Given two pairs of 'Int's, create a list of pairs of 'Int's that form a
|
||||
-- rectangle between them.
|
||||
digitalRect :: (Int,Int) -> (Int,Int) -> [(Int,Int)]
|
||||
{-# INLINE digitalRect #-}
|
||||
digitalRect (a,b) (c,d) = [(s,t) | s <- [minx .. maxx] , t <- [miny .. maxy]]
|
||||
where
|
||||
maxx = max a c
|
||||
minx = min a c
|
||||
maxy = max b d
|
||||
miny = min b d
|
||||
|
||||
-- | Given two Ints, creates the list of Ints between these.
|
||||
intervalList :: Int -> Int -> [Int]
|
||||
intervalList x y
|
||||
|
||||
Reference in New Issue
Block a user