{-# 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