Refactor modules

src/Dodge/Base.hs

@@ -4,21 +4,15 @@
 Basic helpers.
 Consider splitting. -}
 module Dodge.Base 
-    ( module Dodge.Base
-    , module Dodge.Base.Zone
-    , module Dodge.Base.Window
-    , module Dodge.Base.Collide
-    )
     where
 import Dodge.Data
 import Dodge.Base.Zone
 import Dodge.Base.Window
-import Dodge.Base.Collide
 import Geometry
 --import Picture
 import qualified IntMapHelp as IM
+import FoldableHelp
 
-import Data.Foldable
 import Control.Lens
 --import Control.Monad.State
 --import Data.List
@@ -47,7 +41,7 @@ midPadL i x xs ys = take j (xs ++ repeat x) ++ ys
 {- | Implementation copied from 
  - https://hackage.haskell.org/package/utility-ht-0.0.16/docs/src/Data.List.HT.Private.html#takeUntil
  -}
-takeUntil :: (a -> Bool) -> [a] -> [a]
+takeUntil :: Foldable t => (a -> Bool) -> t a -> [a]
 takeUntil p = foldr (\x xs -> x : if p x then [] else xs) []
 
 you :: World -> Creature
@@ -124,7 +118,7 @@ creaturesNearPointI n p w =  IM.unions [f b $ f a $ _creaturesZone w | a<-[x-n..
 
 cloudsNearPoint :: Point2 -> World -> [Cloud]
 --cloudsNearPoint p w =  IM.unions [f b $ f a $ _cloudsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
-cloudsNearPoint p w = f ((IM.lookup x $ _cloudsZone w) >>= IM.lookup y)
+cloudsNearPoint p w = f (IM.lookup x (_cloudsZone w) >>= IM.lookup y)
   where 
     (x,y) = cloudZoneOfPoint p
     f Nothing = []
@@ -495,13 +489,6 @@ isAnimate cr = case _crActionPlan cr of
 sigmoid :: Floating a => a -> a
 sigmoid x = x/sqrt(1+x^(2::Int))
 
-{- | In order to force a list, apply with seq. -}
-forceSpine :: [a] -> ()
-forceSpine = foldr (const id) ()
-
-forceList :: [a] -> [a]
-forceList l = seq (forceSpine l) l
-
 normalizeAnglePi :: Float -> Float
 normalizeAnglePi angle 
     | normalizeAngle angle > pi = normalizeAngle angle - 2*pi

src/Dodge/Base/Collide.hs

@@ -5,10 +5,10 @@ module Dodge.Base.Collide
 import Dodge.Data
 import Dodge.Base.Zone
 import Geometry
+import FoldableHelp
 
 --import Data.List
 import Data.Maybe
-import Data.Foldable
 import qualified Data.IntMap.Strict as IM
 import Control.Lens
 
@@ -26,13 +26,6 @@ safeMinimumOn' f (x:xs) = g x (f x) xs
                       | otherwise = g v mv ys
             where my = f y
 
-safeMinimumOn :: (Foldable t,Ord b) => (a -> b) -> t a -> Maybe a
-safeMinimumOn f = foldl' g Nothing
-  where
-    g (Just x) y 
-        | f x < f y = Just x
-        | otherwise = Just y
-    g Nothing y = Just y
 
 hasLOS :: Point2 -> Point2 -> World -> Bool
 {-# INLINE hasLOS #-}
@@ -46,7 +39,7 @@ hitPointLines
 hitPointLines p1 p2
     = safeMinimumOn (dist p1 . fst)
     . mapMaybe
-    (\(x,y) -> (, (x,y)) <$> (intersectSegSeg' p1 p2 x y))
+    (\(x,y) -> (, (x,y)) <$> intersectSegSeg' p1 p2 x y)
 
 -- | looks for first collision of a point with walls
 -- if found, gives point and reflection velocity

src/Dodge/Creature/Action.hs

@@ -13,6 +13,8 @@ import Dodge.Creature.Stance.Data
 import Dodge.WorldEvent.Shockwave
 import Dodge.Data
 import Dodge.Base
+import Dodge.Base.Zone
+import Dodge.Base.Collide
 import Dodge.SoundLogic
 import Dodge.SoundLogic.Synonyms
 --import Dodge.WorldEvent

src/Dodge/Creature/Action/Flee.hs

@@ -1,8 +1,8 @@
 module Dodge.Creature.Action.Flee
     where
 import Dodge.Data
-import Dodge.Base.Collide
 import Geometry
+import FoldableHelp
 
 retreatPointForFrom
     :: Float -> World -> Creature -> Point2 -> Maybe Point2

src/Dodge/Creature/AlertLevel.hs

@@ -3,8 +3,8 @@ module Dodge.Creature.AlertLevel
     where
 import Dodge.Data
 import Dodge.Creature.AlertLevel.Data
-import Dodge.Base
---import Dodge.Base.Collide
+import Dodge.Base.Collide
+import StrictHelp
 
 import Control.Lens
 import Control.Monad.Reader
@@ -62,4 +62,4 @@ basicAttentionUpdate
     -> Creature
     -> Creature
 basicAttentionUpdate cids w cr = cr & crAttentionDir .~
-    AttentiveTo (forceList $ filter (\cid -> canSee (_crID cr) cid w) cids)
+    AttentiveTo (forceFoldable $ filter (\cid -> canSee (_crID cr) cid w) cids)

src/Dodge/Creature/ArmourChase.hs

@@ -15,6 +15,7 @@ import Dodge.Item.Equipment
 import Dodge.Item.Consumable
 import Picture
 import Geometry
+import FoldableHelp
 
 import Data.Maybe
 import qualified Data.IntMap.Strict as IM

src/Dodge/Creature/ChooseTarget.hs

@@ -2,6 +2,7 @@ module Dodge.Creature.ChooseTarget
     where
 import Dodge.Data
 import Dodge.Base
+import Dodge.Base.Collide
 import Dodge.Creature.AlertLevel.Data
 
 import Control.Lens

src/Dodge/Creature/State.hs

@@ -5,7 +5,7 @@ import Dodge.Creature.State.Data
 import Dodge.Creature.State.WalkCycle
 import Dodge.Creature.Stance.Data
 --import Dodge.Creature.Test
-import Dodge.Base
+--import Dodge.Base
 import Dodge.SoundLogic
 import Dodge.SoundLogic.Synonyms
 import Dodge.RandomHelp
@@ -15,6 +15,7 @@ import Dodge.Creature.Action
 import Geometry
 import Picture
 import qualified IntMapHelp as IM
+import StrictHelp
 
 import Data.List
 --import Data.Char
@@ -81,7 +82,7 @@ crFriction _ _ = (0,0)
 
 doDamage :: Creature -> Creature
 doDamage cr = set (crState . crDamage) [] 
-    $ over (crState . crPastDamage) (forceList . take 20 . (dams :) ) damagedCr
+    $ over (crState . crPastDamage) (forceFoldable . take 20 . (dams :) ) damagedCr
   where 
     dams = _crDamage $ _crState cr
     damagedCr = snd $ _crApplyDamage cr dams cr

src/Dodge/Event.hs

@@ -17,6 +17,7 @@ import Dodge.Event.Keyboard
 --import Dodge.Event.Menu
 import Dodge.Data
 import Dodge.Base
+import Dodge.Base.Window
 --import Dodge.Creature.Action
 import Dodge.SoundLogic
 import Dodge.Inventory

src/Dodge/Event/Menu.hs

@@ -3,7 +3,7 @@ module Dodge.Event.Menu
     ) where
 import Dodge.Data
 import Dodge.Data.Menu
-import Dodge.Base
+import Dodge.Base.Window
 import Dodge.Floor
 import Dodge.Initialisation
 import Dodge.SoundLogic

src/Dodge/Inventory.hs

@@ -2,7 +2,9 @@ module Dodge.Inventory
     where
 import Dodge.Data
 import Dodge.Base
+import Dodge.Base.Collide
 import Geometry
+import FoldableHelp
 
 --import Data.Maybe
 import Data.List

src/Dodge/Item/Weapon.hs

@@ -4,6 +4,7 @@ module Dodge.Item.Weapon
     where
 import Dodge.Data
 import Dodge.Base
+import Dodge.Base.Zone
 import Dodge.Picture.Layer
 import Dodge.SoundLogic
 import Dodge.SoundLogic.Synonyms

src/Dodge/Item/Weapon/Booster.hs

@@ -2,6 +2,8 @@ module Dodge.Item.Weapon.Booster
     where
 import Dodge.Data
 import Dodge.Base
+import Dodge.Base.Zone
+import Dodge.Base.Collide
 import Geometry
 import qualified IntMapHelp as IM
 import Dodge.Picture.Layer

src/Dodge/Item/Weapon/Grenade.hs

@@ -3,6 +3,7 @@ module Dodge.Item.Weapon.Grenade
 import Dodge.Data
 import Dodge.Item.Data
 import Dodge.Base
+import Dodge.Base.Zone
 import Dodge.Picture.Layer
 import Dodge.SoundLogic
 import Dodge.SoundLogic.Synonyms

src/Dodge/Item/Weapon/Launcher.hs

@@ -11,6 +11,7 @@ import Dodge.Item.Draw
 import Dodge.Item.Weapon.Shell
 import Dodge.Item.Weapon.TriggerType
 import Dodge.Base
+import Dodge.Base.Zone
 import Dodge.SoundLogic
 import Dodge.WorldEvent.SpawnParticle
 import Dodge.WorldEvent.Cloud

src/Dodge/Item/Weapon/UseEffect.hs

@@ -5,6 +5,8 @@ module Dodge.Item.Weapon.UseEffect
     where
 import Dodge.Data
 import Dodge.Base
+import Dodge.Base.Zone
+import Dodge.Base.Collide
 import Dodge.Picture.Layer
 --import Dodge.Item.Weapon.Decoration
 import Dodge.Item.Weapon.TriggerType

src/Dodge/Layout.hs

@@ -5,6 +5,7 @@ import Dodge.LevelGen
 import Dodge.LevelGen.StaticWalls
 --import Dodge.LevelGen.Data
 import Dodge.Base
+import Dodge.Base.Zone
 --import Dodge.RandomHelp
 import Dodge.Graph
 import Dodge.Layout.Tree.Polymorphic (applyToRoot)
@@ -64,7 +65,7 @@ initializeStaticWalls :: World -> World
 initializeStaticWalls w = w & staticWalls %~ (\wls' -> foldl' (flip wallToWall) wls' wls)
     & walls %~ IM.filter (not . wlIsWall)
   where
-    wls = [wl | wl@Wall{} <- (IM.elems $ _walls w)]
+    wls = [wl | wl@Wall{} <- IM.elems $ _walls w]
     wlIsWall Wall{} = True
     wlIsWall _ = False
 

src/Dodge/LevelGen/AutoDoor.hs

@@ -1,7 +1,7 @@
 {- |
 Creation of doors that open when creatures approach them.
  -}
-{-# LANGUAGE BangPatterns #-}
+--{-# LANGUAGE BangPatterns #-}
 module Dodge.LevelGen.AutoDoor
     where
 import Dodge.Data

src/Dodge/LevelGen/Block.hs

@@ -2,6 +2,7 @@
 module Dodge.LevelGen.Block where
 import Dodge.Data
 import Dodge.Base
+import Dodge.Base.Zone
 import Dodge.SoundLogic
 import Dodge.WorldEvent.Sound
 import Dodge.LevelGen.Pathing

src/Dodge/LevelGen/MoveDoor.hs

@@ -3,6 +3,7 @@ module Dodge.LevelGen.MoveDoor
     where
 import Dodge.Data
 import Dodge.Base
+import Dodge.Base.Zone
 import Geometry
 
 import qualified Data.IntMap.Strict as IM
@@ -14,7 +15,7 @@ mvP !ep !p = mvPointTowardAtSpeed 2 ep p
 
 mvPs :: (Point2,Point2) -> (Point2,Point2) -> (Point2,Point2)
 {-# INLINE mvPs #-}
-mvPs !(!ex,!ey) !(!sx,!sy) = (mvP ex sx,mvP ey sy)
+mvPs (!ex,!ey) (!sx,!sy) = (mvP ex sx,mvP ey sy)
 
 moveDoorToward :: (Point2,Point2) -> Wall -> Wall
 {-# INLINE moveDoorToward #-}

src/Dodge/LevelGen/Pathing.hs

@@ -2,6 +2,7 @@ module Dodge.LevelGen.Pathing
     where
 import Dodge.Data
 import Dodge.Base
+import Dodge.Base.Zone
 import Geometry
 
 import Control.Lens

src/Dodge/LevelGen/StaticWalls.hs

@@ -5,8 +5,8 @@ Description : Concerns carving out of static walls to create the general room pl
 module Dodge.LevelGen.StaticWalls 
     where
 import Dodge.Data
-import Dodge.Base.Collide
 import Geometry
+import FoldableHelp
 
 --import Control.Lens
 import Data.List

src/Dodge/LevelGen/TriggerDoor.hs

@@ -1,8 +1,9 @@
-{-# LANGUAGE BangPatterns #-}
+--{-# LANGUAGE BangPatterns #-}
 module Dodge.LevelGen.TriggerDoor
     where
 import Dodge.Data
 import Dodge.Base
+import Dodge.Base.Zone
 import Dodge.SoundLogic
 import Dodge.SoundLogic.Synonyms
 import Dodge.LevelGen.Switch

src/Dodge/Path.hs

@@ -1,6 +1,7 @@
 module Dodge.Path where
 import Dodge.Data
-import Dodge.Base
+import Dodge.Base.Collide
+import Dodge.Base.Zone
 import Dodge.Graph
 import Geometry
 

src/Dodge/Render.hs

@@ -6,7 +6,7 @@ module Dodge.Render
   where
 import Dodge.Data
 import Dodge.Config.Data
-import Dodge.Base
+import Dodge.Base.Window
 --import Dodge.Render.HUD
 --import Dodge.Render.MenuScreen
 import Dodge.Render.Picture
@@ -80,7 +80,7 @@ doDrawing pdata w = do
         else renderBlankWalls pdata nWalls
     --_ <- renderFoldable pdata $ (picToAlt (Just 0) (polysToPic $ foregroundPics w) :: [RenderType])
     --_ <- renderFoldable pdata $ (picToAlt (Just 0) pic :: [RenderType])
-    _ <- renderFoldable pdata $ picToLTree (Just 0) (polysToPic $ foregroundPics w)
+    _ <- renderFoldable pdata $ picToLTree Nothing (polysToPic $ foregroundPics w)
     _ <- renderFoldable pdata $ picToLTree (Just 0) pic
     _ <- renderShader (_textureArrayShader pdata) (_floorTiles w)
 

src/Dodge/Render/HUD.hs

@@ -3,6 +3,7 @@ module Dodge.Render.HUD
     where
 import Dodge.Data
 import Dodge.Base
+import Dodge.Base.Window
 import Dodge.Inventory
 import Picture
 import Geometry

src/Dodge/Render/Picture.hs

@@ -2,6 +2,8 @@ module Dodge.Render.Picture
   where
 import Dodge.Data
 import Dodge.Base
+import Dodge.Base.Window
+import Dodge.Base.Zone
 import Dodge.Picture
 import Dodge.Picture.Layer
 import Dodge.Render.HUD

src/Dodge/Room.hs

@@ -226,11 +226,11 @@ roomOctogon = defaultRoom
     poly = [(-20,40),(20,40),(50,70),(50,110),(20,140),(-20,140),(-50,110),(-50,70)]
     lnks = 
         [((0,140),0)
-        ,((35,125),0-pi/4)
+        ,((35,125),negate $ pi/4)
         ,((-35,125),pi/4)
-        ,( (50,90),0-pi/2)
+        ,( (50,90),negate $ pi/2)
         ,( (-50,90),pi/2)
-        ,((35,55),0-3*pi/4)
+        ,((35,55),negate $ 3*pi/4)
         ,((-35,55),3*pi/4)
         ,( (0,40),pi)
         ]
@@ -306,7 +306,7 @@ weaponBetweenPillars :: RandomGen g => State g (Tree (Either Room Room))
 weaponBetweenPillars = do
     wpPos <- takeOne [(x,y) | x <- [20,120,220], y <- [20,120,220]]
     (ps,_) <- takeNMore 2 ([], [(x,y) | x <- [20,220], y <- [20,120,220]])
-    let crPos1 = ps !! 0 
+    let crPos1 = ps !! 0
         crPos2 = ps !! 1
         d p = argV $ (120,120) -.- p
         plmnts = 

src/Dodge/Update.hs

@@ -10,6 +10,7 @@ import Dodge.Data.Menu
 import Dodge.World.Trigger.Data
 --import Dodge.Config.Data
 import Dodge.Base
+import Dodge.Base.Zone
 import Dodge.WallCreatureCollisions
 import Dodge.LevelGen.Block
 import Dodge.Update.Camera

src/Dodge/Update/Camera.hs

@@ -8,6 +8,8 @@ module Dodge.Update.Camera
     where
 import Dodge.Data
 import Dodge.Base
+import Dodge.Base.Window
+import Dodge.Base.Collide
 import Dodge.Config.KeyConfig
 import Dodge.Item.Attachment.Data
 import Geometry

src/Dodge/WallCreatureCollisions.hs

@@ -3,7 +3,7 @@ module Dodge.WallCreatureCollisions where
 import Dodge.Data
 import Dodge.Creature.State.Data
 import Dodge.Debug.Flag.Data
-import Dodge.Base
+import Dodge.Base.Zone
 import Geometry
 
 import Data.List

src/Dodge/WorldEvent/Explosion.hs

@@ -4,7 +4,8 @@ Explosions: creation of shockwave and particles at a given point.
 module Dodge.WorldEvent.Explosion
   where
 import Dodge.Data
-import Dodge.Base
+import Dodge.Base.Zone
+import Dodge.Base.Collide
 import Dodge.WorldEvent.SpawnParticle
 import Dodge.WorldEvent.Flash
 import Dodge.RandomHelp

src/Dodge/WorldEvent/Shockwave.hs

@@ -7,6 +7,7 @@ import Dodge.Data
 import Dodge.WorldEvent.DamageBlock
 import Dodge.Creature.State.Data
 import Dodge.Base
+import Dodge.Base.Zone
 import Dodge.Picture.Layer
 import Geometry
 import Picture

src/Dodge/WorldEvent/SpawnParticle.hs

@@ -6,6 +6,8 @@ module Dodge.WorldEvent.SpawnParticle
 import Dodge.Data
 import Dodge.Creature.State.Data
 import Dodge.Base
+import Dodge.Base.Zone
+import Dodge.Base.Collide
 import Dodge.Picture
 import Dodge.Picture.Layer
 import Dodge.WorldEvent.HitEffect

src/Dodge/WorldEvent/ThingsHit.hs

@@ -5,6 +5,7 @@ module Dodge.WorldEvent.ThingsHit
     where
 import Dodge.Data
 import Dodge.Base
+import Dodge.Base.Zone
 import Geometry
 
 import qualified Data.IntMap.Strict as IM

src/Picture/Data.hs

@@ -1,9 +1,12 @@
 --{-# LANGUAGE TemplateHaskell #-}
 --{-# LANGUAGE Strict #-}
+{-# LANGUAGE DeriveGeneric #-}
 module Picture.Data
     where
 import Geometry.Data
 
+import GHC.Generics (Generic)
+import Control.DeepSeq
 import Data.Foldable
 --import qualified Data.List as L
 --import Data.Monoid
@@ -29,6 +32,8 @@ data RenderType
     | Render22x4 {_unRender22x4 :: ((Point2,Point2),Point4)}
     | Render3x2 {_unRender3x2 :: (Point3,Point2)}
     | Render3x3 {_unRender3x3 :: (Point3,Point3)}
+  deriving Generic
+instance NFData RenderType
 
 type RGBA = (Float,Float,Float,Float)
 type Color = (Float,Float,Float,Float)
@@ -47,11 +52,13 @@ instance Functor FTree where
     fmap f (FBranches ts) = FBranches $ fmap (fmap f) ts
     fmap f (FLeaf x) = FLeaf (f x)
     {-# INLINE fmap #-}
-    
+
 {- Tree with values at and only at the leaves. -}
 data LTree a
     = LBranches [LTree a]
     | LLeaf a
+  deriving (Generic)
+instance NFData a => NFData (LTree a)
 instance Foldable LTree where
     foldMap g (LBranches ts) = mconcat $ map (foldMap g) ts
     foldMap g (LLeaf a) = g a

src/Picture/Tree.hs

@@ -1,6 +1,7 @@
 {- Transform a picture into renderable objects. -}
 module Picture.Tree
     ( picToLTree
+    , picToLTree'
     , picToFTree
     , picToRenderList
     , picToAlt
@@ -10,6 +11,8 @@ module Picture.Tree
 import Picture.Data
 import Geometry
 import Geometry.Data
+--import StrictHelp
+import Control.DeepSeq
 
 import Data.Bifunctor
 import Data.List
@@ -17,6 +20,12 @@ import qualified Data.DList as DL
 import Control.Applicative
 --import Data.Maybe (isNothing)
 
+picToLTree'
+    :: Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf.
+    -> Picture
+    -> LTree RenderType
+picToLTree' x p = rnf (picToLTree x p) `seq` picToLTree x p
+
 -- todo: refactor out the layer check somehow
 -- consider generalising to alternative rather than using LTree
 -- | Transform a picture into a tree of renderable objects
@@ -58,6 +67,7 @@ picToLTree _ (ThickArc startA endA rad wdth) = LLeaf $ RenderArc
 picToLTree _ (Text s) = LLeaf $ RenderText $ stringToList s
 picToLTree _ Blank = LBranches []
 picToLTree j (Pictures pics) = LBranches $ map (picToLTree j) pics
+--picToLTree j (Pictures pics) = LBranches . forceFoldable $ map (picToLTree j) pics
 picToLTree j (OverPic f f' (OverPic g g' pic)) = picToLTree j $ OverPic (f . g) (f' . g') pic
 picToLTree j (OverPic f f' (Pictures ps)) = LBranches (map (picToLTree j . OverPic f f') ps)
 picToLTree j (OverPic f f' pic) = overPos f . overCol f' <$> picToLTree j pic

src/Polyhedra.hs

@@ -83,7 +83,7 @@ boxABC a b c =
     faceNA = rhombus c b
 
 polyToPics :: Polyhedra -> [Picture]
-polyToPics = map (Poly3D) . _pyFaces
+polyToPics = map Poly3D . _pyFaces
 
 polysToPic :: [Polyhedra] -> Picture
 polysToPic = pictures . concatMap polyToPics