topkata-0.1: Topkata/Topka/Topka.hs
module Topkata.Topka.Topka where
import Graphics.UI.GLUT
import Vector
import Data.IORef
import Debug.Trace (trace)
data Direction =
North | East| South | West
deriving (Enum, Eq, Show, Bounded)
data TopkaState = TopkaState {
topTrans :: {-# UNPACK #-} !V3,
-- rot :: V3 GLdouble,
mouth :: {-# UNPACK #-} !GLuint,
primMode :: {-# UNPACK #-} !PrimitiveMode,
closeMouth :: {-# UNPACK #-} !Bool,
yspeed :: {-# UNPACK #-} !GLdouble,
ypower :: {-# UNPACK #-} !GLdouble,
yheight :: {-# UNPACK #-} !GLdouble,
speed :: {-# UNPACK #-} !GLdouble,
topOrientation, topNextOrientation :: {-# UNPACK #-} !Direction
}
initialTopkaState = TopkaState {
topTrans = V3 0.5 0.1 0.5,
-- rot = V3 0 0 0,
mouth = 40,
primMode = QuadStrip,
closeMouth = True,
yheight = 3,
yspeed = 0,
ypower = 0,
speed = 0,
topOrientation = North,
topNextOrientation = North
}
epsilon = 0.1
-- TODO: is there a better approach to write these functions? e.g. template haskell
updateTrans ts f = ts { topTrans = f (topTrans ts) }
--updateRot ts f = ts { rot = f (rot ts) }
updateMouth ts f = ts { mouth = f (mouth ts) }
updatePrimMode ts f = ts { primMode = f (primMode ts) }
updateCloseMouth ts f = ts { closeMouth = f (closeMouth ts) }
updateYHeight ts f = ts { yheight = f (yheight ts) }
updateYSpeed ts f = ts { yspeed = f (yspeed ts) }
updateYPower ts f = ts { ypower = f (ypower ts) }
updateSpeed ts f = ts { speed = f (speed ts) }
updateOrientation ts f = ts { topOrientation = d, topNextOrientation = d }
where d = f (topOrientation ts)
setOrientation ts d = ts { topOrientation = d, topNextOrientation = d, speed = 0.02 }
setNextOrientation ts d =
if topOrientation ts == d && speed ts > 0
then ts { speed = 0.04 }
else ts { topNextOrientation = d, speed = 0.02 }
topPhi ts =
case topOrientation ts of
North -> 0
East -> pi * 1.5
South -> pi
West -> pi / 2.0
{--turnTopka ts delta =
updateRot ts $ \ (V3 a phi b) ->
V3 a (phi+delta) b -}
-- turnTopLeft = turnTopkat (-pi/2)
-- turnTopRight = turnTopkat (pi/2)
topView :: TopkaState -> (GLdouble, GLdouble, GLdouble, GLdouble)
topView ts =
let Vector3 x y z = transVec ts
phi = topPhi ts
in (x, y, z, phi)
--updateState upd f ts =
-- modifyIORef ts $ \t -> upd t f
togglePrimMode LineStrip = QuadStrip
togglePrimMode QuadStrip = LineStrip
-- togglePrimMode_ = updateState updatePrimMode togglePrimMode
-- move = updateState updateTrans
transVec ts =
let V3 x y z = topTrans ts + V3 0 (0.2+0.2*yheight ts) 0 in
Vector3 x y z
v2n (Vertex3 x y z) = Normal3 x y z
merge [] [] = []
merge (h1:t1) (h2:t2) = h1:h2:merge t1 t2
sphereVertex a b =
(TexCoord2 (a/pi) (2*b/pi), Vertex3 (cos b * sin a) (sin a * sin b) (cos a))
segment b1 b2 =
merge (v b1) (v b2)
where z1, z2 :: GLdouble
z1 = cos b1
z2 = cos b2
v b = [sphereVertex a b | a <- [0.0, epsilon .. pi+epsilon]]
ring = segment 0.0 0.7
drawGaumen d =
renderPrimitive TriangleFan $ do
color (Color4 1.0 0 (0 :: GLdouble) 1)
normal (Normal3 0 (-(signum d)) (0 :: GLdouble))
vertex (Vertex3 0 0 (0 :: GLdouble))
mapM_ vertex [snd $ sphereVertex a d | a <- [0.0, epsilon .. pi+epsilon]]
drawTopkata et pm d = do
drawGaumen (d)
drawGaumen (-d+2*epsilon)
texture Texture2D $= Enabled
textureBinding Texture2D $= et
textureFunction $= Modulate
mapM_ (drawSegment pm 0.1) [d, d+epsilon .. 2*pi-d+epsilon]
texture Texture2D $= Disabled
drawSegment pm d a = do
renderPrimitive pm $ do
color (Color4 1 1 (1 :: GLdouble) 1)
mapM_ nvertex (segment a (a+d))
nvertex (t,v) = do
--putStrLn $ show t
texCoord t
normal $ v2n v
vertex v
drawTop ts tops =
let tvec = transVec ts
phi :: GLdouble
phi = topPhi ts
m = mouth ts
pm = primMode ts
in do
translate tvec
scale 0.3 0.3 (0.3 :: GLdouble)
rotate (180*phi/pi-90) (Vector3 0 1 0)
--listBase $= tops
callList (DisplayList (tops+m))
-- drawTopkata pm (fromIntegral m / 100.0)
genTopkataCalllist et = do
(base@(DisplayList b):_) <- genObjectNames 51
--listBase $= base
mapM_ (\ m -> do
defineList (DisplayList (b+m)) Compile $
drawTopkata et QuadStrip (fromIntegral m / 100.0)) [0..51]
--listBase $= 0
return b
rotCW :: Direction -> Direction
rotCCW :: Direction -> Direction
rotCW d | d == maxBound = minBound
rotCW d | otherwise = succ d
rotCCW d | d == minBound = maxBound
rotCCW d | otherwise = pred d
flipOrientation d =
case d of
North -> South
South -> North
East -> West
West -> East
animateTop mstime ts =
let cm = closeMouth ts
m = mouth ts
ys = yspeed ts
yh = yheight ts
sp = speed ts
phi = topPhi ts
xd = sp * sin phi
zd = sp * cos phi
ts1 =
if not cm then
if m > 50 then updateCloseMouth ts (const True)
else updateMouth ts (+1)
else if m <= 10 then updateCloseMouth ts (const False)
else updateMouth ts (\ m -> m - 1)
accelaration = 9.81 * time
time = fromIntegral mstime / 1000.0
ts2 = updateYSpeed ts1 $ \speed -> if yh < 0 && speed < 0 then -speed
else speed-accelaration
ts3 = updateYHeight ts2 $ \ h -> h + ys * time
ts4 = updateTrans ts3 $ \ (V3 x y z) -> V3 (x+xd) y (z+zd)
floor' x = fromIntegral (floor x)
tr x = x - floor' x
inTheMiddle :: String -> GLdouble -> GLdouble -> Bool
inTheMiddle l x1 x2 = --trace (l ++ " " ++ show (tr x1) ++ " " ++ show (tr x2)) $
tr x1 <= 0.50 && tr x2 >= 0.50 ||
tr x1 >= 0.50 && tr x2 <= 0.50
l x = trace (show x) x
ts5 =
let V3 x y z = topTrans ts4 in
if topOrientation ts4 /= topNextOrientation ts4 && sp > 0 && inTheMiddle "x" x (x-xd) && inTheMiddle "z" z (z-zd)
then ts4 { topOrientation = topNextOrientation ts4,
topTrans = V3 (floor' x + 0.5) y (floor' z + 0.5) }
else ts4
in ts5