topkata-0.2.2: Main.hs
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