Refactored spinning-logo demo.

4 files changed, 330 insertions, 0 deletions

diff --git a/GLWidget.hs b/GLWidget.hs
new file mode 100644
index 0000000..8a9d23e
--- /dev/null
+++ b/GLWidget.hs
@@ -0,0 +1,100 @@
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedLabels  #-}
+{-# LANGUAGE OverloadedStrings #-}
+module GLWidget where
+
+import Control.Concurrent
+import Data.Functor.Contravariant
+import Data.Int
+import Data.IORef
+import qualified Data.Text        as Text
+         ;import Data.Text        (Text)
+import Foreign.ForeignPtr
+import Foreign.Ptr
+import GI.Gdk.Objects (GLContext(..),windowCreateGlContext)
+import qualified GI.Gtk           as Gtk
+         ;import GI.Gtk           as Gtk hiding (main)
+import System.IO
+
+data WidgetMethods st = WidgetMethods
+    { glUnrealize     :: st -> IO ()
+    , glRealize       :: st -> IO ()
+    , glResize        :: st -> Int32 -> Int32 -> IO ()
+    , glRender        :: st -> GLContext -> IO Bool
+    , glCreateContext :: st -> IO (Maybe GLContext)
+    , glTitle         :: Text
+    }
+
+instance Contravariant WidgetMethods where
+    contramap f w = w
+        { glUnrealize     = glUnrealize w . f
+        , glRealize       = glRealize w . f
+        , glResize        = glResize w . f
+        , glRender        = glRender w . f
+        , glCreateContext = glCreateContext w . f
+        }
+
+glmethods :: WidgetMethods GLArea
+glmethods = WidgetMethods
+    { glUnrealize     = \_ -> return ()
+    , glRealize       = \_ -> return ()
+    , glRender        = \_ gl -> return True
+    , glResize        = \_ w h -> return ()
+    , glCreateContext =
+        \st -> widgetGetWindow (st::GLArea)
+                    >>= maybe (return Nothing)
+                              (fmap Just . windowCreateGlContext)
+    , glTitle = "GL Area"
+    }
+
+newGLWidget :: (GLArea -> IO st) -> WidgetMethods st -> IO st
+newGLWidget mk w = do
+    g <- gLAreaNew
+    st <- mk g
+    _ <- on g #render        $ glRender w st
+    _ <- on g #resize        $ glResize w st
+    _ <- on g #realize       $ withCurrentGL g (glRealize w st)
+    _ <- on g #unrealize     $ glUnrealize w st
+    _ <- on g #createContext $ nullableContext (glCreateContext w st)
+    return st
+
+withCurrentGL :: GLArea -> IO () -> IO ()
+withCurrentGL glarea action = do
+    gLAreaMakeCurrent glarea
+    e <- gLAreaGetError glarea
+    maybe action oopsG e
+
+nullableContext :: IO (Maybe GLContext) -> IO GLContext
+nullableContext mk = mk >>= maybe mknull return
+  where
+    mknull = do
+        oops "createContext: GLArea has no window."
+        fp <- newForeignPtr_ nullPtr
+        disown <- newIORef Nothing
+        return $ GLContext $ ManagedPtr fp disown
+
+oopsG :: GError -> IO ()
+oopsG e = do
+    msg <- gerrorMessage e
+    oops (Text.unpack msg)
+
+oops :: String -> IO ()
+oops s = hPutStrLn stderr s
+
+runGLApp mk methods = do
+    _ <- Gtk.init Nothing
+
+    let mkChild = newGLWidget mk methods
+
+    window <- do
+        w <- windowNew WindowTypeToplevel
+        windowSetDefaultSize    w 760 760
+        windowSetTitle          w (glTitle methods)
+        containerSetBorderWidth w 0
+        _ <- on w #deleteEvent $ \_ -> mainQuit >> return True
+        child <- mkChild
+        containerAdd w child
+        return w
+
+    widgetShowAll window
+    Gtk.main
diff --git a/LambdaCubeWidget.hs b/LambdaCubeWidget.hs
new file mode 100644
index 0000000..17bb361
--- /dev/null
+++ b/LambdaCubeWidget.hs
@@ -0,0 +1,98 @@
+{-# LANGUAGE LambdaCase #-}
+module LambdaCubeWidget where
+
+import Control.Monad
+import Control.Concurrent
+import Data.Function
+import Data.Int
+import GI.Gdk.Objects
+import GI.Gtk.Objects (GLArea,widgetGetWindow)
+import GLWidget
+import LambdaCube.GL as LC
+import LambdaCube.IR as LC
+import LambdaCube.Gtk
+import qualified Data.Aeson as JSON
+import qualified Data.ByteString as SB
+import System.IO.Error
+import Control.Monad.Writer
+
+data LCRealized x = LCRealized GLStorage GLRenderer x
+
+data LCMethods x = LCMethods
+    { lcRealized       :: MVar (LCRealized x)
+    , lcUploadState    :: GLStorage -> IO x -- implements realize
+    , lcDestroyState   :: x -> IO ()
+    , lcSetUniforms    :: GLContext -> GLStorage -> x -> IO () -- implements render
+    , lcPipeline       :: DynamicPipeline
+    }
+
+data DynamicPipeline = DynamicPipeline
+    { dynamicPipeline :: Pipeline
+    , dynamicSchema   :: PipelineSchema
+    }
+
+loadPipeline :: FilePath -> Writer PipelineSchema a -> IO (Either String DynamicPipeline)
+loadPipeline fname schema = do
+    pipelineDesc <- do
+            maybe (Left $ "Unable to parse " ++ fname) Right . JSON.decodeStrict <$> SB.readFile fname
+        `catchIOError` \e -> return $ Left (show e)
+    return $ do
+        p <- pipelineDesc
+        Right DynamicPipeline
+            { dynamicPipeline = p
+            , dynamicSchema   = makeSchema schema
+            }
+
+lambdaRender :: (GLArea -> LCMethods x) -> WidgetMethods GLArea -> WidgetMethods GLArea
+lambdaRender f m = m
+    { glRender    = lcrender . f
+    , glUnrealize = lcunrealize . f
+    , glRealize   = lcrealize . f
+    , glResize    = \glarea -> lcresize glarea (f glarea)
+    }
+
+tryWithMVar :: IO b -> MVar a -> (a -> IO b) -> IO b
+tryWithMVar failed mvar f = do
+    mr <- tryTakeMVar mvar
+    maybe failed f mr
+
+lcrender :: LCMethods x -> GLContext -> IO Bool
+lcrender lc gl = do
+    mr <- tryTakeMVar (lcRealized lc)
+    maybe (\_ -> oops "Not realized!") (&) mr $ \realized-> do
+        let LCRealized s r0 x = realized
+        r <- fixupRenderTarget r0
+        lcSetUniforms lc gl s x
+        LC.renderFrame r
+        putMVar (lcRealized lc) realized
+    return True
+
+lcunrealize :: LCMethods x -> IO ()
+lcunrealize lc = do
+    m <- tryTakeMVar $ lcRealized lc
+    mapM_ (\(LCRealized _ _ x) -> lcDestroyState lc x) m
+
+lcrealize :: LCMethods x -> IO ()
+lcrealize lc = do
+    _ <- tryTakeMVar (lcRealized lc)
+    storage <- LC.allocStorage (dynamicSchema $ lcPipeline lc)
+    x <- lcUploadState lc storage
+    renderer <- LC.allocRenderer (dynamicPipeline $ lcPipeline lc)
+    compat <- LC.setStorage renderer storage -- check schema compatibility
+    putMVar (lcRealized lc) $ LCRealized storage renderer x
+
+lcresize :: GLArea -> LCMethods x -> Int32 -> Int32 -> IO ()
+lcresize glarea lc w h = do
+    tryTakeMVar (lcRealized lc) >>= \case
+        Nothing -> return ()
+        Just r@(LCRealized storage _ _) -> do
+            -- Plenty of options here.  I went with the last one.
+            -- 1. gLContextGetWindow :: HasCallStack => GLContext -> IO (Maybe Window)
+            -- 2. getGLContextWindow ::                 GLContext -> IO (Maybe Window)
+            -- 3. widgetGetWindow    :: HasCallStack => GLArea    -> IO (Maybe Window)
+            widgetGetWindow glarea >>= mapM_ (\win -> do
+                (wd,ht) <- do wd <- windowGetWidth win
+                              ht <- windowGetHeight win
+                              return (fromIntegral wd,fromIntegral ht)
+                LC.setScreenSize storage wd ht)
+            putMVar (lcRealized lc) r
diff --git a/TimeKeeper.hs b/TimeKeeper.hs
new file mode 100644
index 0000000..d85f61f
--- /dev/null
+++ b/TimeKeeper.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE PatternSynonyms #-}
+module TimeKeeper where
+
+import Data.Int
+import Data.Word
+import GI.Gtk as Gtk
+import GI.Gdk.Objects
+import GI.GLib.Constants (pattern SOURCE_CONTINUE,pattern SOURCE_REMOVE)
+
+import Control.Concurrent
+
+-- | Type alias to mark a value returned by 'widgetAddTickCallback'.
+type TickCallbackHandle = Word32
+
+data TimeKeeper = TimeKeeper
+    { tmSeconds    :: MVar Double
+    , tmFirstFrame :: MVar Int64
+    }
+
+newTimeKeeper :: IO TimeKeeper
+newTimeKeeper = do
+    s <- newMVar 0.0
+    ff <- newMVar 0
+    return $ TimeKeeper s ff
+
+tick :: TimeKeeper -> Widget -> FrameClock -> IO Bool
+tick tm widget clock = widgetGetWindow widget >>= \case
+    Nothing  -> return SOURCE_REMOVE
+    Just win -> do
+        windowInvalidateRect win Nothing False
+        micros <- frameClockGetFrameTime clock
+        ff <- modifyMVar (tmFirstFrame tm) $ \prev ->
+            if prev == 0 then return (micros, micros)
+                         else return (prev, prev)
+        secs <- modifyMVar (tmSeconds tm) $ \_ -> do
+            let secs = fromIntegral (micros - ff) / 1000000.0
+            return (secs,secs)
+        return SOURCE_CONTINUE
+
diff --git a/main.hs b/main.hs
new file mode 100644
index 0000000..dff8263
--- /dev/null
+++ b/main.hs
@@ -0,0 +1,92 @@
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+module Main where
+
+import Codec.Picture             as Juicy
+import Control.Concurrent
+import Data.Word
+import Data.Function
+import qualified Data.Map.Strict as Map
+import qualified Data.Vector     as V
+import GI.Gdk.Objects
+import GI.GLib.Constants
+import GI.Gtk                    as Gtk hiding (main)
+import LambdaCube.GL             as LC
+import LambdaCube.GL.Mesh        as LC
+import System.IO
+import System.IO.Error
+
+import GLWidget
+import LambdaCubeWidget
+import TimeKeeper
+
+type State = (TextureData, TimeKeeper, TickCallbackHandle)
+
+uploadState :: IsWidget glarea => DynamicImage -> glarea -> GLStorage -> IO State
+uploadState img glarea storage = do
+    -- upload geometry to GPU and add to pipeline input
+    LC.uploadMeshToGPU triangleA >>= LC.addMeshToObjectArray storage "objects" []
+    LC.uploadMeshToGPU triangleB >>= LC.addMeshToObjectArray storage "objects" []
+    -- load image and upload texture
+    texture <- LC.uploadTexture2DToGPU img
+    -- setup FrameClock
+    tm <- newTimeKeeper
+    tickcb <- widgetAddTickCallback glarea (tick tm)
+    return (texture,tm,tickcb)
+
+destroyState :: GLArea -> State -> IO ()
+destroyState glarea (texture,tm,tickcb) = do
+    widgetRemoveTickCallback glarea tickcb
+
+setUniforms :: glctx -> GLStorage -> State -> IO ()
+setUniforms gl storage (texture,tm,_) = do
+    t <- withMVar (tmSeconds tm) return
+    LC.updateUniforms storage $ do
+      "diffuseTexture" @= return texture
+      "time" @= return (realToFrac t :: Float)
+
+main :: IO ()
+main = do
+    m <- do
+        mimg <- Juicy.readImage "logo.png" `catchIOError` \e -> return $ Left (show e)
+        mpipeline <- loadPipeline "hello.json" $ do
+                        defObjectArray "objects" Triangles $ do
+                            "position"  @: Attribute_V2F
+                            "uv"        @: Attribute_V2F
+                        defUniforms $ do
+                            "time"           @: Float
+                            "diffuseTexture" @: FTexture2D
+        return $ (,) <$> mimg <*> mpipeline
+    either (\e _ -> hPutStrLn stderr e) (&) m $ \(logo,pipeline) -> do
+        app <- do
+            mvar <- newEmptyMVar
+            return $ \glarea -> LCMethods
+                { lcRealized     = mvar
+                , lcUploadState  = uploadState logo glarea
+                , lcDestroyState = destroyState glarea
+                , lcSetUniforms  = setUniforms
+                , lcPipeline     = pipeline
+                }
+
+        runGLApp return (lambdaRender app glmethods)
+
+-- geometry data: triangles
+triangleA :: LC.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 :: LC.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
+    }
+