-- Cally1.hs
-- Cally1 Cal3D example

module Main where

import Foreign

import Control.Monad
import Data.IORef

import Graphics.Rendering.OpenGL as GL
import Graphics.UI.SDL as SDL hiding (flip, update)

import Graphics.Animation.Cal3D
import Graphics.Animation.Cal3D.OpenGL

import CallyCommon

renderScale = 1.0

main :: IO ()

main = do
  {
    coreModel <- loadCallyCoreModel False

    -- B.  Create model instance(s)

  ; model <- newCallyInstance coreModel False

  ; initSDL initCfg
  ; initGL initCfg

  -- Mix animations.
  -- NOTE: In real life, you would not want to do these three
  -- without some elapsed time!

  -- Set an animation mix, reaching 100% jog after 0.5 second
  ; mixer <- getMixer model
  ; require 50 "cycle jog animation" 
                (blendCycle mixer (jogAnim coreModel) 1.0 0.5)
  -- Use clearCycle to "fade out" the jog animation in 3 seconds
  -- ; require 51 "clear jog animation cycle" 
  --              (clearCycle mixer (jogAnim coreModel) 3.0)
  -- use executeAction to perform an action once, 
  -- with delayIn, delayOut, weightTarget, and autoLock arguments
  -- ; require 52 "execute idle action"
  --          (executeAction mixer (idleAnim coreModel) 2.5 7.5 0.95 True)

  -- Initialize and render the model
  ; update model 0.0 -- time 0
  -- ; putStrLn $ "Where is Cally? " ++ (whereIsModel model)
  ; renderLoop model initCfg

  -- Destroy the model
  -- Contrary to user guide, there is no "destroy" method.
  ; deleteModel model
  ; putStrLn "Model deleted."

  ; SDL.quit

  -- Finish
  ; return ()

  }

-- SDL configuration and initialization

data Config = Config {width, height :: Int32}

initCfg = Config {width = 800, height = 600}

data SDLState = SDLState {sdlWidth, sdlHeight :: Int,
                          sdlSurface :: Surface,
                          sdlFullscreen :: Bool}

-- ------------------------------------------------------------------------
-- SDL state and initialization

videoDepth = 32

videoFlags :: Bool -> [SurfaceFlag]
videoFlags fullscreen = 
    let baseFlags = -- [SDL.OpenGL, Resizable]
                    [SDL.OpenGL, SDL.SrcAlpha, HWAccel, HWSurface]
                    -- No effect: DoubleBuf, SDL.SrcAlpha
                    -- ??: HWAccel, SWSurface, HWSurface
    in if fullscreen then Fullscreen : baseFlags else baseFlags

initSDL :: Config -> IO (IORef SDLState)
initSDL cfg = do
  {
    SDL.init [InitVideo]
  ; SDL.setCaption "Haskell Cal3d Demo with SDL and OpenGL"
                   "Cal3d Demo"
    -- Set reasonable GL attributes
  ; glSetAttribute glDoubleBuffer 1
  ; glSetAttribute glDepthSize 16
  ; mapM_ ((flip glSetAttribute) 8)
          [glRedSize, glGreenSize, glBlueSize, glAlphaSize]
  ; let w = fromIntegral (width cfg)
        h = fromIntegral (height cfg)
  ; surface <- 
      SDL.setVideoMode w h videoDepth (videoFlags False)

  -- ; enableUnicode True
  -- ; enableKeyRepeat 500 30      -- delay, interval
  ; newIORef (SDLState { sdlWidth = w
                       , sdlHeight = h
                       , sdlSurface = surface
                       , sdlFullscreen = False})
  }

-- ------------------------------------------------------------------------
-- OpenGL initialization

initGL :: Config -> IO ()
initGL cfg = do
  {
    viewport $= (Position 0 0, 
                 Size (fromIntegral (width cfg)) (fromIntegral (height cfg)))
  ; clearColor $= (Color4 0 0 0.2 1 :: Color4 GLfloat)
  ; clearDepth $= 1

  ; depthFunc $= Just Less      -- enables depth test
  ; cullFace $= Just Back

  -- Projection
  ; matrixMode $= Projection
  ; loadIdentity
  ; perspective 45.0            -- vertical angle
                (fromIntegral (width cfg) / 
                 fromIntegral (height cfg)) -- aspect
                0.2                         -- near
                1000.0                      -- far

  ; matrixMode $= Modelview 0
  ; loadIdentity


  -- Lighting
  ; lighting $= Enabled
  ; frontFace $= CCW
  ; shadeModel $= Smooth

  ; lightModelAmbient $= Color4 0.15 0.15 0.15 1.0
  ; colorMaterial $= -- Just (FrontAndBack, Diffuse) 
                     Just (Front, Diffuse) -- implies enabled

  -- Light 0
  ; light (Light 0) $= Enabled
  ; position (Light 0) $= lightPosition
  ; ambient (Light 0) $= Color4 0.3 0.3 0.3 1.0
  ; diffuse (Light 0) $= Color4 0.52 0.5 0.5 1.0
  ; specular (Light 0) $= Color4 0.1 0.1 0.1 1.0

  -- Anti-aliasing
  ; polygonSmooth $= Enabled
  ; hint PolygonSmooth $= Fastest

  -- Blending (alpha transparency)
  ; blend $= Enabled
  ; blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)

  -- Vertex arrays
  ; clientState VertexArray $= Enabled
  ; clientState NormalArray $= Enabled
  }

