topkata 0.2.3 → 0.2.4
raw patch · 14 files changed
+308/−572 lines, 14 filesdep +GLFW-bdep +parseargsdep −GLUTdep ~base
Dependencies added: GLFW-b, parseargs
Dependencies removed: GLUT
Dependency ranges changed: base
Files
- Labygen/Render.hs +2/−1
- Main.hs +61/−538
- Makefile +5/−10
- NEWS +26/−0
- ReadImage.hs +3/−2
- Topkata/CommandLineArgs.hs +16/−0
- Topkata/Render.hs +96/−0
- Topkata/State.hs +19/−0
- Topkata/Textures.hs +47/−0
- Topkata/Topka/Base.hs +2/−5
- Topkata/Topka/Ghost.hs +2/−1
- Topkata/Topka/Topka.hs +22/−10
- Vector.hs +3/−2
- topkata.cabal +4/−3
Labygen/Render.hs view
@@ -3,7 +3,8 @@ where import Labygen-import Graphics.UI.GLUT+--import Graphics.UI.GLFW+import Graphics.Rendering.OpenGL import Data.Array import Data.Ix import Debug.Trace
Main.hs view
@@ -1,550 +1,73 @@-module Main where--import System.Exit ( exitWith, ExitCode(ExitSuccess) )-import Graphics.UI.GLUT -#ifdef USE_FTGL- hiding (Font)-import Graphics.Rendering.FTGL-#endif-import Data.IORef ( IORef, newIORef, modifyIORef, readIORef, writeIORef )-import Topkata.Topka.Base-import Topkata.Topka.Ghost-import Topkata.Topka.Topka-import Data.Maybe (listToMaybe, maybeToList)-import Data.Array-import Labygen-import Labygen.Render-import ReadImage (readImageWithSize)-import Control.Monad( sequence_, when )-import qualified Vector as V-import System.Random (randomIO)---#ifdef SOUND-import qualified Sound.ALUT.Initialization as ALUT-import Sound.ALUT.Loaders (createBuffer, SoundDataSource(File))-import Sound.OpenAL (openDevice, closeDevice)-import Sound.OpenAL.AL.Listener-import Sound.OpenAL.AL.Source-import Sound.OpenAL.AL.Errors-import Sound.ALUT (ALfloat)-#endif--import System.FilePath ( (</>) )-import Paths_topkata (getDataFileName)---data ViewMode = ExploringMode- | EgoMode- | FollowMode--data Camera = Camera {- camPosition :: Vector3 GLdouble,- camAngle :: GLdouble-}--data State = State {- topka :: IORef TopkaState,- ghosts :: IORef [GhostState],- camera :: IORef Camera,- vmode :: IORef ViewMode,- laby :: World Pos3,- dij :: Array Pos3 Int,- worldDL :: DisplayList,- textures :: Textures,- score :: IORef Int-#ifdef USE_FTGL- ,font1 :: Font-#endif- }---getDataFileName' fn = getDataFileName ("data" </> fn)--mkCamera x y z angle = Camera { - camPosition = Vector3 x y z,- camAngle = angle-}---mkstate bt textures = do- ts <- newIORef initialTopkaState- vm <- newIORef FollowMode- sh <- newIORef False- laby <- labygenIO (origin, target) origin target- Pos3 (gx, _, gz) <- randomFreePosIO laby - ghosts <- newIORef [newGhost (middle gx) (middle gz)]- worldDL <- compileWorldDL bt laby- camera <- newIORef $ mkCamera 0.31 0.3 (-0.11) 0.0-#ifdef USE_FTGL- font <- createTextureFont "/usr/share/fonts/truetype/ttf-dejavu/DejaVuSans.ttf"- setFontFaceSize font 24 72-#endif- score <- newIORef 0- return $ State { topka = ts, - laby = laby, dij = dijkstra laby target,- vmode = vm,- camera = camera,- worldDL = worldDL, ghosts = ghosts,- score = score,- textures = textures-#ifdef USE_FTGL- , font1 = font-#endif- }- where middle x = fromIntegral x + 0.5--origin = Pos3 (0, 0, 0)-target = Pos3 (30, 0, 30)--tex e = e . textures--incrScore state amount =- score state $~ \ s -> s + amount--topkaUpd state f x =- topka state $~ \ ts ->- f ts x--viewData state = do- vm <- get (vmode state)- case vm of- EgoMode -> do- ts <- get (topka state)- return $ topView ts- ExploringMode -> do- cam <- get (camera state)- let Vector3 camX camY camZ = camPosition cam- angle = camAngle cam- return (camX, camY, camZ, angle)- FollowMode -> do- (x, y, z, phi) <- fmap topView $ get $ topka state- return (x, 3, z-2, 0)--moveD a b c = move a b c >> postRedisplay Nothing--camMove state u =- camera state $~ \ cam ->- cam { camPosition = u $ camPosition cam }--camTurn state d = - camera state $~ \ cam ->- cam { camAngle = camAngle cam + d } --move r state inc = do- r state $~ (+ inc)- get $ r state--camForward state d = do- cam <- get (camera state)- let angle = camAngle cam- dx = sin angle * (-d)- dz = cos angle * d- camMove state (\ (Vector3 x y z) -> Vector3 (x+dx) y (z+dz))- return ()---showHit = putStrLn "HIT!"---safeMove move state d = do- move state d- hit <- testCamHit state- if hit then do- showHit- move state (-d)- else return ()- postRedisplay Nothing-------myInit = do- clearColor $= Color4 0 0 0 0- polygonMode $= (Fill, Fill)-- shadeModel $= Smooth-- materialSpecular FrontAndBack $= Color4 1 1 1 1- materialShininess FrontAndBack $= 25- colorMaterial $= Just (FrontAndBack, Diffuse)-- position (Light 1) $= Vertex4 0 0.5 (-0.5) 1- position (Light 0) $= Vertex4 1 2 (-8) 0-- lighting $= Enabled- light (Light 0) $= Enabled- light (Light 1) $= Enabled- depthFunc $= Just Less-- ambient (Light 0) $= Color4 0.2 0.2 0.2 1.0- diffuse (Light 0) $= Color4 1 1 1 1- diffuse (Light 1) $= Color4 1 1 1 1- specular (Light 1) $= Color4 1 1 1 1- --position (Light 0) $= Vertex4 0 3 2 0-- lightModelAmbient $= Color4 0.4 0.4 0.4 1- lightModelLocalViewer $= Enabled- lightModelTwoSide $= Enabled-- -- blend $= Enabled- -- blendFunc $= (SrcAlpha, OneMinusSrcAlpha)- -- hint PolygonSmooth $= Nicest- --polygonSmooth $= Enabled-- -- hint LineSmooth $= Nicest- -- lineSmooth $= Enabled-- normalize $= Enabled-- let brickSize = TextureSize2D 512 256- brickTex <- fmap listToMaybe $ genObjectNames 1-- textureBinding Texture2D $= brickTex-- textureWrapMode Texture2D S $= (Mirrored, Repeat)- textureWrapMode Texture2D T $= (Mirrored, Repeat)- textureFilter Texture2D $= ((Nearest, Just Nearest), Nearest)-- sequence_ $ zipWith (mkTex "brick") [0..9] (reverse $ take 10 $ iterate (* 2) 1)-- eyeTex <- loadEyes "eyes"- geyeTex <- loadEyes "geyes"-- let textures = Textures {- texTopkata = eyeTex,- texGhost = geyeTex- }- mkstate brickTex textures--loadEyes name = do- let eyeSize = TextureSize2D 256 256- eyeTex <- fmap listToMaybe $ genObjectNames 1-- textureBinding Texture2D $= eyeTex-- --textureFilter Texture2D $= ((Nearest, Just Nearest), Nearest)-- textureWrapMode Texture2D S $= (Repeated, Clamp)- textureWrapMode Texture2D T $= (Repeated, Clamp)- textureFilter Texture2D $= ((Nearest, Nothing), Nearest)- mkTex name 0 256- return eyeTex---mkTex prefix lvl xsize = do- let fname = prefix ++ show xsize ++ ".rgb"- let ysize = max 1 (xsize `div` 2)- let size = TextureSize2D xsize ysize- --putStrLn fname- path <- getDataFileName' fname- (_, bricksData) <- readImageWithSize path xsize ysize- texImage2D Nothing NoProxy lvl RGBA' size 0 bricksData---processHits :: Maybe [HitRecord] -> IO ()-processHits Nothing = putStrLn "selection buffer overflow"-processHits (Just hitRecords) = do- putStrLn ("hits = " ++ show (length hitRecords))- mapM_ (\(HitRecord z1 z2 names) -> do- putStrLn (" number of names for hit = " ++ show (length names))- putStr (" z1 is " ++ show z1)- putStrLn ("; z2 is " ++ show z2)- putStr " the name is"- sequence_ [ putStr (" " ++ show n) | Name n <- names ]- putChar '\n')- hitRecords---testCamHit state = do- frustum (-0.2) 0.5 (-0.2) (0.5) (0.5) (20)- matrixMode $= Projection- loadIdentity- --ortho (-2) (2) (-2) 2 (-2) 2- frustum (-0.2) 0.5 (-0.2) (0.5) (0.49) (0.5)- --perspective 60 (fromIntegral w/fromIntegral h) 0.5 20- depthRange $= (0.45, 0.5)- matrixMode $= Modelview 0- loadIdentity- (x, y, z, phi) <- viewData state- lookAt (Vertex3 x y z) (Vertex3 (x+2*sin phi) (0.5) (z+2*cos phi)) (Vector3 0 1 0)- (_, maybeHitRecords) <- getHitRecords 128 $ do- withName (Name 0) $ preservingMatrix $ callList (worldDL state)- flush- -- processHits maybeHitRecords- case maybeHitRecords of- Just [] -> return False- _ -> return True---white = Color3 1.0 1.0 (1.0 :: GLfloat)---printString :: State -> Vertex2 GLfloat -> String -> IO ()-printString state pos s = do- color white- rasterPos pos-#ifdef USE_FTGL- renderFont (font1 state) "some string" All-#else- renderString Helvetica18 s-#endif---display state tops = do- (_, Size w h) <- get viewport-- matrixMode $= Projection- loadIdentity- lighting $= Enabled- hit <- return False -- get (showHit state)- frustum (-0.2) 0.5 (-0.2) (0.5) (if hit then 0.45 else 0.5) (if hit then 0.5 else 20)-- --showHit state $= False- --perspective 60 (fromIntegral w/fromIntegral h) 0.5 20- depthRange $= (0.5, 20)- matrixMode $= Modelview 0- loadIdentity-- clear [ ColorBuffer, DepthBuffer ]- loadIdentity-- (x, y, z, phi) <- viewData state- --lookAt (Vertex3 x y z) (Vertex3 (x+2*sin phi) (0.5) (z+2*cos phi)) (Vector3 0 1 0)- lookAt (Vertex3 x y z) (Vertex3 (x+1) (0.5) (z+2*cos phi)) (Vector3 0 1 0)-#ifdef SOUND- listenerPosition $= Vertex3 (realToFrac x) (realToFrac y) (realToFrac z)- listenerVelocity $= Vector3 0 0 (0 :: ALfloat)- orientation $= (Vector3 0 0 1, Vector3 0 1 0)-#endif-- preservingMatrix $ callList (worldDL state)--- ts <- get (topka state)- showTopkata ts tops- ghosts <- get (ghosts state)- showGhosts ghosts tops-- showScore state--- flush- swapBuffers--showScore state = do- loadIdentity - matrixMode $= Projection- loadIdentity- ortho (-1) 1 (-1) 1 (-1) 1- matrixMode $= Modelview 0- loadIdentity- lighting $= Disabled- color white - rasterPos (Vertex2 0.0 (0.0 :: GLfloat)) - scr <- get (score state)- printString state (Vertex2 (-0.99) (-0.99)) $ "Score: " ++ show scr--reshape :: ReshapeCallback-reshape size@(Size w h) = do- viewport $= (Position 0 0, size)---keyboardMouse state snds dev k Down _ _ = keyboard state k snds dev-keyboardMouse _ snds dev _ _ _ _ = return ()--myMotionCallback state pos = return () -- putStrLn ("pos=" ++ show pos)--syncCamWithTopkata state = do- (x, _, z, phi) <- viewData state- camera state $= Camera {- camPosition = Vector3 x 0.1 z,- camAngle = phi }--switchMode state = do- syncCamWithTopkata state- vmode state $~ \ v ->- case v of- FollowMode -> EgoMode- EgoMode -> ExploringMode- ExploringMode -> FollowMode---camKeyboard state k =- case k of--- Char 'f' -> zmove state (-0.1)--- Char 'b' -> zmove state (0.2)--- Char 'r' -> xTopMove state (-0.2)- SpecialKey KeyRight -> safeMove camTurn state (0.2)--- Char 'l' -> xTopMove state (0.2)- SpecialKey KeyLeft -> safeMove camTurn state (-0.2)--- Char 'd' -> yTopMove state (-0.2)- SpecialKey KeyDown -> safeMove camForward state (0.02)--- Char 'u' -> yTopMove state (0.2)- SpecialKey KeyUp -> safeMove camForward state (-0.02)-{- Char 'x' -> xrot state (10)- Char 'X' -> xrot state (-10)- Char 'y' -> yrot state (10)- Char 'Y' -> yrot state (-10)- Char 'z' -> zrot state (10)- Char 'Z' -> zrot state (-10)- Char 'm' -> openMouth state (0.05)- Char 'M' -> openMouth state (-0.05)- Char '1' -> togglePrimMode state- Char ' ' -> yrot state 10 -}- _ -> return ()--topKeyboard state k =- case k of- SpecialKey KeyRight -> topkaUpd state updateOrientation rotCW- SpecialKey KeyLeft -> topkaUpd state updateOrientation rotCCW- SpecialKey KeyDown -> topkaUpd state updateSpeed (0.005-)- SpecialKey KeyUp -> topkaUpd state updateSpeed (0.005+)- _ -> return ()--followKeyboard state k =- case k of- SpecialKey KeyRight -> topkaUpd state setNextOrientation East- SpecialKey KeyLeft -> topkaUpd state setNextOrientation West- SpecialKey KeyDown -> topkaUpd state setNextOrientation South- SpecialKey KeyUp -> topkaUpd state setNextOrientation North- _ -> return ()+module Main (main) where +import qualified Graphics.UI.GLFW as GLFW+import qualified Topkata.CommandLineArgs as Args+import Graphics.Rendering.OpenGL ( ($=) )+import Data.IORef+import Control.Monad (unless)+import System.IO.Unsafe (unsafePerformIO)+import qualified Graphics.Rendering.OpenGL as GL+import Topkata.Render (render, mkRenderInfo, renderInit)+import Topkata.State +import Topkata.Topka.Topka (animateTop)+import Topkata.Actions+import qualified Topkata.Keyboard as Keyboard+import Control.Concurrent(threadDelay)+import Graphics.Rendering.OpenGL as OpenGL -keyboard state k snds dev =- case k of- Char '\27' -> do- putStrLn "clean up"-#ifdef SOUND- deleteObjectNames snds- mapM_ closeDevice $ maybeToList dev-#endif- exitWith ExitSuccess- Char '\t' -> switchMode state- Char 'f' -> fullScreen- _ -> do- vm <- get (vmode state)- case vm of- EgoMode -> topKeyboard state k- FollowMode -> followKeyboard state k- ExploringMode -> camKeyboard state k+--windowMode True = GLFW.Window+--windowMode False = GLFW.FullScreen -keyboardMouse' a c d e f = do- -- putStrLn $ show c- keyboardMouse a c d e f+simpleErrorCallback e s =+ putStrLn $ unwords [show e, show s] +initialize actionSlot windowOption = do+ GLFW.setErrorCallback $ Just simpleErrorCallback+ r <- GLFW.init+ + --check $ GLFW.openWindow (GL.Size 800 600) [] (windowMode windowOption)+ Just win <- GLFW.createWindow 800 600 "Topkata" Nothing Nothing+ GLFW.makeContextCurrent $ Just win+ --GLFW.setWindowTitle win "Topkata"+ GL.lighting $= GL.Enabled+ version <- OpenGL.get (OpenGL.majorMinor OpenGL.glVersion)+ putStrLn $ "version: " ++ show version+ renderInit+ version <- OpenGL.get (OpenGL.majorMinor OpenGL.glVersion)+ putStrLn $ "version: " ++ show version+ GLFW.setKeyCallback win (Just $ Keyboard.callback actionSlot)+ GLFW.swapInterval 1+ return win -topInWall laby ts =- inWall laby (x+xd) y (z+zd)- where Vector3 x y z = transVec ts- phi = topPhi ts- sgn = sign (speed ts)- zd = 0.3 * cos phi * sgn- xd = 0.3 * sin phi+quitRef = unsafePerformIO $ newIORef False+{-# NOINLINE quitRef #-} -sign x | x > 0 = 1-sign x | x < 0 = -1-sign x = 0--hitGroundSnd snds ts ts' = do- --putStrLn $ "ts: " ++ show (yspeed ts) ++ ", ts'= " ++ show (yspeed ts')- when (yspeed ts < 0 && yspeed ts' > 0) $ do- putStrLn "boing"-#ifdef SOUND- errors <- get alErrors- mapM_ (putStrLn . show) errors- play [snds !! 0]-#endif- return ()--isWinPosition ts = ix == 30 && iz == 30- where (ix, _, iz) = topPos ts--topPos ts = (ifloor x, ifloor y, ifloor z)- where- Vector3 x y z = transVec ts- ifloor x = fromIntegral (floor x)--topPos3 = Pos3 . topPos--animate snds state = do- ts <- readIORef (topka state)- when (not (topInWall lab ts)) $ do- let ts' = animateTop mstime ts- dist = (dij state) ! topPos3 ts- putStrLn $ show dist- if (topInWall lab ts')- then do topkaUpd state updateOrientation flipOrientation- when (isWinPosition ts) $ do -#ifdef SOUND- play [snds !! 1] -#endif- incrScore state 1000- writeIORef (topka state) initialTopkaState- else do writeIORef (topka state) ts'- hitGroundSnd snds ts ts'- rand <- randomIO :: IO Int- ghosts state $~ \ gs ->- map (\ ghost -> animateGhost rand lab ghost (topPos3 ts)) gs- addTimerCallback mstime $ animate snds state- postRedisplay Nothing- where mstime = 10- lab = laby state+keyCallback (GLFW.Key'Escape) GLFW.KeyState'Pressed = writeIORef quitRef True+keyCallback _ _ = return () -compileWorldDL brickTex laby = defineNewList Compile $ render brickTex laby -- drawWorld world (1, 1, 1)--runMain prog name = do- putStrLn "Topkata..."-#ifdef SOUND- -- dev <- openDevice $ (Just "'( ( devices '( native null ) ) )")- dev <- openDevice Nothing- boing_path <- getDataFileName' "boing_1.wav"- juchhu_path <- getDataFileName' "juchhu.wav"- putStrLn $ "loading " ++ boing_path- boing <- createBuffer $ File boing_path- juchhu <- createBuffer $ File juchhu_path-#else- let dev = Nothing-#endif- --putStrLn (show $ world ! (1, 1, 3) )- getArgsAndInitialize- initialDisplayMode $= [ DoubleBuffered, RGBMode, WithDepthBuffer ]- initialWindowSize $= Size 800 600- initialWindowPosition $= Position 100 100- createWindow "Topkata"- state <- myInit- tops <- genTopkataCalllist $ textures state-#ifdef SOUND- snds@[boingSound, juchhuSound] <- genObjectNames 2 :: IO [Source]-- pitch boingSound $= 1.0- pitch juchhuSound $= 1.0- --gain sndSrc $= 1.0- --position sndSrc $= Vertex3 0 0 0- --velocity sndSrc $= Vector3 0 0 0- buffer boingSound $= Just boing- buffer juchhuSound $= Just juchhu- loopingMode boingSound $= OneShot- loopingMode juchhuSound $= OneShot- deleteObjectNames [boing, juchhu]-#else- let snds = []-#endif+mainLoop win renderInfo actionSlot state = do+ render renderInfo state+ GLFW.swapBuffers win+ threadDelay 10+ GLFW.pollEvents+ r <- performRecordedActions actionSlot $ stTopka state+ case r of+ Left () -> return ()+ Right ts ->+ let state' = state { stTopka = ts } in+ mainLoop win renderInfo actionSlot $ animate state' - displayCallback $= display state tops- keyboardMouseCallback $= Just (keyboardMouse state snds dev)- passiveMotionCallback $= Just (myMotionCallback state)- reshapeCallback $= Just reshape- addTimerCallback 100 $ animate snds state- mainLoop+animate state = + state { stTopka = animateTop 10 (stTopka state) (stLaby state) } -#ifdef SOUND-main = ALUT.withProgNameAndArgs ALUT.runALUT runMain-#else-main = runMain "" []-#endif+main = do+ args <- Args.args+ state <- newState+ actionSlot <- newSlot+ win <- initialize actionSlot $ Args.windowOption args+ renderInfo <- mkRenderInfo state+ mainLoop win renderInfo actionSlot state+ GLFW.terminate
Makefile view
@@ -3,19 +3,14 @@ all: topkata -topkata: setup- ./setup build+topkata: + cabal build -setup: Setup.lhs topkata.cabal- ghc --make -o $@ $<- rm -f .flags || true- echo $(FLAGS) > .flags- ./setup configure -f $(FLAGS) -install: topkata- ./setup install+install: + cabal install clean:- ./setup clean && rm -f ./setup+ cabal clean .PHONY: topkata install clean
+ NEWS view
@@ -0,0 +1,26 @@+Topkata 0.2.3+ - missing module Dijkstra added++Topkata 0.2.2+ - initial position of ghost fixed+ - ghost follows the topkata++Topkata 0.2.1++ - some bug fixes+ - internal cleanup+ - score+ - new setup flag FTGL (doesn't work on my machine)++Topkata 0.2++ - render a dummy ghost as demo+ - fix win position+ - clean up++Topkata 0.1++ - performance tweaks Don Stewart + - Key 'f' -> Fullscreenmode :-)+ - restart when target is reached (and shout "Juchhu")+
ReadImage.hs view
@@ -18,7 +18,8 @@ import System.IO ( Handle, IOMode(ReadMode), openBinaryFile, hGetBuf, hClose ) import System.IO.Error ( mkIOError, eofErrorType ) import Foreign ( Ptr, alloca, mallocBytes, Storable(..) )-import Graphics.UI.GLUT+--import Graphics.UI.GLFW+import Graphics.Rendering.OpenGL -- This is probably overkill, but anyway... newtype Word32BigEndian = Word32BigEndian Word32@@ -64,7 +65,7 @@ hGetBufFully handle buf numBytes return (Size width height, PixelData RGB UnsignedByte buf) -readImageWithSize :: FilePath -> GLint -> GLint -> IO (Size, PixelData a)+readImageWithSize :: FilePath -> GLsizei -> GLsizei -> IO (Size, PixelData a) readImageWithSize filePath width height = withBinaryFile filePath $ \handle -> do let numBytes = fromIntegral (3 * width * height)
+ Topkata/CommandLineArgs.hs view
@@ -0,0 +1,16 @@+module Topkata.CommandLineArgs where++import System.Console.ParseArgs++data Option = WindowOption deriving (Show, Ord, Eq)++argd :: [ Arg Option ] +argd = [ Arg { argIndex = WindowOption,+ argName = Just "window",+ argAbbr = Just 'w',+ argData = Nothing,+ argDesc = "start in window mode" } ]++args = parseArgsIO ArgsComplete argd++windowOption args = gotArg args WindowOption
+ Topkata/Render.hs view
@@ -0,0 +1,96 @@+module Topkata.Render (render, mkRenderInfo, renderInit) where++import Graphics.Rendering.OpenGL +import Topkata.Textures+import Topkata.State ( State(..) )+import Topkata.Topka.Topka (topView, genTopkataCallList, + showTopkata)+import qualified Labygen.Render++data RenderInfo = RenderInfo {+ renderInfoLabyDL :: !DisplayList+ ,renderInfoTopkata :: !GLuint+}++hit = False++whereToLook state =+ let (x, y, z, phi) = topView $ stTopka state in+ (x, 3, z-2, 0)++render renderInfo state = do+ matrixMode $= Projection+ depthRange $= (0.5, 20)+ loadIdentity+ --hit <- return False -- get (showHit state)+ frustum (-0.2) 0.5 (-0.2) (0.5) (0.5) (if hit then 0.5 else 20)++ matrixMode $= Modelview 0+ loadIdentity++ let (x, y, z, phi) = whereToLook state+ --lookAt (Vertex3 x y z) (Vertex3 (x+1) (0.5) (z+2*cos phi)) (Vector3 0 1 0)+ lookAt (Vertex3 x y z) (Vertex3 (x+2*sin phi) (0.5) (z+2*cos phi)) (Vector3 0 1 0)+ clear [ ColorBuffer, DepthBuffer ]+++ preservingMatrix $ callList $ renderInfoLabyDL renderInfo+ + let ts = stTopka state+ showTopkata ts $ renderInfoTopkata renderInfo++mkRenderInfo state = do+ brickTex <- loadBrickTex+ labyDL <- defineNewList Compile $ Labygen.Render.render brickTex laby+ topTex <- loadEyes "eyes"+ ghostTex <- loadEyes "geyes"+ tops <- genTopkataCallList topTex ghostTex+ return $ RenderInfo { + renderInfoLabyDL = labyDL+ ,renderInfoTopkata = tops+ }+ where+ laby = stLaby state++renderInit :: IO ()+renderInit = do+ clearColor $= Color4 0 0 0 0+ polygonMode $= (Fill, Fill)++ shadeModel $= Smooth++ materialSpecular FrontAndBack $= Color4 1 1 1 1+ materialShininess FrontAndBack $= 25+ colorMaterial $= Just (FrontAndBack, Diffuse)++ position (Light 1) $= Vertex4 0 0.5 (-0.5) 1+ position (Light 0) $= Vertex4 1 2 (-8) 0++ lighting $= Enabled+ light (Light 0) $= Enabled+ light (Light 1) $= Enabled+ depthFunc $= Just Less++ ambient (Light 0) $= Color4 0.2 0.2 0.2 1.0+ diffuse (Light 0) $= Color4 1 1 1 1+ diffuse (Light 1) $= Color4 1 1 1 1+ specular (Light 1) $= Color4 1 1 1 1+ --position (Light 0) $= Vertex4 0 3 2 0++ lightModelAmbient $= Color4 0.4 0.4 0.4 1+ lightModelLocalViewer $= Enabled+ lightModelTwoSide $= Enabled++ -- blend $= Enabled+ -- blendFunc $= (SrcAlpha, OneMinusSrcAlpha)+ -- hint PolygonSmooth $= Nicest+ --polygonSmooth $= Enabled++ -- hint LineSmooth $= Nicest+ -- lineSmooth $= Enabled++ normalize $= Enabled++++
+ Topkata/State.hs view
@@ -0,0 +1,19 @@+module Topkata.State where++import Labygen+import Topkata.Topka.Topka++data State = State {+ stLaby :: !(World Pos3)+ ,stTopka :: TopkaState+}++origin = Pos3 (0, 0, 0)+target = Pos3 (30, 0, 30)++newState = do+ laby <- labygenIO (origin, target) origin target+ return $ State { + stLaby = laby+ , stTopka = initialTopkaState + }
+ Topkata/Textures.hs view
@@ -0,0 +1,47 @@+module Topkata.Textures (loadBrickTex, loadEyes) where++import Graphics.Rendering.OpenGL +import Data.Maybe+import Paths_topkata (getDataFileName)+import System.FilePath ( (</>) )+import ReadImage (readImageWithSize)++loadBrickTex = do+ let brickSize = TextureSize2D 512 256+ brickTex <- fmap listToMaybe $ genObjectNames 1+ + textureBinding Texture2D $= brickTex++ textureWrapMode Texture2D S $= (Mirrored, Repeat)+ textureWrapMode Texture2D T $= (Mirrored, Repeat)+ textureFilter Texture2D $= ((Nearest, Just Nearest), Nearest)++ sequence_ $ zipWith (mkTex "brick") [0..9] (reverse $ take 10 $ iterate (* 2) 1)++ return brickTex++getDataFileName' fn = getDataFileName ("data" </> fn)++mkTex prefix lvl xsize = do+ let fname = prefix ++ show xsize ++ ".rgb"+ let ysize = max 1 (xsize `div` 2)+ let size = TextureSize2D xsize ysize+ path <- getDataFileName' fname+ (_, bricksData) <- readImageWithSize path xsize ysize+ texImage2D Texture2D NoProxy lvl RGBA' size 0 bricksData++++loadEyes name = do+ let eyeSize = TextureSize2D 256 256+ eyeTex <- fmap listToMaybe $ genObjectNames 1++ textureBinding Texture2D $= eyeTex++ --textureFilter Texture2D $= ((Nearest, Just Nearest), Nearest)++ textureWrapMode Texture2D S $= (Repeated, Clamp)+ textureWrapMode Texture2D T $= (Repeated, Clamp)+ textureFilter Texture2D $= ((Nearest, Nothing), Nearest)+ mkTex name 0 256+ return eyeTex
Topkata/Topka/Base.hs view
@@ -1,11 +1,8 @@ module Topkata.Topka.Base where -import Graphics.UI.GLUT+--import Graphics.UI.GLFW+import Graphics.Rendering.OpenGL import Labygen--data Textures = Textures {- texTopkata, texGhost :: Maybe TextureObject-} data Direction = North | East| South | West
Topkata/Topka/Ghost.hs view
@@ -1,6 +1,7 @@ module Topkata.Topka.Ghost where -import Graphics.UI.GLUT+--import Graphics.UI.GLFW+import Graphics.Rendering.OpenGL import Topkata.Topka.Base import Vector import Labygen
Topkata/Topka/Topka.hs view
@@ -1,11 +1,13 @@ module Topkata.Topka.Topka where -import Graphics.UI.GLUT+--import Graphics.UI.GLFW+import Graphics.Rendering.OpenGL import Vector import Data.IORef import Debug.Trace (trace) import Topkata.Topka.Ghost import Topkata.Topka.Base+import Labygen (inWall) data TopkaState = TopkaState {@@ -104,7 +106,7 @@ callList (DisplayList (tops+m)) -genTopkataCalllist textures = do+genTopkataCallList topTex ghostTex = do (base@(DisplayList b):_) <- genObjectNames 102 mapM_ (\ m -> do defineList (DisplayList (b+m)) Compile $@@ -113,14 +115,8 @@ drawGhost ghostTex QuadStrip (2 * pi * fromIntegral m / 51.0) ) [0..51] return b- where topTex = texTopkata textures- ghostTex = texGhost textures -----animateTop mstime ts =+animateTop mstime ts laby = let cm = closeMouth ts m = mouth ts ys = yspeed ts@@ -154,4 +150,20 @@ then ts4 { topOrientation = topNextOrientation ts4, topTrans = Vector3 (floor' x + 0.5) y (floor' z + 0.5) } else ts4- in ts5+ ts6 = if topInWall laby ts5 then+ let ts' = updateTrans ts3 $ \ (Vector3 x y z) -> Vector3 (x-xd) y (z-zd) + orient = flipOrientation $ topOrientation ts' + in+ ts' { topOrientation = orient, + topNextOrientation = orient }+ else ts5+ in ts6+++topInWall laby ts =+ inWall laby (x+xd) y (z+zd)+ where Vector3 x y z = transVec ts+ phi = topPhi ts+ sgn = signum (speed ts)+ zd = 0.3 * cos phi * sgn+ xd = 0.3 * sin phi
Vector.hs view
@@ -1,6 +1,7 @@ module Vector where -import Graphics.UI.GLUT+--import Graphics.UI.GLFW+import Graphics.Rendering.OpenGL normalize :: Floating a => Vector3 a -> Vector3 a normalize (Vector3 x y z) =@@ -20,7 +21,7 @@ ypart (Vector3 _ y _) = y zpart (Vector3 _ _ z) = z -instance Floating a => Num (Vector3 a) where+instance (Eq a, Floating a) => Num (Vector3 a) where (Vector3 x1 y1 z1) + (Vector3 x2 y2 z2) = Vector3 (x1 + x2) (y1 + y2) (z1 + z2) (Vector3 x1 y1 z1) * (Vector3 x2 y2 z2) = Vector3 (y1 * z2 - z1 * y2)
topkata.cabal view
@@ -1,5 +1,5 @@ Name: topkata-Version: 0.2.3+Version: 0.2.4 Synopsis: OpenGL Arcade Game Description: Guide a jumping ball through a maze. License: GPL@@ -10,7 +10,7 @@ build-type: Simple Cabal-Version: >= 1.2 Homepage: http://home.arcor.de/chr_bauer/topkata.html-Extra-Source-Files: INSTALL THANKS Makefile+Extra-Source-Files: INSTALL THANKS NEWS Makefile Data-Files: data/boing_1.wav data/brick16.rgb data/brick32.rgb data/brick64.rgb@@ -34,8 +34,9 @@ Executable topkata Main-is: Main.hs- Build-Depends: base, filepath, GLUT, OpenGL, array, random+ Build-Depends: base >= 4 && < 5, filepath, GLFW-b, OpenGL, array, random, parseargs Other-Modules: Labygen, Labygen.Render, + Topkata.CommandLineArgs, Topkata.Render, Topkata.State, Topkata.Textures, Topkata.Topka.Topka, Topkata.Topka.Ghost, Topkata.Topka.Base Vector, ReadImage, Dijkstra Extensions: CPP