cuboid 0.14.1 → 0.14.2
raw patch · 10 files changed
+200/−179 lines, 10 filesdep ~GLUT
Dependency ranges changed: GLUT
Files
- Config.hs +13/−0
- Game.hs +0/−47
- GameLogic.hs +0/−81
- Graphics.hs +16/−18
- Input.hs +13/−23
- Main.hs +6/−3
- Types.hs +31/−0
- Update.hs +88/−0
- Utils.hs +27/−0
- cuboid.cabal +6/−7
+ Config.hs view
@@ -0,0 +1,13 @@+module Config where++import Types++-- TODO: List can't be empty!+testLevel = Level (P3D 0 0 1) (P3D 4 4 5) [P3D 0 0 0, P3D 0 5 1, P3D 5 4 1]+testLevel2 = Level (P3D 0 0 1) (P3D 0 4 1) [P3D 5 5 5]+testLevel3 = Level (P3D 0 1 0) (P3D 4 2 1) [P3D 0 1 1, P3D 1 2 0, P3D 1 3 3,+ P3D 1 1 4, P3D 2 3 0, P3D 3 1 0, P3D 3 4 0, P3D 3 0 2, P3D 3 3 3, P3D 3 1 4,+ P3D 4 2 0] ++levels = concat (repeat [testLevel, testLevel2, testLevel3])+
− Game.hs
@@ -1,47 +0,0 @@-{-# LANGUAGE Arrows #-}-module Game where--import FRP.Yampa.Vector3--import Graphics.UI.GLUT hiding (Level,Vector3(..),normalize)-import qualified Graphics.UI.GLUT as G(Vector3(..))--type R = GLdouble--data Point3D = P3D { x :: Integer, y :: Integer, z :: Integer } deriving (Show)--p3DtoV3 :: (RealFloat a) => Point3D -> Vector3 a-p3DtoV3 (P3D x y z) = vector3 (fromInteger x) (fromInteger y) (fromInteger z)--vectorApply f v = vector3 (f $ vector3X v) (f $ vector3Y v) (f $ vector3Z v)--vector3Rotate' :: (Integral a, RealFloat b) => a -> Vector3 b -> Vector3 b-vector3Rotate' theta v =- let rotateTheta 0 v = id v - rotateTheta 1 v = vector3 (vector3X v) (vector3Z v) (-(vector3Y v))- rotateTheta 2 v = vector3 (vector3X v) (-(vector3Y v)) (-(vector3Z v)) - rotateTheta 3 v = vector3 (vector3X v) (-(vector3Z v)) (vector3Y v)- rotateTheta i _ = rotateTheta (abs $ i `mod` 4) v- in rotateTheta theta $ v--data Level = Level { startingPoint :: Point3D, - endPoint :: Point3D,- obstacles :: [Point3D] }---- TODO: Memoize-size :: Level -> Integer-size = (+1) . maximum . map (\(P3D x y z) -> maximum [x,y,z]) . obstacles--data GameState = Game { level :: Level,- rotX :: R, - playerPos :: Vector3 R }---- TODO: List can't be empty!-testLevel = Level (P3D 0 0 1) (P3D 4 4 5) [P3D 0 0 0, P3D 0 5 1, P3D 5 4 1]-testLevel2 = Level (P3D 0 0 1) (P3D 0 4 1) [P3D 5 5 5]-testLevel3 = Level (P3D 0 1 0) (P3D 4 2 1) [P3D 0 1 1, P3D 1 2 0, P3D 1 3 3,- P3D 1 1 4, P3D 2 3 0, P3D 3 1 0, P3D 3 4 0, P3D 3 0 2, P3D 3 3 3, P3D 3 1 4,- P3D 4 2 0] --levels = concat (repeat [testLevel, testLevel2, testLevel3])-
− GameLogic.hs
@@ -1,81 +0,0 @@-{-# LANGUAGE Arrows, BangPatterns #-}-module GameLogic where--import FRP.Yampa-import FRP.Yampa.Vector3-import FRP.Yampa.Utilities-import Graphics.UI.GLUT hiding (Level,Vector3(..),normalize)-import qualified Graphics.UI.GLUT as G(Vector3(..))--import Input-import Game---- Logic-data WinLose = Win | Lose deriving (Eq)---- Snapping integral -integral' = (iPre zeroVector &&& time) >>> sscan f (zeroVector, 0) >>> arr fst- where f (!prevVal, !prevTime) (!val, !time) - | val == zeroVector = (vectorApply (fromIntegral . round) prevVal, time)- | otherwise = (prevVal ^+^ (realToFrac $ time - prevTime) *^ val, time)--calculateState :: SF ParsedInput GameState-calculateState = proc pi@(ParsedInput ws as ss ds _ _ _ _) -> do- rec speed <- rSwitch selectSpeed -< ((pi, pos, speed, obstacles level),- winLose `tag` selectSpeed)- posi <- drSwitch (integral') -< (speed, winLose `tag` integral')- pos <- arr calculatePPos -< (posi, level)- winLose <- arr testWinLoseCondition -< (pos, level)- wins <- arr (filterE (==Win)) >>> delayEvent 1 -< winLose - level <- countHold >>^ fromInteger >>^ (levels !!) -< wins - - -- TODO: watch for leak on ws/as/ss/ds- returnA -< Game { level = level,- rotX = realToFrac (ws - ss),- playerPos = pos }-- where calculatePPos (pos, level) = pos ^+^ (p3DtoV3 $ startingPoint level)- testBounds pos size = let sizeN = fromInteger size- in vector3X pos > sizeN || vector3X pos < 0 ||- vector3Y pos > sizeN || vector3Y pos < 0 ||- vector3Z pos > sizeN || vector3Z pos < 0 - -- TODO: Abstract further?- testWinLoseCondition (pos, level)- | norm (pos ^-^ (p3DtoV3 $ endPoint level)) < 0.5 = Event Win- | testBounds pos (size level) = Event Lose- | otherwise = NoEvent--selectSpeed :: SF (ParsedInput, Vector3 R, Vector3 R, [Point3D]) - (Vector3 R)-selectSpeed = proc (pi, pos, speed, obss) -> do- let rotX = (fromInteger $ (floor $ (ws pi) - (ss pi)) `mod` 36 + 36) `mod` 36- theta = (((rotX - 6) `div` 9) + 1) `mod` 4- -- TODO: Get rid of the undefined? - speedC <- drSwitch (constant zeroVector) -< - (undefined, tagKeys (upEvs pi) speed ((-v) *^ zAxis) theta `merge` - tagKeys (downEvs pi) speed (v *^ zAxis) theta `merge`- tagKeys (leftEvs pi) speed ((-v) *^ xAxis) theta `merge`- tagKeys (rightEvs pi) speed (v *^ xAxis) theta) - cols <- collision ^>> boolToEvent -< (obss, pos, speedC)- speedf <- rSwitch (constant zeroVector) -< (speedC, tagCols cols) - returnA -< speedf- - where xAxis = vector3 1 0 0 - yAxis = vector3 0 1 0- zAxis = vector3 0 0 1- v = 0.5- -- TODO: make nicer? too many magical numbers & not 100% reliable- collision (obss,pos,speed) = - any (\obs -> norm (pos ^+^ ((1/v) *^ speed) ^-^ (p3DtoV3 obs)) - <= 0.4) obss- -- TODO: Confusing names, can they be generalized?- tagKeys event speed vector theta- | speed == zeroVector = event `tag` constant - (vector3Rotate' theta vector)- | otherwise = NoEvent- tagCols cols- | isNoEvent cols = Event identity- | otherwise = cols `tag` constant zeroVector- boolToEvent = arr (\bool -> if bool then Event () else NoEvent)--
Graphics.hs view
@@ -1,4 +1,4 @@-module Graphics where+module Graphics (initGL, draw) where import FRP.Yampa import FRP.Yampa.Vector3@@ -7,29 +7,30 @@ import Graphics.UI.GLUT hiding (Level,Vector3(..),normalize) import qualified Graphics.UI.GLUT as G(Vector3(..)) -import Game+import Types+import Utils -- Helpful OpenGL constants for rotation-xAxis = G.Vector3 1 0 0 :: G.Vector3 R +xAxis = G.Vector3 1 0 0 :: G.Vector3 R yAxis = G.Vector3 0 1 0 :: G.Vector3 R zAxis = G.Vector3 0 0 1 :: G.Vector3 R initGL :: IO () initGL = do getArgsAndInitialize+ initialDisplayMode $= [ WithDepthBuffer, DoubleBuffered ] createWindow "Cuboid!"- initialDisplayMode $= [ WithDepthBuffer ] depthFunc $= Just Less clearColor $= Color4 0 0 0 0 light (Light 0) $= Enabled- lighting $= Enabled - lightModelAmbient $= Color4 0.5 0.5 0.5 1 + lighting $= Enabled+ lightModelAmbient $= Color4 0.5 0.5 0.5 1 diffuse (Light 0) $= Color4 1 1 1 1 blend $= Enabled- blendFunc $= (SrcAlpha, OneMinusSrcAlpha) + blendFunc $= (SrcAlpha, OneMinusSrcAlpha) colorMaterial $= Just (FrontAndBack, AmbientAndDiffuse) reshapeCallback $= Just resizeScene- return () + return () -- Copied from reactive-glut resizeScene :: Size -> IO ()@@ -41,7 +42,6 @@ loadIdentity perspective 45 (w2/h2) 1 1000 matrixMode $= Modelview 0- flush where w2 = half width h2 = half height@@ -56,17 +56,16 @@ -- TODO: calculate rotation axis based on rotX/Y rotate (rotX * 10) xAxis color $ Color3 (1 :: R) 1 1- position (Light 0) $= Vertex4 0 0 0 1 + position (Light 0) $= Vertex4 0 0 0 1 renderObject Wireframe (Cube $ fromInteger $ size l) renderPlayer pPos renderGoal (p3DtoV3 $ endPoint l) mapM_ (renderObstacle . p3DtoV3) $ obstacles l- flush where size2 :: R size2 = (fromInteger $ size l)/2 green = Color4 0.8 1.0 0.7 0.9 :: Color4 R greenG = Color4 0.8 1.0 0.7 1.0 :: Color4 R- red = Color4 1.0 0.7 0.8 1.0 :: Color4 R + red = Color4 1.0 0.7 0.8 1.0 :: Color4 R renderShapeAt s p = preservingMatrix $ do translate $ G.Vector3 (0.5 - size2 + vector3X p) (0.5 - size2 + vector3Y p)@@ -74,12 +73,11 @@ renderObject Solid s renderObstacle = (color green >>) . (renderShapeAt $ Cube 1) renderPlayer = (color red >>) . (renderShapeAt $ Sphere' 0.5 20 20)- renderGoal = - (color greenG >>) . (renderShapeAt $ Sphere' 0.5 20 20) + renderGoal =+ (color greenG >>) . (renderShapeAt $ Sphere' 0.5 20 20) -game :: SF GameState (IO ())-game = arr $ (\gs -> do+draw :: SF GameState (IO ())+draw = arr $ (\gs -> do clear [ ColorBuffer, DepthBuffer ] renderGame gs- flush)-+ swapBuffers)
Input.hs view
@@ -1,46 +1,36 @@ {-# LANGUAGE Arrows #-}-module Input where+module Input (parseInput) where import FRP.Yampa import FRP.Yampa.Utilities import Graphics.UI.GLUT --- Event Definition:--data Input = Keyboard { key :: Key,- keyState :: KeyState,- modifiers :: Modifiers }--keyDowns :: SF (Event Input) (Event Input)-keyDowns = arr $ filterE ((==Down) . keyState)+import Types -countHold :: SF (Event a) Integer -countHold = count >>> hold 0+-- Event Definition:+filterKeyDowns :: SF (Event Input) (Event Input)+filterKeyDowns = arr $ filterE ((==Down) . keyState) keyIntegral :: Double -> SF (Event a) Double keyIntegral a = let eventToSpeed (Event _) = a eventToSpeed NoEvent = 0 in arr eventToSpeed >>> integral --data ParsedInput = - ParsedInput { ws :: Double, as :: Double, ss :: Double, ds :: Double,- upEvs :: Event Input, downEvs :: Event Input, - rightEvs :: Event Input, leftEvs :: Event Input }- + -- Input parseInput :: SF (Event Input) ParsedInput parseInput = proc i -> do- down <- keyDowns -< i- ws <- countKey 'w' -< down- as <- countKey 'a' -< down- ss <- countKey 's' -< down- ds <- countKey 'd' -< down+ down <- filterKeyDowns -< i+ wCount <- countKey 'w' -< down+ aCount <- countKey 'a' -< down+ sCount <- countKey 's' -< down+ dCount <- countKey 'd' -< down upEvs <- filterKey (SpecialKey KeyUp) -< down downEvs <- filterKey (SpecialKey KeyDown) -< down rightEvs <- filterKey (SpecialKey KeyRight) -< down leftEvs <- filterKey (SpecialKey KeyLeft) -< down- returnA -< ParsedInput ws as ss ds upEvs downEvs rightEvs leftEvs+ returnA -< ParsedInput wCount aCount sCount dCount + upEvs downEvs rightEvs leftEvs where countKey c = filterE ((==(Char c)) . key) ^>> keyIntegral 1 filterKey k = arr $ filterE ((==k) . key)
Main.hs view
@@ -6,17 +6,20 @@ import Data.IORef -import Graphics+import Types import Input-import GameLogic+import Update +import Graphics +mainSF = parseInput >>> update >>> draw + -- | Main, initializes Yampa and sets up reactimation loop main :: IO () main = do newInput <- newIORef NoEvent oldTime <- newIORef (0 :: Int) rh <- reactInit (initGL >> return NoEvent) (\_ _ b -> b >> return False) - (parseInput >>> calculateState >>> game)+ mainSF displayCallback $= return () keyboardMouseCallback $= Just (\k ks m _ -> writeIORef newInput (Event $ Keyboard k ks m))
+ Types.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE Arrows #-}+module Types where++import FRP.Yampa+import FRP.Yampa.Vector3++import Graphics.UI.GLUT hiding (Level,Vector3(..),normalize)+import qualified Graphics.UI.GLUT as G(Vector3(..))++type R = GLdouble++data Point3D = P3D { x :: Integer, y :: Integer, z :: Integer } deriving (Show)++data Level = Level { startingPoint :: Point3D, + endPoint :: Point3D,+ obstacles :: [Point3D] }++data Input = Keyboard { key :: Key,+ keyState :: KeyState,+ modifiers :: Modifiers }++data GameState = Game { level :: Level,+ rotX :: R, + playerPos :: Vector3 R }++data ParsedInput = + ParsedInput { wCount :: Double, aCount :: Double, + sCount :: Double, dCount :: Double,+ upEvs :: Event Input, downEvs :: Event Input, + rightEvs :: Event Input, leftEvs :: Event Input }+
+ Update.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE Arrows, BangPatterns, NamedFieldPuns #-}+module Update (update) where++import FRP.Yampa+import FRP.Yampa.Vector3+import FRP.Yampa.Utilities+import FRP.Yampa.Integration+import Graphics.UI.GLUT hiding (Level,Vector3(..),normalize)+import qualified Graphics.UI.GLUT as G(Vector3(..))++import Types+import Utils+import Config+import Input++-- Logic+data WinLose = Win | Lose deriving (Eq)++-- Snapping integral+integral' = (iPre zeroVector &&& time) >>> sscan f (zeroVector, 0) >>> arr fst+ where f (!prevVal, !prevTime) (!val, !time)+ | val == zeroVector =+ (vectorApply (fromIntegral . round) prevVal, time)+ | otherwise =+ (prevVal ^+^ (realToFrac $ time - prevTime) *^ val, time)++update :: SF ParsedInput GameState+update = proc pi@(ParsedInput{ wCount, aCount, sCount, dCount }) -> do+ rec speed <- rSwitch selectSpeed -< ((pi, pos, speed, obstacles level),+ winLose `tag` selectSpeed)+ posi <- drSwitch (integral') -< (speed, winLose `tag` integral')+ pos <- arr calculatePPos -< (posi, level)+ winLose <- arr testWinLoseCondition -< (pos, level)+ wins <- arr (filterE (==Win)) >>> delayEvent 1 -< winLose+ level <- countHold >>^ fromInteger >>^ (levels !!) -< wins++ -- TODO: watch for leak on wCount/aCount/sCount/dCount+ returnA -< Game { level = level,+ rotX = realToFrac (wCount - sCount),+ playerPos = pos }++ where calculatePPos (pos, level) = pos ^+^ (p3DtoV3 $ startingPoint level)+ testBounds pos size = let sizeN = fromInteger size+ in vector3X pos > sizeN || vector3X pos < 0 ||+ vector3Y pos > sizeN || vector3Y pos < 0 ||+ vector3Z pos > sizeN || vector3Z pos < 0+ -- TODO: Abstract further?+ testWinLoseCondition (pos, level)+ | norm (pos ^-^ (p3DtoV3 $ endPoint level)) < 0.5 = Event Win+ | testBounds pos (size level) = Event Lose+ | otherwise = NoEvent+ countHold = count >>> hold 0++selectSpeed :: SF (ParsedInput, Vector3 R, Vector3 R, [Point3D])+ (Vector3 R)+selectSpeed = proc (pi, pos, speed, obss) -> do+ let rotX = (fromInteger $ (floor $ (wCount pi) - (sCount pi))+ `mod` 36 + 36) `mod` 36+ theta = (((rotX - 6) `div` 9) + 1) `mod` 4+ -- TODO: Get rid of the undefined?+ speedC <- drSwitch (constant zeroVector) -<+ (undefined, tagKeys (upEvs pi) speed ((-v) *^ zAxis) theta `merge`+ tagKeys (downEvs pi) speed (v *^ zAxis) theta `merge`+ tagKeys (leftEvs pi) speed ((-v) *^ xAxis) theta `merge`+ tagKeys (rightEvs pi) speed (v *^ xAxis) theta)+ cols <- collision ^>> boolToEvent -< (obss, pos, speedC)+ speedf <- rSwitch (constant zeroVector) -< (speedC, tagCols cols)+ returnA -< speedf++ where xAxis = vector3 1 0 0+ yAxis = vector3 0 1 0+ zAxis = vector3 0 0 1+ v = 0.5+ -- TODO: make nicer? too many magical numbers & not 100% reliable+ collision (obss,pos,speed) =+ any (\obs -> norm (pos ^+^ ((1/v) *^ speed) ^-^ (p3DtoV3 obs))+ <= 0.4) obss+ -- TODO: Confusing names, can they be generalized?+ tagKeys event speed vector theta+ | speed == zeroVector = event `tag` constant+ (vector3Rotate' theta vector)+ | otherwise = NoEvent+ tagCols cols+ | isNoEvent cols = Event identity+ | otherwise = cols `tag` constant zeroVector+ boolToEvent = arr (\bool -> if bool then Event () else NoEvent)++
+ Utils.hs view
@@ -0,0 +1,27 @@+module Utils where++import FRP.Yampa.Vector3++import Graphics.UI.GLUT hiding (Level,Vector3(..),normalize)++import Types++p3DtoV3 :: (RealFloat a) => Point3D -> Vector3 a+p3DtoV3 (P3D x y z) = vector3 (fromInteger x) (fromInteger y) (fromInteger z)++vectorApply f v = vector3 (f $ vector3X v) (f $ vector3Y v) (f $ vector3Z v)++vector3Rotate' :: (Integral a, RealFloat b) => a -> Vector3 b -> Vector3 b+vector3Rotate' theta v =+ let rotateTheta 0 v = id v + rotateTheta 1 v = vector3 (vector3X v) (vector3Z v) (-(vector3Y v))+ rotateTheta 2 v = vector3 (vector3X v) (-(vector3Y v)) (-(vector3Z v)) + rotateTheta 3 v = vector3 (vector3X v) (-(vector3Z v)) (vector3Y v)+ rotateTheta i _ = rotateTheta (abs $ i `mod` 4) v+ in rotateTheta theta $ v++-- TODO: Memoize+size :: Level -> Integer+size = (+1) . maximum . map (\(P3D x y z) -> maximum [x,y,z]) . obstacles++
cuboid.cabal view
@@ -1,4 +1,4 @@-Name: cuboid +Name: cuboid Category: Game Description: @@ -15,8 +15,8 @@ a great level do send it to me. I plan to extract the levels into a configuration file in the future. -Synopsis: 3D Yampa/GLUT Puzzle Game -Version: 0.14.1+Synopsis: 3D Yampa/GLUT Puzzle Game+Version: 0.14.2 License: MIT License-file: LICENSE Copyright: (C) 2010 Pedro Martins@@ -27,8 +27,7 @@ Build-Type: Simple Cabal-Version: >= 1.6 -Executable cuboid +Executable cuboid Main-Is: Main.hs- Other-Modules: Game, GameLogic, Graphics, Input- Build-Depends: base >= 3 && < 5, Yampa, GLUT-+ Other-Modules: Types, Utils, Config, Input, Update, Graphics+ Build-Depends: base >= 3 && < 5, Yampa, GLUT >= 2.3