{-# LANGUAGE OverloadedStrings #-}
module LambdaHello where

import GI.Gtk as Gtk
import GI.Gdk.Objects

-- import qualified Graphics.Rendering.OpenGL as GL
import Data.Function
import Control.Concurrent
import LambdaCube.GL as LambdaCubeGL
import LambdaCube.GL.Mesh as LambdaCubeGL
import LambdaCube.IR
import Codec.Picture as Juicy
import Data.Aeson as JSON
import qualified Data.ByteString as SB
import System.IO.Error
import qualified Data.Map as Map
import qualified Data.Vector as V

import qualified Backend as RF

data State = State
    { stConfig   :: Config
    , stRealized :: MVar Realized
    }

initState :: IO State
initState = do
    cfg <- either fail return =<< loadConfig
    r <- newEmptyMVar
    return State
        { stConfig   = cfg
        , stRealized = r
        }


render :: State -> GLArea -> GLContext -> IO Bool
render st w _ = do -- gLAreaMakeCurrent w >> gLAreaGetError w >>= \me -> maybe id (\e _ -> print e >> return False) me $ do
    mr <- tryTakeMVar (stRealized st)
    maybe (\_ -> putStrLn "Not realized!") (&) mr $ \r -> do
        -- Load input to pipeline.
        -- GLFW.getWindowSize win >>= \(w,h) -> LambdaCubeGL.setScreenSize storage (fromIntegral w) (fromIntegral h)
        return (500,500) >>= \(w,h) -> LambdaCubeGL.setScreenSize (rStorage r) (fromIntegral w) (fromIntegral h)
        LambdaCubeGL.updateUniforms (rStorage r) $ do
          "diffuseTexture" @= return (rTexture r)
          "time" @= do
                      -- Just t <- GLFW.getTime
                      let t = 1.0 :: Double
                      return (realToFrac t :: Float)

        putStrLn "render!"
        -- GL.clearColor GL.$= GL.Color4 0 255 0 1
        -- GL.clear [GL.ColorBuffer]
        RF.renderFrame (rRenderer r)
        -- GL.flush
        putMVar (stRealized st) r
    return True

data Realized = Realized
    { rStorage  :: GLStorage
    , rTexture  :: TextureData
    , rRenderer :: GLRenderer
    }

realize :: State -> GLArea -> IO ()
realize st w = gLAreaMakeCurrent w >> gLAreaGetError w >>= \me -> maybe id (\e _ -> print e) me $ do
    let cfg = stConfig st

    _ <- tryTakeMVar (stRealized st)

    storage <- LambdaCubeGL.allocStorage (cfgSchema cfg)

    -- upload geometry to GPU and add to pipeline input
    LambdaCubeGL.uploadMeshToGPU triangleA >>= LambdaCubeGL.addMeshToObjectArray storage "objects" []
    LambdaCubeGL.uploadMeshToGPU triangleB >>= LambdaCubeGL.addMeshToObjectArray storage "objects" []

    -- load image and upload texture
    texture <- LambdaCubeGL.uploadTexture2DToGPU (cfgLogo cfg)

    renderer <- LambdaCubeGL.allocRenderer (cfgPipeline cfg)

    compat <- LambdaCubeGL.setStorage renderer storage -- check schema compatibility

    putMVar (stRealized st) $ Realized storage texture renderer
    -- GL.flush
    putStrLn "realize!"
    maybe id (\e _ -> putStrLn e) compat $ return ()

unrealize :: State -> GLArea -> IO ()
unrealize _ _ = return ()

data Config = Config
    { cfgSchema   :: PipelineSchema
    , cfgPipeline :: Pipeline
    , cfgLogo     :: DynamicImage
    }

loadConfig :: IO (Either String Config)
loadConfig = do
    pipelineDesc <- do
            maybe (Left "Unable to parse hello.json") Right . JSON.decodeStrict <$> SB.readFile "hello.json"
        `catchIOError` \e -> return $ Left (show e)
    -- setup render data
    let inputSchema = makeSchema $ do
          defObjectArray "objects" Triangles $ do
            "position"  @: Attribute_V2F
            "uv"        @: Attribute_V2F
          defUniforms $ do
            "time"           @: Float
            "diffuseTexture" @: FTexture2D
    -- load image and upload texture
    img <- Juicy.readImage "logo.png"
        `catchIOError` \e -> return $ Left (show e)
    return $ Config inputSchema <$> pipelineDesc <*> img

-- geometry data: triangles
triangleA :: LambdaCubeGL.Mesh
triangleA = Mesh
    { mAttributes   = Map.fromList
        [ ("position",  A_V2F $ V.fromList [V2 1 1, V2 1 (-1), V2 (-1) (-1)])
        , ("uv",        A_V2F $ V.fromList [V2 1 1, V2 0 1, V2 0 0])
        ]
    , mPrimitive    = P_Triangles
    }

triangleB :: LambdaCubeGL.Mesh
triangleB = Mesh
    { mAttributes   = Map.fromList
        [ ("position",  A_V2F $ V.fromList [V2 1 1, V2 (-1) (-1), V2 (-1) 1])
        , ("uv",        A_V2F $ V.fromList [V2 1 1, V2 0 0, V2 1 0])
        ]
    , mPrimitive    = P_Triangles
    }

createContext :: State -> GLArea -> IO GLContext
createContext st glarea = do
    Just win <- widgetGetWindow glarea
    gl <- windowCreateGlContext win
    return gl