Use tasty for tests, fix bug in circOnLine

src/Dodge/Item/Weapon/BatteryGuns.hs

@@ -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)

src/Dodge/Placement/Instance/Turret.hs

@@ -67,7 +67,7 @@ updateTurret rotSpeed mc w
             cid = IM.newKey (_creatures w')
             thecreature = defaultCreature
                 & crID .~ cid
-                & crInv . at 0 ?~ (_tuWeapon (_mcType mc) & itDimension . dimPortage . handlePos -~ 20
+                & crInv . at 0 ?~ (_tuWeapon (_mcType mc) & itDimension . dimPortage . handlePos -~ 10
                     & itConsumption . ammoLoaded .~ 1
                     )
                 & crPos .~ mcpos

src/Dodge/Room/Room.hs

@@ -21,10 +21,11 @@ import Dodge.Room.Door
 import Dodge.Room.Airlock
 import Geometry
 import Tile
+import MonadHelp
 
 import Control.Lens
 import Control.Monad.State
-import Control.Monad.Loops
+--import Control.Monad.Loops
 import System.Random
 import Data.Maybe
 import Data.Tree

src/Dodge/WorldEvent/ThingsHit.hs

@@ -127,5 +127,6 @@ thingsHitLongLine sp ep w
     --   $ creaturesAlongLine sp ep w
     crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs
     wls = zip (map (fromJust . hitPoint) hitWls) (map Right hitWls)
-    hitWls = wallsOnLine sp ep $ wallsAlongLine sp ep w
+    --hitWls = wallsOnLine sp ep $ wallsAlongLine sp ep w
+    hitWls = wallsOnLine sp ep $ _walls w
     hitPoint wl = uncurry (intersectSegSeg sp ep) (_wlLine wl)