{-# 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 Data.IORef
import Foreign.C.Types
import GI.Gdk
import GI.GObject.Functions
import GI.Gtk hiding (IsWindow,windowFullscreen,windowUnfullscreen)
import Numeric.LinearAlgebra
import LambdaCube.GL as LC
import LambdaCube.IR
import System.IO.Error

import LambdaCube.Gtk
import CubeMap

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
    , 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
    , camWorldToScreen = Nothing
    , camScreenToWorld = Nothing
    }

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
    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
    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"
    r <- fixupRenderTarget (stRenderer st)
    --  lcSetUniforms lc gl s x
    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