justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Clear all warnings

Browse Source
This commit is contained in:
jgk
2021-05-17 23:23:10 +02:00
parent 69f915a894
commit 44f239c673
22 changed files with 176 additions and 202 deletions
Download Patch File Download Diff File Expand all files Collapse all files
app/Main.hs
+5 -8
View File
@@ -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)
src/Dodge/Creature/Action/UseItem.hs
+1 -3
View File
@@ -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
src/Dodge/Creature/ChooseTarget.hs
+1 -1
View File
@@ -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 #-}
src/Dodge/Creature/Rationality.hs
+6 -6
View File
@@ -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
src/Dodge/Creature/Test.hs
+7 -7
View File
@@ -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
src/Dodge/Layout/Tree/GenerateStructure.hs
+4 -12
View File
@@ -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
src/Dodge/Layout/Tree/Polymorphic.hs
+5 -2
View File
@@ -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.
src/Dodge/RandomHelp.hs
+6 -5
View File
@@ -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
src/Dodge/Render/PerspectiveMatrix.hs
+5 -5
View File
@@ -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)
src/Dodge/Update/UsingInput.hs
+10 -10
View File
@@ -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)
src/Geometry.hs
+11 -13
View File
@@ -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.
src/Geometry/Intersect.hs
+20 -27
View File
@@ -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
src/Geometry/Vector.hs
+1 -1
View File
@@ -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.
src/LoadConfig.hs
+4 -7
View File
@@ -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,
src/Loop.hs
+4 -13
View File
@@ -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)
src/MatrixHelper.hs
+5 -5
View File
@@ -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)
src/Picture.hs
+17 -12
View File
@@ -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
src/Picture/Data.hs
+13 -10
View File
@@ -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 #-}
src/Picture/Tree.hs
+11 -11
View File
@@ -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)
src/Shader.hs
+28 -35
View File
@@ -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
src/Sound.hs
+11 -8
View File
@@ -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
src/Sound/Data.hs
+1 -1
View File
@@ -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)