path: root/MeshSketch.hs

{-# LANGUAGE LambdaCase       #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE PatternSynonyms  #-}
module MeshSketch where

import Control.Monad
import qualified Data.Aeson as JSON
import qualified Data.ByteString as SB
import Data.Coerce
import Data.Functor
import qualified Data.Map as Map
import qualified Data.Vector as V
import Data.IORef
import Foreign.C.Types
import GI.Gdk
import GI.GObject.Functions
import GI.Gtk hiding (IsWindow,windowFullscreen,windowUnfullscreen)
import Numeric.LinearAlgebra hiding ((<>))
import LambdaCube.GL as LC
import LambdaCube.GL.Mesh as LC
import LambdaCube.GL.Data
-- import LambdaCube.GL.Type as LC
import LambdaCube.IR
import System.IO.Error

import CubeMap
import LambdaCube.GL.HMatrix ()
import LambdaCube.Gtk
import Matrix

data MeshMaker = MeshMaker
    { mmWidget   :: GLArea
    , mmRealized :: IORef (Maybe State)
    }

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

data State = State
    { stCamera     :: IORef Camera
    , stSkyboxes   :: Skyboxes
    , stSkybox     :: IORef Int
    , stFullscreen :: IO ()
    , stPipeline   :: Pipeline
    , stSchema     :: PipelineSchema
    , stStorage    :: GLStorage
    , stRenderer   :: GLRenderer
    }

initCamera :: Camera
initCamera = Camera
    { camHeightAngle = pi/6
    , camTarget      = fromList [0,0,0]
    , camDirection   = fromList [0,0,-1]
    , camDistance    = 10
    , camWidth       = 0
    , camHeight      = 0
    , camUp          = fromList [0,1,0]
    , camWorldToScreen = Nothing
    , camScreenToWorld = Nothing
    }

viewProjection :: Camera -> (Camera,Matrix Float)
viewProjection c
    | Just m <- camWorldToScreen c = (c,m)
    | otherwise                    = (c { camWorldToScreen = Just m' }, m')
 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)


new :: IO GLArea
new = do
    w <- gLAreaNew
    ref <- newIORef Nothing
    let mm = MeshMaker w ref
    -- _ <- on w #createContext $ onCreateContext mm
    _ <- on w #realize   $ onRealize mm
    _ <- on w #unrealize $ onUnrealize mm
    -- _ <- on w #destroy $ onDestroy mm
    return w

loadPipeline :: IO (Either String (PipelineSchema,Pipeline))
loadPipeline = do
    pipelineDesc <- do
            maybe (Left "Unable to parse meshsketch.json") Right . JSON.decodeStrict <$> SB.readFile "meshsketch.json"
        `catchIOError` \e -> return $ Left (show e)
    -- setup render data
    let inputSchema = makeSchema $ do
          defObjectArray "skypoints" Points $ do
            "position"  @: Attribute_V3F
          defUniforms $ do
            "Cam"    @: M44F
            "Skybox" @: FTextureCube
    return $ (,) inputSchema <$> pipelineDesc


onRealize :: MeshMaker -> IO ()
onRealize mm@(MeshMaker w ref) = do
    putStrLn "realize!"
    readIORef ref >>= \case
        Just st -> onUnrealize mm -- Shouldn't happen.
        Nothing -> return ()
    set w [ #canFocus := True ] -- For keyboard events.
    widgetAddEvents w
        [ EventMaskPointerMotionMask
        , EventMaskButtonPressMask
        , EventMaskButtonReleaseMask
        , EventMaskTouchMask
        , EventMaskScrollMask
        , EventMaskKeyPressMask -- , EventMaskKeyReleaseMask
        ]

    Right (schema,pipeline) <- loadPipeline

    gLAreaMakeCurrent w

    storage <- allocStorage schema
    -- upload state
    renderer <- allocRenderer pipeline
    compat <- setStorage renderer storage -- check schema compatibility

    cam <- newIORef initCamera
    skyboxes <- loadSkyboxes
    skybox <- newIORef 0
    Right ts <- skyboxLoad skyboxes 0
    skybox_id <- uploadCubeMapToGPU ts
    mi <- LC.uploadMeshToGPU Mesh
        { mAttributes = Map.singleton "position" $ A_V3F $ V.fromList
            [ V3 0 0 (-1)
            , V3 0 0 1
            , V3 0 (-1) 0
            , V3 0 1 0
            , V3 (-1) 0 0
            , V3 01 0 0
            ]
        , mPrimitive = P_Points
        }
    LC.addMeshToObjectArray storage "skypoints" [] mi
    LC.updateUniforms storage $ do
        "Skybox" @= return skybox_id
    Just pwidget <- get w #parent
    Just parent <- get pwidget #window
    toggle <- mkFullscreenToggle parent
    let st = State
            { stCamera     = cam
            , stSkyboxes   = skyboxes
            , stSkybox     = skybox
            , stFullscreen = toggle
            , stPipeline   = pipeline
            , stSchema     = schema
            , stStorage    = storage
            , stRenderer   = renderer
            }

    _ <- on w #event $ onEvent w st
    _ <- on w #render $ onRender w st
    writeIORef ref $ Just st

onUnrealize :: MeshMaker -> IO ()
onUnrealize (MeshMaker w ref) = do
    putStrLn "unrealize!"
    readIORef ref >>= \case
        Just st -> do
            -- signalHandlerDisconnect w (sigRender st)
            -- signalHandlerDisconnect w (sigEvent st)
            return ()
        Nothing -> return () -- Shouldn't happen.
    writeIORef ref Nothing


onRender :: w -> State -> GLContext -> IO Bool
onRender w st gl = do
    putStrLn "render"
    mat_vp <- atomicModifyIORef' (stCamera st) viewProjection
    r <- fixupRenderTarget (stRenderer st)
    {-
    let ks = Map.keys $ uniformSetup (stStorage st)
        us = uniforms (stSchema st)
    print (us,ks)
    -}
    LC.updateUniforms (stStorage st) $ do
      "Cam" @= return mat_vp
    -- todo Skybox texture
    LC.renderFrame r
    return True

onEvent :: w -> State -> Event -> IO Bool
onEvent w st ev = do
    msrc <- eventGetSourceDevice ev
    inputSource <- forM msrc $ \src -> do
        src <- get src #inputSource
        return src
    etype <- get ev #type
    -- putStrLn $ "onEvent! " ++ show (etype,inputSource)
    let put x = putStrLn (show inputSource ++ " " ++ show x)
    case etype of

        EventTypeMotionNotify -> do
            mev <- get ev #motion
            x <- get mev #x
            y <- get mev #y
            put (x,y)
            return ()

        EventTypeScroll -> do
            sev <- get ev #scroll
            d <- get sev #direction
            put d
            return ()

        EventTypeKeyPress -> do
            kev <- get ev #key
            val <- get kev #keyval <&> \k -> if k > 0x5A then k - 0x20 else k
            case val of
                KEY_N -> do
                    modifyIORef' (stSkybox st) $ \n -> (n + 1) `mod` (skyboxCount $ stSkyboxes st)
                    idx <- readIORef (stSkybox st)
                    put (skyboxNames (stSkyboxes st) !! idx)
                    return ()
                KEY_F -> do
                    put 'F'
                    stFullscreen st
                _ -> return ()

        e -> return ()

    return False

mkFullscreenToggle :: IsWindow a => a -> IO (IO ())
mkFullscreenToggle w = do
    full <- newIORef False
    return $ do
        b <- atomicModifyIORef' full $ \b -> (not b, not b)
        if b then windowFullscreen w
             else windowUnfullscreen w