module Main where import System.Exit ( exitWith, ExitCode(ExitSuccess) ) import Graphics.UI.GLUT import Data.IORef ( IORef, newIORef, modifyIORef, readIORef, writeIORef ) -- import Topkata.World.Build -- import Topkata.World.Base (wallInFrontOfMe) -- import Topkata.World.Render (drawWorld, inWall) import Topkata.Topka.Topka import Data.Array ((!)) import Data.Maybe (isJust, listToMaybe, mapMaybe, maybeToList) import Labygen import Labygen.Render import ReadImage (readImageWithSize) import Control.Monad( sequence_, when ) --import Debug.Trace (trace) import Data.List( (!!) ) #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.ALUT (ALfloat) #endif import System.FilePath ( () ) import Paths_topkata (getDataFileName) import qualified Vector as V --import Graphics.Rendering.OpenGL.GL.Polygons data ViewMode = ExploringMode | EgoMode | FollowMode data State = State { topka :: !(IORef TopkaState), camX :: !(IORef GLdouble), camY :: !(IORef GLdouble), camZ :: !(IORef GLdouble), camPhi :: !(IORef GLdouble), vmode :: !(IORef ViewMode), laby :: World Pos3, worldDL :: DisplayList } getDataFileName' fn = getDataFileName ("data" fn) mkstate bt eyeTex = do ts <- newIORef initialTopkaState cX <- newIORef 0.31 cY <- newIORef 0.3 cZ <- newIORef (-0.11) phi <- newIORef 0.0 vm <- newIORef FollowMode sh <- newIORef False laby <- labygenIO (origin, target) origin target worldDL <- compileWorldDL bt laby return $ (State { topka = ts, laby = laby, vmode = vm, camX = cX, camY = cY, camZ = cZ, camPhi = phi, worldDL = worldDL }, eyeTex) where origin = Pos3 (1, 1, 1) target = Pos3 (30, 1, 30) 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 camX <- get (camX state) camY <- get (camY state) camZ <- get (camZ state) phi <- get (camPhi state) return (camX, camY, camZ, phi) FollowMode -> do (x, y, z, phi) <- fmap topView $ get $ topka state return (x, 3, z-2, 0) {- togglePrimMode state = do primMode state $~ \ a -> case a of LineStrip -> QuadStrip QuadStrip -> LineStrip postRedisplay Nothing -} {- xTopMove = move xTrans yTopMove = move yTrans zTopMove = move zTrans xTopRot = move xRot yTopRot = move yRot zTopRot = move zRot openMouth = move mouth xrot = xTopRot yrot = yTopRot zrot = zTopRot -} moveD a b c = move a b c >> postRedisplay Nothing xmove = move camX ymove = move camY zmove = move camZ move r state inc = do r state $~ (+ inc) get $ r state camMove state d = do phi <- get (camPhi state) let dx = sin phi * (-d) dz = cos phi * d zmove state dz xmove state dx 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 camTurn state d = move camPhi state d >> return () 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) 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) --textureFilter Texture2D $= ((Nearest, Just Nearest), Nearest) putStrLn $ show $ isJust eyeTex mkTex "eyes" 0 256 mkstate brickTex 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 -- ring = mrect mrect = [Vertex3 0.25 0.25 0.0, Vertex3 0.25 0.75 (0.0 :: GLfloat), Vertex3 0.75 0.25 0.0, Vertex3 0.75 0.75 0.0] 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 display state tops = do (_, Size w h) <- get viewport matrixMode $= Projection loadIdentity --ortho (-2) (2) (-2) 2 (-2) 2 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) preservingMatrix $ do ts <- get (topka state) drawTop ts tops flush swapBuffers 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 camX state $= x camY state $= 0.3 camZ state $= z camPhi state $= 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 camMove state (0.02) -- Char 'u' -> yTopMove state (0.2) SpecialKey KeyUp -> safeMove camMove 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 () {- turnTopkaSafe state ts x = let ts' = turnTopka ts x in if topInWall (laby state) ts' then ts else ts' -} 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+1+xd) (y+1) (z+1) 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 * sgn 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 #ifdef SOUND play [snds !! 0] #endif return () isWinPosition ts = ix == 29 && iz == 0 where Vector3 x z y = transVec ts ifloor x = fromIntegral (floor x) ix = ifloor x iz = ifloor z animate snds state = do ts <- readIORef (topka state) when (not ( topInWall lab ts)) $ do let ts' = animateTop mstime ts if (topInWall lab ts') then do topkaUpd state updateOrientation flipOrientation when (isWinPosition ts) $ do #ifdef SOUND play [snds !! 1] #endif writeIORef (topka state) initialTopkaState else do writeIORef (topka state) ts' hitGroundSnd snds ts ts' 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 ) ) )") 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, eyeTex) <- myInit tops <- genTopkataCalllist eyeTex #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