diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 67d75d8b1..82c5d6223 100644 --- a/src/Dodge/Update.hs +++ b/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 diff --git a/src/Shape.hs b/src/Shape.hs index 348651c57..edb2b6e13 100644 --- a/src/Shape.hs +++ b/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 #-} diff --git a/src/ShapePicture.hs b/src/ShapePicture.hs index e32fac45b..7c8245d10 100644 --- a/src/ShapePicture.hs +++ b/src/ShapePicture.hs @@ -1,15 +1,26 @@ module ShapePicture - ( module ShapePicture - , module ShapePicture.Data + ( emptyBlank + , 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) diff --git a/src/ShapePicture/Data.hs b/src/ShapePicture/Data.hs deleted file mode 100644 index 3e28bac84..000000000 --- a/src/ShapePicture/Data.hs +++ /dev/null @@ -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 diff --git a/src/Sound.hs b/src/Sound.hs index 33720279c..799dbe9da 100644 --- a/src/Sound.hs +++ b/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 = - initialisePlaying sd s +updateSound sd s = initialisePlaying sd s >>= liftIO . (decrementTimer >=> applyPosition) >>= cleanupHalted diff --git a/src/Tile.hs b/src/Tile.hs index c565a0b23..f95379008 100644 --- a/src/Tile.hs +++ b/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 - :: [Point2] - -> Float - -> Tile +makeTileFromPoly :: [Point2] -> Float -> Tile makeTileFromPoly poly z = Tile { _tilePoly = poly , _tileZero = c - --, _tileXY = c +.+ xdir +.+ vNormal xdir , _tileX = c +.+ normalizeV ((poly !! 1) -.- c) , _tileZ = z } diff --git a/src/TreeExtra.hs b/src/TreeExtra.hs deleted file mode 100644 index b8c1ee5aa..000000000 --- a/src/TreeExtra.hs +++ /dev/null @@ -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) diff --git a/src/Tuple.hs b/src/Tuple.hs deleted file mode 100644 index 1471aa373..000000000 --- a/src/Tuple.hs +++ /dev/null @@ -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