From 44f239c673c3e11e49120e98e9b25226753a587c Mon Sep 17 00:00:00 2001 From: jgk Date: Mon, 17 May 2021 23:23:10 +0200 Subject: [PATCH] Clear all warnings --- app/Main.hs | 13 ++--- src/Dodge/Creature/Action/UseItem.hs | 4 +- src/Dodge/Creature/ChooseTarget.hs | 2 +- src/Dodge/Creature/Rationality.hs | 12 ++--- src/Dodge/Creature/Test.hs | 14 ++--- src/Dodge/Layout/Tree/GenerateStructure.hs | 16 ++---- src/Dodge/Layout/Tree/Polymorphic.hs | 7 ++- src/Dodge/RandomHelp.hs | 11 ++-- src/Dodge/Render/PerspectiveMatrix.hs | 10 ++-- src/Dodge/Update/UsingInput.hs | 20 +++---- src/Geometry.hs | 24 ++++----- src/Geometry/Intersect.hs | 47 +++++++--------- src/Geometry/Vector.hs | 2 +- src/LoadConfig.hs | 11 ++-- src/Loop.hs | 17 ++---- src/MatrixHelper.hs | 10 ++-- src/Picture.hs | 29 +++++----- src/Picture/Data.hs | 23 ++++---- src/Picture/Tree.hs | 22 ++++---- src/Shader.hs | 63 ++++++++++------------ src/Sound.hs | 19 ++++--- src/Sound/Data.hs | 2 +- 22 files changed, 176 insertions(+), 202 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 4bceeb1b7..2f81610bf 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,8 +1,6 @@ module Main where import Loop -import Shader import LoadConfig -import Dodge.Default import Dodge.Data import Dodge.Initialisation import Dodge.Update @@ -21,11 +19,10 @@ import Preload import Sound.Data import Music -import Control.Concurrent import Control.Lens -import Foreign (Word32) +--import Foreign (Word32) import Control.Monad -import System.Random +--import System.Random import qualified Data.Map as M import qualified Data.IntMap as IM import Graphics.Rendering.OpenGL hiding (color, rotate, scale, translate) @@ -35,20 +32,20 @@ import qualified SDL.Mixer as Mix main :: IO () main = do (sizex,sizey) <- loadConfig - keyConfig <- loadKeyConfig + theKeyConfig <- loadKeyConfig dodgeConfig <- loadDodgeConfig setupLoop (sizex,sizey) (SDL.cursorVisible $= False >> doPreload >>= applyWorldConfig dodgeConfig) (\x -> (SDL.cursorVisible $= True) >> cleanUpPreload x) - (fmap (setWindowSize sizex sizey keyConfig . (config .~ dodgeConfig)) firstWorld) + (fmap (setWindowSize sizex sizey theKeyConfig . (config .~ dodgeConfig)) firstWorld) doSideEffects handleEvent (Just . update) doSideEffects :: PreloadData SoundOrigin -> World -> IO (PreloadData SoundOrigin) doSideEffects preData w = do - startTicks <- SDL.ticks + --startTicks <- SDL.ticks void $ doDrawing (_renderData preData) w playPositionalSoundQueue (_loadedChunks $ _soundData preData) (_soundQueue w) newPlayingSounds <- playAndUpdate (_soundData preData) (_sounds w) diff --git a/src/Dodge/Creature/Action/UseItem.hs b/src/Dodge/Creature/Action/UseItem.hs index bef66e75a..6f43d56a9 100644 --- a/src/Dodge/Creature/Action/UseItem.hs +++ b/src/Dodge/Creature/Action/UseItem.hs @@ -1,13 +1,11 @@ module Dodge.Creature.Action.UseItem where import Dodge.Data - import Dodge.Inventory import qualified Data.IntMap as IM - import Control.Lens -import Data.Maybe (maybe) +--import Data.Maybe (maybe) useItem :: Int -> World -> World useItem n w = itemEffect n it w diff --git a/src/Dodge/Creature/ChooseTarget.hs b/src/Dodge/Creature/ChooseTarget.hs index b8f1ad229..9829f7de0 100644 --- a/src/Dodge/Creature/ChooseTarget.hs +++ b/src/Dodge/Creature/ChooseTarget.hs @@ -5,7 +5,7 @@ import Dodge.Base import Dodge.Creature.AlertLevel.Data import Control.Lens -import qualified Data.IntMap.Strict as IM +--import qualified Data.IntMap.Strict as IM targetYouLOS :: Creature -> World -> Maybe Creature {-# INLINE targetYouLOS #-} diff --git a/src/Dodge/Creature/Rationality.hs b/src/Dodge/Creature/Rationality.hs index b230aa03d..6219e7baa 100644 --- a/src/Dodge/Creature/Rationality.hs +++ b/src/Dodge/Creature/Rationality.hs @@ -184,13 +184,13 @@ performAction cr w ac = case ac of UseAheadPos f -> performAction cr w (f (_crPos cr +.+ 20 *.* unitVectorAtAngle (_crDir cr))) ArbitraryAction f -> performAction cr w (f cr w) DoImpulsesAlongside sideImp mainAc -> case performAction cr w mainAc of - (imp, Just ac) -> (sideImp ++ imp, Just $ DoImpulsesAlongside sideImp ac) + (imp, Just nxtac) -> (sideImp ++ imp, Just $ DoImpulsesAlongside sideImp nxtac) (imp, _) -> (sideImp ++ imp, Nothing) - DoReplicate t ac -> performAction cr w $ DoReplicatePartial ac t ac - DoReplicatePartial _ 0 ac' -> performAction cr w ac' - DoReplicatePartial ac t ac' -> case performAction cr w ac' of - (imps , Just ac'') -> (imps, Just $ DoReplicatePartial ac t ac'') - (imps , _) -> (imps, Just $ DoReplicatePartial ac (t-1) ac) + DoReplicate t nxtac -> performAction cr w $ DoReplicatePartial nxtac t nxtac + DoReplicatePartial _ 0 pac -> performAction cr w pac + DoReplicatePartial sac t pac -> case performAction cr w pac of + (imps , Just nac) -> (imps, Just $ DoReplicatePartial sac t nac) + (imps , _) -> (imps, Just $ DoReplicatePartial sac (t-1) sac) _ -> ([], Nothing) where cpos = _crPos cr diff --git a/src/Dodge/Creature/Test.hs b/src/Dodge/Creature/Test.hs index 432fef2d2..ff0694f99 100644 --- a/src/Dodge/Creature/Test.hs +++ b/src/Dodge/Creature/Test.hs @@ -25,7 +25,7 @@ onBoth :: (a -> b -> c) -> (d -> a) -> (d -> b) -> d -> c onBoth f g h x = f (g x) (h x) crIsReloading :: (World, Creature) -> Bool -crIsReloading (w,cr) = case cr ^? crInv . ix (_crInvSel cr) . wpReloadState of +crIsReloading (_,cr) = case cr ^? crInv . ix (_crInvSel cr) . wpReloadState of Just t -> t > 0 _ -> False @@ -69,12 +69,12 @@ crHasTargetLOSR cr = reader $ \w -> case cr ^? crTarget . _Just of Nothing -> False crSafeDistFromTarg :: Float -> (World,Creature) -> Bool -crSafeDistFromTarg d (w,cr) = case cr ^? crTarget . _Just of +crSafeDistFromTarg d (_,cr) = case cr ^? crTarget . _Just of Just tcr -> dist (_crPos cr) (_crPos tcr) > d Nothing -> True crSafeDistFromTargR :: Float -> Creature -> Reader World Bool -crSafeDistFromTargR d cr = reader $ \w -> case cr ^? crTarget . _Just of +crSafeDistFromTargR d cr = return $ case cr ^? crTarget . _Just of Just tcr -> dist (_crPos cr) (_crPos tcr) > d Nothing -> True @@ -86,16 +86,16 @@ crStratConMatchesR strat cr = return $ eqConstr strat (_crStrategy $ _crActionPl crAwayFromPost :: (World,Creature) -> Bool crAwayFromPost (_,cr) = case find sentinelGoal $ _crGoal $ _crActionPlan cr of - Just (SentinelAt p dir) -> dist p (_crPos cr) > 15 + Just (SentinelAt p _) -> dist p (_crPos cr) > 15 _ -> False where - sentinelGoal (SentinelAt p dir) = True + sentinelGoal (SentinelAt _ _) = True sentinelGoal _ = False crAwayFromPostR :: Creature -> Reader World Bool crAwayFromPostR cr = return $ case find sentinelGoal $ _crGoal $ _crActionPlan cr of - Just (SentinelAt p dir) -> dist p (_crPos cr) > 15 + Just (SentinelAt p _) -> dist p (_crPos cr) > 15 _ -> False where - sentinelGoal (SentinelAt p dir) = True + sentinelGoal (SentinelAt _ _) = True sentinelGoal _ = False diff --git a/src/Dodge/Layout/Tree/GenerateStructure.hs b/src/Dodge/Layout/Tree/GenerateStructure.hs index 7a65d7136..e4999aba5 100644 --- a/src/Dodge/Layout/Tree/GenerateStructure.hs +++ b/src/Dodge/Layout/Tree/GenerateStructure.hs @@ -10,17 +10,11 @@ import Dodge.RandomHelp import Data.Tree import Control.Monad.State import System.Random - -{- -Single branched tree (a trunk). --} +{- Single branched tree (a trunk). -} treePath :: Int -> Tree () treePath 0 = Node () [] treePath x = Node () [treePath (x-1)] - -{- -Adds a branch at a certain point down a trunk. --} +{- Adds a branch at a certain point down a trunk. -} addBranchAt :: Int -- ^ Depth to add branch at -> Tree () -- ^ Branch to add @@ -29,10 +23,8 @@ addBranchAt addBranchAt 0 b (Node () xs) = Node () (xs ++ [b]) addBranchAt i b (Node () (x:xs)) = Node () (addBranchAt (i-1) b x : xs) - -{- -Randomly generate a tree containing a maximum of three nodes. --} +addBranchAt _ _ _ = error "Trying to add a branch too far along a tree" +{- Randomly generate a tree containing a maximum of three nodes. -} smallBranch :: RandomGen g => State g (Tree ()) smallBranch = takeOne [ treePath 0 diff --git a/src/Dodge/Layout/Tree/Polymorphic.hs b/src/Dodge/Layout/Tree/Polymorphic.hs index 0a5938f84..52adf3504 100644 --- a/src/Dodge/Layout/Tree/Polymorphic.hs +++ b/src/Dodge/Layout/Tree/Polymorphic.hs @@ -40,6 +40,8 @@ Applies a function to the root of a tree. applyToRoot :: (a -> a) -> Tree a -> Tree a applyToRoot f (Node t ts) = Node (f t) ts +-- | Consider defining this using generalised recursion patterns +treeSize :: Tree a -> Int treeSize = length . flatten {- | @@ -72,7 +74,7 @@ treeChildNums :: Tree a -> Tree Int treeChildNums = setRoot 0 where setRoot :: Int -> Tree a -> Tree Int - setRoot i (Node x xs) = Node i (zipWith setRoot [0..] xs) + setRoot i (Node _ xs) = Node i (zipWith setRoot [0..] xs) {- | Makes each node into its path, i.e. the list of indices that, @@ -109,7 +111,7 @@ Find the depth of a tree along the trunk. -} trunkDepth :: Tree a -> Int trunkDepth (Node _ []) = 0 -trunkDepth (Node _ (x:xs)) = trunkDepth x + 1 +trunkDepth (Node _ (x:_)) = trunkDepth x + 1 {- | Split a tree at a given point along its trunk. @@ -121,6 +123,7 @@ splitTrunkAt 0 (Node x xs) = (Node x [],xs) splitTrunkAt i (Node y (x:xs)) = let (t, ts) = splitTrunkAt (i-1) x in (Node y (t : xs) , ts) +splitTrunkAt _ (Node _ []) = error "Trying to split to short a trunk" {- | Split a tree at a random point along its trunk. diff --git a/src/Dodge/RandomHelp.hs b/src/Dodge/RandomHelp.hs index 47d5c5dea..240867b1d 100644 --- a/src/Dodge/RandomHelp.hs +++ b/src/Dodge/RandomHelp.hs @@ -3,7 +3,7 @@ Helpers for random generation. -} module Dodge.RandomHelp where import Geometry -import Geometry.Data +--import Geometry.Data import System.Random import Control.Monad.State @@ -20,15 +20,15 @@ takeOne xs = state (randomR (0,length xs - 1)) >>= (\i -> return (xs !! i)) takeOneWeighted :: (RandomGen g, Random b, Ord b, Num b) => [b] -> [a] -> State g a takeOneWeighted ws xs = state (randomR (0, sum ws)) - >>= (\w -> return (xs !! i w ws)) + >>= (\w -> return (xs !! i w ws)) where i y (z:zs) | y <= z = 0 | otherwise = 1 + i (y-z) zs - i y _ = 0 + i _ _ = 0 takeOneMore :: RandomGen g => ([a],[a]) -> State g ([a],[a]) -takeOneMore (xs,[]) = error "trying to takeOneMore from empty list" +takeOneMore ( _,[]) = error "trying to takeOneMore from empty list" takeOneMore (xs,ys) = do i <- state $ randomR (0,length ys - 1) let (zs, w:ws) = splitAt i ys @@ -38,7 +38,7 @@ takeNMore :: RandomGen g => Int -> ([a],[a]) -> State g ([a],[a]) takeNMore n p = foldr (const (>>= takeOneMore)) (return p) [1..n] takeN :: RandomGen g => Int -> [a] -> State g [a] -takeN 0 xs = return [] +takeN 0 _ = return [] takeN i xs = fst <$> takeNMore i ([],xs) -- | Randomly shuffle a list. @@ -54,6 +54,7 @@ shuffle xs = do -- | Randomly shuffle the tail of a list, not safe. shuffleTail :: RandomGen g => [a] -> State g [a] shuffleTail (x:xs) = (x :) <$> shuffle xs +shuffleTail _ = undefined randomSelectionFromList :: RandomGen g => Float -> [a] -> State g [a] randomSelectionFromList p = filterM $ const $ randProb p diff --git a/src/Dodge/Render/PerspectiveMatrix.hs b/src/Dodge/Render/PerspectiveMatrix.hs index 8c6220205..49122d75d 100644 --- a/src/Dodge/Render/PerspectiveMatrix.hs +++ b/src/Dodge/Render/PerspectiveMatrix.hs @@ -24,11 +24,11 @@ perspectiveMatrix rot zoom (tranx,trany) (winx,winy) (viewFromx,viewFromy) = (V4 (sin rot) (cos rot) 0 0) (V4 0 0 1 0) (V4 0 0 0 1) - tranMat3 = Linear.Matrix.transpose $ - V4 (V4 1 0 0 0) - (V4 0 1 0 0) - (V4 0 0 1 0) - (V4 (-tranx) (-trany) 0 1) + --tranMat3 = Linear.Matrix.transpose $ + -- V4 (V4 1 0 0 0) + -- (V4 0 1 0 0) + -- (V4 0 0 1 0) + -- (V4 (-tranx) (-trany) 0 1) tranMat2 = Linear.Matrix.transpose $ V4 (V4 1 0 0 0) (V4 0 1 0 0) diff --git a/src/Dodge/Update/UsingInput.hs b/src/Dodge/Update/UsingInput.hs index c276f4348..ab604cf5a 100644 --- a/src/Dodge/Update/UsingInput.hs +++ b/src/Dodge/Update/UsingInput.hs @@ -18,30 +18,30 @@ updateUsingInput w = else updatePressedButtons (_mouseButtons w) w updatePressedButtons :: S.Set MouseButton -> World -> World -updatePressedButtons keys w +updatePressedButtons pkeys w | lbPressed && rbPressed = useItem (_yourID w) w | mbPressed = w & clickMousePos .~ _mousePos w & cameraRot -~ rotation | otherwise = w where - lbPressed = ButtonLeft `S.member` keys - rbPressed = ButtonRight `S.member` keys - mbPressed = ButtonMiddle `S.member` keys + lbPressed = ButtonLeft `S.member` pkeys + rbPressed = ButtonRight `S.member` pkeys + mbPressed = ButtonMiddle `S.member` pkeys rotation = angleBetween (_mousePos w) (_clickMousePos w) updatePressedButtonsCarte :: S.Set MouseButton -> World -> World -updatePressedButtonsCarte keys w +updatePressedButtonsCarte pkeys w | rbPressed = w & clickMousePos .~ _mousePos w & carteCenter %~ (-.- trans) | lbPressed = w & clickMousePos .~ _mousePos w & carteRot -~ rot - & carteZoom *~ zoom + & carteZoom *~ czoom | otherwise = w where - lbPressed = ButtonLeft `S.member` keys - rbPressed = ButtonRight `S.member` keys - mbPressed = ButtonMiddle `S.member` keys + lbPressed = ButtonLeft `S.member` pkeys + rbPressed = ButtonRight `S.member` pkeys + --mbPressed = ButtonMiddle `S.member` pkeys rot = angleBetween (_mousePos w) (_clickMousePos w) - zoom = magV (_mousePos w) / magV (_clickMousePos w) + czoom = magV (_mousePos w) / magV (_clickMousePos w) trans = rotateV (_carteRot w) $ (1 / _carteZoom w) *.* (_mousePos w -.- _clickMousePos w) diff --git a/src/Geometry.hs b/src/Geometry.hs index c60ae534f..20f967c31 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -24,7 +24,7 @@ import Geometry.Vector import Data.Function import Data.List import Data.Maybe -import Control.Applicative +--import Control.Applicative -- | Return a point a distance away from a first point towards a second point. -- Does not go past the second point. alongSegBy :: Float -> Point2 -> Point2 -> Point2 @@ -68,11 +68,12 @@ rectWdthHght w h = rectNSWE h (-h) (-w) w -- polygon are listed in anticlockwise order. pointInOrOnPolygon :: Point2 -> [Point2] -> Bool pointInOrOnPolygon !p (x:xs) = all (\l -> not (uncurry isRHS l p)) $ zip (x:xs) (xs ++ [x]) +pointInOrOnPolygon _ _ = undefined -- | Test whether a point is strictly inside a polygon. -- Supposes the points in the polygon are listed in anticlockwise order. pointInPolygon :: Point2 -> [Point2] -> Bool -pointInPolygon !p [] = False pointInPolygon !p (x:xs) = all (\l -> uncurry (errorIsLHS 1) l p) $ zip (x:xs) (xs ++ [x]) +pointInPolygon _ [] = False -- | Debug version of 'pointInPolygon'. errorPointInPolygon :: Int -> Point2 -> [Point2] -> Bool errorPointInPolygon !i !p xs @@ -83,12 +84,12 @@ errorPointInPolygon !i !p xs -- | Debug version of 'normalizeV'. errorNormalizeV :: Int -> Point2 -> Point2 errorNormalizeV !i (0,0) = error $ "problem with function: errorNormalizeV "++show i -errorNormalizeV !i !p = normalizeV p +errorNormalizeV _ !p = normalizeV p -- | Debug version of 'angleVV'. errorAngleVV :: Int -> Point2 -> Point2 -> Float errorAngleVV !i (0,0) _ = error $ "problem with function: errorAngleVV "++show i errorAngleVV !i _ (0,0) = error $ "problem with function: errorAngleVV "++show i -errorAngleVV !i !p !p' = angleVV p p' +errorAngleVV _ !p !p' = angleVV p p' -- | Debug version of 'isLHS'. errorIsLHS :: Int -> Point2 -> Point2 -> Point2 -> Bool errorIsLHS !i !x !y @@ -101,9 +102,9 @@ errorClosestPointOnLine !i !x !y | otherwise = closestPointOnLine x y -- | Debug version of 'closestPointOnLineParam' errorClosestPointOnLineParam :: Int -> Point2 -> Point2 -> Point2 -> Float -errorClosestPointOnLineParam !i !x! y! z +errorClosestPointOnLineParam _ !x! y! z | x == y = dist x z - | otherwise = closestPointOnLineParam x y z + | otherwise = closestPointOnLineParam x y z -- | Test whether a point is on the LHS of a line. -- Returns False if the line is of zero length. isLHS @@ -250,9 +251,6 @@ diffAngles x y | otherwise = diffAngles (x + 2*pi) y where diff = x-y - -differenceAngles = diffAngles -angleDifference = diffAngles -- | Given a triangle where we know the length of a first side, -- the length of a second side, and the angle between the first side and the -- third side, finds the length of the third side. @@ -358,7 +356,7 @@ divideLine x a b = take 5000 where d = dist a b numPoints = max 1 $ ceiling $ d / x - ns = [0 .. numPoints] + ns = [0 :: Int .. numPoints] -- | As 'divideLine', but must return an odd number of points. divideLineOddNumPoints :: Float -> Point2 -> Point2 -> [Point2] --divideLine x a b = map (\i -> a +.+ (i / (fromIntegral numPoints)) *.* (b -.- a)) @@ -371,7 +369,7 @@ divideLineOddNumPoints x a b = take 5000 numPoints | even numPoints' = numPoints' | otherwise = numPoints' + 1 - ns = [0 .. numPoints] + ns = [0 .. numPoints] :: [Int] -- | Given two pairs of Ints, returns a list of pairs of Ints that form -- a digital line between them. digitalLine :: (Int,Int) -> (Int,Int) -> [(Int,Int)] @@ -386,7 +384,7 @@ digitalLine (x1,y1) (x2,y2) | y <- intervalList y1 y2 ] where - rdiv a b = round $ fromIntegral a / fromIntegral b + rdiv a b = round $ fromIntegral a / (fromIntegral b :: Float) -- | Given two pairs of 'Int's, create a list of pairs of 'Int's that form a -- rectangle between them. digitalRect :: (Int,Int) -> (Int,Int) -> [(Int,Int)] @@ -447,7 +445,7 @@ arcStepwisePositive ssize a cen v = (cen +.+) . (`rotateV` v) <$> rots -- loop. makeLoopPairs :: [Point2] -> [(Point2,Point2)] makeLoopPairs [] = error "tried to make loop with empty list of points" -makeLoopPairs [x] = error "tried to make loop with singleton list of points" +makeLoopPairs [_] = error "tried to make loop with singleton list of points" makeLoopPairs (x:xs) = zip (x:xs) (xs ++ [x]) -- | Test whether a point is in a cone. -- Note the pair is ordered. diff --git a/src/Geometry/Intersect.hs b/src/Geometry/Intersect.hs index 6231cff3b..ba06c7cec 100644 --- a/src/Geometry/Intersect.hs +++ b/src/Geometry/Intersect.hs @@ -8,7 +8,6 @@ import Geometry.Data import Control.Applicative import Data.Maybe (isNothing) - -- | If two lines intersect, return 'Just' that point. intersectLineLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 {-# INLINE intersectLineLine' #-} @@ -18,7 +17,6 @@ intersectLineLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4) where den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) - -- | If two segments intersect, return 'Just' that point. intersectSegSeg' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 {-# INLINE intersectSegSeg' #-} @@ -33,7 +31,6 @@ intersectSegSeg' (x1,y1) (x2,y2) (x3,y3) (x4,y4) den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) - -- | Intended to intersect a segment with a half-line-segment, ie a segment -- extending infinitely in one direction. intersectSegLineFrom' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 @@ -49,7 +46,6 @@ intersectSegLineFrom' (x1,y1) (x2,y2) (x3,y3) (x4,y4) den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) - -- | Similar to 'intersectSegLineFrom'', but this version is probably not correct... intersectSegLineext :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 {-# INLINE intersectSegLineext #-} @@ -64,7 +60,6 @@ intersectSegLineext (x1,y1) (x2,y2) (x3,y3) (x4,y4) den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) - -- | Intersect a segment with a line. intersectSegLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 {-# INLINE intersectSegLine' #-} @@ -78,8 +73,7 @@ intersectSegLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4) where den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4) t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4) - u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) - + --u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3) -- | Due to floating point issues, 'intersectSegSeg'' is not always -- accurate---'myIntersectSegSeg' -- fixes at least some of @@ -87,20 +81,25 @@ intersectSegLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4) -- intersection. -- This version is, probably, slower---both testing and benchmarking should be -- done. +myIntersectSegSeg + :: Point2 + -> Point2 + -> Point2 + -> Point2 + -> Maybe Point2 myIntersectSegSeg a@(ax,ay) b@(bx,by) c@(cx,cy) d@(dx,dy) = case ratIntersectLineLine a b c d of - Nothing -> Nothing - Just (x,y) -> if inbetween x && inbetween' y - then Just (x,y) - else Nothing + Nothing -> Nothing + Just (x,y) -> if inbetween x && inbetween' y + then Just (x,y) + else Nothing where inbetween x = ((ax <= x && x <= bx) || (bx <= x && x <= ax)) && ((cx <= x && x <= dx) || (dx <= x && x <= cx)) inbetween' y = ((ay <= y && y <= by) || (by <= y && y <= ay)) && ((cy <= y && y <= dy) || (dy <= y && y <= cy)) - -- | Polymorphic intersection of fractional line points. myIntersectLineLine :: (Eq a,Fractional a) => (a,a) -> (a,a) -> (a,a) -> (a,a) -> Maybe (a,a) -myIntersectLineLine a@(ax,ay) b c@(cx,cy) d +myIntersectLineLine a@(ax,_) b c@(cx,_) d | isNothing (linGrad a b) = (ax ,) <$> axisInt (c *-* (ax,0)) (d *-* (ax,0)) | isNothing (linGrad c d) = (cx ,) <$> axisInt (a *-* (cx,0)) (b *-* (cx,0)) | otherwise @@ -113,8 +112,7 @@ myIntersectLineLine a@(ax,ay) b c@(cx,cy) d (^/^) = liftA2 (/) (^*^) = liftA2 (*) newx = (axisInt c d ^-^ axisInt a b) ^/^ (linGrad a b ^-^ linGrad c d) - (*-*) (ax,ay) (bx,by) = (ax-bx,ay-by) - + (*-*) (ax',ay) (bx,by) = (ax'-bx,ay-by) -- | Transforms floating points to rationals then performs line intersection. ratIntersectLineLine :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2 ratIntersectLineLine a b c d = toNumPoint2 @@ -122,8 +120,6 @@ ratIntersectLineLine a b c d = toNumPoint2 where toRatPoint2 (x,y) = (toRational x, toRational y) toNumPoint2 (x,y) = (fromRational x, fromRational y) - f = toRatPoint2 . roundPoint2 - {- | Round the floats within a 'Point2' to the nearest integer. __Examples__ Rounding jumps after intervals of .5: @@ -138,24 +134,21 @@ but is symmetric around 0: -} roundPoint2 :: Point2 -> Point2 -roundPoint2 (x,y) = (fromIntegral $ round x,fromIntegral $ round y) - +roundPoint2 (x,y) = (fromIntegral $ (round x :: Int),fromIntegral $ (round y :: Int)) -- | Given two points, finds the linear gradient if it is non-infinite. linGrad :: (Eq a,Fractional a) => (a,a) -> (a,a) -> Maybe a -linGrad (x,y) (a,b) | x-a == 0 = Nothing - | otherwise = Just $ (y-b)/(x-a) - +linGrad (x,y) (a,b) + | x-a == 0 = Nothing + | otherwise = Just $ (y-b)/(x-a) -- | Given two points, finds the intersection with the y axis if it exists. axisInt :: (Eq a,Fractional a) => (a,a) -> (a,a) -> Maybe a axisInt p (a,b) = pure b ^-^ (pure a ^*^ linGrad p (a,b)) - where (^-^) = liftA2 (-) - (^*^) = liftA2 (*) - + where + (^-^) = liftA2 (-) + (^*^) = liftA2 (*) -- | Placeholder, undefined. intersectSegsSeg :: [Point2] -> Point2 -> Point2 -> Maybe Point2 intersectSegsSeg = undefined - -- | Placeholder: should intersect a segment with a bezier curve. intersectSegBezquad :: Point2 -> Point2 -> Point2 -> Point2 -> Point2 -> [Point2] intersectSegBezquad = undefined - diff --git a/src/Geometry/Vector.hs b/src/Geometry/Vector.hs index 8dc94efb0..fa6b5f664 100644 --- a/src/Geometry/Vector.hs +++ b/src/Geometry/Vector.hs @@ -174,7 +174,7 @@ safeNormalizeV p = (1/magV p ) *.* p -} magV :: Point2 -> Float {-# INLINE magV #-} -magV (x,y) = sqrt $ x^2 + y^2 +magV (x,y) = sqrt $ x^(2::Int) + y^(2::Int) {- | Magnitude of the cross product of two vectors. Identical to detV. diff --git a/src/LoadConfig.hs b/src/LoadConfig.hs index 3413b2eed..40ab6e538 100644 --- a/src/LoadConfig.hs +++ b/src/LoadConfig.hs @@ -1,15 +1,12 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} - module LoadConfig where - import Data.Aeson -import Foreign.C.Types +--import Foreign.C.Types import GHC.Generics -import qualified GHC.Int -import qualified SDL - -import System.Directory +--import qualified GHC.Int +--import qualified SDL +--import System.Directory data Configuration = Configuration { windowxsize :: Int, diff --git a/src/Loop.hs b/src/Loop.hs index 5b67dfc2d..dc9d1e4d9 100644 --- a/src/Loop.hs +++ b/src/Loop.hs @@ -12,12 +12,10 @@ import Control.Concurrent import Control.Exception import Control.Monad import System.Mem -import Foreign.C +--import Foreign.C import SDL import qualified Graphics.Rendering.OpenGL as GL - -import Control.Lens ((.~),(&),(+~)) - +--import Control.Lens ((.~),(&),(+~)) -- | Create a game loop with an SDL window. setupLoop :: (Int,Int) -- ^ The window size. @@ -78,19 +76,12 @@ doLoop performGC endTicks <- ticks -- it might be better to use System.Clock (monotonic) - let delay = max 0 (20 + fromIntegral startTicks - fromIntegral endTicks) - threadDelay (delay * 1000 ) + let theDelay = max 0 (20 + fromIntegral startTicks - fromIntegral endTicks) + threadDelay (theDelay * 1000 ) doLoop window updatedWorld worldSideEffects eventFn worldUpdate newParams Nothing -> return () -applyEventsIO - :: (world -> Event -> Maybe world) - -> world - -> [Event] - -> IO (Maybe world) -applyEventsIO fn w = foldM (applyEventIO fn) (Just w) - -- | Handle quit events in a manner to exit the loop. Other events handled as -- determined by the custom function, although resize events also change the viewport. applyEventIO :: (world -> Event -> Maybe world) -> Maybe world -> Event -> IO (Maybe world) diff --git a/src/MatrixHelper.hs b/src/MatrixHelper.hs index ae8ba552f..9227a09cc 100644 --- a/src/MatrixHelper.hs +++ b/src/MatrixHelper.hs @@ -18,11 +18,11 @@ perspectiveMatrix rot zoom (tranx,trany) (winx,winy) (viewFromx,viewFromy) = (V4 (sin rot) (cos rot) 0 0) (V4 0 0 1 0) (V4 0 0 0 1) - tranMat3 = Linear.Matrix.transpose $ - V4 (V4 1 0 0 0) - (V4 0 1 0 0) - (V4 0 0 1 0) - (V4 (-tranx) (-trany) 0 1) + --tranMat3 = Linear.Matrix.transpose $ + -- V4 (V4 1 0 0 0) + -- (V4 0 1 0 0) + -- (V4 0 0 1 0) + -- (V4 (-tranx) (-trany) 0 1) tranMat2 = Linear.Matrix.transpose $ V4 (V4 1 0 0 0) (V4 0 1 0 0) diff --git a/src/Picture.hs b/src/Picture.hs index e011dc369..e7985d609 100644 --- a/src/Picture.hs +++ b/src/Picture.hs @@ -46,16 +46,13 @@ module Picture ) where import Geometry -import Geometry.Data - +--import Geometry.Data import Picture.Data -import Data.Bifunctor -import qualified Data.DList as DL - -import Graphics.Rendering.OpenGL (lineWidth, ($=)) - -import Control.Lens +--import Data.Bifunctor +--import qualified Data.DList as DL +--import Graphics.Rendering.OpenGL (lineWidth, ($=)) +--import Control.Lens black :: RGBA black = (0,0,0,1) @@ -205,11 +202,19 @@ thickCircle :: Float -> Float -> Picture {-# INLINE thickCircle #-} thickCircle = thickArc 0 (2*pi) -arcSolid :: Float -> Float -> Float -> Picture +arcSolid + :: Float -- ^ Start angle + -> Float -- ^ End angle + -> Float -- ^ Radius + -> Picture {-# INLINE arcSolid #-} -arcSolid startA endA rad - = polygon $ (0,0) : makeArc rad (startA,endA) +arcSolid startA endA rad = polygon $ (0,0) : makeArc rad (startA,endA) +arc + :: Float -- ^ Start angle + -> Float -- ^ End angle + -> Float -- ^ Radius + -> Picture arc startA endA rad = thickArc startA endA rad 1 {-# INLINE arc #-} @@ -241,7 +246,7 @@ mixColors rata ratb (r0,g0,b0,a0) (r2,g2,b2,a2) = let fullrat = rata + ratb normrata = rata / fullrat normratb = ratb / fullrat - f x y = sqrt $ normrata * x^2 + normratb * y^2 + f x y = sqrt $ normrata * x^(2::Int) + normratb * y^(2::Int) in (f r0 r2 , f g0 g2 , f b0 b2 , normrata * a0 + normratb * a2) light :: Color -> Color diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs index 37393b85b..cfe73e4c3 100644 --- a/src/Picture/Data.hs +++ b/src/Picture/Data.hs @@ -4,14 +4,14 @@ module Picture.Data where import Geometry.Data -import Data.Monoid -import Data.Traversable -import qualified Data.Foldable as F -import qualified Data.Sequence as Se -import qualified Data.DList as DL -import qualified Data.Vector as V -import Control.Lens -import Control.Monad +--import Data.Monoid +--import Data.Traversable +--import qualified Data.Foldable as F +--import qualified Data.Sequence as Se +--import qualified Data.DList as DL +--import qualified Data.Vector as V +--import Control.Lens +--import Control.Monad data RenderType = RenderPoly [(Point3,Point4)] @@ -58,8 +58,11 @@ instance Functor (RTree a) where fmap f (RBranches i ts) = RBranches i $ fmap (fmap f) ts fmap f (RLeaf x) = RLeaf (f x) -flat2 (x,y) = [x,y] -flat3 (x,y,z) = [x,y,z] +flat2 :: (a,a) -> [a] +flat2 (x,y) = [x,y] +flat3 :: (a,a,a) -> [a] +flat3 (x,y,z) = [x,y,z] +flat4 :: (a,a,a,a) -> [a] flat4 (x,y,z,w) = [x,y,z,w] {-# INLINE flat2 #-} {-# INLINE flat3 #-} diff --git a/src/Picture/Tree.hs b/src/Picture/Tree.hs index 1605766a1..ff61fd027 100644 --- a/src/Picture/Tree.hs +++ b/src/Picture/Tree.hs @@ -42,7 +42,7 @@ picToLTree mx (LineCol i vs) where (ps,cs) = unzip vs picToLTree mx (Text i s) = filtB mx i $ LLeaf $ RenderText $ stringToList s -picToLTree j Blank = LBranches [] +picToLTree _ Blank = LBranches [] picToLTree j (Pictures pics) = LBranches $ map (picToLTree j) pics picToLTree j (OverPic f f' r f'' (OverPic g g' s g'' pic)) = picToLTree j $ OverPic (f . g) (f' . g') (r + s) (f'' . g'') pic @@ -64,6 +64,7 @@ doubleLine :: [a] -> [a] doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (: []) (y:xs) doubleLine _ = [] +white, black :: Color white = (1,1,1,1) black = (0,0,0,1) @@ -102,7 +103,7 @@ overCol f (RenderArc (a,b,c)) = RenderArc (a,f b,c) overSca :: (Point2 -> Point2) -> RenderType -> RenderType {-# INLINE overSca #-} overSca f (RenderText vs) = RenderText $ map (scaleT (f (1,1))) vs -overSca f p = p +overSca _ p = p stringToList :: String -> [(Point3,Point4,Point3)] {-# INLINE stringToList #-} @@ -123,12 +124,11 @@ translate3 :: Float -> Float -> Point3 -> Point3 {-# INLINE translate3 #-} translate3 a b (x,y,z) = (x+a,y+b,z) {- Scale a 3D vector in the x and y directions. -} -scale3 :: Float -> Float -> Point3 -> Point3 -{-# INLINE scale3 #-} -scale3 a b (x,y,z) = (x*a,y*b,z) -{- Rotate a 3D vector in the x-y plane. -} -rotate3 :: Float -> Point3 -> Point3 -{-# INLINE rotate3 #-} -rotate3 a (x,y,z) = (x',y',z) - where (x',y') = rotateV a (x,y) - +--scale3 :: Float -> Float -> Point3 -> Point3 +--{-# INLINE scale3 #-} +--scale3 a b (x,y,z) = (x*a,y*b,z) +--{- Rotate a 3D vector in the x-y plane. -} +--rotate3 :: Float -> Point3 -> Point3 +--{-# INLINE rotate3 #-} +--rotate3 a (x,y,z) = (x',y',z) +-- where (x',y') = rotateV a (x,y) diff --git a/src/Shader.hs b/src/Shader.hs index 8c8b321c2..5caeec220 100644 --- a/src/Shader.hs +++ b/src/Shader.hs @@ -19,29 +19,22 @@ module Shader , module Shader.Data ) where +import Geometry import Shader.Data import Foreign import Codec.Picture - -import qualified Data.Vector.Storable as V - -import Control.Monad (when, unless, forM, zipWithM_, forM_, foldM) -import Control.Lens - import Data.Maybe (fromMaybe) - -import qualified Control.Foldl as F - -import Graphics.Rendering.OpenGL hiding (Point (..),translate,scale,imageHeight,imageWidth) ---import Text.RawString.QQ import qualified Data.ByteString as BS - +import qualified Data.Vector.Storable as V +import Control.Monad (unless, forM, zipWithM_, forM_, foldM) +import Control.Lens +import qualified Control.Foldl as F +import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight) +--import Text.RawString.QQ import Linear.Matrix import Linear.V4 -import Geometry - extractProgAndUnis :: FullShader a -> (Program,[UniformLocation]) extractProgAndUnis s = (_shaderProgram s, _shaderUniforms s) @@ -51,8 +44,7 @@ pokeShaders = traverse pokeShader pokeShader :: FullShader a -> F.FoldM IO a Int pokeShader fs = F.FoldM (pokeRender fls (zip ptrs nAtss)) (return 0) return where - vao = _shaderVAO fs - (_,ptrs,nAtss) = unzip3 $ _vaoBufferTargets vao + (_,ptrs,nAtss) = unzip3 $ _vaoBufferTargets $ _shaderVAO fs fls = _shaderPokeStrategy fs pokeRender :: (a -> [[[Float]]]) @@ -93,8 +85,8 @@ drawShader fs i = do currentProgram $= Just (_shaderProgram fs) bindVertexArrayObject $= Just (_vao $ _shaderVAO fs) case _shaderTexture fs of - Just ShaderTexture{_textureObject = to} - -> textureBinding Texture2D $= Just to + Just ShaderTexture{_textureObject = txo} + -> textureBinding Texture2D $= Just txo _ -> return () drawArrays (_shaderDrawPrimitive fs) 0 (fromIntegral i) @@ -129,16 +121,16 @@ makeShader -> IO (FullShader a) makeShader s shaderlist alocs pm renStrat = do (prog,unis) <- makeSourcedShader s shaderlist - vao <- setupVAO alocs + vaob <- setupVAO alocs return $ FullShader { _shaderProgram = prog , _shaderUniforms = unis - , _shaderVAO = vao + , _shaderVAO = vaob , _shaderPokeStrategy = renStrat , _shaderDrawPrimitive = pm , _shaderTexture = Nothing , _shaderCustomUnis = Nothing } - +floatSize :: Int floatSize = sizeOf (0.5 :: GLfloat) {-# INLINE floatSize #-} @@ -171,7 +163,7 @@ setupArrayBuffer (aloc,i) = do , VertexArrayDescriptor (fromIntegral i) Float (fromIntegral $ floatSize * i) - (bufferOffset 0) + (bufferOffset (0::Int)) ) vertexAttribArray (AttribLocation aloc) $= Enabled return vbo @@ -197,30 +189,31 @@ shaderTypeExt :: ShaderType -> String shaderTypeExt VertexShader = ".vert" shaderTypeExt GeometryShader = ".geom" shaderTypeExt FragmentShader = ".frag" +shaderTypeExt _ = undefined makeShaderProgram :: String -> [(ShaderType,BS.ByteString)] -> IO Program makeShaderProgram str sources = do - shaderProgram <- createProgram + theShaderProgram <- createProgram shaders <- mapM (compileAndCheckShader str) sources - mapM_ (attachShader shaderProgram) shaders + mapM_ (attachShader theShaderProgram) shaders - linkProgram shaderProgram - linkingSuccess <- linkStatus shaderProgram + linkProgram theShaderProgram + linkingSuccess <- linkStatus theShaderProgram unless linkingSuccess $ do - infoLog <- get (programInfoLog shaderProgram) + infoLog <- get (programInfoLog theShaderProgram) putStrLn $ str ++ ": Program Linking" ++ infoLog - return shaderProgram + return theShaderProgram compileAndCheckShader :: String -> (ShaderType,BS.ByteString) -> IO Shader -compileAndCheckShader str (shaderType,sourceCode) = do - theShader <- createShader shaderType +compileAndCheckShader str (theShaderType,sourceCode) = do + theShader <- createShader theShaderType shaderSourceBS theShader $= sourceCode compileShader theShader success <- compileStatus theShader unless success $ do infoLog <- get (shaderInfoLog theShader) - putStrLn $ str ++ ": Shader compile: " ++ show shaderType ++ " : " ++ show infoLog + putStrLn $ str ++ ": Shader compile: " ++ show theShaderType ++ " : " ++ show infoLog return theShader resetShaderUniforms :: [(Program, [UniformLocation])] -> IO () @@ -229,10 +222,10 @@ resetShaderUniforms = setShaderUniforms 0 1 (0,0) (2,2) setShaderUniforms :: Float -> Float -> Point2 -> Point2 -> [(Program,[UniformLocation])] -> IO () {-# INLINE setShaderUniforms #-} -setShaderUniforms rot zoom (tranx,trany) (winx,winy) fss = do +setShaderUniforms rot czoom (tranx,trany) (winx,winy) fss = do let scalMat = Linear.Matrix.transpose $ - V4 (V4 (2*zoom/winx) 0 0 (0::GLfloat)) - (V4 0 (2*zoom/winy) 0 0) + V4 (V4 (2*czoom/winx) 0 0 (0::GLfloat)) + (V4 0 (2*czoom/winy) 0 0) (V4 0 0 1 0) (V4 0 0 0 1) let rotMat = Linear.Matrix.transpose $ @@ -252,7 +245,7 @@ setShaderUniforms rot zoom (tranx,trany) (winx,winy) fss = do forM_ fss $ \shad -> do currentProgram $= Just (fst shad) uniform (snd shad !! 0) $= Vector2 winx winy - uniform (snd shad !! 1) $= zoom + uniform (snd shad !! 1) $= czoom uniform (snd shad !! 2) $= rot uniform (snd shad !! 3) $= Vector2 tranx trany uniform (snd shad !! 4) $= wmata diff --git a/src/Sound.hs b/src/Sound.hs index a690ea2c3..768bc46b8 100644 --- a/src/Sound.hs +++ b/src/Sound.hs @@ -78,17 +78,17 @@ initialisePlaying sd s = case _soundStatus s of tryPlay :: IM.IntMap Mix.Chunk -> Sound -> MaybeT IO Sound tryPlay sd s = do i <- tryGetChannel s - liftIO $ do + _ <- liftIO $ do Mix.halt i Mix.playOn i Mix.Once (sd IM.! _soundChunkID s) return $ s & soundChannel ?~ i & soundStatus .~ Playing -repetitions :: Sound -> Mix.Times -repetitions s = case _soundTime s of - Nothing -> Mix.Once - _ -> Mix.Forever +--repetitions :: Sound -> Mix.Times +--repetitions s = case _soundTime s of +-- Nothing -> Mix.Once +-- _ -> Mix.Forever tryGetChannel :: Sound -> MaybeT IO Mix.Channel tryGetChannel s = case _soundChannel s of @@ -110,9 +110,12 @@ applyPosition s = case _soundPos s of Just (a,d) -> Mix.effectPosition (fromJust $ _soundChannel s) a d >> return (s & soundPos .~ Nothing) -fadeOutMaybe :: Maybe Mix.Channel -> Int -> IO () +fadeOutMaybe + :: Maybe Mix.Channel + -> Int -- ^ fade out time: UNUSED, Mix.fadeOut is buggy + -> IO () --fadeOutMaybe (Just x) fadeT = Mix.fadeOut (fromIntegral fadeT + 1) x -fadeOutMaybe (Just x) fadeT = Mix.halt x +fadeOutMaybe (Just x) _ = Mix.halt x fadeOutMaybe _ _ = return () cleanupHalted :: Sound -> MaybeT IO Sound @@ -149,7 +152,7 @@ playPositionalSoundQueue chunkMap ns = forM_ ns $ \(n,a) -> setChannelPos :: Int16 -> Mix.Channel -> MaybeT IO Mix.Channel setChannelPos a i = do - liftIO $ Mix.effectPosition i a 0 + _ <- liftIO $ Mix.effectPosition i a 0 return i diff --git a/src/Sound/Data.hs b/src/Sound/Data.hs index dbc415a31..b8e2987df 100644 --- a/src/Sound/Data.hs +++ b/src/Sound/Data.hs @@ -5,7 +5,7 @@ import qualified SDL.Mixer as Mix import qualified Data.IntMap as IM import qualified Data.Map as M import Control.Lens -import Geometry +--import Geometry import Data.Word (Word8) import Data.Int (Int16)