Split Dodge.Base

src/Dodge/Base.hs

@@ -5,6 +5,7 @@ Basic helpers.
 Consider splitting. -}
 module Dodge.Base 
     ( module Dodge.Base
+    , module Dodge.Base.Arithmetic
     , module Dodge.Base.You
     , module Dodge.Base.NewID
     , module Dodge.Base.WinScale
@@ -15,6 +16,7 @@ module Dodge.Base
     ) where
 import Dodge.Data
 import Dodge.Base.WinScale
+import Dodge.Base.Arithmetic
 import Dodge.Base.NewID
 import Dodge.Base.Coordinate
 import Dodge.Base.CardinalPoint
@@ -37,77 +39,6 @@ import Data.Maybe
 --import qualified Data.Set as S
 
 
-{- | Implementation copied from 
- - https://hackage.haskell.org/package/utility-ht-0.0.16/docs/src/Data.List.HT.Private.html#takeUntil
- -}
-takeUntil :: Foldable t => (a -> Bool) -> t a -> [a]
-takeUntil p = foldr (\x xs -> x : if p x then [] else xs) []
-
-decreaseToZero :: Int -> Int
-decreaseToZero = max 0 . subtract 1
-
-decreaseToNothing' :: (Num a, Ord a) => Maybe' a -> Maybe' a
-decreaseToNothing' ma = case ma of
-    Just' x | x > 0 -> Just' (x - 1)
-    _ -> Nothing'
-
-safeHead :: [a] -> Maybe a
-safeHead (x:_) = Just x
-safeHead _ = Nothing
-
-safeUncons :: [a] -> Maybe (a,[a])
-safeUncons (x:xs) = Just (x,xs)
-safeUncons _ = Nothing
-
-errorHead :: String -> [a] -> a
-errorHead _ (x:_) = x
-errorHead s [] = error s
-
-aCrPos :: Int -> World -> Point2
-aCrPos i w = _crPos $ _creatures w IM.! i
-
-selectedObject :: World -> Maybe (Either FloorItem Button)
-selectedObject w = lookup (_crInvSel ycr) $ zip [n..] $ _closeObjects w
-  where
-    ycr = you w
-    n = length $ _crInv ycr
-
-crItem :: World -> Int -> Item
-crItem w cid = _crInv cr IM.! _crInvSel cr
-  where
-    cr = _creatures w IM.! cid
-
-yourItemRef
-    :: Applicative f
-    => World
-    -> (Item -> f Item)
-    -> World
-    -> f World
-yourItemRef w = creatures . ix (_yourID w) . crInv . ix (_crInvSel (you w))
-
-wallNormal :: Wall -> Point2
-wallNormal = normalizeV . vNormal . uncurry (-.-) . _wlLine
-
-wallsOnLine :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
-wallsOnLine p1 p2 = IM.filter
-    (isJust . uncurry (intersectSegSeg p1 p2) . _wlLine) 
-
-wallsOnLineHit :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Point2, Wall)
-wallsOnLineHit p1 p2 = IM.mapMaybe f
-  where
-    f wl = uncurry (intersectSegSeg p1 p2) (_wlLine wl) <&> (, wl)
-
-wallsOnLine3D :: Point3 -> Point3 -> IM.IntMap Wall -> [Wall]
-wallsOnLine3D = undefined
---  where 
---    hitPoint w = uncurry (intersectSegSeg p1 p2) (_wlLine w)
---    hitWalls = filter (isJust . hitPoint) (IM.elems ws)
-
-wallsOnCirc :: Point2 -> Float -> IM.IntMap Wall -> IM.IntMap Wall
-wallsOnCirc p r = IM.filter f
-  where 
-    f wl = uncurry circOnSeg (_wlLine wl) p r
-
 allWalls :: World -> IM.IntMap Wall
 allWalls = IM.unions . concatMap IM.elems . IM.elems . _znObjects . _wallsZone
 
@@ -200,12 +131,12 @@ adjustIMZone f x y n = IM.adjust f' x
   where 
     f'  = IM.adjust f'' y
     f'' = IM.adjust f n
-{- | Finds unused projectile key. -}
+--{- | Finds unused projectile key. -}
-newProjectileKey :: World -> Int
+--newProjectileKey :: World -> Int
-newProjectileKey = IM.newKey . _props
+--newProjectileKey = IM.newKey . _props
-{- | Finds unused creature key. -}
+--{- | Finds unused creature key. -}
-newCrKey :: World -> Int
+--newCrKey :: World -> Int
-newCrKey = IM.newKey .  _creatures
+--newCrKey = IM.newKey .  _creatures
 -- | Looks for overlap of a circle with walls.
 -- If found, gives wall
 overlapCircWallsReturnWall :: Point2 -> Float -> IM.IntMap Wall -> Maybe Wall

src/Dodge/Base/Arithmetic.hs

