Various cleanups

src/Dodge/Update.hs

@@ -151,8 +151,8 @@ updateLightSources w = over tempLightSources f w
 
 updateProjectiles :: World -> World
 updateProjectiles w = IM.foldl' (flip $ dbArg _pjUpdate) w $ _props w
-{-
+
-Apply internal particle updates, delete 'Nothing's.  -}
+{- Apply internal particle updates, delete 'Nothing's.  -}
 updateParticles :: World -> World
 updateParticles w = set particles (catMaybes ps) w'
   where 
@@ -174,7 +174,7 @@ updateDoors :: World -> World
 updateDoors w = IM.foldl' (\w' dr -> _drMech dr dr w') w (_doors w)
 
 ppEvents :: World -> World
-ppEvents w = IM.foldl' (flip $ \pp w' -> _ppEvent pp pp w') w $ _pressPlates w
+ppEvents w = IM.foldl' (flip $ \pp -> _ppEvent pp pp) w $ _pressPlates w
 
 updateSeenWalls :: World -> World
 updateSeenWalls w = foldl' markWallSeen w wallsToUpdate
@@ -188,23 +188,15 @@ markWallSeen w wl = w { _walls = IM.adjust mw (_wlID wl) $ _walls w }
   where
     mw wl' = wl' {_wlSeen = True}
 
---setTestStringIO :: IO World -> IO World
---setTestStringIO = fmap (\ w -> set testString (show $ s w) w)
---  where 
---    s w = (-.-) <$> (w ^? creatures . ix 0 . crPos) <*> (w ^? creatures . ix 0 . crOldPos)
-
 checkEndGame :: World -> World
 checkEndGame w 
     | _crHP (you w) < 1 = haltSound $ w {_menuLayers = [gameOverMenu]}
     | otherwise         = w
 
---updateClouds :: World -> World
---updateClouds w = w' & clouds %~ mapMaybe (updateCloud w)
 updateClouds :: World -> World
 updateClouds w = w' & clouds .~ catMaybes mclouds
   where
     (w',mclouds) = mapAccumR updateCloud w (_clouds w)
--- did i write a mapMaybeAccumR ?
 
 updateCloud :: World -> Cloud -> (World,Maybe Cloud)
 updateCloud w c
@@ -303,14 +295,13 @@ rotateToOverlappingWall w = case theWall of
     p = _crPos cr
     theWall = overlapCircWallsReturnWall p (_crRad cr + 5) (IM.filter _wlRotateTo $ wallsNearPoint p w)
 
-{-
+{- Finds the visible walls from a point to another point.  -}
-Finds the visible walls from a point to another point.  -}
 visibleWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall]
 visibleWalls p1 p2 ws 
     = takeUntil _wlIsSeeThrough 
     . map snd 
     . sortOn (dist p1 . fromJust . fst) 
-    . filter ((/=) Nothing . fst) 
+    . filter (isJust . fst) 
     . map f 
     $ IM.elems ws
   where 

src/Shape.hs

