diff --git a/Config.hs b/Config.hs new file mode 100644 --- /dev/null +++ b/Config.hs @@ -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]) + diff --git a/Game.hs b/Game.hs deleted file mode 100644 --- a/Game.hs +++ /dev/null @@ -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]) - diff --git a/GameLogic.hs b/GameLogic.hs deleted file mode 100644 --- a/GameLogic.hs +++ /dev/null @@ -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) - - diff --git a/Graphics.hs b/Graphics.hs --- a/Graphics.hs +++ b/Graphics.hs @@ -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) diff --git a/Input.hs b/Input.hs --- a/Input.hs +++ b/Input.hs @@ -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) diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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)) diff --git a/Types.hs b/Types.hs new file mode 100644 --- /dev/null +++ b/Types.hs @@ -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 } + diff --git a/Update.hs b/Update.hs new file mode 100644 --- /dev/null +++ b/Update.hs @@ -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) + + diff --git a/Utils.hs b/Utils.hs new file mode 100644 --- /dev/null +++ b/Utils.hs @@ -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 + + diff --git a/cuboid.cabal b/cuboid.cabal --- a/cuboid.cabal +++ b/cuboid.cabal @@ -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