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