@@ -0,0 +1,10 @@
+module Dodge.Base.Arithmetic where
+import MaybeHelp
+
+decreaseToZero :: Int -> Int
+decreaseToZero = max 0 . subtract 1
+
+decreaseToNothing' :: (Num a, Ord a) => Maybe' a -> Maybe' a
+decreaseToNothing' ma = case ma of
+    Just' x | x > 0 -> Just' (x - 1)
+    _ -> Nothing'

src/Dodge/Base/Collide.hs

@@ -14,6 +14,8 @@ module Dodge.Base.Collide
     , hasLOSIndirect
     , wlIsOpaque
     , wlIsSeeThrough
+    , wallsOnCirc
+    , wallsOnLineHit
     ) where
 import Dodge.Data
 import Dodge.Zone
@@ -308,3 +310,16 @@ canSeeIndirect i j w = not
 --    n = normalizeV $ vNormal $ ipos -.- jpos
 --    ni = _crRad icr *.* n
 --    nj = _crRad jcr *.* n
+
+wallsOnLineHit :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Point2, Wall)
+wallsOnLineHit p1 p2 = IM.mapMaybe f
+  where
+    f wl = uncurry (intersectSegSeg p1 p2) (_wlLine wl) <&> (, wl)
+
+wallsOnCirc :: Point2 -> Float -> IM.IntMap Wall -> IM.IntMap Wall
+wallsOnCirc p r = IM.filter f
+  where 
+    f wl = uncurry circOnSeg (_wlLine wl) p r
+
+--wallNormal :: Wall -> Point2
+--wallNormal = normalizeV . vNormal . uncurry (-.-) . _wlLine

src/Dodge/Base/Item.hs

@@ -0,0 +1,27 @@
+module Dodge.Base.Item 
+    (
+    ) where
+--import Dodge.Data
+--import Dodge.Base.You
+--import LensHelp
+--
+--import qualified Data.IntMap.Strict as IM
+
+--selectedObject :: World -> Maybe (Either FloorItem Button)
+--selectedObject w = lookup (_crInvSel ycr) $ zip [n..] $ _closeObjects w
+--  where
+--    ycr = you w
+--    n = length $ _crInv ycr
+--
+--crItem :: World -> Int -> Item
+--crItem w cid = _crInv cr IM.! _crInvSel cr
+--  where
+--    cr = _creatures w IM.! cid
+--
+--yourItemRef
+--    :: Applicative f
+--    => World
+--    -> (Item -> f Item)
+--    -> World
+--    -> f World
+--yourItemRef w = creatures . ix (_yourID w) . crInv . ix (_crInvSel (you w))

src/Dodge/Base/NewID.hs

@@ -29,3 +29,12 @@ plNew :: ALens' b (IM.IntMap a)
     -> b
     -> b
 plNew l li x = snd . plNewUpID l li x
+
+-- | place an new object into an intmap using the new id
+plNewUsing :: ALens' b (IM.IntMap a)
+    -> (Int -> a)
+    -> b
+    -> b
+plNewUsing l f x = x & l #%~ IM.insert i (f i)
+  where
+    i = IM.newKey $ x ^# l

src/Dodge/Creature/State.hs

@@ -7,6 +7,7 @@ import Dodge.Damage
 import Dodge.Hammer
 import Dodge.Reloading
 import Dodge.Prop.Gib
+--import Dodge.Base.Arithmetic
 import Dodge.Base
 import Dodge.Creature.State.WalkCycle
 import Dodge.Creature.Impulse.Movement

src/Dodge/Debug/Terminal.hs

@@ -1,6 +1,7 @@
 module Dodge.Debug.Terminal
     where
 import MaybeHelp
+import ListHelp (safeHead)
 import Dodge.Inventory.Add
 import Dodge.Creature
 import Dodge.Creature.Damage
@@ -10,7 +11,7 @@ import Dodge.Data
 import Dodge.Menu.PushPop
 import Dodge.Item
 import Control.Monad
-import Dodge.Base
+--import Dodge.Base
 
 import Control.Lens
 import Text.Read (readMaybe)

src/Dodge/Item/Equipment/Booster.hs

@@ -9,6 +9,7 @@ import Geometry
 import qualified IntMapHelp as IM
 import Picture
 import ShapePicture
+import ListHelp (safeHead)
 --import Shape
 
 import Data.Maybe

src/Dodge/Item/Weapon/BatteryGuns.hs

@@ -445,9 +445,9 @@ dualRayAt bt itid w col dam phasev pos dir = basicBeamAt itid w col dam phasev p
     & bmType .~ bt
 
 aTractorBeam :: Item -> Creature -> World -> World
-aTractorBeam _ cr w = w & props . at i ?~ tractorBeamAt i spos outpos dir power
+--aTractorBeam _ cr w = w & props %~  tractorBeamAt i spos outpos dir power
+aTractorBeam _ cr w = w & plNew props pjID (tractorBeamAt spos outpos dir power)
   where 
-    i = newProjectileKey w
     cpos = _crPos cr
     spos = cpos +.+ (_crRad cr + 10) *.* unitVectorAtAngle dir
     xpos = cpos +.+ 400 *.* unitVectorAtAngle dir
