1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
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
}
|
