diff options
-rw-r--r-- | GLWidget.hs | 100 | ||||
-rw-r--r-- | LambdaCubeWidget.hs | 98 | ||||
-rw-r--r-- | TimeKeeper.hs | 40 | ||||
-rw-r--r-- | main.hs | 92 |
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 @@ | |||
1 | {-# LANGUAGE LambdaCase #-} | ||
2 | {-# LANGUAGE OverloadedLabels #-} | ||
3 | {-# LANGUAGE OverloadedStrings #-} | ||
4 | module GLWidget where | ||
5 | |||
6 | import Control.Concurrent | ||
7 | import Data.Functor.Contravariant | ||
8 | import Data.Int | ||
9 | import Data.IORef | ||
10 | import qualified Data.Text as Text | ||
11 | ;import Data.Text (Text) | ||
12 | import Foreign.ForeignPtr | ||
13 | import Foreign.Ptr | ||
14 | import GI.Gdk.Objects (GLContext(..),windowCreateGlContext) | ||
15 | import qualified GI.Gtk as Gtk | ||
16 | ;import GI.Gtk as Gtk hiding (main) | ||
17 | import System.IO | ||
18 | |||
19 | data WidgetMethods st = WidgetMethods | ||
20 | { glUnrealize :: st -> IO () | ||
21 | , glRealize :: st -> IO () | ||
22 | , glResize :: st -> Int32 -> Int32 -> IO () | ||
23 | , glRender :: st -> GLContext -> IO Bool | ||
24 | , glCreateContext :: st -> IO (Maybe GLContext) | ||
25 | , glTitle :: Text | ||
26 | } | ||
27 | |||
28 | instance Contravariant WidgetMethods where | ||
29 | contramap f w = w | ||
30 | { glUnrealize = glUnrealize w . f | ||
31 | , glRealize = glRealize w . f | ||
32 | , glResize = glResize w . f | ||
33 | , glRender = glRender w . f | ||
34 | , glCreateContext = glCreateContext w . f | ||
35 | } | ||
36 | |||
37 | glmethods :: WidgetMethods GLArea | ||
38 | glmethods = WidgetMethods | ||
39 | { glUnrealize = \_ -> return () | ||
40 | , glRealize = \_ -> return () | ||
41 | , glRender = \_ gl -> return True | ||
42 | , glResize = \_ w h -> return () | ||
43 | , glCreateContext = | ||
44 | \st -> widgetGetWindow (st::GLArea) | ||
45 | >>= maybe (return Nothing) | ||
46 | (fmap Just . windowCreateGlContext) | ||
47 | , glTitle = "GL Area" | ||
48 | } | ||
49 | |||
50 | newGLWidget :: (GLArea -> IO st) -> WidgetMethods st -> IO st | ||
51 | newGLWidget mk w = do | ||
52 | g <- gLAreaNew | ||
53 | st <- mk g | ||
54 | _ <- on g #render $ glRender w st | ||
55 | _ <- on g #resize $ glResize w st | ||
56 | _ <- on g #realize $ withCurrentGL g (glRealize w st) | ||
57 | _ <- on g #unrealize $ glUnrealize w st | ||
58 | _ <- on g #createContext $ nullableContext (glCreateContext w st) | ||
59 | return st | ||
60 | |||
61 | withCurrentGL :: GLArea -> IO () -> IO () | ||
62 | withCurrentGL glarea action = do | ||
63 | gLAreaMakeCurrent glarea | ||
64 | e <- gLAreaGetError glarea | ||
65 | maybe action oopsG e | ||
66 | |||
67 | nullableContext :: IO (Maybe GLContext) -> IO GLContext | ||
68 | nullableContext mk = mk >>= maybe mknull return | ||
69 | where | ||
70 | mknull = do | ||
71 | oops "createContext: GLArea has no window." | ||
72 | fp <- newForeignPtr_ nullPtr | ||
73 | disown <- newIORef Nothing | ||
74 | return $ GLContext $ ManagedPtr fp disown | ||
75 | |||
76 | oopsG :: GError -> IO () | ||
77 | oopsG e = do | ||
78 | msg <- gerrorMessage e | ||
79 | oops (Text.unpack msg) | ||
80 | |||
81 | oops :: String -> IO () | ||
82 | oops s = hPutStrLn stderr s | ||
83 | |||
84 | runGLApp mk methods = do | ||
85 | _ <- Gtk.init Nothing | ||
86 | |||
87 | let mkChild = newGLWidget mk methods | ||
88 | |||
89 | window <- do | ||
90 | w <- windowNew WindowTypeToplevel | ||
91 | windowSetDefaultSize w 760 760 | ||
92 | windowSetTitle w (glTitle methods) | ||
93 | containerSetBorderWidth w 0 | ||
94 | _ <- on w #deleteEvent $ \_ -> mainQuit >> return True | ||
95 | child <- mkChild | ||
96 | containerAdd w child | ||
97 | return w | ||
98 | |||
99 | widgetShowAll window | ||
100 | 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 @@ | |||
1 | {-# LANGUAGE LambdaCase #-} | ||
2 | module LambdaCubeWidget where | ||
3 | |||
4 | import Control.Monad | ||
5 | import Control.Concurrent | ||
6 | import Data.Function | ||
7 | import Data.Int | ||
8 | import GI.Gdk.Objects | ||
9 | import GI.Gtk.Objects (GLArea,widgetGetWindow) | ||
10 | import GLWidget | ||
11 | import LambdaCube.GL as LC | ||
12 | import LambdaCube.IR as LC | ||
13 | import LambdaCube.Gtk | ||
14 | import qualified Data.Aeson as JSON | ||
15 | import qualified Data.ByteString as SB | ||
16 | import System.IO.Error | ||
17 | import Control.Monad.Writer | ||
18 | |||
19 | data LCRealized x = LCRealized GLStorage GLRenderer x | ||
20 | |||
21 | data LCMethods x = LCMethods | ||
22 | { lcRealized :: MVar (LCRealized x) | ||
23 | , lcUploadState :: GLStorage -> IO x -- implements realize | ||
24 | , lcDestroyState :: x -> IO () | ||
25 | , lcSetUniforms :: GLContext -> GLStorage -> x -> IO () -- implements render | ||
26 | , lcPipeline :: DynamicPipeline | ||
27 | } | ||
28 | |||
29 | data DynamicPipeline = DynamicPipeline | ||
30 | { dynamicPipeline :: Pipeline | ||
31 | , dynamicSchema :: PipelineSchema | ||
32 | } | ||
33 | |||
34 | loadPipeline :: FilePath -> Writer PipelineSchema a -> IO (Either String DynamicPipeline) | ||
35 | loadPipeline fname schema = do | ||
36 | pipelineDesc <- do | ||
37 | maybe (Left $ "Unable to parse " ++ fname) Right . JSON.decodeStrict <$> SB.readFile fname | ||
38 | `catchIOError` \e -> return $ Left (show e) | ||
39 | return $ do | ||
40 | p <- pipelineDesc | ||
41 | Right DynamicPipeline | ||
42 | { dynamicPipeline = p | ||
43 | , dynamicSchema = makeSchema schema | ||
44 | } | ||
45 | |||
46 | lambdaRender :: (GLArea -> LCMethods x) -> WidgetMethods GLArea -> WidgetMethods GLArea | ||
47 | lambdaRender f m = m | ||
48 | { glRender = lcrender . f | ||
49 | , glUnrealize = lcunrealize . f | ||
50 | , glRealize = lcrealize . f | ||
51 | , glResize = \glarea -> lcresize glarea (f glarea) | ||
52 | } | ||
53 | |||
54 | tryWithMVar :: IO b -> MVar a -> (a -> IO b) -> IO b | ||
55 | tryWithMVar failed mvar f = do | ||
56 | mr <- tryTakeMVar mvar | ||
57 | maybe failed f mr | ||
58 | |||
59 | lcrender :: LCMethods x -> GLContext -> IO Bool | ||
60 | lcrender lc gl = do | ||
61 | mr <- tryTakeMVar (lcRealized lc) | ||
62 | maybe (\_ -> oops "Not realized!") (&) mr $ \realized-> do | ||
63 | let LCRealized s r0 x = realized | ||
64 | r <- fixupRenderTarget r0 | ||
65 | lcSetUniforms lc gl s x | ||
66 | LC.renderFrame r | ||
67 | putMVar (lcRealized lc) realized | ||
68 | return True | ||
69 | |||
70 | lcunrealize :: LCMethods x -> IO () | ||
71 | lcunrealize lc = do | ||
72 | m <- tryTakeMVar $ lcRealized lc | ||
73 | mapM_ (\(LCRealized _ _ x) -> lcDestroyState lc x) m | ||
74 | |||
75 | lcrealize :: LCMethods x -> IO () | ||
76 | lcrealize lc = do | ||
77 | _ <- tryTakeMVar (lcRealized lc) | ||
78 | storage <- LC.allocStorage (dynamicSchema $ lcPipeline lc) | ||
79 | x <- lcUploadState lc storage | ||
80 | renderer <- LC.allocRenderer (dynamicPipeline $ lcPipeline lc) | ||
81 | compat <- LC.setStorage renderer storage -- check schema compatibility | ||
82 | putMVar (lcRealized lc) $ LCRealized storage renderer x | ||
83 | |||
84 | lcresize :: GLArea -> LCMethods x -> Int32 -> Int32 -> IO () | ||
85 | lcresize glarea lc w h = do | ||
86 | tryTakeMVar (lcRealized lc) >>= \case | ||
87 | Nothing -> return () | ||
88 | Just r@(LCRealized storage _ _) -> do | ||
89 | -- Plenty of options here. I went with the last one. | ||
90 | -- 1. gLContextGetWindow :: HasCallStack => GLContext -> IO (Maybe Window) | ||
91 | -- 2. getGLContextWindow :: GLContext -> IO (Maybe Window) | ||
92 | -- 3. widgetGetWindow :: HasCallStack => GLArea -> IO (Maybe Window) | ||
93 | widgetGetWindow glarea >>= mapM_ (\win -> do | ||
94 | (wd,ht) <- do wd <- windowGetWidth win | ||
95 | ht <- windowGetHeight win | ||
96 | return (fromIntegral wd,fromIntegral ht) | ||
97 | LC.setScreenSize storage wd ht) | ||
98 | 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 @@ | |||
1 | {-# LANGUAGE LambdaCase #-} | ||
2 | {-# LANGUAGE PatternSynonyms #-} | ||
3 | module TimeKeeper where | ||
4 | |||
5 | import Data.Int | ||
6 | import Data.Word | ||
7 | import GI.Gtk as Gtk | ||
8 | import GI.Gdk.Objects | ||
9 | import GI.GLib.Constants (pattern SOURCE_CONTINUE,pattern SOURCE_REMOVE) | ||
10 | |||
11 | import Control.Concurrent | ||
12 | |||
13 | -- | Type alias to mark a value returned by 'widgetAddTickCallback'. | ||
14 | type TickCallbackHandle = Word32 | ||
15 | |||
16 | data TimeKeeper = TimeKeeper | ||
17 | { tmSeconds :: MVar Double | ||
18 | , tmFirstFrame :: MVar Int64 | ||
19 | } | ||
20 | |||
21 | newTimeKeeper :: IO TimeKeeper | ||
22 | newTimeKeeper = do | ||
23 | s <- newMVar 0.0 | ||
24 | ff <- newMVar 0 | ||
25 | return $ TimeKeeper s ff | ||
26 | |||
27 | tick :: TimeKeeper -> Widget -> FrameClock -> IO Bool | ||
28 | tick tm widget clock = widgetGetWindow widget >>= \case | ||
29 | Nothing -> return SOURCE_REMOVE | ||
30 | Just win -> do | ||
31 | windowInvalidateRect win Nothing False | ||
32 | micros <- frameClockGetFrameTime clock | ||
33 | ff <- modifyMVar (tmFirstFrame tm) $ \prev -> | ||
34 | if prev == 0 then return (micros, micros) | ||
35 | else return (prev, prev) | ||
36 | secs <- modifyMVar (tmSeconds tm) $ \_ -> do | ||
37 | let secs = fromIntegral (micros - ff) / 1000000.0 | ||
38 | return (secs,secs) | ||
39 | return SOURCE_CONTINUE | ||
40 | |||
@@ -0,0 +1,92 @@ | |||
1 | {-# LANGUAGE OverloadedLabels #-} | ||
2 | {-# LANGUAGE OverloadedStrings #-} | ||
3 | {-# LANGUAGE LambdaCase #-} | ||
4 | module Main where | ||
5 | |||
6 | import Codec.Picture as Juicy | ||
7 | import Control.Concurrent | ||
8 | import Data.Word | ||
9 | import Data.Function | ||
10 | import qualified Data.Map.Strict as Map | ||
11 | import qualified Data.Vector as V | ||
12 | import GI.Gdk.Objects | ||
13 | import GI.GLib.Constants | ||
14 | import GI.Gtk as Gtk hiding (main) | ||
15 | import LambdaCube.GL as LC | ||
16 | import LambdaCube.GL.Mesh as LC | ||
17 | import System.IO | ||
18 | import System.IO.Error | ||
19 | |||
20 | import GLWidget | ||
21 | import LambdaCubeWidget | ||
22 | import TimeKeeper | ||
23 | |||
24 | type State = (TextureData, TimeKeeper, TickCallbackHandle) | ||
25 | |||
26 | uploadState :: IsWidget glarea => DynamicImage -> glarea -> GLStorage -> IO State | ||
27 | uploadState img glarea storage = do | ||
28 | -- upload geometry to GPU and add to pipeline input | ||
29 | LC.uploadMeshToGPU triangleA >>= LC.addMeshToObjectArray storage "objects" [] | ||
30 | LC.uploadMeshToGPU triangleB >>= LC.addMeshToObjectArray storage "objects" [] | ||
31 | -- load image and upload texture | ||
32 | texture <- LC.uploadTexture2DToGPU img | ||
33 | -- setup FrameClock | ||
34 | tm <- newTimeKeeper | ||
35 | tickcb <- widgetAddTickCallback glarea (tick tm) | ||
36 | return (texture,tm,tickcb) | ||
37 | |||
38 | destroyState :: GLArea -> State -> IO () | ||
39 | destroyState glarea (texture,tm,tickcb) = do | ||
40 | widgetRemoveTickCallback glarea tickcb | ||
41 | |||
42 | setUniforms :: glctx -> GLStorage -> State -> IO () | ||
43 | setUniforms gl storage (texture,tm,_) = do | ||
44 | t <- withMVar (tmSeconds tm) return | ||
45 | LC.updateUniforms storage $ do | ||
46 | "diffuseTexture" @= return texture | ||
47 | "time" @= return (realToFrac t :: Float) | ||
48 | |||
49 | main :: IO () | ||
50 | main = do | ||
51 | m <- do | ||
52 | mimg <- Juicy.readImage "logo.png" `catchIOError` \e -> return $ Left (show e) | ||
53 | mpipeline <- loadPipeline "hello.json" $ do | ||
54 | defObjectArray "objects" Triangles $ do | ||
55 | "position" @: Attribute_V2F | ||
56 | "uv" @: Attribute_V2F | ||
57 | defUniforms $ do | ||
58 | "time" @: Float | ||
59 | "diffuseTexture" @: FTexture2D | ||
60 | return $ (,) <$> mimg <*> mpipeline | ||
61 | either (\e _ -> hPutStrLn stderr e) (&) m $ \(logo,pipeline) -> do | ||
62 | app <- do | ||
63 | mvar <- newEmptyMVar | ||
64 | return $ \glarea -> LCMethods | ||
65 | { lcRealized = mvar | ||
66 | , lcUploadState = uploadState logo glarea | ||
67 | , lcDestroyState = destroyState glarea | ||
68 | , lcSetUniforms = setUniforms | ||
69 | , lcPipeline = pipeline | ||
70 | } | ||
71 | |||
72 | runGLApp return (lambdaRender app glmethods) | ||
73 | |||
74 | -- geometry data: triangles | ||
75 | triangleA :: LC.Mesh | ||
76 | triangleA = Mesh | ||
77 | { mAttributes = Map.fromList | ||
78 | [ ("position", A_V2F $ V.fromList [V2 1 1, V2 1 (-1), V2 (-1) (-1)]) | ||
79 | , ("uv", A_V2F $ V.fromList [V2 1 1, V2 0 1, V2 0 0]) | ||
80 | ] | ||
81 | , mPrimitive = P_Triangles | ||
82 | } | ||
83 | |||
84 | triangleB :: LC.Mesh | ||
85 | triangleB = Mesh | ||
86 | { mAttributes = Map.fromList | ||
87 | [ ("position", A_V2F $ V.fromList [V2 1 1, V2 (-1) (-1), V2 (-1) 1]) | ||
88 | , ("uv", A_V2F $ V.fromList [V2 1 1, V2 0 0, V2 1 0]) | ||
89 | ] | ||
90 | , mPrimitive = P_Triangles | ||
91 | } | ||
92 | |||