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

Remove ssaTri, bullet movement is broken

Browse Source
This commit is contained in:
justin
2021-12-15 17:34:20 +00:00
parent dccacd9d22
commit adab32bf68
13 changed files with 74 additions and 213 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base.hs
+3 -51
View File
@@ -191,50 +191,6 @@ newProjectileKey = IM.newKey . _props
{- | Finds unused creature key. -}
newCrKey :: World -> Int
newCrKey = IM.newKey . _creatures
{- | TODO: determine precisely what this does. -}
reflectPointCreature :: Point2 -> Point2 -> Creature -> Maybe (Point2, Point2, Int)
reflectPointCreature p1 p2 cr = case intersectCircSegFirst (_crPos cr) (_crRad cr) p1 p2 of
Nothing -> Nothing
Just a -> Just
( p1
, errorNormalizeV 35 (ssaTriPoint p2 (_crPos cr) p1 (_crRad cr) -.- _crPos cr)
+.+ (_crPos cr -.- _crOldPos cr)
, _crID cr)
{- | TODO: determine precisely what this does. -}
reflectPointCreatures :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe (Point2,Point2,Int)
reflectPointCreatures p1 p2 cs
= safeMinimumOn f
$ IM.mapMaybe (reflectPointCreature p1 p2) cs
where
f (a,_,_) = magV (a -.- p1)
{- | TODO: determine precisely what this does. -}
reflectCircCreature
:: Float -- ^ Radius
-> Point2 -- ^ Start point
-> Point2 -- ^ End point
-> Creature
-> Maybe (Point2, Point2, Int)
reflectCircCreature rad p1 p2 cr = case intersectCircSegFirst (_crPos cr) (rad + _crRad cr) p1 p2 of
Nothing -> Nothing
Just _ -> Just
( p1
, errorNormalizeV 37 (ssaTriPoint p2 (_crPos cr) p1 (_crRad cr) -.- _crPos cr)
+.+ (_crPos cr -.- _crOldPos cr)
, _crID cr
)
{- | TODO: determine precisely what this does. -}
reflectCircCreatures
:: Float -- ^ Radius
-> Point2 -- ^ Start point
-> Point2 -- ^ End point
-> IM.IntMap Creature
-> Maybe (Point2,Point2,Int)
reflectCircCreatures rad p1 p2 cs
= safeMinimumOn f
$ IM.mapMaybe (reflectCircCreature rad p1 p2) cs
where
f (a,_,_) = magV (a -.- p1)
-- | collides a point with forcefields
-- if found, returns point of collision, deflection if required, and the id
collidePointFFs :: a
@@ -336,12 +292,10 @@ collidePointWallsNorm p1 p2 ws
f (a,_) = magV (p1 -.- a)
-- | Returns the first creature, if any, that a point intersects with.
collidePointCreatures :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe Int
collidePointCreatures p1 p2 crs
= fmap fst
collidePointCreatures p1 p2 = fmap fst
. safeMinimumOn snd
. IM.toList
. IM.mapMaybe (\x -> fmap (dist p1) $ intersectCircSegFirst (_crPos x) (_crRad x) p1 p2)
$ crs
. IM.mapMaybe (\x -> dist p1 <$> intersectCircSegFirst (_crPos x) (_crRad x) p1 p2)
-- | As for 'collidePointCreatures', only increases the radius of creatures by a
--fixed amount, thus collides a moving circle with creaures.
collideCircCreatures :: Point2 -> Point2 -> Float -> IM.IntMap Creature -> Maybe Int
@@ -350,12 +304,10 @@ collideCircCreatures p1 p2 rad = collidePointCreatures p1 p2 . fmap (crRad +~ ra
-- | Returns the first creature id, if any, that a point intersects with, gives point
--in creature on line.
collidePointCrsPoint :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe (Point2,Int)
collidePointCrsPoint p1 p2 crs
= fmap f
collidePointCrsPoint p1 p2 = fmap f
. safeMinimumOn (dist p1 . snd)
. IM.toList
. IM.mapMaybe (\x -> intersectCircSegFirst (_crPos x) (_crRad x) p1 p2)
$ crs
where
f (cID,p) = (p,cID)
{- | Finds the first creature hit on a line.
src/Dodge/Data.hs
+2 -2
View File
@@ -463,7 +463,7 @@ data Particle
| BulletPt
{ _ptDraw :: Particle -> Picture
, _ptUpdate :: World -> Particle -> (World, Maybe Particle)
, _btVel' :: Point2
, _ptVel :: Point2
, _btDrag :: Float
, _btColor' :: Color
, _btTrail' :: [Point2]
@@ -475,7 +475,7 @@ data Particle
| PtZ
{ _ptDraw :: Particle -> Picture
, _ptUpdate :: World -> Particle -> (World, Maybe Particle)
, _btVel' :: Point2
, _ptVel :: Point2
, _btColor' :: Color
, _btPos' :: Point2
, _btPassThrough' :: Maybe Int
src/Dodge/Magnet.hs
+3 -3
View File
@@ -6,17 +6,17 @@ import Control.Lens
dampField :: Magnet -> Particle -> Particle
dampField mg pt = case pt of
BulletPt{} | dist (head $ _btTrail' pt) (_mgPos mg) < 100 -> pt & btVel' *~ 0.5
BulletPt{} | dist (head $ _btTrail' pt) (_mgPos mg) < 100 -> pt & ptVel *~ 0.5
_ -> pt
curveLeftField :: Magnet -> Particle -> Particle
curveLeftField mg pt = case pt of
BulletPt{} | dist (head $ _btTrail' pt) (_mgPos mg) < 500 -> pt & btVel' %~ rotateV 0.2
BulletPt{} | dist (head $ _btTrail' pt) (_mgPos mg) < 500 -> pt & ptVel %~ rotateV 0.2
_ -> pt
curveAroundField :: Float -> Float -> Magnet -> Particle -> Particle
curveAroundField minrad maxrad mg pt = case pt of
BulletPt{} | thedist < maxrad -> pt & btVel' %~ rotateToCircle
BulletPt{} | thedist < maxrad -> pt & ptVel %~ rotateToCircle
where
thedist = dist btpos mgpos
mgpos = _mgPos mg
src/Dodge/Particle/Bullet/HitEffect.hs
+14 -14
View File
@@ -28,7 +28,7 @@ bulHitCr bt p cr w
| otherwise = addDamage . bulletHitSound p $ w
where
sp = head $ _btTrail' bt
bulVel = _btVel' bt
bulVel = _ptVel bt
ep = sp +.+ bulVel
mvDams = [ PushDam 1 $ 2 *.* bulVel ]
addDamage = creatures . ix cid . crState . crDamage %~ ((Piercing 100 sp p ep : mvDams) ++ )
@@ -46,7 +46,7 @@ bulBounceArmCr' bt p cr w
| otherwise = addDamage . bulletHitSound p $ w
where
sp = head $ _btTrail' bt
bulVel = _btVel' bt
bulVel = _ptVel bt
ep = sp +.+ bulVel
mvDams = [ PushDam 1 $ 2 *.* bulVel ]
addDamage = creatures . ix cid . crState . crDamage %~ ((Piercing 100 sp p ep : mvDams) ++ )
@@ -77,9 +77,9 @@ bulPenCr' bt p cr w
(d1,_) = randomR (-0.7,0.7) $ _randGen w
cid = _crID cr
sp = head $ _btTrail' bt
ep = sp +.+ _btVel' bt
ep = sp +.+ _ptVel bt
addPiercer = over particles (piercer :)
piercer = (aGenBulAt (Just cid) p (_btVel' bt) (_btDrag bt)
piercer = (aGenBulAt (Just cid) p (_ptVel bt) (_btDrag bt)
(_btHitEffect' bt) (_btWidth' bt)
) {_btTimer' = _btTimer' bt - 1}
{- | Heavy bullet effects when hitting creature:
@@ -100,7 +100,7 @@ hvBulHitCr bt p cr w
(d1,_) = randomR (-0.7,0.7) $ _randGen w
cid = _crID cr
sp = head $ _btTrail' bt
ep = sp +.+ _btVel' bt
ep = sp +.+ _ptVel bt
{- | Create a flamelet when hitting a creature. -}
bulIncCr :: Particle -> Point2 -> Creature -> World -> World
bulIncCr bt p cr w
@@ -112,7 +112,7 @@ bulIncCr bt p cr w
where
cid = _crID cr
sp = head $ _btTrail' bt
ep = sp +.+ _btVel' bt
ep = sp +.+ _ptVel bt
v = evalState (randInCirc 1) $ _randGen w
incFlamelets = over worldEvents $ (.) (makeFlameletTimed p 20 v Nothing 3 20)
{- | Creates a shockwave when hitting a creature. -}
@@ -124,23 +124,23 @@ bulConCr bt p cr
where
cid = _crID cr
sp = head $ _btTrail' bt
ep = sp +.+ _btVel' bt
ep = sp +.+ _ptVel bt
{- | Hitting wall effects: create a spark, damage blocks. -}
bulHitWall :: Particle -> Point2 -> Wall -> World -> World
bulHitWall bt p = damageWall (Piercing 100 sp p ep)
where
ep = sp +.+ _btVel' bt
ep = sp +.+ _ptVel bt
sp = head $ _btTrail' bt
{- | Bounce off walls, do damage to blocks. -}
bulBounceWall :: Particle -> Point2 -> Wall -> World -> World
bulBounceWall bt p wl = damageWall (Blunt 50 sp p ep) wl . over worldEvents addBouncer
where
ep = sp +.+ _btVel' bt
ep = sp +.+ _ptVel bt
sp = head $ _btTrail' bt
pOut = p +.+ squashNormalizeV (sp -.- p)
bouncer = (aGenBulAt Nothing pOut reflectVel 0.5 (_btHitEffect' bt) (_btWidth' bt)
) {_btTimer' = _btTimer' bt - 1}
reflectVel = reflVelWall wl (_btVel' bt)
reflectVel = reflVelWall wl (_ptVel bt)
addBouncer = ( over particles (bouncer : ) . )
-- the hack is to get around the fact that the particles list gets reset after
-- all projectiles in it are checked, so we cannot add to it as we accumulate over
@@ -155,11 +155,11 @@ bulIncWall
-> World
bulIncWall bt p wl = damageWall (Blunt 50 sp p ep) wl . incFlamelets
where
ep = sp +.+ _btVel' bt
ep = sp +.+ _ptVel bt
sp = head $ _btTrail' bt
pOut = p +.+ squashNormalizeV (sp -.- p)
wallV = uncurry (-.-) (_wlLine wl)
reflectVel = squashNormalizeV $ reflectIn wallV (_btVel' bt)
reflectVel = squashNormalizeV $ reflectIn wallV (_ptVel bt)
incFlamelets = over worldEvents $ (.) (makeFlameletTimed pOut 20 reflectVel Nothing 3 20)
{- | Create a shockwave on wall-}
bulConWall
@@ -171,7 +171,7 @@ bulConWall
bulConWall bt p wl = damageWall (Blunt 10 sp p ep) wl .
over worldEvents ( makeShockwaveAt [] p 15 4 1 white . )
where
ep = sp +.+ _btVel' bt
ep = sp +.+ _ptVel bt
sp = head $ _btTrail' bt
hvBulHitWall
@@ -184,7 +184,7 @@ hvBulHitWall bt p wl w = damageWall (Piercing 200 sp p ep) wl
. damageWall (Blunt 100 sp p ep) wl
$ set randGen g $ foldr ($) w (sparks pOut sv)
where
ep = sp +.+ _btVel' bt
ep = sp +.+ _ptVel bt
sp = head $ _btTrail' bt
pOut = p +.+ squashNormalizeV (sp -.- p)
(a, g) = randomR (-0.2,0.2) $ _randGen w
src/Dodge/Particle/Bullet/Spawn.hs
+5 -5
View File
@@ -23,7 +23,7 @@ aGenBulAt
aGenBulAt maycid pos vel drag hiteff width = BulletPt
{ _ptDraw = drawBul
, _ptUpdate = mvBullet
, _btVel' = vel
, _ptVel = vel
, _btDrag = drag
, _btColor' = V4 2 2 2 2
, _btTrail' = [pos]
@@ -44,7 +44,7 @@ aDelayedBulAt
aDelayedBulAt vfact maycid pos vel drag hiteff width = BulletPt
{ _ptDraw = drawBul
, _ptUpdate = \w -> resetVel . mvBullet w
, _btVel' = vfact *.* vel
, _ptVel = vfact *.* vel
, _btDrag = drag
, _btColor' = V4 2 2 2 2
, _btTrail' = [pos]
@@ -54,7 +54,7 @@ aDelayedBulAt vfact maycid pos vel drag hiteff width = BulletPt
, _btHitEffect' = hiteff
}
where
resetVel = second $ fmap $ (ptUpdate .~ mvBullet) . (btVel' .~ vel)
resetVel = second $ fmap $ (ptUpdate .~ mvBullet) . (ptVel .~ vel)
aCurveBulAt
:: Maybe Int -- ^ Pass-through creature id
@@ -68,7 +68,7 @@ aCurveBulAt
aCurveBulAt maycid col pos control targ hiteff width = BulletPt
{ _ptDraw = drawBul
, _ptUpdate = \w -> mvBullet w . setVel
, _btVel' = V2 0 0
, _ptVel = V2 0 0
, _btDrag = 1
, _btColor' = col
, _btTrail' = [pos]
@@ -78,5 +78,5 @@ aCurveBulAt maycid col pos control targ hiteff width = BulletPt
, _btHitEffect' = hiteff
}
where
setVel pt = pt & btVel' .~ bf (fromIntegral $ _btTimer' pt - 1) -.- bf (fromIntegral $ _btTimer' pt)
setVel pt = pt & ptVel .~ bf (fromIntegral $ _btTimer' pt - 1) -.- bf (fromIntegral $ _btTimer' pt)
bf t = bQuadToF (pos,control,targ) $ (100 - t) * 0.05
src/Dodge/Particle/Bullet/Update.hs
+4 -4
View File
@@ -1,4 +1,4 @@
{-# LANGUAGE TupleSections #-}
--{-# LANGUAGE TupleSections #-}
{- Bullet update. -}
module Dodge.Particle.Bullet.Update
( mvBullet
@@ -15,15 +15,15 @@ import Control.Lens
{- Update for a generic bullet. -}
mvBullet :: World -> Particle -> (World, Maybe Particle)
mvBullet w bt'
| t <= 0 || magV (_btVel' bt) < 1 = (w,Nothing)
| t <= 0 || magV (_ptVel bt) < 1 = (w,Nothing)
| otherwise = second (fmap dodrag) $
hiteff bt (thingsHitExceptCr mcr p (p +.+ vel) w) w
where
bt = foldr (\mg b -> _mgField mg mg b) bt' $ _magnets w
dodrag = btVel' %~ (drag *.*)
dodrag = ptVel %~ (drag *.*)
drag = _btDrag bt
mcr = _btPassThrough' bt
(p:_) = _btTrail' bt
vel = _btVel' bt
vel = _ptVel bt
hiteff = _btHitEffect' bt
t = _btTimer' bt
src/Dodge/Particle/Spark.hs
+17 -19
View File
@@ -16,30 +16,28 @@ import System.Random
--import Control.Lens
createBarrelSpark :: Point2 -> Float -> Maybe Int -> Int -> Int -> World -> World
createBarrelSpark pos dir maycid time colid w = w
& instantParticles .:~ spark
createBarrelSpark pos dir maycid time colid = instantParticles .:~ BulletPt
{ _ptDraw = drawBul
, _ptUpdate = mvBullet
, _ptVel = rotateV dir (V2 5 0)
, _btDrag = 0.9
, _btColor' = numColor colid
, _btTrail' = [pos]
, _btPassThrough' = maycid
, _btWidth' = 1
, _btTimer' = time
, _btHitEffect' = destroyOnImpact sparkEff noEff
}
where
spark = BulletPt
{ _ptDraw = drawBul
, _ptUpdate = mvBullet
, _btVel' = rotateV dir (V2 5 0)
, _btDrag = 0.9
, _btColor' = numColor colid
, _btTrail' = [pos]
, _btPassThrough' = maycid
, _btWidth' = 1
, _btTimer' = time
, _btHitEffect' = destroyOnImpact sparkEff noEff
}
sparkEff bt p cr = creatures . ix (_crID cr) . crState . crDamage .:~ SparkDam 1 sp p ep
where
where
sp = head (_btTrail' bt)
ep = sp +.+ _btVel' bt
ep = sp +.+ _ptVel bt
colSpark :: Int -> Color -> Point2 -> Float -> World -> World
colSpark = colSpark' 0.7
colSpark' :: Float -> Int -> Color -> Point2 -> Float -> World -> World
colSpark' randDir time col pos baseDir w = w
& worldEvents %~ ( over particles (spark :) . )
& instantParticles .:~ spark
& randGen .~ g
where
(a,g) = randomR (-randDir,randDir) $ _randGen w
@@ -48,7 +46,7 @@ colSpark' randDir time col pos baseDir w = w
{ _ptDraw = drawBul
, _ptUpdate = mvBullet
, _btDrag = 0.9
, _btVel' = rotateV dir (V2 5 0)
, _ptVel = rotateV dir (V2 5 0)
, _btColor' = col
, _btTrail' = [pos]
, _btPassThrough' = Nothing
@@ -59,4 +57,4 @@ colSpark' randDir time col pos baseDir w = w
sparkEff bt p cr = creatures . ix (_crID cr) . crState . crDamage %~ ( SparkDam 1 sp p ep : )
where
sp = head (_btTrail' bt)
ep = sp +.+ _btVel' bt
ep = sp +.+ _ptVel bt
src/Dodge/WorldEvent/HitEffect.hs
+3 -3
View File
@@ -47,7 +47,7 @@ mvPt pt = Just $ pt
& btTimer' -~ 1
& btPassThrough' .~ Nothing
where
f trl = head trl +.+ _btVel' pt : trl
f trl = head trl +.+ _ptVel pt : trl
destroyAt :: Point2 -> Particle -> Maybe Particle
destroyAt hitp pt = Just $ pt
@@ -60,7 +60,7 @@ killBulletUpdate w pt
| _btTimer' pt <= 0 = (w,Nothing)
| otherwise = (w
,Just $ pt & btTimer' -~ 1
& btTrail' %~ (\(x:xs) -> (x:x:xs))
& btTrail' %~ (\(x:xs) -> x:x:xs)
)
penWalls
@@ -82,7 +82,7 @@ doFlameDam amount pt p cr = creatures . ix (_crID cr) . crState . crDamage %~
(Flaming amount sp p ep :)
where
sp = _btPos' pt
ep = sp +.+ _btVel' pt
ep = sp +.+ _ptVel pt
noEff :: a -> b -> c -> d -> d
noEff _ _ _ = id
src/Dodge/WorldEvent/SpawnParticle.hs
+11 -12
View File
@@ -20,8 +20,8 @@ import Geometry
--import Geometry.Vector3D
--import Geometry.Data
import qualified IntMapHelp as IM
import LensHelp
import Control.Lens
import System.Random
import Control.Monad.State
import Data.Tuple
@@ -34,7 +34,7 @@ aFlameParticle
aFlameParticle t pos vel maycid = PtZ
{ _ptDraw = drawFlame vel
, _ptUpdate = moveFlame vel
, _btVel' = vel
, _ptVel = vel
, _btColor' = red
, _btPos' = pos
, _btPassThrough' = maycid
@@ -90,13 +90,13 @@ moveFlame rotd w pt
time = _btTimer' pt
doSound = soundContinue Flame (V2 x y) fireLoudS (Just 2)
sp@(V2 x y) = _btPos' pt
vel = _btVel' pt
vel = _ptVel pt
ep = sp +.+ vel
mvPt speed = Just $ pt
{ _btTimer' = time - 1
, _btPos' = ep
, _btPassThrough' = Nothing
, _btVel' = speed *.* vel }
, _ptVel = speed *.* vel }
damcrs = foldr (\cr -> fst . hiteff [(ep,Left cr)]) w
$ IM.filter closeCrs $ _creatures w
closeCrs cr = dist ep (_crPos cr)
@@ -107,7 +107,7 @@ moveFlame rotd w pt
rfl wl p = Just $ pt
{ _btTimer' = time -1
, _btPos' = pOut p
, _btVel' = reflV wl
, _ptVel = reflV wl
}
pOut p = p +.+ squashNormalizeV (sp -.- p)
reflV wall = (0.3 *.* reflectIn (uncurry (-.-) . swap $ _wlLine wall) vel )
@@ -124,12 +124,10 @@ makeFlameletTimed
-> World
makeFlameletTimed (V2 x y) z vel maycid size time w = w
& randGen .~ g
& particles %~ (theFlamelet :)
where
theFlamelet = PtZ
& particles .:~ PtZ
{ _ptDraw = drawFlameletZ rot
, _ptUpdate = moveFlamelet
, _btVel' = vel
, _ptVel = vel
, _btColor' = red
, _btPos' = V2 x y
, _btPassThrough' = maycid
@@ -138,6 +136,7 @@ makeFlameletTimed (V2 x y) z vel maycid size time w = w
, _btHitEffect' = destroyOnImpact (doFlameDam 1) noEff
, _ptZ = z
}
where
(rot ,g) = randomR (0,3) $ _randGen w
drawFlameletZ
@@ -152,7 +151,7 @@ drawFlameletZ rot pt = pictures
where
z = _ptZ pt
sp = _btPos' pt
vel = _btVel' pt
vel = _ptVel pt
ep = sp +.+ vel
size = _btWidth' pt
siz2 = size + 0.2
@@ -193,13 +192,13 @@ moveFlamelet w pt
| otherwise = (flameFlicker pt damcrs, mvPt)
where
sp = _btPos' pt
vel = _btVel' pt
vel = _ptVel pt
ep = sp +.+ vel
size = _btWidth' pt
mvPt = Just $ pt & btTimer' -~ 1
& btPos' .~ ep
& btPassThrough' .~ Nothing
& btVel' .~ 0.8 *.* vel
& ptVel .~ 0.8 *.* vel
damcrs = w & creatures %~ IM.map damifclose
isClose cr = dist ep (_crPos cr) < _crRad cr + size
damifclose cr
src/Dodge/WorldEvent/ThingsHit.hs
+9 -55
View File
@@ -7,7 +7,6 @@ module Dodge.WorldEvent.ThingsHit
, thingHit
, thingsHitLongLine
, thingsHitExceptCr
, thingsHitExceptCr3D'
, thingsHitExceptCrLongLine
)
where
@@ -19,7 +18,7 @@ import Geometry
import qualified Data.IntMap.Strict as IM
import Data.List
import Data.Maybe
import Data.Bifunctor
--import Data.Bifunctor
{- List those objects that appear on a line. -}
thingsHit
:: Point2 -- ^ Line start point
@@ -30,67 +29,22 @@ thingsHit sp ep w
| sp == ep = []
| otherwise = sortOn (dist sp . fst) (crs ++ wls)
where
hitCrs = IM.elems
$ IM.filter (\cr -> circOnSeg sp ep (_crPos cr) (_crRad cr))
crs = mapMaybe
(\cr -> (,Left cr) <$> listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp ep))
. IM.elems
$ _creatures w
-- $ creaturesAlongLine sp ep w
crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs
crs = zip crPs (map Left hitCrs)
hitWls = wallsOnLine sp ep (IM.unions [f b $ f a $ _znObjects $ _wallsZone w | a<-[x-1,x,x+1]
, b<-[y-1,y,y+1]])
--hitWls = wallsOnLine sp ep $ _walls w
hitWls = wallsOnLine sp ep
$ IM.unions [f b $ f a $ _znObjects $ _wallsZone w
| a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
-- $ _walls w
(x,y) = zoneOfPoint (0.5 *.* (sp +.+ ep))
f i m = case IM.lookup i m of
Just val -> val
_ -> IM.empty
wls = zip (map (fromJust . hitPoint) hitWls) (map Right hitWls)
hitPoint w' = uncurry (intersectSegSeg sp ep) (_wlLine w')
{- List those objects that appear on a line. -}
thingsHit3D
:: Point3 -- ^ Line start point
-> Point3 -- ^ Line end point
-> World
-> [(Point3, Either Creature Wall)]
thingsHit3D sp ep w
| sp == ep = []
| otherwise = sortOn (dist3 sp . fst) (crs ++ wls)
where
hitCrs = IM.elems
$ IM.filter (\cr -> circOnSeg (stripZ sp) (stripZ ep) (_crPos cr) (_crRad cr))
$ _creatures w
crPs = map (\cr -> ssaTriPoint (stripZ ep) (_crPos cr) (stripZ sp) (_crRad cr)) hitCrs
crs = zip (map (addZ 20) crPs) (map Left hitCrs)
hitWls = wallsOnLine (stripZ sp) (stripZ ep)
(IM.unions [f b $ f a $ _znObjects $ _wallsZone w | a<-[x-1,x,x+1]
, b<-[y-1,y,y+1]])
(x,y) = zoneOfPoint (0.5 *.* (stripZ sp +.+ stripZ ep))
f i m = case IM.lookup i m of
Just val -> val
_ -> IM.empty
wls = zip (map (addZ 20 . fromJust . hitPoint) hitWls) (map Right hitWls)
hitPoint w' = uncurry (intersectSegSeg (stripZ sp) (stripZ ep)) (_wlLine w')
thingHit :: Point2 -> Point2 -> World -> Maybe (Point2, Either Creature Wall)
thingHit sp ep = listToMaybe . thingsHit sp ep
thingsHitExceptCr3D'
:: Maybe Int -- ^ A possible creature ID
-> Point3 -- ^ Line start point
-> Point3 -- ^ Line end point
-> World
-> [(Point2, Either Creature Wall)]
thingsHitExceptCr3D' mcid sp ep = fmap (first stripZ) . thingsHitExceptCr3D mcid sp ep
{- List objects that appear on a line.
Can filter out a creature. -}
thingsHitExceptCr3D
:: Maybe Int -- ^ A possible creature ID
-> Point3 -- ^ Line start point
-> Point3 -- ^ Line end point
-> World
-> [(Point3, Either Creature Wall)]
thingsHitExceptCr3D Nothing sp ep = thingsHit3D sp ep
thingsHitExceptCr3D (Just cid) sp ep = filter crNotCid . thingsHit3D sp ep
where
crNotCid (_,Left cr) = _crID cr /= cid
crNotCid _ = True
{- List objects that appear on a line.
Can filter out a creature. -}
thingsHitExceptCr
@@ -120,7 +74,7 @@ thingsHitExceptCrLongLine (Just cid) sp ep = filter crNotCid . thingsHitLongLine
thingsHitLongLine :: Point2 -> Point2 -> World -> [(Point2, Either Creature Wall)]
thingsHitLongLine sp ep w
| sp == ep = []
| otherwise = sortOn (dist sp . fst) (crs ++ wls)
| otherwise = sortOn (dist sp . fst) (crs ++ wls)
where
crs = mapMaybe
(\cr -> (,Left cr) <$> listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp ep))
src/Geometry.hs
+1 -43
View File
@@ -164,55 +164,13 @@ diffAngles x y
| otherwise = diffAngles (x + 2*pi) y
where
diff = x-y
-- | Given a triangle where we know the length of a first side,
-- the length of a second side, and the angle between the first side and the
-- third side, finds the length of the third side.
-- Note this doesn't necessarily find ALL solutions, asin is a map not a function.
ssaTri :: Float -> Float -> Float -> Float
ssaTri ab bc a
| sin a == 0 = ab - bc
| bc == 0 = ab
| otherwise =
let c = asin ( (ab * sin a)/bc)
b = pi - (a + c)
in sin b * bc / sin a
-- | Given two points of a triangle and a third point, return
-- the point which lies between pa and pc' on a line from pb of length bc.
-- Note that there are likely two such points, this should return the point
-- closer to pc'.
-- TODO this still causes errors, should be made error free
ssaTriPoint :: Point2 -> Point2 -> Point2 -> Float -> Point2
ssaTriPoint pa pb pc' bc
= let ab = magV (pa -.- pb)
a = errorAngleVV 6 (pb -.- pa) (pc' -.- pa)
ac = ssaTri ab bc a
in pa +.+ (ac *.* errorNormalizeV 47 (pc' -.- pa))
-- | Safe version of 'ssaTriPoint'.
--ssaTriPoint' :: Point2 -> Point2 -> Point2 -> Float -> Maybe Point2
--ssaTriPoint' pa pb pc' bc
-- | dist pb (closestPointOnSeg pa pc' pb) >= bc
-- = Nothing
-- | otherwise
-- = Just $ ssaTriPoint pa pb pc' bc
-- | Return Just a point if it is inside a circle, Nothing otherwise.
pointInCircle :: Point2 -> Float -> Point2 -> Maybe Point2
pointInCircle p r c
| p == c = Just p
| magV (p -.- c) < r = Just p
| otherwise = Nothing
-- | Determines if a moving point intersects with a circle,
-- if so, returns a point on circle that intersects with the line passing
-- throught the circle : HOPEFULLY THE CORRECT OF THE TWO!
--collidePointCirc :: Point2 -> Point2 -> Float -> Point2 -> Maybe Point2
--collidePointCirc p1 p2 rad c = ssaTriPoint' p2 c p1 rad
-- | As 'collidePointCirc', but changes the point to a measure of the distance.
--collidePointCirc' :: Point2 -> Point2 -> Float -> Point2 -> Maybe Float
--collidePointCirc' p1 p2 rad c = fmap (\x -> magV (x -.- p1))
-- (collidePointCirc p1 p2 rad c)
-- | As 'collidePointCirc', but returns both the point and the measure of the distance.
--collidePointCirc'' :: Point2 -> Point2 -> Float -> Point2 -> Maybe (Point2,Float)
--collidePointCirc'' p1 p2 rad c = (,) <$> collidePointCirc p1 p2 rad c
-- <*> collidePointCirc' p1 p2 rad c
-- | Finds the height of a triangle using herons formula.
-- The base is the line between the first two points.
heron :: Point2 -> Point2 -> Point2 -> Float
src/Geometry/Intersect.hs
+1 -1
View File
@@ -247,7 +247,7 @@ closestPointOnSeg segP1 segP2 p
orthogonalPointOnSeg :: Point2 -> Point2 -> Point2 -> Maybe Point2
orthogonalPointOnSeg a b p
| param < 0 || param > 1 = Nothing
| otherwise = Just $ a +.+ param *.* (normalizeV $ b -.- a)
| otherwise = Just $ a +.+ param *.* normalizeV (b -.- a)
where
param = closestPointOnLineParam a b p
test/Spec.hs
+1 -1
View File
@@ -3,7 +3,7 @@ import Test.Tasty
import qualified Test.Tasty.QuickCheck as QC
import Test.Tasty.HUnit
import Dodge.Room.CheckConsistency
import Geometry
--import Geometry
import Dodge.LevelGen.StaticWalls
import Geometry