@@ -86,7 +86,7 @@ upperPrismPolyHalf h ps = [ShapeObj (TopPrism n) (f upps downps)]
 
 colorSH :: Color -> Shape -> Shape
 {-# INLINE colorSH #-}
-colorSH col = overCol $ const col
+colorSH = overCol . const
 
 overCol :: (Point4 -> Point4) -> Shape -> Shape
 {-# INLINE overCol #-}

src/ShapePicture.hs

@@ -1,15 +1,26 @@
 module ShapePicture
-    ( module ShapePicture
+    ( emptyBlank
-    , module ShapePicture.Data
+    , translateSPf
+    , translateSPz
+    , rotateSP
+    , SPic
+    , _spShape
+    , _spPicture
     )
     where
 import Shape
-import ShapePicture.Data
 import Picture
 import Geometry
 
 import Data.Bifunctor
 
+type SPic =  (Shape, Picture)
+
+_spShape :: SPic -> Shape
+_spShape = fst
+_spPicture :: SPic -> Picture
+_spPicture = snd
+
 emptyBlank :: SPic
 emptyBlank = (emptySH,blank)
 

src/ShapePicture/Data.hs

@@ -1,14 +0,0 @@
-{-# LANGUAGE StrictData #-}
---{-# LANGUAGE TemplateHaskell #-}
-module ShapePicture.Data
-    where
-import Shape
-import Picture
---import Control.Lens
-
-type SPic =  (Shape, Picture)
-
-_spShape :: SPic -> Shape
-_spShape = fst
-_spPicture :: SPic -> Picture
-_spPicture = snd

src/Sound.hs

@@ -66,8 +66,7 @@ updateSounds sd ss = do
     return $ M.mapMaybe id may
 
 updateSound :: IM.IntMap Mix.Chunk -> Sound -> MaybeT IO Sound
-updateSound sd s =
+updateSound sd s = initialisePlaying sd s 
-    initialisePlaying sd s 
     >>= liftIO . (decrementTimer >=> applyPosition) 
     >>= cleanupHalted
 

src/Tile.hs

@@ -1,8 +1,9 @@
 module Tile
-    where
+    ( tToRender
+    , makeTileFromPoly
+    ) where
 import Data.Tile
 import Geometry
---import Geometry.Data
 
 tToRender :: Tile -> [(Point3,Point3)]
 tToRender t = polyToTris $ zip ps3 coords3
@@ -15,9 +16,6 @@ tToRender t = polyToTris $ zip ps3 coords3
 addToV2 :: a -> V2 a -> V3 a
 addToV2 z (V2 x y) = V3 x y z
 
-mkTrip :: c -> (a,b) -> (a,b,c)
-mkTrip z (x,y) = (x,y,z)
-
 calcTexCoord
     :: Point2   -- ^ tile (0,0)
     -> Point2   -- ^ tile (1,0)
@@ -28,14 +26,10 @@ calcTexCoord c p x = V2 (0.02 * dotV (p -.- c) xdir) (0.02 * dotV (p -.- c) ydir
     xdir = x -.- c
     ydir = vNormal xdir
 
-makeTileFromPoly
+makeTileFromPoly :: [Point2] -> Float -> Tile
-    :: [Point2]
-    -> Float
-    -> Tile
 makeTileFromPoly poly z = Tile
     { _tilePoly = poly
     , _tileZero = c
-    --, _tileXY   = c +.+ xdir +.+ vNormal xdir
     , _tileX  = c +.+ normalizeV ((poly !! 1) -.- c)
     , _tileZ = z
     }

src/TreeExtra.hs

@@ -1,56 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-module TreeExtra 
-  where
-import GHC.Generics (Generic)
-import Control.DeepSeq
-import Data.Foldable
-data FTree a
-    = FBranch (a -> a) (FTree a)
-    | FBranches [FTree a]
-    | FLeaf a
-instance Foldable FTree where
-    foldMap g (FBranch f t) = foldMap (g . f) t
-    foldMap g (FBranches ts) = mconcat $ map (foldMap g) ts
-    foldMap g (FLeaf x) = g x
-    {-# INLINE foldMap #-}
-instance Functor FTree where
-    fmap g (FBranch f t) = fmap (g . f) t
-    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
-    {-# INLINE foldMap #-}
-    foldr _ x (LBranches []) = x
-    --foldr g x (LBranches (t:ts)) = foldr g x t `seq` foldr g (foldr g x t) (LBranches ts)
-    foldr g x (LBranches (t:ts)) = foldr g (foldr g x t) (LBranches ts)
-    --foldr g x (LBranches (t:ts)) = foldr g (foldr g x (LBranches ts)) t
-    foldr g x (LLeaf y) = g y x
-    {-# INLINE foldr #-}
-    foldl' _ x (LBranches []) = x
-    foldl' g x (LBranches (t:ts)) = foldl' g x t `seq` foldl' g (foldl' g x t) (LBranches ts)
-    foldl' g x (LLeaf y) = g x y
-    {-# INLINE foldl' #-}
-instance Functor LTree where
-    fmap f (LBranches ts) = LBranches $ fmap (fmap f) ts
-    fmap f (LLeaf x) = LLeaf (f x)
-    {-# INLINE fmap #-}
-
-data RTree a b
-    = RBranches a [RTree a b]
-    | RLeaf b
-instance Foldable (RTree a) where
-    foldMap g (RBranches _ ts) = mconcat $ map (foldMap g) ts
-    foldMap g (RLeaf x)      = g x
-    {-# INLINE foldMap #-}
-instance Functor (RTree a) where
-    fmap f (RBranches i ts) = RBranches i $ fmap (fmap f) ts
-    fmap f (RLeaf x)      = RLeaf (f x)

src/Tuple.hs

@@ -1,16 +0,0 @@
-module Tuple
-    ( trip1
-    , trip2
-    , trip3
-    )
-  where
-
-trip1 :: (a,b,c) -> a
-{-# INLINE trip1 #-}
-trip1 (x,_,_) = x
-trip2 :: (a,b,c) -> b
-{-# INLINE trip2 #-}
-trip2 (_,x,_) = x
-trip3 :: (a,b,c) -> c
-{-# INLINE trip3 #-}
-trip3 (_,_,x) = x