diff options
Diffstat (limited to 'MeshSketch.hs')
-rw-r--r-- | MeshSketch.hs | 34 |
1 files changed, 31 insertions, 3 deletions
diff --git a/MeshSketch.hs b/MeshSketch.hs index 30d14b7..45e5710 100644 --- a/MeshSketch.hs +++ b/MeshSketch.hs | |||
@@ -8,18 +8,22 @@ import qualified Data.Aeson as JSON | |||
8 | import qualified Data.ByteString as SB | 8 | import qualified Data.ByteString as SB |
9 | import Data.Coerce | 9 | import Data.Coerce |
10 | import Data.Functor | 10 | import Data.Functor |
11 | import qualified Data.Map as Map | ||
11 | import Data.IORef | 12 | import Data.IORef |
12 | import Foreign.C.Types | 13 | import Foreign.C.Types |
13 | import GI.Gdk | 14 | import GI.Gdk |
14 | import GI.GObject.Functions | 15 | import GI.GObject.Functions |
15 | import GI.Gtk hiding (IsWindow,windowFullscreen,windowUnfullscreen) | 16 | import GI.Gtk hiding (IsWindow,windowFullscreen,windowUnfullscreen) |
16 | import Numeric.LinearAlgebra | 17 | import Numeric.LinearAlgebra hiding ((<>)) |
17 | import LambdaCube.GL as LC | 18 | import LambdaCube.GL as LC |
19 | -- import LambdaCube.GL.Type as LC | ||
18 | import LambdaCube.IR | 20 | import LambdaCube.IR |
19 | import System.IO.Error | 21 | import System.IO.Error |
20 | 22 | ||
21 | import LambdaCube.Gtk | ||
22 | import CubeMap | 23 | import CubeMap |
24 | import LambdaCube.GL.HMatrix () | ||
25 | import LambdaCube.Gtk | ||
26 | import Matrix | ||
23 | 27 | ||
24 | data MeshMaker = MeshMaker | 28 | data MeshMaker = MeshMaker |
25 | { mmWidget :: GLArea | 29 | { mmWidget :: GLArea |
@@ -33,6 +37,7 @@ data Camera = Camera | |||
33 | , camDistance :: Float | 37 | , camDistance :: Float |
34 | , camWidth :: Float | 38 | , camWidth :: Float |
35 | , camHeight :: Float | 39 | , camHeight :: Float |
40 | , camUp :: Vector Float | ||
36 | , camWorldToScreen :: Maybe (Matrix Float) | 41 | , camWorldToScreen :: Maybe (Matrix Float) |
37 | , camScreenToWorld :: Maybe (Matrix Float) | 42 | , camScreenToWorld :: Maybe (Matrix Float) |
38 | } | 43 | } |
@@ -56,10 +61,22 @@ initCamera = Camera | |||
56 | , camDistance = 10 | 61 | , camDistance = 10 |
57 | , camWidth = 0 | 62 | , camWidth = 0 |
58 | , camHeight = 0 | 63 | , camHeight = 0 |
64 | , camUp = fromList [0,1,0] | ||
59 | , camWorldToScreen = Nothing | 65 | , camWorldToScreen = Nothing |
60 | , camScreenToWorld = Nothing | 66 | , camScreenToWorld = Nothing |
61 | } | 67 | } |
62 | 68 | ||
69 | viewProjection :: Camera -> (Camera,Matrix Float) | ||
70 | viewProjection c | ||
71 | | Just m <- camWorldToScreen c = (c,m) | ||
72 | | otherwise = (c { camWorldToScreen = Just m' }, m') | ||
73 | where | ||
74 | m' = proj <> cam | ||
75 | cam = lookat pos (camTarget c) (camUp c) | ||
76 | pos = camTarget c - scale (camDistance c) (camDirection c) | ||
77 | proj = perspective 0.1 100 (camHeightAngle c) (camWidth c / camHeight c) | ||
78 | |||
79 | |||
63 | new :: IO GLArea | 80 | new :: IO GLArea |
64 | new = do | 81 | new = do |
65 | w <- gLAreaNew | 82 | w <- gLAreaNew |
@@ -80,6 +97,9 @@ loadPipeline = do | |||
80 | let inputSchema = makeSchema $ do | 97 | let inputSchema = makeSchema $ do |
81 | defObjectArray "skypoints" Points $ do | 98 | defObjectArray "skypoints" Points $ do |
82 | "position" @: Attribute_V3F | 99 | "position" @: Attribute_V3F |
100 | defUniforms $ do | ||
101 | "Cam" @: M44F | ||
102 | "Skybox" @: FTextureCube | ||
83 | return $ (,) inputSchema <$> pipelineDesc | 103 | return $ (,) inputSchema <$> pipelineDesc |
84 | 104 | ||
85 | 105 | ||
@@ -144,8 +164,16 @@ onUnrealize (MeshMaker w ref) = do | |||
144 | onRender :: w -> State -> GLContext -> IO Bool | 164 | onRender :: w -> State -> GLContext -> IO Bool |
145 | onRender w st gl = do | 165 | onRender w st gl = do |
146 | putStrLn "render" | 166 | putStrLn "render" |
167 | mat_vp <- atomicModifyIORef' (stCamera st) viewProjection | ||
147 | r <- fixupRenderTarget (stRenderer st) | 168 | r <- fixupRenderTarget (stRenderer st) |
148 | -- lcSetUniforms lc gl s x | 169 | {- |
170 | let ks = Map.keys $ uniformSetup (stStorage st) | ||
171 | us = uniforms (stSchema st) | ||
172 | print (us,ks) | ||
173 | -} | ||
174 | LC.updateUniforms (stStorage st) $ do | ||
175 | "Cam" @= return mat_vp | ||
176 | -- todo Skybox texture | ||
149 | LC.renderFrame r | 177 | LC.renderFrame r |
150 | return True | 178 | return True |
151 | 179 | ||