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

Use tasty for tests, fix bug in circOnLine

Browse Source
This commit is contained in:
justin
2021-12-14 11:50:01 +00:00
parent ec51efabca
commit 47391f3850
19 changed files with 143 additions and 113 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Item/Weapon/BatteryGuns.hs
+17 -24
View File
@@ -3,8 +3,7 @@ module Dodge.Item.Weapon.BatteryGuns
, teslaGun
, tractorGun
, makeLaserAt
)
where
) where
import Dodge.Data
import Dodge.Creature.HandPos
import Dodge.Particle.TeslaArc
@@ -27,11 +26,9 @@ import ShapePicture
import Dodge.Picture
import LensHelp
--import Data.Function
--import qualified Data.Sequence as Seq
import Data.List
import Data.Bifunctor
import System.Random
--import Data.Maybe
import Data.Tuple
import qualified Data.IntMap.Strict as IM
teslaGun :: Item
@@ -161,7 +158,7 @@ aTeslaArc cr w = set randGen g w
aLaser :: Item -> Creature -> World -> World
aLaser it cr = particles .:~ makeLaserAt phasev pos dir
where
pos = _crPos cr +.+ (aimingMuzzlePos cr it) *.* unitVectorAtAngle dir
pos = _crPos cr +.+ aimingMuzzlePos cr it *.* unitVectorAtAngle dir
dir = _crDir cr
phasev = _phaseV . _itParams $ _crInv cr IM.! j
j = _crInvSel cr
@@ -171,34 +168,34 @@ makeLaserAt phasev pos dir = Particle
{ _ptDraw = const blank
, _ptUpdate = moveLaser phasev pos dir
}
moveLaser
:: Float -- ^ Phase velocity, controls deflection through windows
moveLaser :: Float -- ^ Phase velocity, controls deflection through windows
-> Point2
-> Float
-> World
-> Particle
-> (World, Maybe Particle)
moveLaser phasev pos dir w pt
= ( hitEffect w
= ( damThingHitWith (Lasering 19) pos xp thHit w
, Just pt {_ptDraw = const pic ,_ptUpdate = ptSimpleTime 0 }
)
where
where
xp = pos +.+ 800 *.* unitVectorAtAngle dir
(thHit, ps) = f [] pos xp
f :: [Wall] -> Point2 -> Point2 -> (Maybe (Point2,Either Creature Wall),[Point2])
f seenWs x y = case find (h' seenWs) $ thingsHitExceptCrLongLine Nothing x y w of
--f seenWs x y = case find (h' seenWs) $ thingsHitExceptCr Nothing x y w of
f seenWs x y = case find (notseen seenWs) $ thingsHitExceptCrLongLine Nothing x y w of
--f seenWs x y = case find (notseen seenWs) $ thingsHitExceptCr Nothing x y w of
Just (p,Right wl)
| _wlOpacity wl == SeeThrough -> addPoint p $ f (wl:seenWs) p (h x y wl p)
| _wlOpacity wl == SeeThrough -> second (p:) $ f (wl:seenWs) p (refract x y wl p)
| otherwise -> (Just (p,Right wl), [p])
Just (p,obj) -> (Just (p,obj), [p])
Nothing -> (Nothing, [y])
addPoint p (x,ps') = (x,p:ps')
h x y wl p
| isEntering = p +.+ rotateV angleRef normalDist
| otherwise = p +.+ rotateV angleRef' normalDist'
refract x y wl p
| isEntering = p +.+ rotateV angleRef (normalDist wlNormal)
| otherwise = p +.+ rotateV angleRef' (normalDist wlNormal')
where
wlNormal = vNormal $ uncurry (-.-) $ swap (_wlLine wl)
normalDist = magV (p -.- y) *.* normalizeV wlNormal
wlNormal' = vNormal $ uncurry (-.-) (_wlLine wl)
normalDist wlnormal = magV (p -.- y) *.* normalizeV wlnormal
angleInc = piRange $ argV wlNormal - argV (x -.- y)
angleRef
| reflectExternal = angleInc
@@ -208,8 +205,6 @@ moveLaser phasev pos dir w pt
| a' > negate pi = a'
| otherwise = a' + 2 * pi
isEntering = not $ isLeftOf (x -.- y) (uncurry (-.-) (_wlLine wl))
wlNormal' = vNormal $ uncurry (-.-) (_wlLine wl)
normalDist' = magV (p -.- y) *.* normalizeV wlNormal'
angleInc' = piRange $ argV wlNormal' - argV (x -.- y)
angleRef'
| reflectInternal = angleInc'
@@ -217,10 +212,8 @@ moveLaser phasev pos dir w pt
reflectInternal = 1 < abs (phasev * sin angleInc')
reflectExternal = 1 < abs (sin angleInc / phasev)
h' ws (_,Right wl) = not $ any (\w' -> _wlID w' == _wlID wl) ws
h' _ _ = True
(thHit, ps) = f [] pos xp
hitEffect = damThingHitWith (Lasering 19) pos xp thHit
notseen ws (_,Right wl) = not $ any (\w' -> _wlID w' == _wlID wl) ws
notseen _ _ = True
pic = setLayer 1 $ pictures
[ setDepth 19 . color (brightX 0 0.5 yellow) $ lineOfThickness 20 (pos:ps)
, setDepth 19.5 . color (brightX 10 1 yellow) $ lineOfThickness 3 (pos:ps)