From 64f1a100fc887fb2a8bc87e2ac6975e872010ef5 Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Wed, 17 Apr 2019 14:18:12 -0400 Subject: Refactored spinning-logo demo. --- GLWidget.hs | 100 ++++++++++++++++++++++++++++++++++++++++++++++++++++ LambdaCubeWidget.hs | 98 ++++++++++++++++++++++++++++++++++++++++++++++++++ TimeKeeper.hs | 40 +++++++++++++++++++++ main.hs | 92 +++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 330 insertions(+) create mode 100644 GLWidget.hs create mode 100644 LambdaCubeWidget.hs create mode 100644 TimeKeeper.hs create mode 100644 main.hs 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 + } + -- cgit v1.2.3