From c155a1d9b8ca4b2cc5f327580847ad8f6249c1b6 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Sun, 7 Apr 2019 10:03:53 -0400 Subject: Non-working experiment. --- GtkHello.hs | 184 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 174 insertions(+), 10 deletions(-) (limited to 'GtkHello.hs') 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 -- cgit v1.2.3