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 () 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 keyboardMouse' a c d e f = do -- putStrLn $ show c keyboardMouse a c d e f 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 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 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 displayCallback $= display state tops keyboardMouseCallback $= Just (keyboardMouse state snds dev) passiveMotionCallback $= Just (myMotionCallback state) reshapeCallback $= Just reshape addTimerCallback 100 $ animate snds state mainLoop #ifdef SOUND main = ALUT.withProgNameAndArgs ALUT.runALUT runMain #else main = runMain "" [] #endif