path: root/MeshSketch.hs

{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
module MeshSketch where

import Codec.Picture             as Juicy
import Control.Concurrent
import Control.Monad
import Data.Word
import Data.Function ((&))
import Data.Int
import Data.IORef
import Data.Text (Text)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.Vector     as V
import GI.Gdk.Objects
import GI.GLib.Constants
import qualified GI.Gtk          as Gtk (main)
import GI.Gtk                    as Gtk hiding (main)
import LambdaCube.GL             as LC
import LambdaCube.GL.Mesh        as LC
import Numeric.LinearAlgebra hiding ((<>))
import System.Environment
import System.IO
import System.IO.Error
import Control.Exception
import LambdaCube.GL as LC
import LambdaCube.IR as LC
import LambdaCube.Gtk

import GLWidget (nullableContext, withCurrentGL)
import LambdaCube.GL.HMatrix
import LambdaCubeWidget (loadPipeline,DynamicPipeline(..))
import Animator
import LoadMesh
import InfinitePlane
import MtlParser (ObjMaterial(..))
import Matrix

-- State created by uploadState.
data State = State
    { stAnimator :: Animator
    , stCamera   :: IORef Camera
    }

data Camera = Camera
    { camHeightAngle   :: Float
    , camTarget        :: Vector Float
    , camDirection     :: Vector Float
    , camDistance      :: Float
    , camWidth         :: Float
    , camHeight        :: Float
    , camUp            :: Vector Float
    , camWorldToScreen :: Maybe (Matrix Float)
    , camScreenToWorld :: Maybe (Matrix Float)
    }

initCamera :: Camera
initCamera = Camera
    { camHeightAngle = pi/6
    , camTarget      = fromList [0,0,0]
    , camDirection   = scale (1/d) $ fromList [-2,-2,-10]
    , camDistance    = d
    , camWidth       = 700
    , camHeight      = 700
    , camUp          = fromList [0,1,0]
    , camWorldToScreen = Nothing
    , camScreenToWorld = Nothing
    }
    where d = realToFrac $ norm_2 $ fromList [2::Float,2,10]

viewProjection :: Camera -> (Camera,(Matrix Float,Vector Float))
viewProjection c
    | Just m <- camWorldToScreen c = (c,(m,pos))
    | otherwise                    = (c { camWorldToScreen = Just m' }, (m',pos))
 where
    m' = proj <> cam
    cam = lookat pos (camTarget c) (camUp c)
    pos = camTarget c - scale (camDistance c) (camDirection c)
    proj = perspective 0.1 100 (camHeightAngle c) (camWidth c / camHeight c)


addOBJToObjectArray :: GLStorage -> String -> [(GPUMesh, Maybe Text)] -> Map Text (ObjMaterial,TextureData) -> IO [LC.Object]
addOBJToObjectArray storage slotName objMesh mtlLib = forM objMesh $ \(mesh,mat) -> do
  obj <- LC.addMeshToObjectArray storage slotName ["diffuseTexture","diffuseColor"] mesh
         -- diffuseTexture and diffuseColor values can change on each model
  case mat >>= flip Map.lookup mtlLib of
    Nothing -> return ()
    Just (ObjMaterial{..},t) -> LC.updateObjectUniforms obj $ do
      "diffuseTexture" @= return t -- set model's diffuse texture
      "diffuseColor" @= let (r,g,b) = mtl_Kd in return (V4 r g b mtl_Tr)
  return obj


uploadState :: IsWidget glarea => MeshData -> glarea -> GLStorage -> IO State
uploadState obj glarea storage = do
    -- load OBJ geometry and material descriptions
    (objMesh,mtlLib) <- uploadOBJToGPU obj
    -- load materials textures
    gpuMtlLib <- uploadMtlLib mtlLib
    -- add OBJ to pipeline input
    addOBJToObjectArray storage "objects" objMesh gpuMtlLib
    -- grid plane
    uploadMeshToGPU xzplane >>= addMeshToObjectArray storage "plane" []

    -- setup FrameClock
    tm <- newAnimator =<< toWidget glarea
    cam <- newIORef initCamera
    let st = State
            { stAnimator     = tm
            , stCamera       = cam
            }
    _ <- addAnimation tm (whirlingCamera st)

    return st


destroyState :: GLArea -> State -> IO ()
destroyState glarea st = do
    -- widgetRemoveTickCallback glarea (stTickCallback st)
    return ()

deg30 :: Float
deg30 = pi/6

whirlingCamera :: State -> Animation
whirlingCamera st = Animation $ \_ t -> do
    let tf = realToFrac (t/10.0) :: Float
        rot = rotMatrixZ (-tf) <> rotMatrixX (-tf)
    modifyIORef (stCamera st) $ \cam -> cam
                            { camUp            = rot #> fromList [0,1,0]
                            , camDirection     = (scale (1/camDistance cam) $ fromList [-2,-2,-10]) <# rot
                            , camWorldToScreen = Nothing
                            , camScreenToWorld = Nothing
                            }
    return $ Just (whirlingCamera st)

setUniforms :: glctx -> GLStorage -> State -> IO ()
setUniforms gl storage st = do
    (mvp,pos) <- atomicModifyIORef' (stCamera st) viewProjection

    {-
    let pos = rot #> fromList [2,2,10]
        up = rot #> fromList [0,1,0]
        view = lookat pos 0 up
        aspect = 1
        proj = perspective 0.1 100 deg30 aspect
        mvp = proj <> view
    -}

    LC.updateUniforms storage $ do
      "CameraPosition" @= return (pos :: Vector Float)
      "ViewProjection" @= return (mvp :: Matrix Float)

data MeshSketch = MeshSketch
    { mmWidget   :: GLArea
    , mmRealized :: IORef (Maybe Realized)
    }

data Realized = Realized
    { stStorage  :: GLStorage
    , stRenderer :: GLRenderer
    , stState    :: State
    }

new :: IO GLArea
new = do
    m <- do
        objName <- head . (++ ["cube.obj"]) <$> getArgs
        mobj <- loadOBJ objName
        mpipeline <- loadPipeline "hello_obj2.json" $ do
          defObjectArray "objects" Triangles $ do
            "position"  @: Attribute_V4F
            "normal"    @: Attribute_V3F
            "uvw"       @: Attribute_V3F
          defObjectArray "plane" Triangles $ do
            "position"  @: Attribute_V4F
          defUniforms $ do
            "CameraPosition"  @: V3F
            "ViewProjection"  @: M44F
            "diffuseTexture"  @: FTexture2D
            "diffuseColor"    @: V4F
        return $ (,) <$> mobj <*> mpipeline
    either (\e _ -> hPutStrLn stderr e >> throwIO (userError e)) (&) m $ \(obj,pipeline) -> do

        ref <- newIORef Nothing
        -- glarea <- newGLWidget return (lambdaRender app glmethods)
        do
            g <- gLAreaNew
            let mm = MeshSketch g ref
            gLAreaSetHasDepthBuffer g True
            st <- return g
            -- _ <- on g #render        $ glRender w st
            -- _ <- on g #resize        $ glResize w st
            _ <- on g #realize       $ withCurrentGL g (onRealize obj (dynamicPipeline pipeline) (dynamicSchema pipeline) mm)
            _ <- on g #unrealize     $ onUnrealize mm
            -- _ <- on g #createContext $ nullableContext (glCreateContext w st)
            return g

onUnrealize :: MeshSketch -> IO ()
onUnrealize mm = do
    m <- readIORef (mmRealized mm)
    forM_ m $ \st -> do
        LC.disposeStorage (stStorage st)
        LC.disposeRenderer (stRenderer st)
        -- lcDestroyState lc x

onRealize :: MeshData -> Pipeline -> PipelineSchema -> MeshSketch -> IO ()
onRealize mesh pipeline schema mm = do
    onUnrealize mm
    storage <- LC.allocStorage schema
    renderer <- LC.allocRenderer pipeline
    compat <- LC.setStorage renderer storage -- check schema compatibility
    x <- uploadState mesh (mmWidget mm) storage
    let r = Realized
            { stStorage  = storage
            , stRenderer = renderer
            , stState    = x
            }
    _ <- on (mmWidget mm) #render $ onRender (mmWidget mm) r
    _ <- on (mmWidget mm) #resize $ onResize (mmWidget mm) r
    writeIORef (mmRealized mm) $ Just r

onRender :: w -> Realized -> GLContext -> IO Bool
onRender w realized gl = do
    r <- fixupRenderTarget (stRenderer realized)
    setUniforms gl (stStorage realized) (stState realized)
    LC.renderFrame r
    return True

onResize :: GLArea -> Realized -> Int32 -> Int32 -> IO ()
onResize glarea realized w h = do
    let storage = stStorage realized
    -- Plenty of options here.  I went with the last one.
    -- 1. gLContextGetWindow :: HasCallStack => GLContext -> IO (Maybe Window)
    -- 2. getGLContextWindow ::                 GLContext -> IO (Maybe Window)
    -- 3. widgetGetWindow    :: HasCallStack => GLArea    -> IO (Maybe Window)
    widgetGetWindow glarea >>= mapM_ (\win -> do
        (wd,ht) <- do wd <- windowGetWidth win
                      ht <- windowGetHeight win
                      return (fromIntegral wd,fromIntegral ht)
        modifyIORef' (stCamera $ stState realized)
                  $ \c -> c { camWidth  = fromIntegral wd
                            , camHeight = fromIntegral ht
                            }
        LC.setScreenSize (stStorage realized) wd ht)