camDist :: (Num a) => a
camDist = 250

cameraPosition :: Vertex3 GLdouble
cameraPosition = Vertex3 camDist (-camDist) (camDist / 10) 

lightPosition :: Vertex4 GLfloat
lightPosition = 
    Vertex4 (camDist + 1) (-camDist - 1) ((camDist / 10) + 1) 1.0

-- ------------------------------------------------------------------------
-- Actual rendering

beginFrame :: Config -> IO ()
beginFrame cfg = do 
  {
    matrixMode $= Modelview 0
  ; loadIdentity
  ; clear [ColorBuffer, DepthBuffer]
  ; let dist = 250
  ; lookAt cameraPosition (Vertex3 0 0 60) (Vector3 0 0 1)
  ; return ()
  }

endFrame :: IO ()
endFrame = glSwapBuffers

renderLoop :: Model -> Config -> IO ()
renderLoop model cfg = do
  {
    beginFrame cfg
  -- Update the model state, given 0.05 second elapsed time
  ; update model 0.005
  ; renderModel model renderBuffers
  -- sanity pyramid
  ; drawPyramidArrayed

  ; endFrame
  ; event <- pollEvent
  ; case event of
      KeyDown (Keysym {symKey = SDLK_ESCAPE}) -> return () -- quit
      Quit -> return ()                                    -- quit
      _ -> renderLoop model cfg                            -- continue
  }

renderBuffers :: RenderInfo -> IO ()
renderBuffers info = do
  {
    materialAmbient Front $= riAmbient info
  ; materialDiffuse Front $= riDiffuse info
  ; materialSpecular Front $= riSpecular info
  ; materialShininess Front $= riShininess info
  ; renderArrays (3 * (riFaceCount info))
                 (riVtxBuf info)
                 (riNormBuf info)
                 (castPtr (riFaceBuf info)) -- from (Ptr CInt) to (Ptr Int)
  }


-- ------------------------------------------------------------------------

-- Pyramid to check sanity



drawPyramidArrayed :: IO ()
drawPyramidArrayed =
    let s = 25                -- scale
        a = [-s, -s, 0]
        b = [s, -s, 0]
        c = [s, s, 0]
        d = [-s, s, 0]
        e = [0, 0, s]
        
        face v1 v2 v3 = concat [v1, v2, v3]

        -- vertex data: 6 faces x 3 vertices x 3 coords = 54 floats
        vertexData :: [GLfloat]
        vertexData = concat [face a b d,
                             face d b c,
                             face a b e,
                             face b c e,
                             face c d e,
                             face d a e]

        -- normal data: 6 faces x 3 normals x 3 coords = 54 floats
        m = 0.5 * sqrt 2
        normals :: [[GLfloat]]
        normals = [ [0.0, 0.0, (-1.0)] -- normal down
                  , [0.0, 0.0, (-1.0)]
                  , [0.0, (-m), m]
                  , [m, 0.0, m]
                  , [0.0, m, m]
                  , [(-m), 0.0, m]
                  ]
        normalData = concatMap (normals !!) [0, 0, 0, -- d b a
                                       1, 1, 1, -- c b d
                                       2, 2, 2, -- a b e
                                       3, 3, 3, -- b c e
                                       4, 4, 4, -- c d e
                                       5, 5, 5] -- d a e
        n = length vertexData
        indexData :: [Int]
        indexData = [0..n - 1]

      in if (n /= length normalData ||
             n /= length indexData)
         then error ("vertexData, normalData, indexData: " ++
                     "lengths must be equal: " ++
                     show (length vertexData, length normalData,
                          length indexData))
         else do
           {
             materialAmbientAndDiffuse Front $=
             (Color4 0 0 1 0.10 :: Color4 GLfloat) -- trans-blue for debugging
             -- (Color4 0 0 0 1 :: Color4 GLfloat)
           ; materialSpecular Front $= Color4 0 0 0 1
           
           ; withArray vertexData
             (\ vtxBuf -> 
                  (withArray normalData
                   (\ normBuf ->
                        (withArray indexData
                         (\ indexes -> 
                              renderArrays n vtxBuf normBuf indexes)))))
           }

-- Keep

renderArrays :: Int -> Ptr GLfloat -> Ptr GLfloat -> Ptr Int -> IO ()
renderArrays n vtxBuf normBuf indexes = 
    let vad nc etype stride buf =
            VertexArrayDescriptor nc etype stride buf
    in do
      {
        arrayPointer VertexArray $= vad 3 Float 0 vtxBuf
      ; arrayPointer NormalArray $= vad 3 Float 0 normBuf
      ; drawElements Triangles (fromIntegral n) UnsignedInt indexes
      }