cuboid 0.1 → 0.11
raw patch · 5 files changed
+248/−1 lines, 5 files
Files
- Game.hs +45/−0
- GameLogic.hs +74/−0
- Graphics.hs +85/−0
- Input.hs +42/−0
- cuboid.cabal +2/−1
+ Game.hs view
@@ -0,0 +1,45 @@+{-# 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 }++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 view
@@ -0,0 +1,74 @@+{-# LANGUAGE Arrows #-}+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)++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 = (fromInteger $ (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)+ | pos == (p3DtoV3 $ endPoint level) = 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 $ ((ws pi) - (ss pi)) `mod` 36 + 36) `mod` 36+ theta = (((rotX - 6) `div` 9) + 1) `mod` 4+ -- TODO: Get rid of the undefineds? + 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+ collision (obss,pos,speed) = + any (\obs -> norm (pos ^+^ (2 *^ speed) ^-^ (p3DtoV3 obs)) + <= 0.001) 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
@@ -0,0 +1,85 @@+module Graphics 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 Game++-- Helpful OpenGL constants for rotation+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+ 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 + diffuse (Light 0) $= Color4 1 1 1 1+ blend $= Enabled+ blendFunc $= (SrcAlpha, OneMinusSrcAlpha) + colorMaterial $= Just (FrontAndBack, AmbientAndDiffuse)+ reshapeCallback $= Just resizeScene+ return () ++-- Copied from reactive-glut+resizeScene :: Size -> IO ()+resizeScene (Size w 0) = resizeScene (Size w 1) -- prevent divide by zero+resizeScene s@(Size width height) = do+ -- putStrLn "resizeScene"+ viewport $= (Position 0 0, s)+ matrixMode $= Projection+ loadIdentity+ perspective 45 (w2/h2) 1 1000+ matrixMode $= Modelview 0+ flush+ where+ w2 = half width+ h2 = half height+ half z = realToFrac z / 2++-- Rendering Code:++renderGame :: GameState -> IO ()+renderGame (Game l rotX pPos) = do+ loadIdentity+ translate $ G.Vector3 (0 :: R) 0 (-2*(fromInteger $ size l))+ -- 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 + 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 + renderShapeAt s p = preservingMatrix $ do+ translate $ G.Vector3 (0.5 - size2 + vector3X p)+ (0.5 - size2 + vector3Y p)+ (0.5 - size2 + vector3Z p)+ 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) ++game :: SF GameState (IO ())+game = arr $ (\gs -> do+ clear [ ColorBuffer, DepthBuffer ]+ renderGame gs+ flush)+
+ Input.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE Arrows #-}+module Input 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)++countHold :: SF (Event a) Integer+countHold = count >>> hold 0++data ParsedInput = + ParsedInput { ws :: Integer, as :: Integer, ss :: Integer, ds :: Integer,+ 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+ 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+ where countKey c = filterE ((==(Char c)) . key) ^>> countHold+ filterKey k = arr $ filterE ((==k) . key)++
cuboid.cabal view
@@ -16,7 +16,7 @@ into a configuration file in the future. Synopsis: 3D Yampa/GLUT Puzzle Game -Version: 0.1+Version: 0.11 License: MIT License-file: LICENSE Copyright: (C) 2010 Pedro Martins@@ -28,5 +28,6 @@ Executable cuboid Main-Is: Main.hs+ Other-Modules: Game, GameLogic, Graphics, Input Build-Depends: base >= 3 && < 5, Yampa, GLUT