Topka.hs

module Topkata.Topka.Topka where

import Graphics.UI.GLUT
import Vector
import Data.IORef
import Debug.Trace (trace)
import Topkata.Topka.Ghost
import Topkata.Topka.Base


data TopkaState = TopkaState {
  topTrans      :: Vector3 GLdouble,
  mouth         :: GLuint,
  primMode      :: PrimitiveMode,
  closeMouth    :: Bool,
  yspeed        :: GLdouble,
  ypower        :: GLdouble,
  yheight       :: GLdouble,
  speed         :: GLdouble,
  topOrientation, topNextOrientation :: Direction
}

initialTopkaState = TopkaState {
  topTrans = Vector3 0.5 0.1 0.5,
--  rot = Vector3 0 0 0,
  mouth = 40,
  primMode = QuadStrip,
  closeMouth = True,
  yheight = 3,
  yspeed = 0,
  ypower = 0,
  speed  = 0,
  topOrientation   = North,
  topNextOrientation   = North
}



-- 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 }



{--turnTopka ts delta =
    updateRot ts $ \ (Vector3 a phi b) ->
        Vector3 a (phi+delta) b -}


-- turnTopLeft  = turnTopkat (-pi/2)
-- turnTopRight = turnTopkat (pi/2)

topPhi = angleOfDirection . topOrientation

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 Vector3 x y z = topTrans ts + Vector3 0 (0.2+0.2*yheight ts) 0 in
    Vector3 x y z







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_ (\a -> drawSegment pm $ segment a (a+d)) [d, d+epsilon .. 2*pi-d+epsilon]
  texture Texture2D $= Disabled


showTopkata ts tops =
   let tvec         = transVec ts
       phi :: GLdouble
       phi          = topPhi ts
       m            = mouth ts
    in preservingMatrix  $ 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 textures = do
  (base@(DisplayList b):_) <- genObjectNames 102
  mapM_ (\ m -> do
           defineList (DisplayList (b+m)) Compile $
             drawTopkata topTex QuadStrip (fromIntegral m / 100.0)
           defineList (DisplayList (51+b+m)) Compile $
             drawGhost ghostTex QuadStrip (2 * pi * fromIntegral m / 51.0)
        ) [0..51]
  return b
 where topTex     = texTopkata textures
       ghostTex   = texGhost   textures





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 $ \ (Vector3 x y z) -> Vector3 (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 ++ " " ++ sho w(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 Vector3 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 = Vector3 (floor' x + 0.5)  y (floor' z + 0.5) }
               else ts4
  in ts5