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

Merge branch 'master' into testing

Browse Source
This commit is contained in:
Ross
2021-03-29 23:28:27 +01:00
parent c722b6f38f b709aad2a6
commit e264857831
18 changed files with 649 additions and 596 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Creature/Inanimate.hs
+5 -3
View File
@@ -15,8 +15,10 @@ import Picture
import qualified Data.IntMap.Strict as IM import qualified Data.IntMap.Strict as IM
import Control.Lens import Control.Lens
defaultInanimate = defaultCreature & crIsAnimate .~ False
lamp :: Creature lamp :: Creature
lamp = defaultCreature lamp = defaultInanimate
{ _crUpdate = initialiseLamp { _crUpdate = initialiseLamp
, _crHP = 500 , _crHP = 500
, _crPict = \ _ -> onLayer CrLayer $ color white $ circleSolid 10 , _crPict = \ _ -> onLayer CrLayer $ color white $ circleSolid 10
@@ -40,7 +42,7 @@ updateLamp i = unrandUpdate handleLS internalUpdate
barrel :: Creature barrel :: Creature
barrel = defaultCreature barrel = defaultInanimate
{ _crUpdate = updateBarrel { _crUpdate = updateBarrel
, _crHP = 500 , _crHP = 500
, _crPict = \ _ -> onLayer CrLayer $ pictures , _crPict = \ _ -> onLayer CrLayer $ pictures
@@ -56,7 +58,7 @@ barrel = defaultCreature
} }
explosiveBarrel :: Creature explosiveBarrel :: Creature
explosiveBarrel = defaultCreature explosiveBarrel = defaultInanimate
{ _crUpdate = updateExpBarrel { _crUpdate = updateExpBarrel
, _crHP = 400 , _crHP = 400
, _crPict = \ _ -> onLayer CrLayer $ pictures [ color orange $ circleSolid 10 , _crPict = \ _ -> onLayer CrLayer $ pictures [ color orange $ circleSolid 10
src/Dodge/Creature/LookupStatus.hs
-14
View File
@@ -1,14 +0,0 @@
module Dodge.Creature.LookupStatus
where
import Dodge.Data
import Geometry
import Control.Lens
isArmouredFrom :: Point2 -> Creature -> Bool
isArmouredFrom p cr
= p /= _crPos cr
&& any (\it -> it ^? itIdentity == Just FrontArmour) (_crInv cr)
&& angleVV (unitVectorAtAngle $ _crDir cr) (p -.- _crPos cr) < pi/2
-- even though angleVV can generate NaN, the comparison seems to deal with it
src/Dodge/Creature/Property.hs
+20
View File
@@ -0,0 +1,20 @@
module Dodge.Creature.Property
where
import Dodge.Data
import Geometry
import Control.Lens
crIsArmouredFrom :: Point2 -> Creature -> Bool
crIsArmouredFrom p cr
= p /= _crPos cr
&& any (\it -> it ^? itIdentity == Just FrontArmour) (_crInv cr)
&& angleVV (unitVectorAtAngle $ _crDir cr) (p -.- _crPos cr) < pi/2
-- even though angleVV can generate NaN, the comparison seems to deal with it
crOnSeg :: Point2 -> Point2 -> Creature -> Bool
crOnSeg p1 p2 cr = circOnLine p1 p2 (_crPos cr) (_crRad cr)
crNearSeg :: Float -> Point2 -> Point2 -> Creature -> Bool
crNearSeg d p1 p2 cr = circOnLine p1 p2 (_crPos cr) (_crRad cr + d)
src/Dodge/Data.hs
+33 -28
View File
@@ -127,21 +127,26 @@ data TempLightSource = TLS
} }
data Creature = Creature data Creature = Creature
{ _crPos :: Point2 { _crPos :: Point2
, _crOldPos :: Point2 , _crOldPos :: Point2
, _crDir :: Float , _crVel :: Point2
, _crID :: Int , _crDir :: Float
, _crPict :: Creature -> Picture , _crID :: Int
, _crUpdate :: World -> (World -> World,StdGen) -> Creature , _crPict :: Creature -> Picture
-> ((World -> World,StdGen), Maybe Creature) , _crUpdate
, _crRad :: Float :: World
, _crMass :: Float -> (World -> World,StdGen)
, _crHP :: Int -> Creature
, _crMaxHP :: Int -> ((World -> World,StdGen), Maybe Creature)
, _crInv :: IM.IntMap Item , _crRad :: Float
, _crInvSel :: Int , _crMass :: Float
, _crState :: CreatureState , _crHP :: Int
, _crCorpse :: Picture , _crMaxHP :: Int
, _crInv :: IM.IntMap Item
, _crInvSel :: Int
, _crState :: CreatureState
, _crCorpse :: Picture
, _crIsAnimate :: Bool
} }
data CreatureState = CrSt data CreatureState = CrSt
@@ -480,21 +485,21 @@ type HitEffect = Particle' -> [(Point2, (Either3 Creature Wall ForceField))] ->
data Projectile data Projectile
= Projectile = Projectile
{ _ptPos :: Point2 { _pjPos :: Point2
, _ptStartPos :: Point2 , _pjStartPos :: Point2
, _ptVel :: Point2 , _pjVel :: Point2
, _ptPict :: Picture , _pjPict :: Picture
, _ptID :: Int , _pjID :: Int
, _ptUpdate :: World -> World , _pjUpdate :: World -> World
} }
| Shell | Shell
{ _ptPos :: Point2 { _pjPos :: Point2
, _ptStartPos :: Point2 , _pjStartPos :: Point2
, _ptVel :: Point2 , _pjVel :: Point2
, _ptPict :: Picture , _pjPict :: Picture
, _ptID :: Int , _pjID :: Int
, _ptUpdate :: World -> World , _pjUpdate :: World -> World
, _ptExplosion :: Point2-> World -> World , _pjPayload :: Point2-> World -> World
} }
data DamageType data DamageType
src/Dodge/Debug.hs
+36 -33
View File
@@ -12,39 +12,42 @@ import Control.Lens
import qualified Data.IntMap.Strict as IM import qualified Data.IntMap.Strict as IM
drawCircleAtFor :: Point2 -> Int -> World -> World drawCircleAtFor :: Point2 -> Int -> World -> World
drawCircleAtFor p t w = drawCircleAtFor p t w = w & projectiles %~
let n = newProjectileKey w IM.insert k Projectile
in over projectiles ( IM.insert n { _pjPos = p
Projectile { _ptPos = p , _pjStartPos = p
, _ptStartPos = p , _pjVel = (0,0)
, _ptVel = (0,0) , _pjPict = onLayer PtLayer $ uncurry translate p $ color white $ circleSolid 20
, _ptPict = onLayer PtLayer $ uncurry translate p $ color white $ circleSolid 20 , _pjID = k
, _ptID = n , _pjUpdate = pjTimer t k
, _ptUpdate = ptTimer t n }
} ) w where
k = newKey $ _projectiles w
drawCircleAtForCol :: Point2 -> Int -> Color -> World -> World drawCircleAtForCol :: Point2 -> Int -> Color -> World -> World
drawCircleAtForCol p t col w = drawCircleAtForCol p t col w = w & projectiles %~
let n = newProjectileKey w IM.insert k Projectile
in over projectiles ( IM.insert n { _pjPos = p
Projectile { _ptPos = p , _pjStartPos = p
, _ptStartPos = p , _pjVel = (0,0)
, _ptVel = (0,0) , _pjPict = onLayer PtLayer $ uncurry translate p $ color col $ circleSolid 20
, _ptPict = onLayer PtLayer $ uncurry translate p $ color col $ circleSolid 20 , _pjID = k
, _ptID = n , _pjUpdate = pjTimer t k
, _ptUpdate = ptTimer t n }
} ) w where
k = newKey $ _projectiles w
drawLineForCol :: [Point2] -> Int -> Color -> World -> World drawLineForCol :: [Point2] -> Int -> Color -> World -> World
drawLineForCol ps t col w = drawLineForCol ps t col w = w & projectiles %~
let n = newProjectileKey w IM.insert k Projectile
in over projectiles ( IM.insert n { _pjPos = head ps
Projectile { _ptPos = head ps , _pjStartPos = head ps
, _ptStartPos = head ps , _pjVel = (0,0)
, _ptVel = (0,0) , _pjPict = onLayer PtLayer $ color col $ lineOfThickness 5 ps
, _ptPict = onLayer PtLayer $ color col $ lineOfThickness 5 ps , _pjID = k
, _ptID = n , _pjUpdate = pjTimer t k
, _ptUpdate = ptTimer t n }
} ) w where
k = newKey $ _projectiles w
ptTimer :: Int -> Int -> World -> World pjTimer :: Int -> Int -> World -> World
ptTimer 0 i = over projectiles (IM.delete i) pjTimer 0 i = projectiles %~ IM.delete i
ptTimer time i = set (projectiles . ix i . ptUpdate) $ ptTimer (time - 1) i pjTimer time i = projectiles . ix i . pjUpdate .~ pjTimer (time - 1) i
src/Dodge/Default.hs
+18 -16
View File
@@ -50,20 +50,22 @@ defaultDoor = Door { _wlLine = [(0,0),(50,0)]
} }
defaultCreature :: Creature defaultCreature :: Creature
defaultCreature = Creature defaultCreature = Creature
{ _crPos = (0,0) { _crPos = (0,0)
, _crOldPos = (0,0) , _crOldPos = (0,0)
, _crDir = 0 , _crVel = (0,0)
, _crID = 1 , _crDir = 0
, _crPict = const $ onLayer CrLayer $ circleSolid 10 , _crID = 1
, _crPict = const $ onLayer CrLayer $ circleSolid 10
, _crUpdate = \ w f cr -> (f , Just cr) , _crUpdate = \ w f cr -> (f , Just cr)
, _crRad = 10 , _crRad = 10
, _crMass = 10 , _crMass = 10
, _crHP = 100 , _crHP = 100
, _crMaxHP = 150 , _crMaxHP = 150
, _crInv = IM.empty , _crInv = IM.empty
, _crInvSel = 0 , _crInvSel = 0
, _crState = defaultState , _crState = defaultState
, _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ circleSolid 10 , _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ circleSolid 10
, _crIsAnimate = True
} }
defaultState = CrSt { _goals = [] defaultState = CrSt { _goals = []
, _stance = Stance {_carriage=Walking 0 0,_posture=AtEase} , _stance = Stance {_carriage=Walking 0 0,_posture=AtEase}
@@ -161,12 +163,12 @@ defaultButton = Button
, _btState = BtOff , _btState = BtOff
} }
defaultPT = Projectile defaultPT = Projectile
{ _ptPos = (0,0) { _pjPos = (0,0)
, _ptStartPos = (0,0) , _pjStartPos = (0,0)
, _ptVel = (0,0) , _pjVel = (0,0)
, _ptPict = blank , _pjPict = blank
, _ptID = 0 , _pjID = 0
, _ptUpdate = id , _pjUpdate = id
} }
defaultPP = PressPlate defaultPP = PressPlate
{ _ppPict = onLayer PressPlateLayer $ color (dim $ dim $ bright $ blue) $ circleSolid 5 { _ppPict = onLayer PressPlateLayer $ color (dim $ dim $ bright $ blue) $ circleSolid 5
src/Dodge/Item/Weapon.hs
+282 -301
View File
@@ -732,121 +732,121 @@ aRocket = aRocket' makeShellAt
makeShellAt :: Int -> Int -> Point2 -> Float -> Projectile makeShellAt :: Int -> Int -> Point2 -> Float -> Projectile
makeShellAt i cid pos dir = Shell makeShellAt i cid pos dir = Shell
{ _ptPos = pos { _pjPos = pos
, _ptStartPos = pos , _pjStartPos = pos
, _ptVel = rotateV dir (1,0) , _pjVel = rotateV dir (1,0)
, _ptPict = blank -- onLayer PtLayer $ uncurry translate pos $ rotate (radToDeg dir) shellPic , _pjPict = blank -- onLayer PtLayer $ uncurry translate pos $ rotate (radToDeg dir) shellPic
, _ptID = i , _pjID = i
, _ptUpdate = moveShell 50 i cid 0 (rotateV dir (2,0)) , _pjUpdate = moveShell 50 i cid 0 (rotateV dir (2,0))
, _ptExplosion = shellExplosionAt , _pjPayload = shellExplosionAt
} }
makeFlameShellAt :: Int -> Int -> Point2 -> Float -> Projectile makeFlameShellAt :: Int -> Int -> Point2 -> Float -> Projectile
makeFlameShellAt i cid pos dir = Shell makeFlameShellAt i cid pos dir = Shell
{ _ptPos = pos { _pjPos = pos
, _ptStartPos = pos , _pjStartPos = pos
, _ptVel = rotateV dir (1,0) , _pjVel = rotateV dir (1,0)
, _ptPict = blank -- onLayer PtLayer $ uncurry translate pos $ rotate (radToDeg dir) shellPic , _pjPict = blank -- onLayer PtLayer $ uncurry translate pos $ rotate (radToDeg dir) shellPic
, _ptID = i , _pjID = i
, _ptUpdate = moveShell 50 i cid 0 (rotateV dir (2,0)) , _pjUpdate = moveShell 50 i cid 0 (rotateV dir (2,0))
, _ptExplosion = makeFlameExplosionAt , _pjPayload = makeFlameExplosionAt
} }
makePoisonShellAt :: Int -> Int -> Point2 -> Float -> Projectile makePoisonShellAt :: Int -> Int -> Point2 -> Float -> Projectile
makePoisonShellAt i cid pos dir = Shell makePoisonShellAt i cid pos dir = Shell
{ _ptPos = pos { _pjPos = pos
, _ptStartPos = pos , _pjStartPos = pos
, _ptVel = rotateV dir (1,0) , _pjVel = rotateV dir (1,0)
, _ptPict = blank -- onLayer PtLayer $ uncurry translate pos $ rotate (radToDeg dir) shellPic , _pjPict = blank -- onLayer PtLayer $ uncurry translate pos $ rotate (radToDeg dir) shellPic
, _ptID = i , _pjID = i
, _ptUpdate = moveShell 50 i cid 0 (rotateV dir (2,0)) , _pjUpdate = moveShell 50 i cid 0 (rotateV dir (2,0))
, _ptExplosion = makePoisonExplosionAt , _pjPayload = makePoisonExplosionAt
} }
makeTeslaShellAt :: Int -> Int -> Point2 -> Float -> Projectile makeTeslaShellAt :: Int -> Int -> Point2 -> Float -> Projectile
makeTeslaShellAt i cid pos dir = Shell makeTeslaShellAt i cid pos dir = Shell
{ _ptPos = pos { _pjPos = pos
, _ptStartPos = pos , _pjStartPos = pos
, _ptVel = rotateV dir (1,0) , _pjVel = rotateV dir (1,0)
, _ptPict = blank -- onLayer PtLayer $ uncurry translate pos $ rotate (radToDeg dir) shellPic , _pjPict = blank -- onLayer PtLayer $ uncurry translate pos $ rotate (radToDeg dir) shellPic
, _ptID = i , _pjID = i
, _ptUpdate = moveShell 50 i cid 0 (rotateV dir (2,0)) , _pjUpdate = moveShell 50 i cid 0 (rotateV dir (2,0))
, _ptExplosion = makeTeslaExplosionAt , _pjPayload = makeTeslaExplosionAt
} }
moveShell :: Int -> Int -> Int -> Float -> Point2 -> World -> World moveShell :: Int -> Int -> Int -> Float -> Point2 -> World -> World
moveShell time i cid rot accel w moveShell time i cid rot accel w
| time > 40 = if circOnSomeWall oldPos 4 w | time > 40 = if circOnSomeWall oldPos 4 w
then projectileExplosion oldPos $ over projectiles (IM.delete i) w then projectileExplosion oldPos $ over projectiles (IM.delete i) w
else over (projectiles . ix i . ptPos) (+.+ vel) else over (projectiles . ix i . pjPos) (+.+ vel)
$ set (projectiles . ix i . ptPict) piclow $ set (projectiles . ix i . pjPict) piclow
$ set (projectiles . ix i . ptUpdate) $ set (projectiles . ix i . pjUpdate)
(moveShell (time-1) i cid rot (rotateV rot accel)) (moveShell (time-1) i cid rot (rotateV rot accel))
w w
| time == 35 = case thingHit of | time == 35 = case thingHit of
Just p -> projectileExplosion oldPos Just p -> projectileExplosion oldPos
$ over projectiles (IM.delete i) w $ over projectiles (IM.delete i) w
Nothing -> over (projectiles . ix i . ptPos) (+.+ vel) Nothing -> over (projectiles . ix i . pjPos) (+.+ vel)
$ set (projectiles . ix i . ptPict) pic $ set (projectiles . ix i . pjPict) pic
$ set (projectiles . ix i . ptUpdate) $ set (projectiles . ix i . pjUpdate)
(moveShell (time-1) i cid spin accel) (moveShell (time-1) i cid spin accel)
w w
| time >= 20 = case thingHit of | time >= 20 = case thingHit of
Just p -> projectileExplosion oldPos Just p -> projectileExplosion oldPos
$ over projectiles (IM.delete i) w $ over projectiles (IM.delete i) w
Nothing -> over (projectiles . ix i . ptPos) (+.+ vel) Nothing -> over (projectiles . ix i . pjPos) (+.+ vel)
$ set (projectiles . ix i . ptPict) pic $ set (projectiles . ix i . pjPict) pic
$ set (projectiles . ix i . ptUpdate) $ set (projectiles . ix i . pjUpdate)
(moveShell (time-1) i cid rot (rotateV rot accel)) (moveShell (time-1) i cid rot (rotateV rot accel))
w w
| time > -99 | time > -99 = case thingHit of
= case thingHit of Just p -> projectileExplosion oldPos
Just p -> projectileExplosion oldPos $ stopSoundFrom (ShellSound i)
$ stopSoundFrom (ShellSound i) $ over projectiles (IM.delete i) w
$ over projectiles (IM.delete i) w Nothing -> over (projectiles . ix i . pjPos) (+.+ vel)
Nothing -> over (projectiles . ix i . ptPos) (+.+ vel) $ set randGen g
$ set randGen g $ set (projectiles . ix i . pjPict) pic
$ set (projectiles . ix i . ptPict) pic $ set (projectiles . ix i . pjUpdate)
$ set (projectiles . ix i . ptUpdate) (moveShell (time-1) i cid rot (rotateV rot accel))
(moveShell (time-1) i cid rot (rotateV rot accel)) $ over (projectiles . ix i . pjVel) (\v -> accel +.+ frict *.* v)
$ over (projectiles . ix i . ptVel) (\v -> accel +.+ frict *.* v) $ soundFrom (ShellSound i) (fromIntegral smokeTrailSound) (1) 250
$ soundFrom (ShellSound i) (fromIntegral smokeTrailSound) (1) 250 $ makeFlameletTimed oldPos
$ makeFlameletTimed oldPos (0.5 *.* rotateV (pi+sparkD) accel) Nothing 3 10
(0.5 *.* rotateV (pi+sparkD) accel) Nothing 3 10 $ smokeGen
$ smokeGen w
w
| time > -200 = case thingHit of | time > -200 = case thingHit of
Just p -> projectileExplosion oldPos Just p -> projectileExplosion oldPos
$ stopSoundFrom (ShellSound i) $ stopSoundFrom (ShellSound i)
$ over projectiles (IM.delete i) w $ over projectiles (IM.delete i) w
Nothing -> over (projectiles . ix i . ptPos) (+.+ vel) Nothing -> over (projectiles . ix i . pjPos) (+.+ vel)
$ set (projectiles . ix i . ptPict) pic $ set (projectiles . ix i . pjPict) pic
$ set (projectiles . ix i . ptUpdate) $ set (projectiles . ix i . pjUpdate)
(moveShell (time-1) i cid rot (rotateV rot accel)) (moveShell (time-1) i cid rot (rotateV rot accel))
w w
| otherwise = projectileExplosion oldPos | otherwise = projectileExplosion oldPos
$ stopSoundFrom (ShellSound i) $ stopSoundFrom (ShellSound i)
$ over projectiles (IM.delete i) w $ over projectiles (IM.delete i) w
where pt = _projectiles w IM.! i where
oldPos = _ptPos pt pj = _projectiles w IM.! i
vel = _ptVel pt oldPos = _pjPos pj
projectileExplosion = _ptExplosion pt vel = _pjVel pj
newPos = oldPos +.+ vel projectileExplosion = _pjPayload pj
(frict,g) = randomR (0.6,0.9) $ _randGen w newPos = oldPos +.+ vel
(sparkD,_) = randomR (-0.5,0.5) $ _randGen w (frict,g) = randomR (0.6,0.9) $ _randGen w
dir = argV $ vel (sparkD,_) = randomR (-0.5,0.5) $ _randGen w
pic = onLayer PtLayer $ uncurry translate newPos $ rotate (argV accel) shellPic dir = argV $ vel
piclow = onLayerL [levLayer CrLayer - 2] pic = onLayer PtLayer $ uncurry translate newPos $ rotate (argV accel) shellPic
$ uncurry translate newPos $ rotate (argV accel) shellPic piclow = onLayerL [levLayer CrLayer - 2]
hitCr = fmap fst $ collideCircCrsPoint oldPos newPos 4 w $ uncurry translate newPos $ rotate (argV accel) shellPic
hitWl = fmap fst $ collideCircWalls' oldPos newPos 2 $ wallsNearPoint newPos w hitCr = fmap fst $ collideCircCrsPoint oldPos newPos 4 w
thingHit = hitCr <|> hitWl hitWl = fmap fst $ collideCircWalls' oldPos newPos 2 $ wallsNearPoint newPos w
spin = case w ^? creatures . ix cid of thingHit = hitCr <|> hitWl
Just cr -> min 0.1 $ max (-0.1) spin = case w ^? creatures . ix cid of
$ (normalizeAnglePi (dir - _crDir cr)) / 20 Just cr -> min 0.1 $ max (-0.1)
_ -> 0 $ (normalizeAnglePi (dir - _crDir cr)) / 20
r1 = _randGen w & evalState (randInCirc 10) _ -> 0
smokeGen = makeSmokeCloudAt (oldPos +.+ r1 +.+ 30 *.* (normalizeV (oldPos -.- newPos))) r1 = _randGen w & evalState (randInCirc 10)
smokeGen = makeSmokeCloudAt (oldPos +.+ r1 +.+ 30 *.* (normalizeV (oldPos -.- newPos)))
normalizeAnglePi angle | normalizeAngle angle > pi = normalizeAngle angle - 2*pi normalizeAnglePi angle | normalizeAngle angle > pi = normalizeAngle angle - 2*pi
@@ -865,15 +865,16 @@ shellExplosionAt = makeExplosionAt
tractorBeamAt :: Int -> Int -> Point2 -> Float -> Projectile tractorBeamAt :: Int -> Int -> Point2 -> Float -> Projectile
tractorBeamAt colID i pos dir = Projectile tractorBeamAt colID i pos dir = Projectile
{ _ptPos = pos { _pjPos = pos
, _ptStartPos = p' , _pjStartPos = p'
, _ptVel = d , _pjVel = d
, _ptPict = blank , _pjPict = blank
, _ptID = i , _pjID = i
, _ptUpdate = updateTractor colID 10 i , _pjUpdate = updateTractor colID 10 i
} }
where d = unitVectorAtAngle dir where
p' = pos +.+ 400 *.* d d = unitVectorAtAngle dir
p' = pos +.+ 400 *.* d
aGasCloud :: Int -> World -> World aGasCloud :: Int -> World -> World
aGasCloud cid w aGasCloud cid w
@@ -925,74 +926,74 @@ reflect a b = a + 2*(a-b)
moveGrenade :: Int -> Float -> Int -> World -> World moveGrenade :: Int -> Float -> Int -> World -> World
moveGrenade 0 dir pID w = over projectiles (IM.delete pID) moveGrenade 0 dir pID w = over projectiles (IM.delete pID)
$ explosion (_ptPos (_projectiles w IM.! pID)) $ explosion (_pjPos (_projectiles w IM.! pID))
-- $ set (pointToItem (_itemPositions w IM.! wpID) . itEquipPict) -- $ set (pointToItem (_itemPositions w IM.! wpID) . itEquipPict)
-- (drawWeapon $ grenadePic 50) -- (drawWeapon $ grenadePic 50)
w w
where where
pt = _projectiles w IM.! pID pj = _projectiles w IM.! pID
explosion = _ptExplosion pt explosion = _pjPayload pj
moveGrenade time dir pID w moveGrenade time dir pID w
= case hitWl of = case hitWl of
Just _ -> soundOnce (fromIntegral tapQuiet) updatedWorld Just _ -> soundOnce (fromIntegral tapQuiet) updatedWorld
_ -> updatedWorld _ -> updatedWorld
where where
updatedWorld = updateV $ set (projectiles . ix pID . ptPos) finalPos updatedWorld = updateV $ set (projectiles . ix pID . pjPos) finalPos
$ set (projectiles .ix pID.ptPict) $ set (projectiles .ix pID.pjPict)
(onLayer PtLayer $ uncurry translate newPos (onLayer PtLayer $ uncurry translate newPos
$ rotate dir $ grenadePic time) $ rotate dir $ grenadePic time)
$ set (projectiles .ix pID.ptUpdate) (moveGrenade (time-1) dir pID) w $ set (projectiles .ix pID.pjUpdate) (moveGrenade (time-1) dir pID) w
pt = _projectiles w IM.! pID pj = _projectiles w IM.! pID
oldPos = _ptPos pt oldPos = _pjPos pj
newPos = _ptVel pt +.+ oldPos newPos = _pjVel pj +.+ oldPos
hitWl = collideCircWalls' oldPos newPos 4 $ wallsNearPoint newPos w hitWl = collideCircWalls' oldPos newPos 4 $ wallsNearPoint newPos w
finalPos = fromMaybe newPos (fmap fst hitWl) finalPos = fromMaybe newPos (fmap fst hitWl)
setV v = set (projectiles .ix pID.ptVel) v setV v = set (projectiles .ix pID.pjVel) v
updateV = fromMaybe id (fmap (setV.snd) hitWl) updateV = fromMaybe id (fmap (setV.snd) hitWl)
pointToItem (InInv cid invid) = creatures . ix cid . crInv . ix invid pointToItem (InInv cid invid) = creatures . ix cid . crInv . ix invid
pointToItem (OnFloor flid) = floorItems . ix flid . flIt pointToItem (OnFloor flid) = floorItems . ix flid . flIt
retireRemoteRocket :: Int -> Int -> Int -> World -> World retireRemoteRocket :: Int -> Int -> Int -> World -> World
retireRemoteRocket itid 0 ptid w retireRemoteRocket itid 0 pjid w
= set (pointToItem (_itemPositions w IM.! itid) . itAttachment . _Just . scopePos) = set (pointToItem (_itemPositions w IM.! itid) . itAttachment . _Just . scopePos)
(0,0) (0,0)
$ set (pointToItem (_itemPositions w IM.! itid) . wpFire) $ set (pointToItem (_itemPositions w IM.! itid) . wpFire)
fireRemoteLauncher fireRemoteLauncher
(w & projectiles %~ IM.delete ptid) (w & projectiles %~ IM.delete pjid)
retireRemoteRocket itid t ptid w = setScope w & projectiles . ix ptid . ptUpdate .~ retireRemoteRocket itid (t-1) ptid retireRemoteRocket itid t pjid w = setScope w & projectiles . ix pjid . pjUpdate .~ retireRemoteRocket itid (t-1) pjid
where where
setScope w' = case _itemPositions w' IM.! itid of setScope w' = case _itemPositions w' IM.! itid of
InInv cid invid InInv cid invid
-> w' & creatures . ix cid . crInv . ix invid . itAttachment -> w' & creatures . ix cid . crInv . ix invid . itAttachment
. _Just . scopePos .~ (pos -.- _crPos (_creatures w' IM.! cid)) . _Just . scopePos .~ (pos -.- _crPos (_creatures w' IM.! cid))
_ -> w' _ -> w'
pos = fromMaybe (0,0) $ w ^? projectiles . ix ptid . ptPos pos = fromMaybe (0,0) $ w ^? projectiles . ix pjid . pjPos
retireRemoteBomb :: Int -> Int -> Int -> World -> World retireRemoteBomb :: Int -> Int -> Int -> World -> World
retireRemoteBomb itid 0 ptid w retireRemoteBomb itid 0 pjid w
= set (pointToItem (_itemPositions w IM.! itid) . itAttachment . _Just . scopePos) = set (pointToItem (_itemPositions w IM.! itid) . itAttachment . _Just . scopePos)
(0,0) (0,0)
$ set (pointToItem (_itemPositions w IM.! itid) . itZoom) $ set (pointToItem (_itemPositions w IM.! itid) . itZoom)
defaultItZoom defaultItZoom
$ set (pointToItem (_itemPositions w IM.! itid) . twFire) $ set (pointToItem (_itemPositions w IM.! itid) . twFire)
throwRemoteBomb throwRemoteBomb
(w & projectiles %~ IM.delete ptid) (w & projectiles %~ IM.delete pjid)
retireRemoteBomb itid t ptid w retireRemoteBomb itid t pjid w
= setScope w & projectiles . ix ptid . ptUpdate .~ retireRemoteBomb itid (t-1) ptid = setScope w & projectiles . ix pjid . pjUpdate .~ retireRemoteBomb itid (t-1) pjid
where where
setScope w' = case _itemPositions w' IM.! itid of setScope w' = case _itemPositions w' IM.! itid of
InInv cid invid InInv cid invid
-> w' & creatures . ix cid . crInv . ix invid . itAttachment -> w' & creatures . ix cid . crInv . ix invid . itAttachment
. _Just . scopePos .~ (pos -.- _crPos (_creatures w' IM.! cid)) . _Just . scopePos .~ (pos -.- _crPos (_creatures w' IM.! cid))
_ -> w' _ -> w'
pos = fromMaybe (0,0) $ w ^? projectiles . ix ptid . ptPos pos = fromMaybe (0,0) $ w ^? projectiles . ix pjid . pjPos
moveRemoteBomb :: Int -> Int -> Int -> World -> World moveRemoteBomb :: Int -> Int -> Int -> World -> World
moveRemoteBomb itid time pID w moveRemoteBomb itid time pID w
| time < -4 = setScope | time < -4 = setScope
$ updatePicture $ updatePicture
$ set (projectiles .ix pID.ptUpdate) (moveRemoteBomb itid (f time) pID) $ set (projectiles .ix pID.pjUpdate) (moveRemoteBomb itid (f time) pID)
w w
| time < 2 | time < 2
= case hitWl of = case hitWl of
@@ -1004,9 +1005,9 @@ moveRemoteBomb itid time pID w
_ -> updatedWorld _ -> updatedWorld
where where
updatedWorld updatedWorld
= updateV $ set (projectiles . ix pID . ptPos) finalPos = updateV $ set (projectiles . ix pID . pjPos) finalPos
$ updatePicture $ updatePicture
$ set (projectiles .ix pID.ptUpdate) (moveRemoteBomb itid (time-1) pID) $ set (projectiles .ix pID.pjUpdate) (moveRemoteBomb itid (time-1) pID)
$ setScope $ setScope
w w
setScope w' = case _itemPositions w' IM.! itid of setScope w' = case _itemPositions w' IM.! itid of
@@ -1016,20 +1017,20 @@ moveRemoteBomb itid time pID w
& creatures . ix cid . crInv . ix invid . itZoom & creatures . ix cid . crInv . ix invid . itZoom
.~ (defaultItZoom {_itAimZoomMax = 0.5, _itAimZoomMin = 0.5}) .~ (defaultItZoom {_itAimZoomMax = 0.5, _itAimZoomMin = 0.5})
_ -> w' _ -> w'
pt = _projectiles w IM.! pID pj = _projectiles w IM.! pID
oldPos = _ptPos pt oldPos = _pjPos pj
newPos = _ptVel pt +.+ oldPos newPos = _pjVel pj +.+ oldPos
-- this is hacky, should use a version of collidePointWalls' that collides -- this is hacky, should use a version of collidePointWalls' that collides
-- circles and walls -- circles and walls
invShift x = x -.- 5 *.* normalizeV (_ptVel pt) invShift x = x -.- 5 *.* normalizeV (_pjVel pj)
hitWl = collideCircWalls' oldPos newPos 4 $ wallsNearPoint newPos w hitWl = collideCircWalls' oldPos newPos 4 $ wallsNearPoint newPos w
finalPos = fromMaybe newPos (fmap (invShift . fst) hitWl) finalPos = fromMaybe newPos (fmap (invShift . fst) hitWl)
setV v = set (projectiles .ix pID.ptVel) v setV v = set (projectiles .ix pID.pjVel) v
updateV = fromMaybe id (fmap (setV.snd) hitWl) updateV = fromMaybe id (fmap (setV.snd) hitWl)
halfV = over (projectiles . ix pID . ptVel) (\v -> 0.5 *.* v) halfV = over (projectiles . ix pID . pjVel) (\v -> 0.5 *.* v)
f x | x < -369 = -10 f x | x < -369 = -10
| otherwise = x - 1 | otherwise = x - 1
updatePicture = set (projectiles . ix pID.ptPict) updatePicture = set (projectiles . ix pID.pjPict)
(onLayer PtLayer $ uncurry translate newPos (onLayer PtLayer $ uncurry translate newPos
$ remoteBombPic time) $ remoteBombPic time)
. lowLightDirected (withAlpha 0.1 red) newPos . lowLightDirected (withAlpha 0.1 red) newPos
@@ -1270,60 +1271,35 @@ remoteBomb = defaultThrowable
throwGrenade' :: (Point2 -> World -> World) -> Int -> Int -> World -> World throwGrenade' :: (Point2 -> World -> World) -> Int -> Int -> World -> World
throwGrenade' explosion fuseTime n w = setWp $ removePict $ over projectiles addG $ set randGen g w throwGrenade' explosion fuseTime n w = setWp $ removePict $ over projectiles addG $ set randGen g w
where addG = IM.insert i where
$ Shell { _ptPos = p addG = IM.insert i $ Shell
, _ptStartPos = p { _pjPos = p
, _ptVel = v , _pjStartPos = p
, _ptPict = onLayer PtLayer $ uncurry translate p $ grenadePic 0 , _pjVel = v
, _ptID = i , _pjPict = onLayer PtLayer $ uncurry translate p $ grenadePic 0
, _ptUpdate = moveGrenade fuseTime dir i , _pjID = i
, _ptExplosion = explosion , _pjUpdate = moveGrenade fuseTime dir i
} , _pjPayload = explosion
j = _crInvSel $ _creatures w IM.! n }
removePict = set (creatures . ix n . crInv . ix j . itEquipPict) $ \ _ _ -> blank j = _crInvSel $ _creatures w IM.! n
i = newProjectileKey w removePict = set (creatures . ix n . crInv . ix j . itEquipPict) $ \ _ _ -> blank
(a, g) = randomR (-grenadeAccA,grenadeAccA::Float) (_randGen w) i = newProjectileKey w
(l, _) = randomR (1 - 2*grenadeAccL,1+grenadeAccL::Float) g (a, g) = randomR (-grenadeAccA,grenadeAccA::Float) (_randGen w)
-- v = 0.02 * l / _cameraZoom w *.* rotateV (a+_cameraRot w) (limitRange $ _mousePos w) (l, _) = randomR (1 - 2*grenadeAccL,1+grenadeAccL::Float) g
v' = 1 / (fromIntegral fuseTime * _cameraZoom w) *.* rotateV (_cameraRot w) ( _mousePos w) -- - v = 0.02 * l / _cameraZoom w *.* rotateV (a+_cameraRot w) (limitRange $ _mousePos w)
v | magV v' > 6 = 6 *.* normalizeV v' v' = 1 / (fromIntegral fuseTime * _cameraZoom w) *.* rotateV (_cameraRot w) ( _mousePos w)
| otherwise = v' v | magV v' > 6 = 6 *.* normalizeV v'
cr = _creatures w IM.! n | otherwise = v'
p' = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr,0) cr = _creatures w IM.! n
p | circOnSomeWall p' 4 w = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr-4,0) p' = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr,0)
| otherwise = p' p | circOnSomeWall p' 4 w = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr-4,0)
dir = argV v | otherwise = p'
setWp :: World -> World dir = argV v
setWp w' = w' & creatures . ix n . crInv . ix j . itEffect .~ throwArmReset 20 setWp :: World -> World
setWp w' = w' & creatures . ix n . crInv . ix j . itEffect .~ throwArmReset 20
throwGrenade :: Int -> Int -> World -> World throwGrenade :: Int -> Int -> World -> World
throwGrenade = throwGrenade' makeExplosionAt throwGrenade = throwGrenade' makeExplosionAt
-- setWp $ removePict $ over projectiles addG $ set randGen g w
-- where addG = IM.insert i
-- $ Shell { _ptPos = p
-- , _ptStartPos = p
-- , _ptVel = v
-- , _ptPict = onLayer PtLayer $ uncurry translate p $ grenadePic 0
-- , _ptID = i
-- , _ptUpdate = moveGrenade fuseTime dir i
-- , _ptExplosion = makeExplosionAt
-- }
-- j = _crInvSel $ _creatures w IM.! n
-- removePict = set (creatures . ix n . crInv . ix j . itEquipPict) $ \ _ _ -> blank
-- i = newProjectileKey w
-- (a, g) = randomR (-grenadeAccA,grenadeAccA::Float) (_randGen w)
-- (l, _) = randomR (1 - 2*grenadeAccL,1+grenadeAccL::Float) g
-- -- v = 0.02 * l / _cameraZoom w *.* rotateV (a+_cameraRot w) (limitRange $ _mousePos w)
-- v' = 1 / (fromIntegral fuseTime * _cameraZoom w) *.* rotateV (_cameraRot w) ( _mousePos w)
-- v | magV v' > 6 = 6 *.* normalizeV v'
-- | otherwise = v'
-- cr = _creatures w IM.! n
-- p' = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr,0)
-- p | circOnSomeWall p' 4 w = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr-4,0)
-- | otherwise = p'
-- dir = argV v
-- setWp :: World -> World
-- setWp w' = w' & creatures . ix n . crInv . ix j . itEffect .~ throwArmReset 20
throwArmReset :: Int -> ItEffect throwArmReset :: Int -> ItEffect
throwArmReset x = throwArmReset x =
@@ -1352,45 +1328,46 @@ fireRemoteLauncher :: Int -> World -> World
fireRemoteLauncher cid w = setLocation $ resetFire $ resetName fireRemoteLauncher cid w = setLocation $ resetFire $ resetName
$ soundOnce (fromIntegral launcherSound) $ soundOnce (fromIntegral launcherSound)
$ over projectiles remRocket w $ over projectiles remRocket w
where where
i = newKey $ _projectiles w i = newKey $ _projectiles w
cr = _creatures w IM.! cid cr = _creatures w IM.! cid
dir = _crDir cr dir = _crDir cr
pos = _crPos cr +.+ rotateV dir (_crRad cr + 1,0) pos = _crPos cr +.+ rotateV dir (_crRad cr + 1,0)
remRocket = IM.insert i $ Projectile { _ptPos = pos remRocket = IM.insert i $ Projectile
, _ptStartPos = pos { _pjPos = pos
, _ptVel = rotateV dir (1,0) , _pjStartPos = pos
, _ptPict = blank , _pjVel = rotateV dir (1,0)
, _ptID = i , _pjPict = blank
, _ptUpdate = moveRemoteShell 50 i cid itid dir , _pjID = i
} , _pjUpdate = moveRemoteShell 50 i cid itid dir
j = _crInvSel $ _creatures w IM.! cid }
newitid = newKey $ _itemPositions w j = _crInvSel $ _creatures w IM.! cid
maybeitid = w ^? creatures . ix cid . crInv . ix j . itID . _Just newitid = newKey $ _itemPositions w
resetFire = set (creatures . ix cid . crInv . ix j . wpFire) $ explodeRemoteRocket itid i maybeitid = w ^? creatures . ix cid . crInv . ix j . itID . _Just
resetName = set (creatures . ix cid . crInv . ix j . itName) "REMOTEROCKET" resetFire = set (creatures . ix cid . crInv . ix j . wpFire) $ explodeRemoteRocket itid i
setLocation :: World -> World resetName = set (creatures . ix cid . crInv . ix j . itName) "REMOTEROCKET"
setLocation w' = case maybeitid of setLocation :: World -> World
Nothing -> w' & creatures . ix cid . crInv . ix j . itID .~ Just newitid setLocation w' = case maybeitid of
& itemPositions %~ IM.insert newitid (InInv cid j) Nothing -> w' & creatures . ix cid . crInv . ix j . itID .~ Just newitid
_ -> w' & itemPositions %~ IM.insert newitid (InInv cid j)
itid = fromMaybe newitid maybeitid _ -> w'
itid = fromMaybe newitid maybeitid
moveRemoteShell :: Int -> Int -> Int -> Int -> Float -> World -> World moveRemoteShell :: Int -> Int -> Int -> Int -> Float -> World -> World
moveRemoteShell time i cid itid dir w moveRemoteShell time i cid itid dir w
| time > 40 = if circOnSomeWall oldPos 4 w | time > 40 = if circOnSomeWall oldPos 4 w
then doExplosion w then doExplosion w
else over (projectiles . ix i . ptPos) (+.+ vel) else over (projectiles . ix i . pjPos) (+.+ vel)
$ set (projectiles . ix i . ptPict) piclow $ set (projectiles . ix i . pjPict) piclow
$ set (projectiles . ix i . ptUpdate) $ set (projectiles . ix i . pjUpdate)
(moveRemoteShell (time-1) i cid itid newdir) (moveRemoteShell (time-1) i cid itid newdir)
$ setScope $ setScope
w w
| time >= 20 = case thingHit of | time >= 20 = case thingHit of
Just p -> doExplosion w Just p -> doExplosion w
Nothing -> over (projectiles . ix i . ptPos) (+.+ vel) Nothing -> over (projectiles . ix i . pjPos) (+.+ vel)
$ set (projectiles . ix i . ptPict) pic $ set (projectiles . ix i . pjPict) pic
$ set (projectiles . ix i . ptUpdate) $ set (projectiles . ix i . pjUpdate)
(moveRemoteShell (time-1) i cid itid newdir) (moveRemoteShell (time-1) i cid itid newdir)
$ setScope $ setScope
w w
@@ -1399,12 +1376,12 @@ moveRemoteShell time i cid itid dir w
Just p -> doExplosion Just p -> doExplosion
$ stopSoundFrom (ShellSound i) $ stopSoundFrom (ShellSound i)
w w
Nothing -> over (projectiles . ix i . ptPos) (+.+ vel) Nothing -> over (projectiles . ix i . pjPos) (+.+ vel)
$ set randGen g $ set randGen g
$ set (projectiles . ix i . ptPict) pic $ set (projectiles . ix i . pjPict) pic
$ set (projectiles . ix i . ptUpdate) $ set (projectiles . ix i . pjUpdate)
(moveRemoteShell (time-1) i cid itid newdir) (moveRemoteShell (time-1) i cid itid newdir)
$ over (projectiles . ix i . ptVel) (\v -> accel +.+ frict *.* v) $ over (projectiles . ix i . pjVel) (\v -> accel +.+ frict *.* v)
$ soundFrom (ShellSound i) (fromIntegral smokeTrailSound) (1) 250 $ soundFrom (ShellSound i) (fromIntegral smokeTrailSound) (1) 250
$ smokeGen $ smokeGen
$ makeFlameletTimed oldPos $ makeFlameletTimed oldPos
@@ -1415,108 +1392,112 @@ moveRemoteShell time i cid itid dir w
Just p -> doExplosion Just p -> doExplosion
$ stopSoundFrom (ShellSound i) $ stopSoundFrom (ShellSound i)
w w
Nothing -> over (projectiles . ix i . ptPos) (+.+ vel) Nothing -> over (projectiles . ix i . pjPos) (+.+ vel)
$ set (projectiles . ix i . ptPict) pic $ set (projectiles . ix i . pjPict) pic
$ set (projectiles . ix i . ptUpdate) $ set (projectiles . ix i . pjUpdate)
(moveRemoteShell (time-1) i cid itid newdir) (moveRemoteShell (time-1) i cid itid newdir)
$ setScope $ setScope
w w
| otherwise = doExplosion | otherwise = doExplosion
$ stopSoundFrom (ShellSound i) $ stopSoundFrom (ShellSound i)
w w
where pt = _projectiles w IM.! i where
oldPos = _ptPos pt pj = _projectiles w IM.! i
vel = _ptVel pt oldPos = _pjPos pj
newPos = oldPos +.+ vel vel = _pjVel pj
newdir newPos = oldPos +.+ vel
| SDL.ButtonRight `S.member` (_mouseButtons w) newdir
&& w ^? creatures . ix cid . crInvSel == w ^? itemPositions . ix itid . itInvId | SDL.ButtonRight `S.member` (_mouseButtons w)
= _cameraRot w + (argV $ _mousePos w) && w ^? creatures . ix cid . crInvSel == w ^? itemPositions . ix itid . itInvId
| otherwise = dir = _cameraRot w + (argV $ _mousePos w)
accel = rotateV newdir (2,0) | otherwise = dir
(frict,g) = randomR (0.6,0.9) $ _randGen w accel = rotateV newdir (2,0)
(sparkD,_) = randomR (-0.5,0.5) $ _randGen w (frict,g) = randomR (0.6,0.9) $ _randGen w
dir = argV $ vel (sparkD,_) = randomR (-0.5,0.5) $ _randGen w
pic = onLayer PtLayer $ uncurry translate newPos dir = argV $ vel
$ rotate (argV accel) $ remoteShellPic time pic = onLayer PtLayer $ uncurry translate newPos
piclow = onLayerL [levLayer CrLayer - 2] $ rotate (argV accel) $ remoteShellPic time
$ uncurry translate newPos $ rotate (argV accel) piclow = onLayerL [levLayer CrLayer - 2]
$ remoteShellPic time $ uncurry translate newPos $ rotate (argV accel)
hitCr = fmap fst $ collideCircCrsPoint oldPos newPos 4 w $ remoteShellPic time
hitWl = fmap fst $ collideCircWalls' oldPos newPos 2 $ wallsNearPoint newPos w hitCr = fmap fst $ collideCircCrsPoint oldPos newPos 4 w
thingHit = hitCr <|> hitWl hitWl = fmap fst $ collideCircWalls' oldPos newPos 2 $ wallsNearPoint newPos w
thingHit = hitCr <|> hitWl
r1 = _randGen w & evalState (randInCirc 10) r1 = _randGen w & evalState (randInCirc 10)
smokeGen = makeSmokeCloudAt (oldPos +.+ r1 +.+ 30 *.* (normalizeV (oldPos -.- newPos))) smokeGen = makeSmokeCloudAt (oldPos +.+ r1 +.+ 30 *.* (normalizeV (oldPos -.- newPos)))
doExplosion = explodeRemoteRocket itid i cid doExplosion = explodeRemoteRocket itid i cid
setScope w' = case _itemPositions w' IM.! itid of setScope w' = case _itemPositions w' IM.! itid of
InInv cid invid InInv cid invid
-> w' & creatures . ix cid . crInv . ix invid . itAttachment -> w' & creatures . ix cid . crInv . ix invid . itAttachment
. _Just . scopePos .~ (newPos -.- _crPos (_creatures w' IM.! cid)) . _Just . scopePos .~ (newPos -.- _crPos (_creatures w' IM.! cid))
_ -> w' _ -> w'
explodeRemoteRocket :: Int -> Int -> Int -> World -> World explodeRemoteRocket :: Int -> Int -> Int -> World -> World
explodeRemoteRocket itid ptid n w explodeRemoteRocket itid pjid n w
= set (projectiles . ix ptid . ptUpdate) (retireRemoteRocket itid 30 ptid) = set (projectiles . ix pjid . pjUpdate) (retireRemoteRocket itid 30 pjid)
$ set (projectiles . ix ptid . ptPict) blank $ set (projectiles . ix pjid . pjPict) blank
$ set (itPoint . wpFire) (flip const) $ set (itPoint . wpFire) (flip const)
$ resetName $ resetName
$ makeExplosionAt (_ptPos (_projectiles w IM.! ptid)) w $ makeExplosionAt (_pjPos (_projectiles w IM.! pjid)) w
where resetName = set (itPoint . itName) "REMOTELAUNCHER" where
itPoint = pointToItem $ _itemPositions w IM.! itid resetName = set (itPoint . itName) "REMOTELAUNCHER"
itPoint = pointToItem $ _itemPositions w IM.! itid
throwRemoteBomb :: Int -> World -> World throwRemoteBomb :: Int -> World -> World
throwRemoteBomb n w = setLocation $ removePict $ resetFire throwRemoteBomb n w = setLocation $ removePict $ resetFire
$ resetName $ over projectiles addG w $ resetName $ over projectiles addG w
where addG = IM.insert i where
$ Projectile { _ptPos = p addG = IM.insert i $ Projectile
, _ptStartPos = p { _pjPos = p
, _ptVel = v , _pjStartPos = p
, _ptPict = blank , _pjVel = v
, _ptID = i , _pjPict = blank
, _ptUpdate = moveRemoteBomb itid 50 i , _pjID = i
} , _pjUpdate = moveRemoteBomb itid 50 i
i = newProjectileKey w }
-- fireDist = zoom *.* (rotateV (_cameraRot w) (_mousePos w) +.+ _cameraCenter w -.- yourPos) i = newProjectileKey w
d = argV $ _mousePos w -- fireDist = zoom *.* (rotateV (_cameraRot w) (_mousePos w) +.+ _cameraCenter w -.- yourPos)
--(l, _) = randomR (1 - grenadeAccL,1+grenadeAccL) (_randGen w) d = argV $ _mousePos w
--(a, g) = randomR (-grenadeAccA,grenadeAccA) (_randGen w) --(l, _) = randomR (1 - grenadeAccL,1+grenadeAccL) (_randGen w)
v' = 0.02 / _cameraZoom w *.* rotateV (_cameraRot w) ( _mousePos w) --(a, g) = randomR (-grenadeAccA,grenadeAccA) (_randGen w)
v | magV v' > 6 = 6 *.* normalizeV v' v' = 0.02 / _cameraZoom w *.* rotateV (_cameraRot w) ( _mousePos w)
-- zoom = 1 / _cameraZoom w v | magV v' > 6 = 6 *.* normalizeV v'
j = _crInvSel $ _creatures w IM.! n -- zoom = 1 / _cameraZoom w
resetName = set (creatures . ix n . crInv . ix j . itName) "REMOTE" j = _crInvSel $ _creatures w IM.! n
removePict = set (creatures . ix n . crInv . ix j . itEquipPict) $ \ _ _ -> blank resetName = set (creatures . ix n . crInv . ix j . itName) "REMOTE"
resetFire = set (creatures . ix n . crInv . ix j . twFire) $ explodeRemoteBomb itid i removePict = set (creatures . ix n . crInv . ix j . itEquipPict) $ \ _ _ -> blank
cr = _creatures w IM.! n resetFire = set (creatures . ix n . crInv . ix j . twFire) $ explodeRemoteBomb itid i
p' = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr,0) cr = _creatures w IM.! n
p | circOnSomeWall p' 4 w = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr-4,0) p' = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr,0)
| otherwise = p' p | circOnSomeWall p' 4 w = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr-4,0)
maybeitid = w ^? creatures . ix n . crInv . ix j . itID . _Just | otherwise = p'
setLocation :: World -> World maybeitid = w ^? creatures . ix n . crInv . ix j . itID . _Just
setLocation w' = case maybeitid of setLocation :: World -> World
Nothing -> w' & creatures . ix n . crInv . ix j . itID .~ Just newitid setLocation w' = case maybeitid of
& itemPositions %~ IM.insert newitid (InInv n j) Nothing -> w' & creatures . ix n . crInv . ix j . itID .~ Just newitid
_ -> w' & itemPositions %~ IM.insert newitid (InInv n j)
newitid = newKey $ _itemPositions w _ -> w'
itid = fromMaybe newitid maybeitid newitid = newKey $ _itemPositions w
itid = fromMaybe newitid maybeitid
explodeRemoteBomb :: Int -> Int -> Int -> World -> World explodeRemoteBomb :: Int -> Int -> Int -> World -> World
explodeRemoteBomb itid ptid n w explodeRemoteBomb itid pjid n w
= set (projectiles . ix ptid . ptUpdate) (retireRemoteBomb itid 30 ptid) = set (projectiles . ix pjid . pjUpdate) (retireRemoteBomb itid 30 pjid)
$ set (projectiles . ix ptid . ptPict) blank $ set (projectiles . ix pjid . pjPict) blank
$ set (creatures . ix n . crInv . ix j . twFire) (flip const) $ set (creatures . ix n . crInv . ix j . twFire) (flip const)
$ resetName $ resetName
$ resetPict $ resetPict
-- $ resetScope -- $ resetScope
$ makeExplosionAt (_ptPos (_projectiles w IM.! ptid)) w $ makeExplosionAt (_pjPos (_projectiles w IM.! pjid)) w
-- $ makeShrapnelBombAt (_ptPos (_projectiles w IM.! ptid)) w -- $ makeShrapnelBombAt (_pjPos (_projectiles w IM.! pjid)) w
where resetName = set (creatures . ix n . crInv . ix j . itName) "REMOTEBOMB" where
resetPict = set (creatures . ix n . crInv . ix j . itEquipPict ) resetName = set (creatures . ix n . crInv . ix j . itName) "REMOTEBOMB"
(drawWeapon $ remoteBombUnarmedPic) resetPict = set (creatures . ix n . crInv . ix j . itEquipPict )
-- resetScope = creatures . ix n . crInv . ix j . itScope . _Just . scopePos .~ (0,0) (drawWeapon $ remoteBombUnarmedPic)
j = _crInvSel $ _creatures w IM.! n -- resetScope = creatures . ix n . crInv . ix j . itScope . _Just . scopePos .~ (0,0)
j = _crInvSel $ _creatures w IM.! n
remoteBombPic :: Int -> Picture remoteBombPic :: Int -> Picture
remoteBombPic x = pictures [ color (dark $ dark orange) $ circleSolid 5 remoteBombPic x = pictures [ color (dark $ dark orange) $ circleSolid 5
, rotate (0 - degToRad (fromIntegral x * 10 + 45)) $ color red $ arc 0 (pi/2) 5 , rotate (0 - degToRad (fromIntegral x * 10 + 45)) $ color red $ arc 0 (pi/2) 5
@@ -1667,8 +1648,8 @@ moveInt toReload totalAmmo = (x, totalAmmo-x)
updateTractor :: Int -> Int -> Int -> World -> World updateTractor :: Int -> Int -> Int -> World -> World
updateTractor colID time i w updateTractor colID time i w
| time > 0 = set (projectiles . ix i . ptUpdate) (updateTractor colID (time-1) i) | time > 0 = set (projectiles . ix i . pjUpdate) (updateTractor colID (time-1) i)
$ set (projectiles . ix i . ptPict) pic $ set (projectiles . ix i . pjPict) pic
$ over creatures (IM.map tractCr) $ over creatures (IM.map tractCr)
$ over floorItems (IM.map tractFlIt) $ over floorItems (IM.map tractFlIt)
w w
@@ -1693,10 +1674,10 @@ updateTractor colID time i w
iP = _flItPos it iP = _flItPos it
m | dist iP p1 < 350 = 1 m | dist iP p1 < 350 = 1
| otherwise = (410 - dist iP p1) / 60 | otherwise = (410 - dist iP p1) / 60
pt = _projectiles w IM.! i pj = _projectiles w IM.! i
q = _ptVel pt q = _pjVel pj
p1 = _ptPos pt p1 = _pjPos pj
p' = _ptStartPos pt p' = _pjStartPos pj
p2 = fromMaybe p' $ fmap fst $ collidePointWalls p1 p' $ wallsNearPoint p' w p2 = fromMaybe p' $ fmap fst $ collidePointWalls p1 p' $ wallsNearPoint p' w
p4 = vNormal p5 p4 = vNormal p5
p5 = errorNormalizeV 12 $ p2 -.- p1 p5 = errorNormalizeV 12 $ p2 -.- p1
src/Dodge/Item/Weapon/Bullet.hs
+3 -3
View File
@@ -6,7 +6,7 @@ import Dodge.WorldEvent
import Dodge.SoundLogic import Dodge.SoundLogic
import Dodge.RandomHelp import Dodge.RandomHelp
import Dodge.Creature.LookupStatus import Dodge.Creature.Property
import Geometry import Geometry
@@ -22,7 +22,7 @@ import Picture
-- bullet effects -- bullet effects
bulHitCr' :: Particle' -> Point2 -> Creature -> World -> World bulHitCr' :: Particle' -> Point2 -> Creature -> World -> World
bulHitCr' bt p cr w bulHitCr' bt p cr w
| isArmouredFrom p cr | crIsArmouredFrom p cr
= createSpark 8 colID p1 (argV (p1 -.- p) + d1) Nothing = createSpark 8 colID p1 (argV (p1 -.- p) + d1) Nothing
. addDamageArmoured $ w . addDamageArmoured $ w
| otherwise | otherwise
@@ -43,7 +43,7 @@ bulHitCr' bt p cr w
bulBounceArmCr' :: Particle' -> Point2 -> Creature -> World -> World bulBounceArmCr' :: Particle' -> Point2 -> Creature -> World -> World
bulBounceArmCr' bt p cr w bulBounceArmCr' bt p cr w
| isArmouredFrom p cr | crIsArmouredFrom p cr
= addBouncer . addDamageArmoured $ w = addBouncer . addDamageArmoured $ w
| otherwise | otherwise
= addDamage . hitSound . flashEff $ w = addDamage . hitSound . flashEff $ w
src/Dodge/Layout.hs
+1 -1
View File
@@ -68,7 +68,7 @@ wallsFromTree t =
. divideWalls . divideWalls
. assignKeys . assignKeys
. foldr cutWalls [] -- $ map (map (g . roundPoint2)) . foldr cutWalls [] -- $ map (map (g . roundPoint2))
. map (map roundPoint2) -- . map (map roundPoint2)
$ (concatMap _rmPolys $ flatten t) $ (concatMap _rmPolys $ flatten t)
where where
assignKeys = IM.fromList . zip [0..] . zipWith f [0..] assignKeys = IM.fromList . zip [0..] . zipWith f [0..]
src/Dodge/LevelGen/AutoDoor.hs
+27 -24
View File
@@ -5,6 +5,8 @@ import Dodge.Data
import Dodge.Base import Dodge.Base
import Dodge.SoundLogic import Dodge.SoundLogic
import Dodge.Creature.Property
import Geometry import Geometry
import Picture import Picture
@@ -24,7 +26,7 @@ autoDoorAt a b wls = IM.union wls $ IM.fromList $ zip is $ mkAutoDoor a b is
is = [i..] is = [i..]
mkAutoDoor :: Point2 -> Point2 -> [Int] -> [Wall] mkAutoDoor :: Point2 -> Point2 -> [Int] -> [Wall]
mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane [pl,pr]) mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane (pl,pr))
xs xs
(lDoorClosed ++ rDoorClosed) (lDoorClosed ++ rDoorClosed)
(map shiftL lDoorClosed ++ map shiftR rDoorClosed) (map shiftL lDoorClosed ++ map shiftR rDoorClosed)
@@ -55,8 +57,8 @@ mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane [pl,pr])
| otherwise = dm w | otherwise = dm w
where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1 where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1
autoDoorPane :: [Point2] -> Int -> [Point2] -> [Point2] -> Wall autoDoorPane :: (Point2,Point2) -> Int -> [Point2] -> [Point2] -> Wall
autoDoorPane trigL n closedPos openPos = Door autoDoorPane (trigx,trigy) n closedPos openPos = Door
{ _wlLine = closedPos { _wlLine = closedPos
, _wlID = n , _wlID = n
, _doorMech = dm , _doorMech = dm
@@ -66,24 +68,25 @@ autoDoorPane trigL n closedPos openPos = Door
, _wlIsSeeThrough = False , _wlIsSeeThrough = False
, _doorPathable = True , _doorPathable = True
} }
where where
a = closedPos !! 0 a = closedPos !! 0
b = closedPos !! 1 b = closedPos !! 1
dm w | crsNearLine 40 trigL w dm w | any (crNearSeg 40 trigx trigy) $ IM.filter (_crIsAnimate) $ _creatures w
= flip (foldr changeZonedWall) zoneps -- crsNearLine 40 trigL w
$ over walls (IM.adjust openDoor n) w = flip (foldr changeZonedWall) zoneps
| otherwise = flip (foldr changeZonedWall') zoneps $ over walls (IM.adjust openDoor n) w
$ over walls (IM.adjust closeDoor n) w | otherwise = flip (foldr changeZonedWall') zoneps
mvP !ep !p = mvPointTowardAtSpeed 2 ep p $ over walls (IM.adjust closeDoor n) w
moveToward :: [Point2] -> Wall -> Wall mvP !ep !p = mvPointTowardAtSpeed 2 ep p
moveToward !ps w = let !newPs = zipWith mvP ps $ _wlLine w moveToward :: [Point2] -> Wall -> Wall
in deepseq newPs $ w {_wlLine = newPs} moveToward !ps w = let !newPs = zipWith mvP ps $ _wlLine w
--deepseq ps $ w & wlLine %~ zipWith mvP ps in deepseq newPs $ w {_wlLine = newPs}
openDoor = moveToward openPos --deepseq ps $ w & wlLine %~ zipWith mvP ps
closeDoor = moveToward closedPos openDoor = moveToward openPos
zoneps | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b] closeDoor = moveToward closedPos
| otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b zoneps | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
changeZonedWall (!x,!y) | otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b
= over wallsZone $ adjustIMZone openDoor x y n changeZonedWall (!x,!y)
changeZonedWall' (!x,!y) = over wallsZone $ adjustIMZone openDoor x y n
= over wallsZone $ adjustIMZone closeDoor x y n changeZonedWall' (!x,!y)
= over wallsZone $ adjustIMZone closeDoor x y n
src/Dodge/LevelGen/StaticWalls.hs
+22 -26
View File
@@ -22,15 +22,15 @@ type WallP = (Point2,Point2)
cutWalls :: [Point2] -> [WallP] -> [WallP] cutWalls :: [Point2] -> [WallP] -> [WallP]
cutWalls ps wls = case mapMaybe (flip checkWallRight newWalls) newWalls of cutWalls ps wls = case mapMaybe (flip checkWallRight newWalls) newWalls of
[] -> newWalls [] -> newWalls
errs -> error $ "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"
++ unlines (map show errs) ++ unlines (map show errs)
++ "\nStart walls:\n"
++ unlines (map show wls)
++ "\nEnd walls:\n"
++ unlines (map show newWalls)
++ "\nLeft corner errors:\n" ++ "\nLeft corner errors:\n"
++ unlines (map show errsL) ++ unlines (map show errsL)
++ "\nWalls before cut:\n"
++ unlines (map show wls)
++ "\nWalls after cut:\n"
++ unlines (map show newWalls)
where where
newWalls = cutWalls' ps wls newWalls = cutWalls' ps wls
errsL = mapMaybe (flip checkWallLeft newWalls) newWalls errsL = mapMaybe (flip checkWallLeft newWalls) newWalls
@@ -51,7 +51,7 @@ cutWalls' qs walls =
nub nub
. filter (not.wallIsZeroLength) . filter (not.wallIsZeroLength)
. fuseWallsWith zs . fuseWallsWith zs
. createPolyWalls rs . addPolyWalls rs
-- . removeWallsInPolygon ps -- . removeWallsInPolygon ps
-- . filter (not.wallIsZeroLength) -- . filter (not.wallIsZeroLength)
-- . fuseWallsWith zs -- . fuseWallsWith zs
@@ -65,7 +65,7 @@ cutWalls' qs walls =
-- split walls that intersect with the polygon into two -- split walls that intersect with the polygon into two
-- (possibly three if the wall extends across the polygon) -- (possibly three if the wall extends across the polygon)
-- remove any created walls that are inside the polygon -- remove any created walls that are inside the polygon
-- draw the required new walls along the polygon boundary -- create the required new walls along the polygon boundary
-- fuse wall endpoints that end up close to each or to polygon intersection points -- fuse wall endpoints that end up close to each or to polygon intersection points
-- remove any walls that ended up zero length after fusing -- remove any walls that ended up zero length after fusing
-- remove any duplicate walls -- remove any duplicate walls
@@ -77,7 +77,7 @@ cutWallsWithPoints :: [Point2] -> [WallP] -> ([Point2], [WallP] )
cutWallsWithPoints (p:ps) ws = foldr f ([],ws) (zip (p:ps) (ps++[p])) cutWallsWithPoints (p:ps) ws = foldr f ([],ws) (zip (p:ps) (ps++[p]))
where where
f (p1,p2) (as,ws') = f (p1,p2) (as,ws') =
( as ++ cutWallsPoints p1 p2 ws' ( nub $ as ++ cutWallsPoints p1 p2 ws'
, concatMap (cutWall p1 p2) ws' , concatMap (cutWall p1 p2) ws'
) )
@@ -86,20 +86,19 @@ 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 ws = mapMaybe (uncurry $ myIntersectSegSeg p1 p2) ws
-- given a segment and a wall, adds a cut point to the wall if it intersects the -- given a segment and a wall, split the wall into two if it crosses the segment
-- segment
cutWall :: Point2 -> Point2 -> WallP -> [WallP] cutWall :: Point2 -> Point2 -> WallP -> [WallP]
cutWall p1 p2 (x,y) = case myIntersectSegSeg p1 p2 x y of cutWall p1 p2 (x,y) = case myIntersectSegSeg p1 p2 x y of
Nothing -> [(x,y)] Nothing -> [(x,y)]
Just cp -> [(x,cp),(cp,y)] Just cp -> [(x,cp),(cp,y)]
createPolyWalls :: [Point2] -> [WallP] -> [WallP] addPolyWalls :: [Point2] -> [WallP] -> [WallP]
createPolyWalls (q:qs) walls = foldr createPolyWall walls (zip (q:qs) (qs++[q])) addPolyWalls (q:qs) walls = foldr addPolyWall walls (zip (q:qs) (qs++[q]))
-- adds a wall if there is not already a wall on the clockwise normal to this wall -- adds a wall if there is not already a wall on the clockwise normal to this wall
-- such that this existing wall faces towards the new wall -- such that this existing wall faces towards the new wall
createPolyWall :: WallP -> [WallP] -> [WallP] addPolyWall :: WallP -> [WallP] -> [WallP]
createPolyWall (p1,p2) walls = addPolyWall (p1,p2) walls =
case maybeW of Just (x,y) -> if isLHS x y p3 case maybeW of Just (x,y) -> if isLHS x y p3
then walls then walls
else (p1,p2) : walls else (p1,p2) : walls
@@ -144,30 +143,27 @@ fusePoint ps p = fromMaybe p $ findClosePoint ps p
-- if either wall point is not moved, this point gets added to the list -- if either wall point is not moved, this point gets added to the list
fuseWall :: ([Point2], WallP) -> ([Point2], WallP) fuseWall :: ([Point2], WallP) -> ([Point2], WallP)
fuseWall (ps, (x,y)) = ( nub (x':y':ps) , (x',y') ) fuseWall (ps, (x,y)) = ( nub (x':y':ps) , (x',y') )
where x' = fusePoint ps x where
y' = fusePoint (x':ps) y x' = fusePoint ps x
y' = fusePoint (x':ps) y
-- given list of points and collection of walls, fuses the wall ends if -- given list of points and collection of walls, fuses the wall ends if
-- they are close to the list of points or each other -- they are close to the list of points or each other
fuseWallsWith :: [Point2] -> [WallP] -> [WallP] fuseWallsWith :: [Point2] -> [WallP] -> [WallP]
fuseWallsWith zs ws = snd $ foldr fuseWalls' (zs, []) ws fuseWallsWith zs ws = snd $ foldr fuseWalls' (zs, []) ws
where fuseWalls' w (ps, ws) = let (qs, w') = fuseWall (ps, w) where
in (qs, w' : ws) fuseWalls' w (ps, ws) =
let (qs, w') = fuseWall (ps, w)
in (qs, w' : ws)
wallIsZeroLength (x,y) = x == y wallIsZeroLength (x,y) = x == y
removeWallsInPolygon :: [Point2] -> [WallP] -> [WallP] removeWallsInPolygon :: [Point2] -> [WallP] -> [WallP]
removeWallsInPolygon ps walls = filter (not . cond) walls removeWallsInPolygon ps walls = filter (not . cond) walls
where cond wall = pointInsidePolygon (fst wall) ps where
cond wall = pointInsidePolygon (fst wall) ps
&& pointInsidePolygon (snd wall) ps && pointInsidePolygon (snd wall) ps
pointInsidePolygon :: Point2 -> [Point2] -> Bool
pointInsidePolygon p (x:xs) = all (\l -> not (uncurry isRHS l (p +.+ normalizeV s))) pairs
|| any (\l -> uncurry isOnLine l p) pairs
where pairs = zip (x:xs) (xs ++ [x])
s = ((1/fromIntegral (length (x:xs))) *.* (foldr1 (+.+) (x:xs)))
-.- p
------------------------------------------------------------------------------------ ------------------------------------------------------------------------------------
-- idea: create inner walls to draw and to cast shadows -- idea: create inner walls to draw and to cast shadows
createInnerWalls :: IM.IntMap Wall -> IM.IntMap Wall createInnerWalls :: IM.IntMap Wall -> IM.IntMap Wall
src/Dodge/Rendering.hs
+1 -1
View File
@@ -28,7 +28,7 @@ import qualified Data.Set as S
worldPictures :: World -> Picture worldPictures :: World -> Picture
worldPictures w = pictures $ concat worldPictures w = pictures $ concat
[ IM.elems $ _decorations w [ IM.elems $ _decorations w
, map _ptPict . IM.elems $ _projectiles w , map _pjPict . IM.elems $ _projectiles w
, map drawItem . IM.elems $ _floorItems w , map drawItem . IM.elems $ _floorItems w
, map crDraw . IM.elems $ _creatures w , map crDraw . IM.elems $ _creatures w
, map clDraw . IM.elems $ _clouds w , map clDraw . IM.elems $ _clouds w
src/Dodge/Room/Data.hs
+1
View File
@@ -1,4 +1,5 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
module Dodge.Room.Data module Dodge.Room.Data
where where
src/Dodge/Rooms.hs
+7 -5
View File
@@ -148,12 +148,14 @@ roomC x y = Room
, _rmPS = [windowLine (x/2,0) (x/2,y-60) , _rmPS = [windowLine (x/2,0) (x/2,y-60)
] ]
--, _rmBound = rectNSWE y 0 0 x --, _rmBound = rectNSWE y 0 0 x
, _rmBound = [] , _rmBound = rectNSWE (y+5) (-5) (-5) (x+5)
} }
where lnks = [( (x-20, 0),pi) where
,( ( 20, 0),pi) lnks =
,( ( 0, 20),pi/2) [( (x-20, 0),pi)
] ,( ( 20, 0),pi)
,( ( 0, 20),pi/2)
]
makeRect :: Float -> Float -> [(Point2,Point2)] makeRect :: Float -> Float -> [(Point2,Point2)]
makeRect x y = [((0,0),(x,0)) makeRect x y = [((0,0),(x,0))
src/Dodge/Update.hs
+6 -3
View File
@@ -45,7 +45,7 @@ update w
. wallEvents . wallEvents
. set worldEvents id . set worldEvents id
$ _worldEvents w1 w1 $ _worldEvents w1 w1
where -- zoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w)) where -- zoning w = set wallsZone (IM.foldr wallInZone IM.empty (_walls w))
-- w -- w
-- wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize -- wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize
-- = insertIMInZone x y wlid wl -- = insertIMInZone x y wlid wl
@@ -68,7 +68,7 @@ updateSoundQueue = set soundQueue []
updateLightSources w = set tempLightSources (catMaybes tlss) w' updateLightSources w = set tempLightSources (catMaybes tlss) w'
where (w',tlss) = mapAccumR (\a b -> _tlsUpdate b a b) w $ _tempLightSources w where (w',tlss) = mapAccumR (\a b -> _tlsUpdate b a b) w $ _tempLightSources w
updateProjectiles w = IM.foldr' _ptUpdate w $ _projectiles w updateProjectiles w = IM.foldr' _pjUpdate w $ _projectiles w
updateParticles' :: World -> World updateParticles' :: World -> World
updateParticles' w = set particles' (catMaybes ps) w' updateParticles' w = set particles' (catMaybes ps) w'
@@ -76,7 +76,10 @@ updateParticles' w = set particles' (catMaybes ps) w'
updateCreatures :: World -> World updateCreatures :: World -> World
updateCreatures w = f $ set randGen newG $ set creatures (IM.mapMaybe id crs) w updateCreatures w = f $ set randGen newG $ set creatures (IM.mapMaybe id crs) w
where ((f,newG),crs) = IM.mapAccum (\g' cr -> _crUpdate cr w g' cr) (id,_randGen w) $ _creatures w where
((f,newG),crs) = IM.mapAccum (\g' cr -> _crUpdate cr w g' (setOldPos cr)) (id,_randGen w)
$ _creatures w
setOldPos cr = cr & crOldPos .~ _crPos cr
wallEvents :: World -> World wallEvents :: World -> World
src/Dodge/WallCreatureCollisions.hs
+45 -27
View File
@@ -14,23 +14,18 @@ colCrsWalls :: World -> World
colCrsWalls w = over creatures (fmap (colCrWall w)) w colCrsWalls w = over creatures (fmap (colCrWall w)) w
colCrWall :: World -> Creature -> Creature colCrWall :: World -> Creature -> Creature
colCrWall w c = pushOutFromWall w c colCrWall w c
| p1 == p2 = pushOrCrush ls c
pushOutFromWall :: World -> Creature -> Creature | otherwise = c & crPos %~
pushOutFromWall w c collideCorners rad p1 wallPoints
| p1 == p2 = c . collideWalls rad p1 ls
| otherwise = over crPos ( . checkPushThroughs rad p1 ls
collideCorners rad p1 wallPoints where
. rad = _crRad c + wallBuffer
collideWalls rad p1 ls p1 = _crOldPos c
. checkPushThroughs rad p1 ls p2 = _crPos c
) ls = IM.elems $ fmap _wlLine $ wallsNearPoint p2 w
c wallPoints = nub $ concat ls
where rad = _crRad c + wallBuffer
p1 = _crOldPos c
p2 = _crPos c
ls = IM.elems $ fmap _wlLine $ wallsNearPoint p2 w
wallPoints = nub $ concat ls
-- colCrPushThrough :: World -> Creature -> Creature -- colCrPushThrough :: World -> Creature -> Creature
-- colCrPushThrough w cr = set crPos (checkPushThroughs rad p1 p2 ls) cr -- colCrPushThrough w cr = set crPos (checkPushThroughs rad p1 p2 ls) cr
@@ -43,23 +38,40 @@ pushOutFromWall w c
-- the amount to push creatures out from walls, extra to their radius -- the amount to push creatures out from walls, extra to their radius
wallBuffer = 3 wallBuffer = 3
-- the following tests whether a moving circle crosses a list of walls, and -- the following tests whether or not a point is on a wall, and if so pushes it
-- places the circle accordingly. -- out from the wall
-- It supposes that the circle will only interact with at most two walls. -- If the resultant push out is itself on another wall, the original point is
-- the reverse prevents the collision from happening again with the first wall, -- returned
-- when two walls are collided with
collideWalls :: Float -> Point2 -> [[Point2]] -> Point2 -> Point2 collideWalls :: Float -> Point2 -> [[Point2]] -> Point2 -> Point2
collideWalls rad cp1 walls cp2 collideWalls rad cp1 walls cp2
= case (listToMaybe.mapMaybe (collideWall rad cp1 cp2)) walls of = case (listToMaybe.mapMaybe (pushOutFromWall rad cp2)) walls of
Nothing -> cp2 Nothing -> cp2
Just cp3 -> case (listToMaybe.reverse.mapMaybe (collideWall rad cp1 cp3)) walls of Just cp3 -> case (listToMaybe.reverse.mapMaybe (pushOutFromWall rad cp3)) walls of
Nothing -> cp3 Nothing -> cp3
Just cp4 -> cp4 Just cp4 -> cp1
-- pushes a point out from a list of walls
-- if multiple new points occur, chooses the one closest to the orignal pointjk
pushOutFromWalls :: Float -> [[Point2]] -> Point2 -> Point2
pushOutFromWalls rad walls p =
fromMaybe p
. listToMaybe
. sortBy (compare `on` dist p)
$ mapMaybe (pushOutFromWall rad p)
walls
pushOrCrush :: [[Point2]] -> Creature -> Creature
pushOrCrush wls cr = case mapMaybe (pushOutFromWall (_crRad cr) cpos) wls of
[] -> cr
[p] -> cr & crPos .~ p
_ -> cr & crState . crDamage %~ ( (Blunt 50 cpos cpos cpos) :)
where
cpos = _crPos cr
-- assumes that the wall is orientated -- assumes that the wall is orientated
-- assumes wall points are different -- assumes wall points are different
collideWall :: Float -> Point2 -> Point2 -> [Point2] -> Maybe (Point2) pushOutFromWall :: Float -> Point2 -> [Point2] -> Maybe (Point2)
collideWall rad cp1 cp2 (wp1:wp2:_) pushOutFromWall rad cp2 (wp1:wp2:_)
| isOnWall = Just newP -- +.+ (1 *.* norm)) | isOnWall = Just newP -- +.+ (1 *.* norm))
| otherwise = Nothing | otherwise = Nothing
where norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2) where norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2)
@@ -70,6 +82,12 @@ collideWall rad cp1 cp2 (wp1:wp2:_)
isJust Nothing = False isJust Nothing = False
isJust _ = True isJust _ = True
pushOutFromCorners :: World -> Creature -> Creature
pushOutFromCorners w cr = cr & crPos .~ newPos
where
newPos = foldr (intersectCirclePoint (_crRad cr)) (_crPos cr) ls
ls = nub . concat . IM.elems $ fmap _wlLine $ wallsNearPoint (_crPos cr) w
collideCorners :: Float -> Point2 -> [Point2] -> Point2 -> Point2 collideCorners :: Float -> Point2 -> [Point2] -> Point2 -> Point2
collideCorners rad p1 ps p2 = foldr (intersectCirclePoint rad) p2 ps collideCorners rad p1 ps p2 = foldr (intersectCirclePoint rad) p2 ps
src/Dodge/WorldEvent/SpawnParticle.hs
+9 -9
View File
@@ -194,19 +194,19 @@ cloudPoisonDamage c w = w & creatures %~ flip (foldr (IM.adjust doDam)) damagedC
makeTeslaArcAt :: Int -> Point2 -> Float -> Projectile makeTeslaArcAt :: Int -> Point2 -> Float -> Projectile
makeTeslaArcAt i pos dir = Projectile makeTeslaArcAt i pos dir = Projectile
{ _ptPos = pos { _pjPos = pos
, _ptStartPos = pos , _pjStartPos = pos
, _ptVel = (0,0) , _pjVel = (0,0)
, _ptPict = onLayer PtLayer $ line [(0,0),(0,0)] , _pjPict = onLayer PtLayer $ line [(0,0),(0,0)]
, _ptID = i , _pjID = i
, _ptUpdate = moveTeslaArc pos dir i , _pjUpdate = moveTeslaArc pos dir i
} }
moveTeslaArc :: Point2 -> Float -> Int -> World -> World moveTeslaArc :: Point2 -> Float -> Int -> World -> World
moveTeslaArc p d i w = moveTeslaArc p d i w =
set (projectiles . ix i . ptPict) pic set (projectiles . ix i . pjPict) pic
$ set (projectiles . ix i . ptUpdate) $ set (projectiles . ix i . pjUpdate)
(ptTimer 2 i) (pjTimer 2 i)
$ set randGen g $ set randGen g
$ createSpark 8 nc q2 (argV sv + d1) Nothing $ createSpark 8 nc q2 (argV sv + d1) Nothing
$ foldr damCrs w hitCrs $ foldr damCrs w hitCrs
src/Geometry.hs
+133 -102
View File
@@ -20,139 +20,154 @@ import Control.Applicative
-- TODO add bang patterns -- TODO add bang patterns
alongLineBy :: Float -> Point2 -> Point2 -> Point2 alongLineBy :: Float -> Point2 -> Point2 -> Point2
alongLineBy x a b = a +.+ y *.* normalizeV (b -.- a) alongLineBy !x !a !b = a +.+ y *.* normalizeV (b -.- a)
where where
y = min x $ dist a b y = min x $ dist a b
closestPointOnLine :: Point2 -> Point2 -> Point2 -> Point2 closestPointOnLine :: Point2 -> Point2 -> Point2 -> Point2
{-# INLINE closestPointOnLine #-} {-# INLINE closestPointOnLine #-}
closestPointOnLine a b p closestPointOnLine !a !b !p = a +.+ u *.* (b -.- a)
= a +.+ u *.* (b -.- a) where u = closestPointOnLineParam a b p
where u = closestPointOnLineParam a b p
closestPointOnLineParam :: Point2 -> Point2 -> Point2 -> Float closestPointOnLineParam :: Point2 -> Point2 -> Point2 -> Float
{-# INLINE closestPointOnLineParam #-} {-# INLINE closestPointOnLineParam #-}
closestPointOnLineParam a b p closestPointOnLineParam !a !b !p
= (p -.- a) `dotV` (b -.- a) / (b -.- a) `dotV` (b -.- a) = (p -.- a) `dotV` (b -.- a) / (b -.- a) `dotV` (b -.- a)
-- the following helper draws a rectangle based on maximal N E S W values -- the following helper draws a rectangle based on maximal N E S W values
rectNESW :: Float -> Float -> Float -> Float -> [Point2] rectNESW :: Float -> Float -> Float -> Float -> [Point2]
rectNESW a b c d = [(b,a),(b,c),(d,c),(d,a) rectNESW !a !b !c !d = [(b,a),(b,c),(d,c),(d,a) ]
]
rectNSEW :: Float -> Float -> Float -> Float -> [Point2] rectNSEW :: Float -> Float -> Float -> Float -> [Point2]
rectNSEW n s e w = rectNESW n e s w 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)]
-- -- the following filters points in a polygon: supposes the points in the -- -- the following filters points in a polygon: supposes the points in the
-- polygon are listed in anticlockwise order -- polygon are listed in anticlockwise order
pointInOrOnPolygon :: Point2 -> [Point2] -> Bool pointInOrOnPolygon :: Point2 -> [Point2] -> Bool
pointInOrOnPolygon p (x:xs) = all (\l -> not (uncurry isRHS l p)) $ zip (x:xs) (xs ++ [x]) pointInOrOnPolygon !p (x:xs) = all (\l -> not (uncurry isRHS l p)) $ zip (x:xs) (xs ++ [x])
pointInPolygon :: Point2 -> [Point2] -> Bool pointInPolygon :: Point2 -> [Point2] -> Bool
pointInPolygon p [] = False pointInPolygon !p [] = False
pointInPolygon p (x:xs) = all (\l -> uncurry (errorIsLHS 1) l p) $ zip (x:xs) (xs ++ [x]) pointInPolygon !p (x:xs) = all (\l -> uncurry (errorIsLHS 1) l p) $ zip (x:xs) (xs ++ [x])
pointInsidePolygon :: Point2 -> [Point2] -> Bool
pointInsidePolygon !p (x:xs) = all (\l -> not (uncurry isRHS l (p +.+ normalizeV s))) pairs
|| any (\l -> uncurry isOnLine l p) pairs
where
pairs = zip (x:xs) (xs ++ [x])
s = ((1/fromIntegral (length (x:xs))) *.* (foldr1 (+.+) (x:xs))) -.- p
errorPointInPolygon :: Int -> Point2 -> [Point2] -> Bool errorPointInPolygon :: Int -> Point2 -> [Point2] -> Bool
errorPointInPolygon i p xs | length xs == 1 = error "one point polygon" errorPointInPolygon !i !p xs
| length xs == 2 = error "two point polygon" | length xs == 1 = error "one point polygon"
| nub xs == xs = pointInPolygon p xs | length xs == 2 = error "two point polygon"
| otherwise = error $ "errorPointInPolygon "++ show i | nub xs == xs = pointInPolygon p xs
| otherwise = error $ "errorPointInPolygon "++ show i
errorNormalizeV :: Int -> Point2 -> Point2 errorNormalizeV :: Int -> Point2 -> Point2
errorNormalizeV i (0,0) = error $ "problem with function: errorNormalizeV "++show i errorNormalizeV !i !(0,0) = error $ "problem with function: errorNormalizeV "++show i
errorNormalizeV i p = normalizeV p errorNormalizeV !i !p = normalizeV p
errorAngleVV :: Int -> Point2 -> Point2 -> Float errorAngleVV :: Int -> Point2 -> Point2 -> Float
errorAngleVV i (0,0) _ = error $ "problem with function: errorAngleVV "++show i errorAngleVV !i !(0,0) _ = error $ "problem with function: errorAngleVV "++show i
errorAngleVV i _ (0,0) = error $ "problem with function: errorAngleVV "++show i errorAngleVV !i _ !(0,0) = error $ "problem with function: errorAngleVV "++show i
errorAngleVV i p p' = angleVV p p' errorAngleVV !i !p !p' = angleVV p p'
errorIsLHS :: Int -> Point2 -> Point2 -> Point2 -> Bool errorIsLHS :: Int -> Point2 -> Point2 -> Point2 -> Bool
errorIsLHS i x y | x == y = error $ "problem with function: errorIsLHS " errorIsLHS !i !x !y
++show i | x == y = error $ "problem with function: errorIsLHS " ++show i
| otherwise = isLHS x y | otherwise = isLHS x y
errorClosestPointOnLine :: Int -> Point2 -> Point2 -> Point2 -> Point2 errorClosestPointOnLine :: Int -> Point2 -> Point2 -> Point2 -> Point2
errorClosestPointOnLine i x y | x == y = error $ "problem with function: errorClosestPointOnLine " errorClosestPointOnLine !i !x !y
++show i | x == y = error $ "problem with function: errorClosestPointOnLine " ++show i
| otherwise = closestPointOnLine x y | otherwise = closestPointOnLine x y
errorClosestPointOnLineParam :: Int -> Point2 -> Point2 -> Point2 -> Float errorClosestPointOnLineParam :: Int -> Point2 -> Point2 -> Point2 -> Float
errorClosestPointOnLineParam i x y z | x == y = dist x z errorClosestPointOnLineParam !i !x! y! z
-- error $ "problem with function: errorClosestPointOnLineParam " ++show i | x == y = dist x z
| otherwise = closestPointOnLineParam x y z | otherwise = closestPointOnLineParam x y z
safeNormalizeV :: Point2 -> Point2 safeNormalizeV :: Point2 -> Point2
safeNormalizeV (0,0) = (0,0) safeNormalizeV !(0,0) = (0,0)
safeNormalizeV p = normalizeV p safeNormalizeV !p = normalizeV p
-- tests whether a point is on the LHS of a line -- tests whether a point is on the LHS of a line
-- this has been called somewhere with l1 == l2
isLHS :: Point2 -> Point2 -> Point2 -> Bool isLHS :: Point2 -> Point2 -> Point2 -> Bool
{-# INLINE isLHS #-} {-# INLINE isLHS #-}
isLHS' :: (Float, Float) -> (Float, Float) -> Point2 -> Bool isLHS' :: (Float, Float) -> (Float, Float) -> Point2 -> Bool
isLHS' l1 l2 p | l1 == l2 = False isLHS' !l1 !l2 !p
| otherwise = closestPointOnLineParam l1 (l1 +.+ vNormal (l2 -.- l1)) p < 0 | l1 == l2 = False
| otherwise = closestPointOnLineParam l1 (l1 +.+ vNormal (l2 -.- l1)) p < 0
isLHS (x,y) (x',y') (x'',y'') isLHS !(x,y) !(x',y') !(x'',y'')
| (x,y) == (x',y') = False | (x,y) == (x',y') = False
| otherwise = a1 * b2 - a2 * b1 > 0 | otherwise = a1 * b2 - a2 * b1 > 0
where a1 = x' - x where
a2 = y' - y a1 = x' - x
b1 = x'' - x a2 = y' - y
b2 = y'' - y b1 = x'' - x
b2 = y'' - y
isRHS :: Point2 -> Point2 -> Point2 -> Bool isRHS :: Point2 -> Point2 -> Point2 -> Bool
{-# INLINE isRHS #-} {-# INLINE isRHS #-}
isRHS (x,y) (x',y') (x'',y'') isRHS !(x,y) !(x',y') !(x'',y'')
| (x,y) == (x',y') = False | (x,y) == (x',y') = False
| otherwise = a1 * b2 - a2 * b1 < 0 | otherwise = a1 * b2 - a2 * b1 < 0
where a1 = x' - x where
a2 = y' - y a1 = x' - x
b1 = x'' - x a2 = y' - y
b2 = y'' - y b1 = x'' - x
--isRHS l1 l2 p = closestPointOnLineParam l1 (l1 +.+ vNormal (l2 -.- l1)) p > 0 b2 = y'' - y
-- reorders points to be anticlockwise around their center -- reorders points to be anticlockwise around their center
orderPolygon :: [Point2] -> [Point2] orderPolygon :: [Point2] -> [Point2]
orderPolygon [] = [] orderPolygon [] = []
orderPolygon ps = sortBy (compare `on` \p -> argV (p -.- cen)) ps orderPolygon ps = sortBy (compare `on` \p -> argV (p -.- cen)) ps
where cen = 1/ fromIntegral (length ps) *.* foldr1 (+.+) ps where
cen = 1/ fromIntegral (length ps) *.* foldr1 (+.+) ps
dist :: Point2 -> Point2 -> Float dist :: Point2 -> Point2 -> Float
{-# INLINE dist #-} {-# INLINE dist #-}
dist p1 p2 = magV (p2 -.- p1) dist !p1 !p2 = magV (p2 -.- p1)
pHalf :: Point2 -> Point2 -> Point2 pHalf :: Point2 -> Point2 -> Point2
pHalf a b = 0.5 *.* (a +.+ b) pHalf !a !b = 0.5 *.* (a +.+ b)
circOnLine' :: Point2 -> Point2 -> Point2 -> Float -> Bool circOnLine' :: Point2 -> Point2 -> Point2 -> Float -> Bool
circOnLine' p1 p2 c rad = isJustTrue (fmap (\p -> magV (p -.- c) < rad) y) circOnLine' !p1 !p2 !c !rad = isJustTrue (fmap (\p -> magV (p -.- c) < rad) y)
where y = intersectSegLine' p1 p2 c (c +.+ vNormal (p1 -.- p2)) where
isJustTrue (Just True) = True y = intersectSegLine' p1 p2 c (c +.+ vNormal (p1 -.- p2))
isJustTrue _ = False isJustTrue (Just True) = True
isJustTrue _ = False
-- this should probably be circOnSeg
circOnLine :: Point2 -> Point2 -> Point2 -> Float -> Bool circOnLine :: Point2 -> Point2 -> Point2 -> Float -> Bool
circOnLine p1 p2 c rad = magV (p1 -.- c) <= rad || magV (p2 -.- c) <= rad circOnLine !p1 !p2 !c !rad = magV (p1 -.- c) <= rad || magV (p2 -.- c) <= rad
|| isJustTrue (fmap (\p -> magV (p -.- c) < rad) y) || isJustTrue (fmap (\p -> magV (p -.- c) < rad) y)
where y = intersectSegLine' p1 p2 c (c +.+ vNormal (p1 -.- p2)) where
isJustTrue (Just True) = True y = intersectSegLine' p1 p2 c (c +.+ vNormal (p1 -.- p2))
isJustTrue _ = False isJustTrue (Just True) = True
isJustTrue _ = False
difference :: (Ord a, Num a) => a -> a -> a difference :: (Ord a, Num a) => a -> a -> a
difference x y | x > y = x - y difference x y
| otherwise = y - x | x > y = x - y
| otherwise = y - x
reflectIn :: Point2 -> Point2 -> Point2 reflectIn :: Point2 -> Point2 -> Point2
reflectIn line vec = let angle = 2 * angleBetween line vec reflectIn line vec =
in rotateV angle vec let angle = 2 * angleBetween line vec
in rotateV angle vec
angleBetween :: Point2 -> Point2 -> Float angleBetween :: Point2 -> Point2 -> Float
angleBetween v1 v2 = argV v1 - argV v2 angleBetween v1 v2 = argV v1 - argV v2
@@ -163,8 +178,10 @@ doublePair (x,y) = [(x,y),(y,x)]
polysIntersect :: [Point2] -> [Point2] -> Bool polysIntersect :: [Point2] -> [Point2] -> Bool
polysIntersect (p:ps) (q:qs) polysIntersect (p:ps) (q:qs)
= any isJust $ (\(a,b) (c,d) -> myIntersectSegSeg a b c d) <$> pairs1 <*> pairs2 = any isJust $ (\(a,b) (c,d) -> myIntersectSegSeg a b c d) <$> pairs1 <*> pairs2
where pairs1 = zip (p:ps) (ps++[p]) where
pairs2 = zip (q:qs) (qs++[q]) pairs1 = zip (p:ps) (ps++[p])
pairs2 = zip (q:qs) (qs++[q])
polysIntersect [] _ = False polysIntersect [] _ = False
polysIntersect _ [] = False polysIntersect _ [] = False
@@ -178,22 +195,24 @@ nRaysRad :: Int -> Float -> [Point2]
nRaysRad n x = take n $ iterate (rotateV (2*pi/fromIntegral n)) (x,0) nRaysRad n x = take n $ iterate (rotateV (2*pi/fromIntegral n)) (x,0)
-- angles go from 0 to 2pi, need to work out what is left of another -- angles go from 0 to 2pi, need to work out what is left of another
isLeftOfA :: Float -> Float -> Bool isLeftOfA :: Float -> Float -> Bool
isLeftOfA angle1 angle2 = (angle1 - angle2 < pi && angle1 > angle2) isLeftOfA angle1 angle2 =
|| (angle2 - angle1 > pi && angle2 > angle1) (angle1 - angle2 < pi && angle1 > angle2)
|| (angle2 - angle1 > pi && angle2 > angle1)
isLeftOf :: Point2 -> Point2 -> Bool isLeftOf :: Point2 -> Point2 -> Bool
isLeftOf x y = isLeftOfA (argV x) (argV y) isLeftOf x y = isLeftOfA (argV x) (argV y)
-- diffAngles has an issue... -- diffAngles has an issue...
diffAngles :: Float -> Float -> Float diffAngles :: Float -> Float -> Float
diffAngles x y | diff > pi = diffAngles (x - 2*pi) y diffAngles x y
| diff >= 0 = diff | diff > pi = diffAngles (x - 2*pi) y
| diff > -pi = -diff | diff >= 0 = diff
| otherwise = diffAngles (x + 2*pi) y | diff > -pi = -diff
where diff = x-y | otherwise = diffAngles (x + 2*pi) y
where
diff = x-y
differenceAngles = diffAngles differenceAngles = diffAngles
angleDifference = diffAngles angleDifference = diffAngles
@@ -205,9 +224,10 @@ ssaTri :: Float -> Float -> Float -> Float
ssaTri ab bc a ssaTri ab bc a
| sin a == 0 = 0 | sin a == 0 = 0
| bc == 0 = ab | bc == 0 = ab
| otherwise = let c = asin ( (ab * sin a)/bc) | otherwise =
b = pi - (a + c) let c = asin ( (ab * sin a)/bc)
in sin b * bc / sin a b = pi - (a + c)
in sin b * bc / sin a
-- fix points: we now fix the triangle in the coordinate system, and return a -- fix points: we now fix the triangle in the coordinate system, and return a
-- third unknown point: -- third unknown point:
@@ -233,8 +253,9 @@ ssaTriPointCorrect :: Point2 -> Point2 -> Point2 -> Float -> Maybe Point2
ssaTriPointCorrect pa pb pc' bc ssaTriPointCorrect pa pb pc' bc
| param <= 1 && param >= 0 = Just p | param <= 1 && param >= 0 = Just p
| otherwise = Nothing | otherwise = Nothing
where p = ssaTriPoint pa pb pc' bc where
param = closestPointOnLineParam pa pc' p p = ssaTriPoint pa pb pc' bc
param = closestPointOnLineParam pa pc' p
closestPointOnSeg :: Point2 -> Point2 -> Point2 -> Point2 closestPointOnSeg :: Point2 -> Point2 -> Point2 -> Point2
@@ -244,9 +265,10 @@ closestPointOnSeg segP1 segP2 p
| otherwise = errorClosestPointOnLine 2 segP1 segP2 p | otherwise = errorClosestPointOnLine 2 segP1 segP2 p
pointInCircle :: Point2 -> Float -> Point2 -> Maybe Point2 pointInCircle :: Point2 -> Float -> Point2 -> Maybe Point2
pointInCircle p r c | p == c = Just p pointInCircle p r c
| magV (p -.- c) < r = Just p | p == c = Just p
| otherwise = Nothing | magV (p -.- c) < r = Just p
| otherwise = Nothing
--determines if a moving point intersects with a circle, --determines if a moving point intersects with a circle,
--if so, returns a point on circle that intersects with the line passing --if so, returns a point on circle that intersects with the line passing
@@ -272,34 +294,39 @@ collidePointCircCorrect p1 p2 rad c = ssaTriPointCorrect p2 c p1 rad
-- finds the height of a triangle using herons formula -- finds the height of a triangle using herons formula
-- the base is the line between the first two points -- the base is the line between the first two points
heron :: Point2 -> Point2 -> Point2 -> Float heron :: Point2 -> Point2 -> Point2 -> Float
heron x y z | x == y = 0 heron x y z
| otherwise = let a = magV $ x -.- y | x == y = 0
b = magV $ y -.- z | otherwise =
c = magV $ z -.- x let a = magV $ x -.- y
s = (a+b+c)/2 b = magV $ y -.- z
area = sqrt(s*(s-a)*(s-b)*(s-c)) c = magV $ z -.- x
in 2*area/a s = (a+b+c)/2
area = sqrt(s*(s-a)*(s-b)*(s-c))
in 2*area/a
-- multiplies reflection in normal by factor -- multiplies reflection in normal by factor
reflectInParam :: Float -> Point2 -> Point2 -> Point2 reflectInParam :: Float -> Point2 -> Point2 -> Point2
reflectInParam x line vec = let angle = 2 * angleBetween line vec reflectInParam x line vec =
rAng = rotateV angle vec let angle = 2 * angleBetween line vec
p = x *.* errorClosestPointOnLine 3 (0,0) (vNormal line) rAng rAng = rotateV angle vec
in rAng -.- p p = x *.* errorClosestPointOnLine 3 (0,0) (vNormal line) rAng
in rAng -.- p
reflectIn' :: Point2 -> Point2 -> Point2 -> Point2 -> Point2 reflectIn' :: Point2 -> Point2 -> Point2 -> Point2 -> Point2
reflectIn' l1 l2 v1 v2 = v1 +.+ reflectIn (l1 -.- l2) (v2 -.- v1) reflectIn' l1 l2 v1 v2 = v1 +.+ reflectIn (l1 -.- l2) (v2 -.- v1)
isOnLine :: Point2 -> Point2 -> Point2 -> Bool isOnLine :: Point2 -> Point2 -> Point2 -> Bool
isOnLine l1 l2 p = errorClosestPointOnLineParam 10 l1 (l1 +.+ vNormal (l2 -.- l1)) p == 0 isOnLine l1 l2 p =
&& errorClosestPointOnLineParam 11 l1 l2 p <= 1 errorClosestPointOnLineParam 10 l1 (l1 +.+ vNormal (l2 -.- l1)) p == 0
&& errorClosestPointOnLineParam 12 l1 l2 p >= 0 && errorClosestPointOnLineParam 11 l1 l2 p <= 1
&& errorClosestPointOnLineParam 12 l1 l2 p >= 0
-- the take 5000 here is a hack, otherwise divideLine seems to sometimes -- the take 5000 here is a hack, otherwise divideLine seems to sometimes
-- generate an infinite list, and I don't know why -- generate an infinite list, and I don't know why
divideLine :: Float -> Point2 -> Point2 -> [Point2] divideLine :: Float -> Point2 -> Point2 -> [Point2]
--divideLine x a b = map (\i -> a +.+ (i / (fromIntegral numPoints)) *.* (b -.- a)) --divideLine x a b = map (\i -> a +.+ (i / (fromIntegral numPoints)) *.* (b -.- a))
divideLine x a b = take 5000 divideLine x a b =
take 5000
$ map (\i -> a +.+ (fromIntegral i / fromIntegral numPoints *.* (b -.- a)) ) $ map (\i -> a +.+ (fromIntegral i / fromIntegral numPoints *.* (b -.- a)) )
ns ns
where where
@@ -335,11 +362,12 @@ bresenham pa@(xa,ya) pb@(xb,yb) = map maySwitch . unfoldr go $ (x1,y1,0)
go (xTemp, yTemp, error) go (xTemp, yTemp, error)
| xTemp > x2 = Nothing | xTemp > x2 = Nothing
| otherwise = Just ((xTemp, yTemp), (xTemp + 1, newY, newError)) | otherwise = Just ((xTemp, yTemp), (xTemp + 1, newY, newError))
where where
tempError = error + deltay tempError = error + deltay
(newY, newError) = if (2*tempError) >= deltax (newY, newError) =
then (yTemp+ystep,tempError-deltax) if (2*tempError) >= deltax
else (yTemp,tempError) then (yTemp+ystep,tempError-deltax)
else (yTemp,tempError)
digitalLine :: (Int,Int) -> (Int,Int) -> [(Int,Int)] digitalLine :: (Int,Int) -> (Int,Int) -> [(Int,Int)]
digitalLine (x1,y1) (x2,y2) digitalLine (x1,y1) (x2,y2)
@@ -364,9 +392,12 @@ nPointsOnCirc :: Int -> Float -> [Point2]
nPointsOnCirc n rad = take n $ iterate (rotateV (2*pi/fromIntegral n)) (rad,0) nPointsOnCirc n rad = take n $ iterate (rotateV (2*pi/fromIntegral n)) (rad,0)
lineInPolygon :: Point2 -> Point2 -> [Point2] -> Bool lineInPolygon :: Point2 -> Point2 -> [Point2] -> Bool
lineInPolygon a b ps = pointInPolygon a ps || pointInPolygon b ps lineInPolygon a b ps =
|| any (isJust . uncurry (intersectSegSeg' a b)) pss pointInPolygon a ps
where pss = zip ps (tail ps ++ [head ps]) || pointInPolygon b ps
|| any (isJust . uncurry (intersectSegSeg' a b)) pss
where
pss = zip ps (tail ps ++ [head ps])
makeLoopPairs :: [Point2] -> [(Point2,Point2)] makeLoopPairs :: [Point2] -> [(Point2,Point2)]
makeLoopPairs [] = error "tried to make loop with empty list of points" makeLoopPairs [] = error "tried to make loop with empty list of points"