@@ -456,13 +456,13 @@ aTractorBeam _ cr w = w & props . at i ?~ tractorBeamAt i spos outpos dir power
         $ wallsAlongLine cpos xpos w
     power = _attractionPower . _itParams $ _crInv cr IM.! _crInvSel cr
 
-tractorBeamAt :: Int -> Point2 -> Point2 -> Float -> Point2 -> Prop
+tractorBeamAt :: Point2 -> Point2 -> Float -> Point2 -> Prop
-tractorBeamAt i pos outpos dir power = ProjectileTimed
+tractorBeamAt pos outpos dir power = ProjectileTimed
     { _prPos = pos
     , _pjStartPos = outpos
     , _pjVel = d
     , _prDraw = tractorSPic
-    , _pjID = i
+    , _pjID = 0
     , _pjUpdate = updateTractor
     , _pjTime = 10
     }

src/Dodge/Item/Weapon/Grenade.hs

@@ -101,7 +101,7 @@ throwGrenade thePayload cr w = setWp $ removePict $ over props addG w
         }
     j = _crInvSel cr
     removePict = set (creatures . ix n . crInv . ix j . itEquipPict) $ \ _ _ -> (,) emptySH blank
-    i = newProjectileKey w
+    i = IM.newKey $ _props w
     v' = 1 / (fromIntegral fuseTime * _cameraZoom w) *.* rotateV (_cameraRot w) ( _mousePos w)
     v | magV v' > 6 = 6 *.* normalizeV v'
       | otherwise   = v'
@@ -229,7 +229,7 @@ throwRemoteBomb cr w = setLocation
         , _pjID = i
         , _pjUpdate = \_ -> moveRemoteBomb itid 50 i
         }
-    i = newProjectileKey w
+    i = IM.newKey $ _props w
     v' = 0.02 / _cameraZoom w *.* rotateV (_cameraRot w) ( _mousePos w)
     v   | magV v' > 6 = 6 *.* normalizeV v'
         | otherwise   = v'

src/Dodge/Reloading.hs

@@ -4,7 +4,7 @@ module Dodge.Reloading
     , crStopReloading
     ) where
 import Dodge.Data
-import Dodge.Base
+import Dodge.Base.Arithmetic
 --import qualified Data.IntMap.Strict as IM
 
 import Control.Lens

src/Dodge/Terminal.hs

@@ -2,12 +2,13 @@
 module Dodge.Terminal where
 import Dodge.Data
 import Dodge.Default
-import Dodge.Base
+--import Dodge.Base
 import Dodge.SoundLogic
 import Color
 import Justify
 import LensHelp
 import Sound.Data
+import ListHelp (find,safeUncons,safeHead)
 
 import Data.Char
 import Data.Maybe
@@ -15,7 +16,6 @@ import qualified Data.Map.Strict as M
 import qualified Data.IntMap.Strict as IM
 import qualified Data.Text as T
 --import Text.Read
-import Data.List (find)
 
 quitCommand :: TerminalCommand
 quitCommand = TerminalCommand

src/Dodge/Update.hs

@@ -20,6 +20,7 @@ import Dodge.Inventory
 import Sound.Data
 import Geometry
 import LensHelp
+import FoldableHelp
 
 --import qualified Data.Text as T
 --import System.Random

src/FoldableHelp.hs

@@ -6,6 +6,7 @@ module FoldableHelp
     , safeMinimumOnMaybeL
     , safeMinMaybeL
     , filter3
+    , takeUntil
     , module Data.Foldable
     )
     where
@@ -82,3 +83,9 @@ filter3 t1 t2 t3 = L.fold $ (,,)
 --    go x (y:xs) | f x < f y = go x xs
 --                | otherwise = go y xs
 --    go x [] = x
+
+{- | Implementation copied from 
+ - https://hackage.haskell.org/package/utility-ht-0.0.16/docs/src/Data.List.HT.Private.html#takeUntil
+ -}
+takeUntil :: Foldable t => (a -> Bool) -> t a -> [a]
+takeUntil p = foldr (\x xs -> x : if p x then [] else xs) []

src/ListHelp.hs

@@ -4,6 +4,9 @@ module ListHelp
     , insertOver
     , swapIndices
     , (!?)
+    , safeHead
+    , safeUncons
+    , errorHead
     )where
 import Data.List
 
@@ -31,3 +34,15 @@ xs !? n
                                    0 -> Just x
                                    _ -> r (k-1)) (const Nothing) xs n
 {-# INLINABLE (!?) #-}
+
+safeHead :: [a] -> Maybe a
+safeHead (x:_) = Just x
+safeHead _ = Nothing
+
+safeUncons :: [a] -> Maybe (a,[a])
+safeUncons (x:xs) = Just (x,xs)
+safeUncons _ = Nothing
+
+errorHead :: String -> [a] -> a
+errorHead _ (x:_) = x
+errorHead s [] = error s