Non-working experiment.

1 files changed, 174 insertions, 10 deletions

diff --git a/GtkHello.hs b/GtkHello.hs
index 43de1d2..0084d87 100644
--- a/GtkHello.hs
+++ b/GtkHello.hs
@@ -1,12 +1,25 @@
 {-# 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
@@ -20,17 +33,100 @@ 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' storage _ = bin
+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 #render $ render storage]
+    $ 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
@@ -58,24 +154,85 @@ triangleB = Mesh
 
 data Constants = Constants
     { cStorage  :: GLStorage
+    , cSchema   :: PipelineSchema
     , cPipeline :: Pipeline
+    , cTextures :: TextureData
+    , cLogo     :: DynamicImage
     }
 
 
 render :: Constants -> GLContext -> Gtk.GLArea -> IO (Bool, Event)
-render c _ _ = do
-    putStrLn "render!"
+render c0 gl area = do
+    e <- Gtk.gLAreaGetError area
+    putStrLn $ "render! " ++ show e
 
-    renderer <- LambdaCubeGL.allocRenderer (cPipeline c)
 
-    {-
+    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"
@@ -89,14 +246,17 @@ main = 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" []
 
-    -- load image and upload texture
-    Right img <- Juicy.readImage "logo.png"
+    -- upload texture
     textureData <- LambdaCubeGL.uploadTexture2DToGPU img
 
     -- Disabled, triggers shader compilation.
@@ -106,12 +266,16 @@ main = 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 }
+        { view         = view' Constants { cStorage = storage, cPipeline = pipelineDesc, cTextures = textureData, cLogo = img, cSchema = inputSchema }
         , update       = update'
         , inputs       = []
         , initialState = ()
         }
+    LambdaCubeGL.disposeStorage storage