diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index 4a6325e1e..e6f828fd4 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -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. diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index f0c636efe..2960b6d1d 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -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 diff --git a/src/Dodge/Magnet.hs b/src/Dodge/Magnet.hs index b02a3ba1d..5c7e9a9fe 100644 --- a/src/Dodge/Magnet.hs +++ b/src/Dodge/Magnet.hs @@ -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 diff --git a/src/Dodge/Particle/Bullet/HitEffect.hs b/src/Dodge/Particle/Bullet/HitEffect.hs index af9b81a33..d57be16c6 100644 --- a/src/Dodge/Particle/Bullet/HitEffect.hs +++ b/src/Dodge/Particle/Bullet/HitEffect.hs @@ -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 diff --git a/src/Dodge/Particle/Bullet/Spawn.hs b/src/Dodge/Particle/Bullet/Spawn.hs index 228a4e9c0..21ed10ee3 100644 --- a/src/Dodge/Particle/Bullet/Spawn.hs +++ b/src/Dodge/Particle/Bullet/Spawn.hs @@ -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 diff --git a/src/Dodge/Particle/Bullet/Update.hs b/src/Dodge/Particle/Bullet/Update.hs index f49db782c..c1647cef4 100644 --- a/src/Dodge/Particle/Bullet/Update.hs +++ b/src/Dodge/Particle/Bullet/Update.hs @@ -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 diff --git a/src/Dodge/Particle/Spark.hs b/src/Dodge/Particle/Spark.hs index 9e55e6da6..9e8ff3a38 100644 --- a/src/Dodge/Particle/Spark.hs +++ b/src/Dodge/Particle/Spark.hs @@ -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 diff --git a/src/Dodge/WorldEvent/HitEffect.hs b/src/Dodge/WorldEvent/HitEffect.hs index c8b0b98e0..0f01f0d23 100644 --- a/src/Dodge/WorldEvent/HitEffect.hs +++ b/src/Dodge/WorldEvent/HitEffect.hs @@ -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 diff --git a/src/Dodge/WorldEvent/SpawnParticle.hs b/src/Dodge/WorldEvent/SpawnParticle.hs index 33b66770a..c45bae1a1 100644 --- a/src/Dodge/WorldEvent/SpawnParticle.hs +++ b/src/Dodge/WorldEvent/SpawnParticle.hs @@ -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 diff --git a/src/Dodge/WorldEvent/ThingsHit.hs b/src/Dodge/WorldEvent/ThingsHit.hs index 9051525da..2d3d2173c 100644 --- a/src/Dodge/WorldEvent/ThingsHit.hs +++ b/src/Dodge/WorldEvent/ThingsHit.hs @@ -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)) diff --git a/src/Geometry.hs b/src/Geometry.hs index 54042d44e..37634f725 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -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 diff --git a/src/Geometry/Intersect.hs b/src/Geometry/Intersect.hs index 2408df2ae..3171680a1 100644 --- a/src/Geometry/Intersect.hs +++ b/src/Geometry/Intersect.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs index cf2bd770a..83a3025f8 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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