From 4a2286b37ad100f9d23c981b2e1120373234fdc8 Mon Sep 17 00:00:00 2001 From: uotbw Date: Fri, 18 Sep 2015 14:39:30 +0200 Subject: [PATCH] Added Cuboid2 game as example --- Source/Haskell-Source/CMakeLists.txt | 1 + Source/Haskell-Source/Samples/Cuboid2.hs | 314 ++++++++++++++++++ .../Samples/HGamer3D-SamplePackage.cabal | 7 +- Source/Haskell-Source/Samples/LiveStarter.hs | 20 +- 4 files changed, 335 insertions(+), 7 deletions(-) create mode 100644 Source/Haskell-Source/Samples/Cuboid2.hs diff --git a/Source/Haskell-Source/CMakeLists.txt b/Source/Haskell-Source/CMakeLists.txt index 0a51e04..bd4bf9b 100644 --- a/Source/Haskell-Source/CMakeLists.txt +++ b/Source/Haskell-Source/CMakeLists.txt @@ -102,6 +102,7 @@ set (SAMPLE_SRCS Samples/RotatingCube.hs Samples/Materials.hs Samples/engineShutdown.hs + Samples/Cuboid2.hs ) foreach(file ${SAMPLE_SRCS}) add_custom_command(OUTPUT ${CMAKE_CURRENT_BINARY_DIR}/${file} diff --git a/Source/Haskell-Source/Samples/Cuboid2.hs b/Source/Haskell-Source/Samples/Cuboid2.hs new file mode 100644 index 0000000..d8657b4 --- /dev/null +++ b/Source/Haskell-Source/Samples/Cuboid2.hs @@ -0,0 +1,314 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- + Sample: Cuboid2, a 3D puzzle game, thanks to Pedro Martins for game idea (https://github.com/pedromartins/cuboid) + HGamer3D Library (A project to enable 3D game development in Haskell) + Copyright 2011-2015 Peter Althainz + + Distributed under the Apache License, Version 2.0 + (See attached file LICENSE or copy at + http://www.apache.org/licenses/LICENSE-2.0) + + file: Samples/Cuboid.hs +-} + +module Main where + +import HGamer3D + +import qualified Data.Text as T +import Control.Concurrent +import Control.Monad +import Data.Fixed +import Data.IORef +import Data.List + + +-- Game Logic, pure functional parts +------------------------------------ + +-- largest dimension +maxDim :: Int +maxDim = 5 + +-- logical positions, range from 0 to dim - 1 +type FieldPos = (Int, Int, Int) + +-- one level of positions, start and end position +data Level = Level { lDim :: Int, + lField :: [FieldPos], + lStart :: FieldPos, + lGoal :: FieldPos } deriving (Show, Eq) + +-- all game data, array of levels +type GameData = [Level] + +gameData :: GameData -- static data of all levels +gameData = [ + Level 5 [(2,2,2),(1,1,1),(3,3,3)] (0, 3, 4) (4, 3, 4) , + Level 5 [(0,4,4),(0,0,3),(4,1,3)] (0,4,3) (3,1,0), + Level 5 [(1,3,0),(3,3,0),(1,1,1),(3,1,1),(3,4,2),(0,3,3),(1,2,4),(2,1,4),(3,0,4),(3,3,4),(4,2,4)] (0,3,4) (4,2,3) + ] + + +-- function, evaluating a move, moving the cursor in a specific direction, Bool is if success +steps :: FieldPos -> FieldPos -> Level -> ([FieldPos], Bool) +steps start move level = + + let atGoal p = p == (lGoal level) + blocked p = p `elem` (lField level) + outOfBounds (a, b, c) = let d = lDim level in a >= d || b >= d || c >= d || a < 0 || b < 0 || c < 0 + next (x, y, z) (x', y', z') = (x+x', y+y', z+z') + + oneStep ps start pos + | atGoal pos = (ps ++ [pos], True) -- stopping at goal + | blocked pos = (ps, False) -- stopping at current pos, blocked + | outOfBounds pos = (ps ++ [pos, start], False) -- stopping, due to outofbounds, back to start + | otherwise = oneStep (ps ++ [pos]) start (next pos move) -- successful step do next step + + in oneStep [] start (next start move) + + + +-- rename IORef +--------------- +newVar :: a -> IO (IORef a) +newVar v = newIORef v + +updateVar :: IORef v -> (v -> v) -> IO v +updateVar v f = atomicModifyIORef v (\v -> let r = f v in (r, r)) + +updateVar' :: IORef v -> (v -> (v, w)) -> IO w +updateVar' = atomicModifyIORef + +setVar :: IORef v -> v -> IO () +setVar v val = atomicModifyIORef v (\v -> (val, ())) + +readVar :: IORef v -> IO v +readVar = readIORef + +-- Engine related low level routines +------------------------------------ + +-- creates and adds entities to world +creator w l = newE l >>= \e -> (addToWorld w e >> return e) + +-- setup basic 3D world +setupWorld = do + -- initialize + eG3D <- newE [ctGraphics3DConfig #: standardGraphics3DConfig, ctGraphics3DCommand #: NoCmd] + world <- forkGraphics3DWorld (setC eG3D ctGraphics3DCommand Step >> return False) (msecT 20) + addToWorld world eG3D + -- camera and light + cam <- creator world [ctCamera #: FullViewCamera, ctPosition #: Vec3 0 0 0, ctOrientation #: unitU] + light1 <- creator world [ctLight #: Light (SpotLight (Deg 50) 1.0) 1.0 100.0 1.0, ctPosition #: Vec3 (10) (-10) (-10.0)] + light2 <- creator world [ctLight #: Light PointLight 0.5 1000.0 0.8, ctPosition #: Vec3 0 0 (-50)] + light3 <- creator world [ctLight #: Light DirectionalLight 1.0 1000.0 1.0, ctOrientation #: (rotU vec3Y 45 .*. rotU vec3X 45)] + -- keyboard, mouse input + kb <- creator world [ctKeyEvent #: KeyUp 0 0 ""] + return (world, cam, kb) + +-- quat from 2 vectors, normalized input +ufrom2v u v = let (Vec3 x y z) = u &^ v in mkU (Vec4 (1.0 + (u &. v)) x y z ) + +-- create a line +line :: [SystemData] -> Material -> Vec3 -> Vec3 -> Float -> IO ERef +line w m p1 p2 t = do + let d = p2 &- p1 + let l = len d + let u = ufrom2v (normalize (Vec3 0 l 0)) (normalize d) + l <- creator w [ctMaterial #: m, ctGeometry #: ShapeGeometry Cube, + ctPosition #: (p1 &+ (d &* 0.5)) , ctScale #: (Vec3 t l t), ctOrientation #: u] + return l + +-- create a sphere +sphere w m p s = do + s <- creator w [ctMaterial #: m, ctGeometry #: ShapeGeometry Sphere, + ctPosition #: p, ctScale #: s, ctOrientation #: unitU] + return s + +-- create a cube +cube w m p s = do + s <- creator w [ctMaterial #: m, ctGeometry #: ShapeGeometry Cube, + ctPosition #: p, ctScale #: s, ctOrientation #: unitU] + return s + +-- Containing cube +cubeOutline p s = let + corners = [ Vec3 x y z | x <- [-1,1], y <- [-1,1], z <- [-1,1]] + edges = filter (\(a, b) -> (a &- b) `elem` [Vec3 2 0 0, Vec3 0 (-2) 0, Vec3 0 0 2] ) [(ca, cb) | ca <- corners, cb <- corners] + trans v = (v &! s) &+ p + in (map trans corners, map (\(a, b) -> (trans a, trans b)) edges) + +-- constants between fieldPos and real world +oC :: Vec3 +oC = (Vec3 0 0 20.0) + +sC :: Float +sC = 10.0 + +spC :: FieldPos +spC = (0, -10, 0) + +-- cuboid position into vec3 positions +f2pos :: FieldPos -> Vec3 +f2pos pos@(x, y, z) = let + vs = Vec3 (fromIntegral x) (fromIntegral y) (fromIntegral z) + dim = fromIntegral maxDim + vs' = (vs &* (2.0 / (dim - 1))) &- unitVec3 + in oC &+ (sC *& vs') + +-- draw the static frame around the cubes +drawCubeFrame w = do + let (corners, edges) = cubeOutline oC (unitVec3 &* (sC * 1.05)) + mapM (\(a, b) -> line w matMetal a b (0.05 * sC) ) edges + mapM (\v -> sphere w matMetal v (unitVec3 &* (sC * 0.12))) corners + +-- create all used sphere +createSpheres w = do + let sphereSize = unitVec3 &* (2.0 * sC / (fromIntegral maxDim)) + cubes <- mapM (\_ -> cube w matBlue (f2pos spC) (sphereSize &* 0.9)) [0.. (maxDim * maxDim) -1] + startSphere <- sphere w matLime (f2pos spC) sphereSize + endSphere <- sphere w matRed (f2pos spC) sphereSize + return (startSphere, endSphere, cubes) + +setPos er fp = setC er ctPosition (f2pos fp) + +-- Low Level Event Routines +--------------------------- + +-- two different ways of event handling demonstrated here +-- camera is moved by traditional listener +-- other key events are fed into Sodium network for game logic + +-- install key handler, moves each key up and currently pressed keys in variable +installKeyHandler :: IORef [T.Text] -> IORef [T.Text] -> ERef -> IO () +installKeyHandler varKeysUp varKeysPressed kb = do + let handleKeys ke = do + case ke of + KeyUp _ _ k -> do + updateVar varKeysPressed (\keys -> filter (\k' -> k' /= k) keys) + updateVar varKeysUp (\keys -> keys ++ [k]) + return () + KeyDown _ _ k -> updateVar varKeysPressed (\keys -> if not (k `elem` keys) then k:keys else keys) >> return () + _ -> return () + addListener kb ctKeyEvent (\_ enew -> handleKeys (enew # ctKeyEvent)) + return () + +-- camera movement +installMoveCamera cam varKeysPressed = do + let mUX = (Vec3 0.3 0 0.0) + let mUZ = (Vec3 0 0 0.3) + let move = do + keys <- readVar varKeysPressed + if "D" `elem` keys then updateC cam ctPosition (\v -> v &+ mUX) else return () + if "A" `elem` keys then updateC cam ctPosition (\v -> v &- mUX) else return () + if "W" `elem` keys then updateC cam ctPosition (\v -> v &+ mUZ) else return () + if "S" `elem` keys then updateC cam ctPosition (\v -> v &- mUZ) else return () + return () + forkIO $ forever $ move >> sleepFor (msecT 50) + return() + + +-- Game Preparation Work +------------------------ + +startWorld = do + (world, cam, keyboard) <- setupWorld + varKeysUp <- newVar [] + varKeysPressed <- newVar [] + installKeyHandler varKeysUp varKeysPressed keyboard + installMoveCamera cam varKeysPressed + drawCubeFrame world + (startSphere, endSphere, spheres) <- createSpheres world + return (varKeysUp, (startSphere, endSphere, spheres)) + + +-- Game Actions +--------------- +-- actions are fired and do something in the game world + +-- action set new field +newFieldA (sS, eS, ss) level = do + mapM (\s -> setPos s spC) ss + mapM (\(s, p) -> setPos s p) (zip ss (lField level)) + setPos sS (lStart level) + setPos eS (lGoal level) + return () + +-- action move cursor, also fractional values are possible +moveA sS start end val = do + let sV = f2pos start + let eV = f2pos end + let v = sV &+ ((eV &- sV) &* val) + setC sS ctPosition v + return () + +-- timeLoop, do a sequence of actions in a specific time +timeLoop :: [IO()] -> GameTime -> IO() +timeLoop actionList tRun = do + let tDiff = usecT ((usec tRun) `div` (length actionList)) + mapM (\a -> sleepFor tDiff >> a) actionList + return () + +-- move object slowly to next location +moveTime sS start end tRun = do + let nSteps = 20 + steps = map (\d -> moveA sS start end d) (map (\n -> (fromIntegral n) / (fromIntegral nSteps)) [1..nSteps]) + timeLoop steps (msecT 500) + +-- blink cursor a little bit +blinkCursor c = do + timeLoop (map (\m -> setC c ctMaterial m) [matOlive, matGreen, matOlive, matGreen, matOlive, matGreen, matOlive, matLime]) (secT 2) + return () + +getMoveFromKey k = case k of + "Left" -> Just (-1, 0, 0) + "Right" -> Just (1, 0, 0) + "Up" -> Just (0, 1, 0) + "Down" -> Just (0, -1, 0) + "PageUp" -> Just (0, 0, 1) + "PageDown" -> Just (0, 0, -1) + _ -> Nothing + +runLevel varKeysUp allS@(sS, eS, ss) level = do + + newFieldA allS level + let moveSteps pos list = case list of + (p: ps) -> moveTime sS pos p (msecT 200) >> moveSteps p ps + [] -> return () + resetKeys = setVar varKeysUp [] + pause = sleepFor (msecT 20) + getMove = do + keys <- updateVar' varKeysUp (\ks -> ([], ks)) + if length keys > 0 then + case getMoveFromKey (head keys) of + Just m -> return m + Nothing -> pause >> getMove + else pause >> getMove + processMove pos m = case steps pos m level of + ([], False) -> blinkCursor sS >> return (pos, False) + (steps, False) -> moveSteps pos steps >> return (((head . reverse) steps), False) + (steps, True) -> moveSteps pos steps >> return (((head . reverse) steps), True) + loopKey pos = do + m <- getMove + (pos', success) <- processMove pos m + if success then return () else loopKey pos' + resetKeys + loopKey (lStart level) + +main = do + (varKeysUp, allS) <- startWorld + mapM (\l -> runLevel varKeysUp allS l) gameData + return () + +{- + +:s OverloadedStrings + +-- start +:l Cuboid2 +:import Control.Concurrent +forkIO $ main + +-} \ No newline at end of file diff --git a/Source/Haskell-Source/Samples/HGamer3D-SamplePackage.cabal b/Source/Haskell-Source/Samples/HGamer3D-SamplePackage.cabal index 7610067..d997a27 100644 --- a/Source/Haskell-Source/Samples/HGamer3D-SamplePackage.cabal +++ b/Source/Haskell-Source/Samples/HGamer3D-SamplePackage.cabal @@ -23,11 +23,16 @@ Executable engineShutdown Executable RotatingCube Build-Depends: base >= 3 && < 5, HGamer3D, text Main-Is: RotatingCube.hs - ghc-options: -threaded + ghc-options: -threaded -rtsopts "-with-rtsopts=-N -A15M -qg -G3" Executable Materials Build-Depends: base >= 3 && < 5, HGamer3D, text Main-Is: Materials.hs ghc-options: -threaded -rtsopts "-with-rtsopts=-N -A15M -qg -G3" +Executable Cuboid2 + Build-Depends: base >= 3 && < 5, HGamer3D, text + Main-Is: Cuboid2.hs + ghc-options: -threaded -rtsopts "-with-rtsopts=-N -A15M -qg -G3" + diff --git a/Source/Haskell-Source/Samples/LiveStarter.hs b/Source/Haskell-Source/Samples/LiveStarter.hs index d92947e..3a12697 100644 --- a/Source/Haskell-Source/Samples/LiveStarter.hs +++ b/Source/Haskell-Source/Samples/LiveStarter.hs @@ -20,9 +20,11 @@ run notepad++ Usable command lines: :s OverloadedStrings -:l Test +:l LiveStarter (w, c, g, l) <- main +experiment with those: + setC l ctLight (Light (SpotLight (Deg 50) 1.0) 1.0 1000.0 1.5) setC l ctColour white @@ -43,6 +45,7 @@ import qualified Data.Text as T import Control.Concurrent import Control.Monad +-- routine to initialize the system startWorld = do eG3D <- newE [ ctGraphics3DConfig #: standardGraphics3DConfig, @@ -53,11 +56,13 @@ startWorld = do addToWorld world eG3D return world +-- small tool, to create entities creator w l = do e <- newE l addToWorld w e return e - + +-- entity creation tools camera w pos = creator w [ ctCamera #: FullViewCamera, ctPosition #: pos @@ -76,18 +81,19 @@ light w pos = creator w [ ctPosition #: pos, ctColour #: white ] - + +-- creation of some event receivers mouse w = creator w [ ctMouse #: Mouse MMAbsolute, ctMouseEvent #: undefined, ctVisible #: False ] - + keyboard w = creator w [ ctKeyEvent #: KeyUp 0 0 "" ] - +-- event usage, testing the mouse modes testMouseModes m k = do let handleKeys n = do case n of @@ -98,12 +104,14 @@ testMouseModes m k = do _ -> return () return () in addListener k ctKeyEvent (\_ enew -> handleKeys (enew # ctKeyEvent)) - + +-- the main program, putting all together main = do w <- startWorld c <- camera w (Vec3 0.0 0.0 0.0) g <- cube w (Vec3 0.0 0.0 (10.0)) l <- light w (Vec3 0.0 0.0 0.0) return (w, c, g, l) + -- here the program stops, use it in GHCI