path: root/GtkHello.hs

{-# LANGUAGE OverloadedLabels  #-}
{-# LANGUAGE OverloadedLists   #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
module Main where

import GHC.OverloadedLabels

import qualified GI.Gtk                        as Gtk
import           GI.Gtk.Declarative
import           GI.Gtk.Declarative.App.Simple
import           GI.Gdk.Objects.GLContext
import           GI.Gdk.Objects.Window
import Data.Bits

import Graphics.GL.Compatibility33 as GL33
{-
import qualified Graphics.Rendering.OpenGL.GL.Framebuffer as GL
import Graphics.Rendering.OpenGL.GL.VertexSpec
import Data.StateVar
-}

import qualified Data.Map as Map
import qualified Data.Vector as V

import LambdaCube.GL as LambdaCubeGL -- renderer
import LambdaCube.GL.Mesh as LambdaCubeGL
import LambdaCube.IR

import Codec.Picture as Juicy

import Data.Aeson
import qualified Data.ByteString as SB

import System.Exit

type State = ()

data Event = Closed | Ignored

view' :: Constants -> State -> AppView Gtk.Window Event
view' c _ = bin
    Gtk.Window
    [ #title := "LambdaCube 3D DSL Hello World"
    , on #deleteEvent $ {- GI.Gdk.Unions.Event.Event -> (Bool, Event) -} \_ -> (True,Closed)
    ]
    $ widget Gtk.GLArea
        [ onM #realize $ realize c
        -- , onM #unrealize $ unrealize c
        , onM #render $ render c
        -- , on #createContext $ _todo -- createContext
        ]
-- type instance SignalList GLArea = GLAreaSignalList
-- type GLAreaSignalList = ('[ '("accel-closures-changed" , WidgetAccelClosuresChangedSignalInfo)
--     , '("button-press-event" , WidgetButtonPressEventSignalInfo)
--     , '("button-release-event" , WidgetButtonReleaseEventSignalInfo)
--     , '("can-activate-accel" , WidgetCanActivateAccelSignalInfo)
--     , '("child-notify" , WidgetChildNotifySignalInfo)
--     , '("composited-changed" , WidgetCompositedChangedSignalInfo)
--     , '("configure-event" , WidgetConfigureEventSignalInfo)
--     , '("create-context" , GLAreaCreateContextSignalInfo)
--     , '("damage-event" , WidgetDamageEventSignalInfo)
--     , '("delete-event" , WidgetDeleteEventSignalInfo)
--     , '("destroy" , WidgetDestroySignalInfo)
--     , '("destroy-event" , WidgetDestroyEventSignalInfo)
--     , '("direction-changed" , WidgetDirectionChangedSignalInfo)
--     , '("drag-begin" , WidgetDragBeginSignalInfo)
--     , '("drag-data-delete" , WidgetDragDataDeleteSignalInfo)
--     , '("drag-data-get" , WidgetDragDataGetSignalInfo)
--     , '("drag-data-received" , WidgetDragDataReceivedSignalInfo)
--     , '("drag-drop" , WidgetDragDropSignalInfo)
--     , '("drag-end" , WidgetDragEndSignalInfo)
--     , '("drag-failed" , WidgetDragFailedSignalInfo)
--     , '("drag-leave" , WidgetDragLeaveSignalInfo)
--     , '("drag-motion" , WidgetDragMotionSignalInfo)
--     , '("draw" , WidgetDrawSignalInfo)
--     , '("enter-notify-event" , WidgetEnterNotifyEventSignalInfo)
--     , '("event" , WidgetEventSignalInfo)
--     , '("event-after" , WidgetEventAfterSignalInfo)
--     , '("focus" , WidgetFocusSignalInfo)
--     , '("focus-in-event" , WidgetFocusInEventSignalInfo)
--     , '("focus-out-event" , WidgetFocusOutEventSignalInfo)
--     , '("grab-broken-event" , WidgetGrabBrokenEventSignalInfo)
--     , '("grab-focus" , WidgetGrabFocusSignalInfo)
--     , '("grab-notify" , WidgetGrabNotifySignalInfo)
--     , '("hide" , WidgetHideSignalInfo)
--     , '("hierarchy-changed" , WidgetHierarchyChangedSignalInfo)
--     , '("key-press-event" , WidgetKeyPressEventSignalInfo)
--     , '("key-release-event" , WidgetKeyReleaseEventSignalInfo)
--     , '("keynav-failed" , WidgetKeynavFailedSignalInfo)
--     , '("leave-notify-event" , WidgetLeaveNotifyEventSignalInfo)
--     , '("map" , WidgetMapSignalInfo)
--     , '("map-event" , WidgetMapEventSignalInfo)
--     , '("mnemonic-activate" , WidgetMnemonicActivateSignalInfo)
--     , '("motion-notify-event" , WidgetMotionNotifyEventSignalInfo)
--     , '("move-focus" , WidgetMoveFocusSignalInfo)
--     , '("notify" , GObject.ObjectNotifySignalInfo)
--     , '("parent-set" , WidgetParentSetSignalInfo)
--     , '("popup-menu" , WidgetPopupMenuSignalInfo)
--     , '("property-notify-event" , WidgetPropertyNotifyEventSignalInfo)
--     , '("proximity-in-event" , WidgetProximityInEventSignalInfo)
--     , '("proximity-out-event" , WidgetProximityOutEventSignalInfo)
--     , '("query-tooltip" , WidgetQueryTooltipSignalInfo)
--     , '("realize" , WidgetRealizeSignalInfo)
--     , '("render" , GLAreaRenderSignalInfo)
--     , '("resize" , GLAreaResizeSignalInfo)
--     , '("screen-changed" , WidgetScreenChangedSignalInfo)
--     , '("scroll-event" , WidgetScrollEventSignalInfo)
--     , '("selection-clear-event" , WidgetSelectionClearEventSignalInfo)
--     , '("selection-get" , WidgetSelectionGetSignalInfo)
--     , '("selection-notify-event" , WidgetSelectionNotifyEventSignalInfo)
--     , '("selection-received" , WidgetSelectionReceivedSignalInfo)
--     , '("selection-request-event" , WidgetSelectionRequestEventSignalInfo)
--     , '("show" , WidgetShowSignalInfo)
--     , '("show-help" , WidgetShowHelpSignalInfo)
--     , '("size-allocate" , WidgetSizeAllocateSignalInfo)
--     , '("state-changed" , WidgetStateChangedSignalInfo)
--     , '("state-flags-changed" , WidgetStateFlagsChangedSignalInfo)
--     , '("style-set" , WidgetStyleSetSignalInfo)
--     , '("style-updated" , WidgetStyleUpdatedSignalInfo)
--     , '("touch-event" , WidgetTouchEventSignalInfo)
--     , '("unmap" , WidgetUnmapSignalInfo)
--     , '("unmap-event" , WidgetUnmapEventSignalInfo)
--     , '("unrealize" , WidgetUnrealizeSignalInfo)
--     , '("visibility-notify-event" , WidgetVisibilityNotifyEventSignalInfo)
--     , '("window-state-event" , WidgetWindowStateEventSignalInfo)
--     , '("notify::[property]" , GObjectNotifySignalInfo)] :: [(Symbol, *)])



update' :: State -> Event -> Transition State Event
update' _ Closed = Exit
update' _ _      = Transition () (return Nothing)

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

data Constants = Constants
    { cStorage  :: GLStorage
    , cSchema   :: PipelineSchema
    , cPipeline :: Pipeline
    , cTextures :: TextureData
    , cLogo     :: DynamicImage
    }


render :: Constants -> GLContext -> Gtk.GLArea -> IO (Bool, Event)
render c0 gl area = do
    e <- Gtk.gLAreaGetError area
    putStrLn $ "render! " ++ show e


    storage <- LambdaCubeGL.allocStorage (cSchema c0)

    -- 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
    textureData <- LambdaCubeGL.uploadTexture2DToGPU (cLogo c0)

    let c = c0 { cStorage = storage, cTextures = textureData }

    renderer <- LambdaCubeGL.allocRenderer (cPipeline c)

    compat <- LambdaCubeGL.setStorage renderer (cStorage c) -- check schema compatibility

    maybe id (\e _ -> putStrLn e) compat $ do

        -- Load input to pipeline.
        -- GLFW.getWindowSize win >>= \(w,h) -> LambdaCubeGL.setScreenSize storage (fromIntegral w) (fromIntegral h)
        return (500,500) >>= \(w,h) -> LambdaCubeGL.setScreenSize (cStorage c) (fromIntegral w) (fromIntegral h)
        LambdaCubeGL.updateUniforms (cStorage c) $ do
          "diffuseTexture" @= return (cTextures c)
          "time" @= do
                      -- Just t <- GLFW.getTime
                      let t = 1.0 :: Double
                      return (realToFrac t :: Float)

        -- GL33.glClearColor 0 255 0 128
        -- GL33.glClear $ GL_COLOR_BUFFER_BIT .|. GL_DEPTH_BUFFER_BIT
        --
        -- -- GL33.glDrawArrays GL_TRIANGLES 0 3

        -- Run pipeline.
        LambdaCubeGL.renderFrame renderer
        -- GL33.glDrawArrays GL_TRIANGLES 0 3
        -- GL33.glEnd
        GL33.glFlush
        {-
        w <- getGLContextWindow gl
        mapM_ windowEndPaint w
        -}
        return ()

    LambdaCubeGL.disposeRenderer renderer
    -- LambdaCubeGL.disposeStorage storage -- Not implemented?
    return (True,Ignored)

realize :: Constants -> Gtk.GLArea -> IO Event
realize c _ = do
    putStrLn "realize!"
    exitSuccess
    return Closed -- Ignored

unrealize :: Constants -> Gtk.GLArea -> IO Event
unrealize c _ = do
    putStrLn "unrealize!"
    return Ignored


-- createContext :: GI.Gtk.Declarative.Attributes.Internal.EventHandler.UserEventHandler Gtk.GLAreaCreateContextCallback Gtk.GLArea 'GI.Gtk.Declarative.Attributes.Internal.EventHandler.Impure Event
{-
createContext :: Gtk.GLArea -> IO (GLContext,Event)
createContext _ = do
    return (error "todo",Ignored)
-}

main :: IO ()
main = do
    Just pipelineDesc <- decodeStrict <$> SB.readFile "hello.json"

    -- 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
    Right img <- Juicy.readImage "logo.png"

    {-
    storage <- LambdaCubeGL.allocStorage inputSchema

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

    -- upload texture
    textureData <- LambdaCubeGL.uploadTexture2DToGPU img

    -- Disabled, triggers shader compilation.
    -- This triggers lots of garbage to be dumped to the terminal and apparently
    -- never returns to display the gtk window.
    let _ = do
            -- allocate GL pipeline
            renderer <- LambdaCubeGL.allocRenderer pipelineDesc
            return ()
    -}
    let storage = error "storage"
        textureData = error "textureData"

    putStrLn "Starting Gtk window!"
    run App
        -- :: App Gtk.Window State Event
        { view         = view' Constants { cStorage = storage, cPipeline = pipelineDesc, cTextures = textureData, cLogo = img, cSchema = inputSchema }
        , update       = update'
        , inputs       = []
        , initialState = ()
        }
    LambdaCubeGL.disposeStorage storage