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

Add no weapon start

Browse Source
This commit is contained in:
jgk
2021-04-27 19:26:35 +02:00
parent 64b5b9e2a5
commit 6d229f8de2
20 changed files with 448 additions and 313 deletions
Download Patch File Download Diff File Expand all files Collapse all files
package.yaml
+1 -1
View File
@@ -28,7 +28,6 @@ dependencies:
- sdl2-mixer - sdl2-mixer
- text - text
- OpenGL - OpenGL
#- OpenGLRaw
- raw-strings-qq - raw-strings-qq
- bytestring - bytestring
- lens - lens
@@ -47,6 +46,7 @@ dependencies:
- aeson - aeson
- directory - directory
- QuickCheck - QuickCheck
- utility-ht
library: library:
source-dirs: src source-dirs: src
src/Dodge/Base.hs
+13 -10
View File
@@ -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 wallsAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Wall
{-# INLINE wallsAlongLine #-} {-# INLINE wallsAlongLine #-}
wallsAlongLine a b w = IM.foldrWithKey' g IM.empty kps 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)) where
kps = zoneOfLine' a b 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 kps = zoneOfLineIntMap a b
_ -> IM.empty f i m = case IM.lookup i m of
Just val -> val
_ -> IM.empty
wallsNearZone' :: IM.IntMap IS.IntSet -> World -> IM.IntMap Wall wallsNearZone' :: IM.IntMap IS.IntSet -> World -> IM.IntMap Wall
{-# INLINE wallsNearZone' #-} {-# INLINE wallsNearZone' #-}
@@ -235,7 +237,7 @@ creaturesAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Creature
-- _ -> IM.empty -- _ -> IM.empty
creaturesAlongLine a b w = IM.foldrWithKey' g IM.empty kps 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)) 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 f i m = case IM.lookup i m of Just val -> val
_ -> IM.empty _ -> IM.empty
@@ -281,9 +283,9 @@ zoneOfLine (aa,ab) (ba,bb) = nub $ concatMap f
$ digitalLine (zoneOfPoint (aa,ab)) (zoneOfPoint (ba,bb)) $ 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]] 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 zoneOfLineIntMap :: Point2 -> Point2 -> IM.IntMap IS.IntSet
{-# INLINE zoneOfLine' #-} {-# INLINE zoneOfLineIntMap #-}
zoneOfLine' a b = expandLine $ digitalLine (x-1,y-1) (x'-1,y'-1) zoneOfLineIntMap a b = expandLine $ digitalLine (x-1,y-1) (x'-1,y'-1)
where (x,y) = zoneOfPoint a where (x,y) = zoneOfPoint a
(x',y') = zoneOfPoint b (x',y') = zoneOfPoint b
--zoneOfLine (aa,ab) (ba,bb) = nub $ concatMap f --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] ) ++ [p2]
collidePointIndirect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2 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) $ IM.mapMaybe ( ( \(x:y:_) -> intersectSegSeg' p1 p2 x y)
. _wlLine . _wlLine
) notWindows ) notWindows
where notWindows = IM.filter (not . _wlIsSeeThrough) ws where
notWindows = IM.filter (not . _wlIsSeeThrough) ws
collidePointFire :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2 collidePointFire :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Point2
collidePointFire p1 p2 ws = listToMaybe $ sortBy (compare `on` dist p1) $ IM.elems collidePointFire p1 p2 ws = listToMaybe $ sortBy (compare `on` dist p1) $ IM.elems
src/Dodge/Creature/Action.hs
+227 -155
View File
@@ -1,4 +1,4 @@
{- Actions performed by creatures within the world {- | Actions performed by creatures within the world
-} -}
{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BangPatterns #-}
module Dodge.Creature.Action module Dodge.Creature.Action
@@ -27,94 +27,139 @@ import System.Random
import qualified Data.IntMap.Strict as IM import qualified Data.IntMap.Strict as IM
import qualified Data.Map as M 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 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 crStrafeLeft
mvForward speed cid w = stepForward cid speed $ over (creatures . ix cid . crPos) (+.+ p) w :: Float -- ^ Speed
where p = (*.*) (speed * equipFactor) $ unitVectorAtAngle $ _crDir $ _creatures w IM.! cid -> Creature
equipFactor = product $ map equipSpeed $ IM.elems $ _crInv $ _creatures w IM.! cid -> 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 crStrafeRight
crStrafeLeft speed cr = stepForward' s2 $ over crPos (+.+ p) cr :: Float -- ^ Speed
where p = (*.*) s2 $ unitVectorAtAngle $ (_crDir cr + pi/2) -> Creature
equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr -> Creature
s2 = (speed * equipFactor) crStrafeRight speed cr = stepForward s2 $ over crPos (+.+ p) cr
crStrafeRight :: Float -> Creature -> Creature where
crStrafeRight speed cr = stepForward' s2 $ over crPos (+.+ p) cr p = (*.*) s2 $ unitVectorAtAngle $ (_crDir cr - pi/2)
where p = (*.*) s2 $ unitVectorAtAngle $ (_crDir cr - pi/2) equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr
equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr s2 = (speed * equipFactor)
s2 = (speed * equipFactor)
crMvForward :: Float -> Creature -> Creature crMvForward
:: Float -- ^ Speed
-> Creature
-> Creature
crMvForward speed cr = over crPos (+.+ p) cr crMvForward speed cr = over crPos (+.+ p) cr
where p = (*.*) (speed * equipFactor) $ unitVectorAtAngle $ _crDir cr where
equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr p = (*.*) (speed * equipFactor) $ unitVectorAtAngle $ _crDir cr
equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr
crMvBy :: Point2 -> Creature -> Creature crMvBy
crMvBy p' cr = stepForward' (magV p) $ over crPos (+.+ p) cr :: Point2 -- ^ Movement translation vector
where p = (*.*) (equipFactor * aimingFactor) $ rotateV (_crDir cr) p' -> Creature
equipFactor = product $ map equipSpeed $ IM.elems $ _crInv cr -> Creature
aimingFactor | (_posture $ _stance $ _crState cr) == Aiming crMvBy p' cr = stepForward (magV p) $ over crPos (+.+ p) cr
= fromMaybe 1 $ it ^? itAimingSpeed where
| otherwise = 1 p = (*.*) (equipFactor * aimingFactor) $ rotateV (_crDir cr) p'
it = _crInv cr IM.! _crInvSel cr 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
stepForward cid speed = over (creatures . ix cid . crState . stance . carriage) f :: Float -- ^ Speed
where f (w@Walking {}) = w {_stepToAdd = ceiling speed} -> Creature
f s = s -> Creature
stepForward speed cr = over (crState . stance . carriage) f cr
stepForward' :: Float -> Creature -> Creature where
stepForward' speed cr = over (crState . stance . carriage) f cr f (w@Walking {}) = w {_stepToAdd = ceiling speed}
where f (w@Walking {}) = w {_stepToAdd = ceiling speed} f s = s
f s = s
{- Determine the speed modifier of an item. -}
equipSpeed :: Item -> Float
equipSpeed NoItem = 1 equipSpeed NoItem = 1
equipSpeed it | _itIdentity it == FrontArmour = 0.75 equipSpeed it | _itIdentity it == FrontArmour = 0.75
| _itIdentity it == FlameShield = 0.75 | _itIdentity it == FlameShield = 0.75
| otherwise = 1 | 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 turnTo p n w = set (creatures . ix n . crDir) dirToTarget w
where cr = _creatures w IM.! n where
dirToTarget = argV (p -.- _crPos cr) cr = _creatures w IM.! n
dirToTarget = argV (p -.- _crPos cr)
turnToward :: Point2 -> Int -> World -> World turnTowardRandomise
turnToward p n w | isLeftOfA dirToTarget (_crDir cr) :: Point2 -- ^ Target point
= f $ over (creatures . ix n . crDir) -> Int -- ^ Creature id
(normalizeAngle . (+ (0.03 + r*m))) w -> World
| otherwise = f $ over (creatures . ix n . crDir) -> World
(\x->normalizeAngle (x - (0.03 + r*m))) w turnTowardRandomise p n w
where cr = _creatures w IM.! n | isLeftOfA dirToTarget (_crDir cr)
dirToTarget = argV (p -.- _crPos cr) = f $ over (creatures . ix n . crDir)
(r,g) = randomR (-0.1,0.1) (_randGen w) (normalizeAngle . (+ (0.03 + r*m))) w
m = diffAngles dirToTarget (_crDir cr) | otherwise = f $ over (creatures . ix n . crDir)
f = set randGen g (\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 turnTowardAngle a n w
| isLeftOfA a (_crDir cr) = f $ over (creatures . ix n . crDir) | isLeftOfA a (_crDir cr) = f $ over (creatures . ix n . crDir)
(normalizeAngle . (+ (0.03 + r*m))) w (normalizeAngle . (+ (0.03 + r*m))) w
| otherwise = f $ over (creatures . ix n . crDir) | otherwise = f $ over (creatures . ix n . crDir)
(\x->normalizeAngle (x - (0.03 + r*m))) w (\x->normalizeAngle (x - (0.03 + r*m))) w
where cr = _creatures w IM.! n where
(r,g) = randomR (-0.1,0.1) (_randGen w) cr = _creatures w IM.! n
m = diffAngles a (_crDir cr) (r,g) = randomR (-0.1,0.1) (_randGen w)
f = set randGen g m = diffAngles a (_crDir cr)
f = set randGen g
turnToward'' :: Float -> Point2 -> Int -> World -> World turnTowardWithSpeed
turnToward'' turnSpeed p n w :: Float -- ^ Turn speed
-> Point2 -- ^ Target point
-> Int -- ^ Creature id
-> World
-> World
turnTowardWithSpeed turnSpeed p n w
| isLeftOfA dirToTarget (_crDir cr) | isLeftOfA dirToTarget (_crDir cr)
= f $ over (creatures . ix n . crDir) (normalizeAngle. (+ (turnSpeed + r))) w = f $ over (creatures . ix n . crDir) (normalizeAngle. (+ (turnSpeed + r))) w
| otherwise = f $ over (creatures . ix n . crDir) (\x->normalizeAngle (x - (turnSpeed + r))) w | otherwise = f $ over (creatures . ix n . crDir) (\x->normalizeAngle (x - (turnSpeed + r))) w
where cr = _creatures w IM.! n where
dirToTarget = argV (p -.- _crPos cr) cr = _creatures w IM.! n
(r,g) = randomR (-0.1,0.1) (_randGen w) dirToTarget = argV (p -.- _crPos cr)
f = set randGen g (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 crTurnAndStrafeIn strafeSpeed turnSpeed p cr
| vToTarg == (0,0) = cr -- this should deal with the angleVV error | vToTarg == (0,0) = cr -- this should deal with the angleVV error
| errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed | errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed
@@ -124,15 +169,23 @@ crTurnAndStrafeIn strafeSpeed turnSpeed p cr
$ crStrafeLeft strafeSpeed cr $ crStrafeLeft strafeSpeed cr
| otherwise = over crDir (\x->normalizeAngle (x - turnAmount)) | otherwise = over crDir (\x->normalizeAngle (x - turnAmount))
$ crStrafeRight strafeSpeed cr $ crStrafeRight strafeSpeed cr
where vToTarg = p -.- _crPos cr where
dirToTarget = argV vToTarg vToTarg = p -.- _crPos cr
turnAmount = turnSpeed dirToTarget = argV vToTarg
turnAmount = turnSpeed
crTurnTo :: Point2 -> Creature -> Creature crTurnTo
:: Point2 -- ^ Target position
-> Creature
-> Creature
crTurnTo p cr = set crDir dirToTarget cr crTurnTo p cr = set crDir dirToTarget cr
where dirToTarget = argV (p -.- _crPos 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 crTurnTowardSpeed turnSpeed p cr
| vToTarg == (0,0) = cr -- this should deal with the angleVV error | vToTarg == (0,0) = cr -- this should deal with the angleVV error
| errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed | errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed
@@ -144,7 +197,12 @@ crTurnTowardSpeed turnSpeed p cr
dirToTarget = argV vToTarg dirToTarget = argV vToTarg
turnAmount = turnSpeed 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 turnTowardSpeed turnSpeed p n w
| vToTarg == (0,0) = w -- this should deal with the angleVV error | vToTarg == (0,0) = w -- this should deal with the angleVV error
| errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed | errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed
@@ -157,43 +215,54 @@ turnTowardSpeed turnSpeed p n w
dirToTarget = argV vToTarg dirToTarget = argV vToTarg
turnAmount = turnSpeed turnAmount = turnSpeed
turnLRS :: Int -> World -> World turnToward
turnLRS n w = f $ over (creatures . ix n . crDir) (+ (fromIntegral r * pi / 2)) w :: Point2 -- ^ Target position
where (r,g) = randomR (negate 1::Int,1) (_randGen w) -> Int -- ^ Creature id
f = set randGen g -> 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 {- Move a creature forward in the direction it is facing. -}
turnToward' p n w | isLeftOfA dirToTarget (_crDir cr) moveForward
= over (creatures . ix n . crDir) (+ 0.03) w :: Int -- ^ Creature id
| otherwise = over (creatures . ix n . crDir) (\x-> x - 0.03) w -> World
where cr = _creatures w IM.! n -> World
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 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 moveToward p n w
| angle < 10 = moveForwardSpeed 0.1 n w | angle < 10 = moveForwardSpeed 0.1 n w
| angle < 20 = moveForwardSpeed 0.02 n w | angle < 20 = moveForwardSpeed 0.02 n w
| angle < 40 = moveForwardSpeed 0.01 n w | angle < 40 = moveForwardSpeed 0.01 n w
| otherwise = w | otherwise = w
where angle = errorAngleVV 5 (p -.- curPos) (unitVectorAtAngle (_crDir (_creatures w IM.! n))) where
curPos = _crPos (_creatures w IM.! n) 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) moveBy n v = over (creatures . ix n . crPos) (+.+ v)
reloadWeapon :: Int -> World -> Maybe World reloadWeapon
:: Int -- ^ Creature id
-> World
-> Maybe World
reloadWeapon cid w = reloadWeapon cid w =
let cr = _creatures w IM.! cid let cr = _creatures w IM.! cid
it = _crInv cr IM.! _crInvSel cr it = _crInv cr IM.! _crInvSel cr
@@ -204,24 +273,32 @@ reloadWeapon cid w =
$ set ( itRef . wpReloadState) rT w $ set ( itRef . wpReloadState) rT w
_ -> Nothing _ -> Nothing
{- Start reloading if clip is empty. -}
crAutoReload :: Creature -> Creature crAutoReload :: Creature -> Creature
crAutoReload cr = case cr ^? crInv . ix (_crInvSel cr) . wpLoadedAmmo of crAutoReload cr = case cr ^? crInv . ix (_crInvSel cr) . wpLoadedAmmo of
Just 0 -> cr & crInv . ix (_crInvSel cr) . wpReloadState %~ (`fromMaybe` reloadT) Just 0 -> cr & crInv . ix (_crInvSel cr) . wpReloadState %~ (`fromMaybe` reloadT)
& crInv . ix (_crInvSel cr) . wpLoadedAmmo %~ (`fromMaybe` maxA) & crInv . ix (_crInvSel cr) . wpLoadedAmmo %~ (`fromMaybe` maxA)
_ -> cr _ -> cr
where reloadT = cr ^? crInv . ix (_crInvSel cr) . wpReloadTime where
maxA = cr ^? crInv . ix (_crInvSel cr) . wpMaxAmmo reloadT = cr ^? crInv . ix (_crInvSel cr) . wpReloadTime
maxA = cr ^? crInv . ix (_crInvSel cr) . wpMaxAmmo
blinkAction :: Int -> World -> World {- Teleport a creature to the mouse position -}
blinkAction n w = soundOnce teleSound $ set (creatures . ix n . crPos) p3 blinkAction
$ blinkShockwave n p3 :: Int -- ^ Creature id
$ inverseShockwaveAt cp 40 2 2 2 -> World
w -> World
where p1 = _cameraCenter w +.+ (1 / _cameraZoom w) *.* rotateV (_cameraRot w) (_mousePos w) blinkAction n w = soundOnce teleSound
cp = _crPos $ _creatures w IM.! n $ set (creatures . ix n . crPos) p3
p2 = collidePointWalls cp p1 $ wallsAlongLine cp p1 w $ blinkShockwave n p3
r = 1.5 * _crRad (_creatures w IM.! n) $ inverseShockwaveAt cp 40 2 2 2
p3 = fromMaybe p1 (fmap ((\p -> moveAmountToward p r cp) . fst) p2) 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 blinkShockwave
:: Int -- ^ Blinking creature ID. :: Int -- ^ Blinking creature ID.
@@ -230,19 +307,25 @@ blinkShockwave
-> World -> World
blinkShockwave i p = makeShockwaveAt [i] p 60 1 2 cyan 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 moveAmountToward p1 am p2
= p1 +.+ am *.* errorNormalizeV 44 (p2 -.- p1) = p1 +.+ am *.* errorNormalizeV 44 (p2 -.- p1)
facePointAI :: Point2 -> Int -> World -> World reverseDir
facePointAI p n w = set (creatures . ix n . crDir) :: Int -- ^ Creature id
(argV (p -.- _crPos (_creatures w IM.! n)) ) -> World
w -> World
reverseDir :: Int -> World -> World
reverseDir n = over (creatures . ix n . crDir) (+ pi) 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) 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 :: World -> World
youDropItem w = case yourItem w of youDropItem w = case yourItem w of
NoItem -> w NoItem -> w
it -> rmSelectedInvItem (_yourID w) $ over floorItems (IM.insert flid theflit) it -> rmSelectedInvItem (_yourID w)
$ updateLocation . copyItemToFloor (you w) (_crInvSel $ you w)
$ soundOnce putDownSound $ soundOnce putDownSound
$ set randGen g w 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}
{- Drop an item silently. -} {- Copy an inventory item to the floor. -}
dropItem copyItemToFloor
:: Int -- ^ Creature id :: Creature
-> Int -- ^ Inventory position -> Int -- ^ Inventory position
-> World -> World
-> World -> World
dropItem cid i w = case _crInv cr IM.! i of copyItemToFloor cr i w = case _crInv cr IM.! i of
NoItem -> w NoItem -> w
it -> rmInvItem cid i it -> over floorItems (IM.insert flid theflit)
. over floorItems (IM.insert flid theflit)
. updateLocation . updateLocation
$ set randGen g w $ set randGen g w
where where
(rot, g) = randomR (-pi,pi) $ _randGen w (rot, g) = randomR (-pi,pi) $ _randGen w
offset = _crRad cr *.* unitVectorAtAngle rot offset = (_crRad cr + 2) *.* unitVectorAtAngle rot
updateLocation w = case it ^? itID of updateLocation w = case it ^? itID of
Just (Just i) -> w & itemPositions . ix i .~ OnFloor flid Just (Just i) -> w & itemPositions . ix i .~ OnFloor flid
_ -> w _ -> w
flid = newKey $ _floorItems w flid = newKey $ _floorItems w
theflit = FlIt theflit = FlIt
{_flIt = set itAmount 1 it {_flIt = it
,_flItPos = offset +.+ _crPos cr ,_flItPos = offset +.+ _crPos cr
,_flItRot = rot ,_flItRot = rot
,_flItID = flid ,_flItID = flid
} }
where
cr = _creatures w IM.! cid
pickUpItem' :: FloorItem -> World -> World {- Pick up a specific item. -}
pickUpItem' flit w = case maybeInvSlot of pickUpItem :: FloorItem -> World -> World
pickUpItem flit w = case maybeInvSlot of
Nothing -> w Nothing -> w
Just i -> soundOnce pickUpSound Just i -> w
$ updateItLocation i & soundOnce pickUpSound
$ w & floorItems %~ IM.delete (_flItID flit) & updateItLocation i
& creatures . ix 0 . crInv . ix i %~ addItem it & floorItems %~ IM.delete (_flItID flit)
where & creatures . ix 0 . crInv . ix i %~ addItem it
it = _flIt flit where
maybeInvSlot = checkInvSlotsYou it w it = _flIt flit
updateItLocation invid w' maybeInvSlot = checkInvSlotsYou it w
= case _itID it of Nothing -> w' updateItLocation invid w' = case _itID it of
Just j -> w' & itemPositions . ix j .~ InInv 0 invid Nothing -> w'
Just j -> w' & itemPositions . ix j .~ InInv 0 invid
src/Dodge/Creature/Inanimate.hs
+2 -2
View File
@@ -22,8 +22,8 @@ lamp :: Creature
lamp = defaultInanimate lamp = defaultInanimate
{ _crUpdate = initialiseLamp { _crUpdate = initialiseLamp
, _crHP = 500 , _crHP = 500
, _crPict = \ _ -> onLayer CrLayer $ color white $ circleSolid 5 , _crPict = \ _ -> onLayer CrLayer $ color white $ circleSolid 3
, _crRad = 5 , _crRad = 3
} }
initialiseLamp :: CRUpdate initialiseLamp :: CRUpdate
src/Dodge/Creature/State.hs
-25
View File
@@ -67,31 +67,6 @@ dropByState cr w = foldr (copyItemToFloor cr) w is
DropSpecific xs -> xs DropSpecific xs -> xs
DropAmount n -> take n $ evalState (shuffle $ IM.keys $ _crInv cr) (_randGen w) 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 :: Creature -> Creature
setOldPos cr = set crOldPos (_crPos cr) cr setOldPos cr = set crOldPos (_crPos cr) cr
src/Dodge/Creature/YourControl.hs
+2 -2
View File
@@ -57,13 +57,13 @@ wasdWithAiming w speed aimSpeed i cr
= set (crState . stance . carriage) Floating = set (crState . stance . carriage) Floating
cr cr
| isAiming | isAiming
= stepForward' aimSpeed = stepForward aimSpeed
$ over crPos (+.+ (aimSpeed *.* mov)) $ over crPos (+.+ (aimSpeed *.* mov))
$ set crDir mouseDir $ set crDir mouseDir
$ set (crState . stance . carriage) (Walking 0 0) $ set (crState . stance . carriage) (Walking 0 0)
cr cr
| isMoving | isMoving
= stepForward' speed = stepForward speed
$ over ( crPos) (+.+ (speed *.* mov)) $ over ( crPos) (+.+ (speed *.* mov))
$ over ( crDir) (flip fromMaybe dir) $ over ( crDir) (flip fromMaybe dir)
$ set (crState . stance . carriage) (Walking 0 0) $ set (crState . stance . carriage) (Walking 0 0)
src/Dodge/Event/Keyboard.hs
+9 -17
View File
@@ -76,7 +76,7 @@ spaceAction w = if _carteDisplay w
w & carteCenter .~ theLoc w & carteCenter .~ theLoc
else else
case listToMaybe $ _closeActiveObjects w of 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 Just (Right but) -> updateTopCloseObject (_btID but) $ _btEvent but but w
Nothing -> w Nothing -> w
where where
@@ -90,22 +90,14 @@ toggleMap w = w & carteDisplay %~ not
escapeMap w = w & carteDisplay .~ False escapeMap w = w & carteDisplay .~ False
dropLight :: World -> World dropLight :: World -> World
dropLight w = placeLS ls dec pos 0 dropLight w = placeLS ls dec pos 0 w
-- $ over creatures IM.insert i (lamp) where --(rot, g) = randomR (-pi,pi) $ _randGen w
$ w i = newCrKey w -- to give different lights different keys
--case yourItem w of pos = _crPos(you w)
--NoItem -> w ls = lightAt pos 0
--it -> rmInvItem (_yourID w) $ over floorItems (IM.insert flid theflit) dec = onLayer PtLayer $ color white $ circleSolid 8
-- 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' :: World -> World dropLight' :: World -> World
dropLight' w = placeCr lamp pos 0 w dropLight' w = placeCr lamp pos 0 w
where where
pos = _crPos(you w) pos = _crPos(you w)
src/Dodge/Floor.hs
+3 -1
View File
@@ -42,6 +42,8 @@ roomTreex = do
t = treeFromTrunk t = treeFromTrunk
[[StartRoom] [[StartRoom]
,[Corridor] ,[Corridor]
,[SpecificRoom $ fmap (pure . Right) $ randomiseAllLinks =<< centerVaultRoom 1 200 200 50]
,[SpecificRoom blockedCorridor]
,[OrAno [[DoorAno] ,[OrAno [[DoorAno]
,[Corridor] ,[Corridor]
,[DoorNumAno 0,AirlockAno]] ,[DoorNumAno 0,AirlockAno]]
@@ -68,7 +70,7 @@ levx = untilJust roomTreex
lev1' :: RandomGen g => State g (Tree Room) lev1' :: RandomGen g => State g (Tree Room)
lev1' = do lev1' = do
firstWeapon <- takeOne $ [[branchRectWith weaponRoom,blockedCorridor]] ++ replicate 5 [weaponRoom] firstWeapon <- takeOne $ [[branchRectWith weaponRoom,longBlockedCorridor]] ++ replicate 5 [weaponRoom]
iterateWhile boundClip $ fmap (shiftRoomTree . expandTreeBy id) iterateWhile boundClip $ fmap (shiftRoomTree . expandTreeBy id)
$ sequence $ treeFromPost $ sequence $ treeFromPost
( (
src/Dodge/Layout/Tree/Annotate.hs
+2 -1
View File
@@ -9,6 +9,7 @@ import Dodge.Layout.Tree.Polymorphic
import Dodge.Layout.Tree.Either import Dodge.Layout.Tree.Either
import Dodge.Room.Procedural import Dodge.Room.Procedural
import Dodge.Room.Branch import Dodge.Room.Branch
import Dodge.Room.RoadBlock
import Dodge.Room.Door import Dodge.Room.Door
import Dodge.Room.Boss import Dodge.Room.Boss
import Dodge.Room.Treasure import Dodge.Room.Treasure
@@ -66,7 +67,7 @@ annoToRoomTree [DoorAno] = roomThenCorridor door
annoToRoomTree [DoorNumAno i,AirlockAno] = roomThenCorridor (airlock i) annoToRoomTree [DoorNumAno i,AirlockAno] = roomThenCorridor (airlock i)
annoToRoomTree [FirstWeapon] = do annoToRoomTree [FirstWeapon] = do
branchWP <- branchRectWith weaponRoom branchWP <- branchRectWith weaponRoom
blockedC <- blockedCorridor blockedC <- longBlockedCorridor
firstWeapon <- takeOne $ [return $ appendEitherTree branchWP [blockedC]] ++ replicate 5 weaponRoom firstWeapon <- takeOne $ [return $ appendEitherTree branchWP [blockedC]] ++ replicate 5 weaponRoom
firstWeapon firstWeapon
annoToRoomTree [EndRoom] = fmap (pure . Right) (telRoomLev 1) annoToRoomTree [EndRoom] = fmap (pure . Right) (telRoomLev 1)
src/Dodge/LevelGen/Pathing.hs
+4 -4
View File
@@ -23,7 +23,7 @@ removePathsCrossing :: Point2 -> Point2 -> World -> World
removePathsCrossing a b w = set pathGraph newGraph $ set pathGraph' pg' removePathsCrossing a b w = set pathGraph newGraph $ set pathGraph' pg'
$ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph)) $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
w w
where pg' = filter (not . isJust . uncurry (intersectSegSeg' a b)) $ _pathGraph' w where
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp] pg' = filter (isNothing . uncurry (intersectSegSeg' a b)) $ _pathGraph' w
newGraph = pairsToGraph dist pg' insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
newGraph = pairsToGraph dist pg'
src/Dodge/LevelGen/StaticWalls.hs
+11 -17
View File
@@ -35,26 +35,26 @@ nearCollinear (a,b) (x,y)
-- | Remove inverse walls. -- | Remove inverse walls.
removeInverseWalls :: [WallP] -> [WallP] removeInverseWalls :: [WallP] -> [WallP]
removeInverseWalls ((a,b):ps) removeInverseWalls ((a,b):ps)
| elem (b,a) ps = removeInverseWalls $ delete (b,a) ps | (b,a) `elem` ps = removeInverseWalls $ delete (b,a) ps
| otherwise = (a,b) : (removeInverseWalls ps) | otherwise = (a,b) : removeInverseWalls ps
removeInverseWalls ps = ps removeInverseWalls ps = ps
-- | Cut out a polygon from a set of walls, and check for errors in the -- | Cut out a polygon from a set of walls, and check for errors in the
-- created walls. -- created walls.
-- If created walls are not consistent, expand poly and retry. -- If created walls are not consistent, expand poly and retry.
cutWalls :: [Point2] -> [WallP] -> [WallP] cutWalls :: [Point2] -> [WallP] -> [WallP]
cutWalls ps wls = case mapMaybe (flip checkWallRight newWalls) newWalls of cutWalls ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
[] -> newWalls [] -> newWalls
_ -> cutWalls (expandPolyBy 0.01 ps) wls _ -> cutWalls (expandPolyBy 0.01 ps) wls
where where
newWalls = cutWalls' ps wls 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 -- | Cut out a polygon from a set of walls, and check for errors in the
-- created walls. -- created walls.
-- Give error if created walls are not consistent. -- Give error if created walls are not consistent.
cutWalls'' :: [Point2] -> [WallP] -> [WallP] cutWalls'' :: [Point2] -> [WallP] -> [WallP]
cutWalls'' ps wls = case mapMaybe (flip checkWallRight newWalls) newWalls of cutWalls'' ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
[] -> newWalls [] -> newWalls
errs -> error $ "during level generation function cutWalls: when cutting poly:\n" ++ show ps errs -> error $ "during level generation function cutWalls: when cutting poly:\n" ++ show ps
++ "\nRight corner errors:\n" ++ "\nRight corner errors:\n"
@@ -67,7 +67,7 @@ cutWalls'' ps wls = case mapMaybe (flip checkWallRight newWalls) newWalls of
++ unlines (map show newWalls) ++ unlines (map show newWalls)
where where
newWalls = cutWalls' ps wls 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 -- | 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 -- 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 :: Float -> [Point2] -> [Point2]
expandPolyBy x ps = map f ps expandPolyBy x ps = map f ps
where 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) f p = p +.+ x *.* (p -.- cp)
-- | Given a polygon expressed as a list of points and a collection of walls, -- | 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. -- | List the points of intersection between a segment and collection of walls.
cutWallsPoints :: Point2 -> Point2 -> [WallP] -> [Point2] cutWallsPoints :: Point2 -> Point2 -> [WallP] -> [Point2]
--cutWallsPoints p1 p2 ws = mapMaybe (\(x:y:_) -> intersectExtendedSegSeg p1 p2 x y) --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. -- | Given a segment and a wall, split the wall into two if it crosses the segment.
cutWall :: Point2 -> Point2 -> WallP -> [WallP] cutWall :: Point2 -> Point2 -> WallP -> [WallP]
@@ -171,9 +171,7 @@ addPolyWall (p1,p2) walls =
where where
p3 = 0.5 *.* (p1 +.+ p2) p3 = 0.5 *.* (p1 +.+ p2)
p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1) p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
maybeWs = -- listToMaybe . maybeWs = fmap (map fst)
fmap (fst . unzip)
-- . fmap unzip
. listToMaybe . listToMaybe
$ groupBy ((==) `on` (dist p3 . snd)) $ groupBy ((==) `on` (dist p3 . snd))
wlsP wlsP
@@ -224,10 +222,6 @@ wallIsZeroLength (x,y) = x == y
-- | Given a polygon and list of walls, removes walls inside the polygon. -- | Given a polygon and list of walls, removes walls inside the polygon.
removeWallsInPolygon :: [Point2] -> [WallP] -> [WallP] removeWallsInPolygon :: [Point2] -> [WallP] -> [WallP]
removeWallsInPolygon ps walls = filter (not . cond) walls removeWallsInPolygon ps = filter (not . cond)
where where
cond wall = cond wall = pointInOrOnPolygon (0.5 *.* uncurry (+.+) wall) ps
pointInOrOnPolygon (0.5 *.* (fst wall +.+ snd wall)) ps
-- pointInOrOnPolygon (fst wall) ps
-- && pointInOrOnPolygon (snd wall) ps
src/Dodge/LevelGen/Switch.hs
+31 -27
View File
@@ -29,10 +29,14 @@ makeButton c eff = Button
, _btState = BtOff , _btState = BtOff
} }
where 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)) 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 makeSwitch c effOn effOff = Button
{ _btPict = offPict { _btPict = offPict
, _btPos = (0,0) , _btPos = (0,0)
@@ -42,28 +46,28 @@ makeSwitch c effOn effOff = Button
, _btText = "SWITCH/" , _btText = "SWITCH/"
, _btState = BtOff , _btState = BtOff
} }
where where
flipSwitch b w = switchEffect b . soundOnce 1 $ w flipSwitch b w = switchEffect b . soundOnce 1 $ w
switchEffect b = case _btState b of switchEffect b = case _btState b of
BtOff -> effOn . over buttons (IM.adjust turnOn (_btID b)) BtOff -> effOn . over buttons (IM.adjust turnOn (_btID b))
BtOn -> effOff . over buttons (IM.adjust turnOff (_btID b)) BtOn -> effOff . over buttons (IM.adjust turnOff (_btID b))
offPict = onLayer WlLayer $ color c $ pictures [--translate (-8) 4 $ circleSolid 5 offPict = onLayer WlLayer $ color c $ pictures [--translate (-8) 4 $ circleSolid 5
polygon $ rectNSEW (-2) (-5) (-10) (10) polygon $ rectNSEW (-2) (-5) (-10) 10
,polygon [(-2,-5),(-10,4),(-6,4),(2,-5)] ,polygon [(-2,-5),(-10,4),(-6,4),(2,-5)]
] ]
onPict = onLayer WlLayer $ color c $ pictures [--translate (8) 4 $ circleSolid 5 onPict = onLayer WlLayer $ color c $ pictures [--translate (8) 4 $ circleSolid 5
polygon $ rectNSEW (-2) (-5) (-10) (10) polygon $ rectNSEW (-2) (-5) (-10) 10
,polygon [(-2,-5), (6,4),( 10,4),(2,-5)] ,polygon [(-2,-5), (6,4),( 10,4),(2,-5)]
] ]
turnOn :: Button -> Button turnOn :: Button -> Button
turnOn bt = bt turnOn bt = bt
{ _btState = BtOn { _btState = BtOn
, _btPict = onPict , _btPict = onPict
, _btText = "SWITCH\\" , _btText = "SWITCH\\"
} }
turnOff :: Button -> Button turnOff :: Button -> Button
turnOff bt = bt turnOff bt = bt
{ _btState = BtOff { _btState = BtOff
, _btPict = offPict , _btPict = offPict
, _btText = "SWITCH/" , _btText = "SWITCH/"
} }
src/Dodge/LevelGen/TriggerDoor.hs
+7 -7
View File
@@ -88,7 +88,7 @@ mkTriggerDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPane c cond)
] ]
shiftRight = map (+.+ (0.5 *.* (pr -.- pl))) shiftRight = map (+.+ (0.5 *.* (pr -.- pl)))
shiftLeft = map (+.+ (0.5 *.* (pl -.- pr))) 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) hw = 0.5 *.* (pl +.+ pr)
perp = 5 *.* normalizeV (pl -.- pr) perp = 5 *.* normalizeV (pl -.- pr)
plu = pl +.+ norm plu = pl +.+ norm
@@ -99,12 +99,12 @@ mkTriggerDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPane c cond)
hwd = hw -.- norm hwd = hw -.- norm
addSound (x:xs) = f x : xs addSound (x:xs) = f x : xs
f wl = over doorMech g wl f wl = over doorMech g wl
g dm w | dist wp pld > 2 && dist wp hwd > 2 g dm w
= soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0 | dist wp pld > 2 && dist wp hwd > 2
$ dm w = soundFrom (WallSound (head xs)) (fromIntegral doorSound) 1 0 $ dm w
| otherwise = dm w | otherwise = dm w
where where
wp = _wlLine (_walls w IM.! (head xs)) !! 1 wp = _wlLine (_walls w IM.! head xs) !! 1
triggerDoorPane :: Color -> (World -> Bool) -> Int -> [Point2] -> [Point2] -> Wall triggerDoorPane :: Color -> (World -> Bool) -> Int -> [Point2] -> [Point2] -> Wall
triggerDoorPane c cond n closedPos openPos = Door triggerDoorPane c cond n closedPos openPos = Door
src/Dodge/Render/Picture.hs
+1 -1
View File
@@ -210,7 +210,7 @@ wallsForShadows w = map (linePairs . _wlLine)
. IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w . IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
where linePairs (x:y:_) = (x,y) where linePairs (x:y:_) = (x,y)
lightsForGloom' :: World -> [(Point4)] lightsForGloom' :: World -> [Point4]
lightsForGloom' w = map getLS (IM.elems $ _lightSources w) ++ map getTLS (_tempLightSources w) 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) 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) getTLS ls = ( fst $ _tlsPos ls,snd $ _tlsPos ls, _tlsRad ls, _tlsIntensity ls)
src/Dodge/Room.hs
+13 -19
View File
@@ -65,7 +65,10 @@ airlockOneWay n = Room
] ]
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w) cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
col = dim $ dim $ bright red col = dim $ dim $ bright red
airlock :: Int -> Room
airlock
:: Int -- ^ Door id
-> Room
airlock n = Room airlock n = Room
{ _rmPolys = { _rmPolys =
[ rectNSWE 100 0 0 40 [ rectNSWE 100 0 0 40
@@ -85,11 +88,13 @@ airlock n = Room
] ]
, _rmBound = rectNSWE 75 15 0 40 , _rmBound = rectNSWE 75 15 0 40
} }
where lnks = [((20,85),0) where
,((20, 5),pi) lnks = [((20,85),0)
] ,((20, 5),pi)
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w) ]
col = dim $ dim $ bright red cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
col = dim $ dim $ bright red
roomC :: Float -> Float -> Room roomC :: Float -> Float -> Room
roomC x y = Room roomC x y = Room
{ _rmPolys = [rectNSWE y 0 0 x] { _rmPolys = [rectNSWE y 0 0 x]
@@ -312,8 +317,8 @@ randFirstWeapon = do
++ replicate 5 multGun ++ replicate 5 multGun
++ replicate 2 autoGun ++ replicate 2 autoGun
++ [launcher] ++ [launcher]
++ [lasGun] -- ++ [lasGun]
++ [flamer] -- ++ [flamer]
--randC1 :: State StdGen PSType --randC1 :: State StdGen PSType
randC1 = RandPS $ takeOne $ map PutCrit $ (armourChaseCrit : replicate 50 chaseCrit) randC1 = RandPS $ takeOne $ map PutCrit $ (armourChaseCrit : replicate 50 chaseCrit)
@@ -381,17 +386,6 @@ weaponBetweenPillars = do
(fmap connectRoom . randomiseOutLinks) =<< (filterLinks f $ over rmPS (++plmnts) $ roomPillars) (fmap connectRoom . randomiseOutLinks) =<< (filterLinks f $ over rmPS (++plmnts) $ roomPillars)
where f (_,a) = a == 0 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 :: RandomGen g => State g (Tree (Either Room Room))
weaponLongCorridor = do weaponLongCorridor = do
root <- takeOne $ [tEast, tWest] root <- takeOne $ [tEast, tWest]
src/Dodge/Room/Procedural.hs
+51 -2
View File
@@ -1,10 +1,11 @@
{- {-
Procedural creation of rooms. Procedural creation of rooms and subroom parts.
-} -}
module Dodge.Room.Procedural module Dodge.Room.Procedural
( roomRect ( roomRect
, roomRectAutoLinks , roomRectAutoLinks
, testRoom , testRoom
, centerVaultRoom
) where ) where
import Dodge.Data import Dodge.Data
import Dodge.Room.Data import Dodge.Room.Data
@@ -18,9 +19,11 @@ import Dodge.LevelGen.Data
import Dodge.Creature import Dodge.Creature
import Dodge.Default import Dodge.Default
import Geometry import Geometry
import Picture
import Data.List (nub,nubBy,sortBy,minimumBy) import Data.List (nub,nubBy,sortBy,minimumBy)
import Data.Function (on) import Data.Function (on)
import qualified Data.Map as M
import Control.Lens import Control.Lens
import Control.Monad import Control.Monad
import Control.Monad.State import Control.Monad.State
@@ -220,9 +223,55 @@ testRoom = do
nCrits <- state $ randomR (1,3) nCrits <- state $ randomR (1,3)
crits <- takeN nCrits $ fmap PutCrit $ [spreadGunCrit,pistolCrit,autoCrit,armourChaseCrit] crits <- takeN nCrits $ fmap PutCrit $ [spreadGunCrit,pistolCrit,autoCrit,armourChaseCrit]
++ replicate 20 chaseCrit ++ replicate 20 chaseCrit
randomiseAllLinks . (fillNothingPlacements $ crits ++ itms) =<< randomiseAllLinks . fillNothingPlacements (crits ++ itms) =<<
( shufflePlacements ( shufflePlacements
. foldr1 combineRooms . foldr1 combineRooms
$ zipWith (\r a -> shiftRoomBy ((0,0),a) r) corners [0,pi/2,pi,3*pi/2] $ 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)
src/Dodge/Room/RoadBlock.hs
+30
View File
@@ -7,12 +7,15 @@ import Geometry
import Dodge.Room.Data import Dodge.Room.Data
import Dodge.Room.Link import Dodge.Room.Link
import Dodge.Room.Placement import Dodge.Room.Placement
import Dodge.Room.Corridor
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
import Dodge.RandomHelp import Dodge.RandomHelp
import Dodge.Creature import Dodge.Creature
import Dodge.Layout.Tree.Polymorphic
import Data.Tree import Data.Tree
import Control.Monad.State import Control.Monad.State
import Control.Lens
import System.Random import System.Random
armouredCorridor :: RandomGen g => State g Room armouredCorridor :: RandomGen g => State g Room
@@ -46,3 +49,30 @@ litCorridor90 = do
] ]
, _rmBound = poly , _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
src/Dodge/Room/Teleport.hs
+1 -1
View File
@@ -28,7 +28,7 @@ telRoomLev i = do
h <- state $ randomR (200,300) h <- state $ randomR (200,300)
return $ roomRectAutoLinks w h & rmPS .~ return $ roomRectAutoLinks w h & rmPS .~
[ PS (w/2,h/2) 0 $ PutPressPlate telPP [ 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 where
telPP = PressPlate telPP = PressPlate
src/Dodge/Update.hs
+23 -21
View File
@@ -118,11 +118,11 @@ ppEvents w = IM.foldr (\pp w -> _ppEvent pp pp w) w $ _pressPlates w
updateSeenWalls :: World -> World updateSeenWalls :: World -> World
updateSeenWalls w = foldr markSeen w wallsToUpdate updateSeenWalls w = foldr markSeen w wallsToUpdate
where yPos = _crPos $ _creatures w IM.! 0 where
-- wallsToUpdate = map _wlID $ IM.elems $ wallsNearPoint yPos w vPos = _cameraViewFrom w
wallsToUpdate = concatMap (\p -> collidePointFindWalls yPos (yPos +.+p) $ wallsAlongLine yPos (yPos +.+ p) w) wallsToUpdate = concatMap (\p -> visibleWalls vPos (vPos +.+p) $ wallsAlongLine vPos (vPos +.+ p) w)
$ nRays 60 $ nRays 20
markSeen i = set (walls . ix i . wlSeen) True markSeen i = set (walls . ix i . wlSeen) True
setTestStringIO :: IO World -> IO World setTestStringIO :: IO World -> IO World
setTestStringIO = fmap (\ w -> set testString (show $ s w) w) 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 overlap2 = ((comRad - diff) * _crMass c1 * 0.5 / massT) *.* errorNormalizeV 56 vec
massT = _crMass c1 + _crMass c2 massT = _crMass c1 + _crMass c2
collidePointFindWall :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe Int {-
collidePointFindWall p1 p2 ws = fmap fst $ listToMaybe $ sortBy f Finds the IDs of visible walls from a point to another point.
$ IM.toList -}
$ IM.mapMaybe ((\(x:y:_) -> intersectSegSeg' p1 p2 x y) . _wlLine) ws visibleWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Int]
where f (_,a) (_,b) = compare (magV (p1 -.- a)) (magV (p1 -.- b)) visibleWalls p1 p2 ws
= map fst
collidePointFindWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Int] . takeUntil (_wlIsSeeThrough . snd)
collidePointFindWalls p1 p2 ws . map snd
-- = map fst . takeWhileAnd g . map snd . sortBy (compare `on` (dist p1 . fst . fromJust)) . filter ((/=) Nothing . fst) . map f $ IM.toList ws . sortOn (dist p1 . fromJust . fst)
= map fst . takeWhileAnd g . map snd . sortBy (compare `on` (dist p1 . fromJust . fst)) . filter ((/=) Nothing . fst) . map f $ IM.toList ws . filter ((/=) Nothing . fst)
where f (i,wl) = (intersectSegSeg' (_wlLine wl !! 0) (_wlLine wl !! 1) p1 p2, (i,wl)) . map f
g (_,wl) = _wlIsSeeThrough wl $ IM.toList ws
takeWhileAnd h xs = let (ys,zs) = span h xs where
in ys ++ tf zs f (i,wl) = (intersectSegSeg' (_wlLine wl !! 0) (_wlLine wl !! 1) p1 p2, (i,wl))
where tf (x:_) = [x] takeUntil h xs = let (ys,zs) = span h xs
tf _ = [] in ys ++ tf zs
where tf (x:_) = [x]
tf _ = []
src/Geometry.hs
+17
View File
@@ -68,6 +68,11 @@ rectNSEW !n !s !e !w = rectNESW n e s w
rectNSWE :: Float -> Float -> Float -> Float -> [Point2] rectNSWE :: Float -> Float -> Float -> Float -> [Point2]
rectNSWE !n !s !w !e = [ (w,n), (w,s), (e,s), (e,n)] 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. -- | Test whether a point is in a polygon or on the polygon border.
-- Supposes the points in the -- Supposes the points in the
-- polygon are listed in anticlockwise order. -- 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 -- | Given two pairs of Ints, returns a list of pairs of Ints that form
-- a digital line between them. -- a digital line between them.
digitalLine :: (Int,Int) -> (Int,Int) -> [(Int,Int)] digitalLine :: (Int,Int) -> (Int,Int) -> [(Int,Int)]
{-# INLINE digitalLine #-}
digitalLine (x1,y1) (x2,y2) digitalLine (x1,y1) (x2,y2)
| abs (x1-x2) > abs (y1-y2) = [ (x,( (y1-y2) * x + x1*y2 - x2*y1) `rdiv` (x1-x2) ) | abs (x1-x2) > abs (y1-y2) = [ (x,( (y1-y2) * x + x1*y2 - x2*y1) `rdiv` (x1-x2) )
| x <- intervalList x1 x2 ] | x <- intervalList x1 x2 ]
@@ -431,6 +437,17 @@ digitalLine (x1,y1) (x2,y2)
where where
rdiv a b = round $ fromIntegral a / fromIntegral b 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. -- | Given two Ints, creates the list of Ints between these.
intervalList :: Int -> Int -> [Int] intervalList :: Int -> Int -> [Int]
intervalList x y intervalList x y