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