WIP: Abandon GLWidget in favor of (non-working) MeshSketch design.

author: Joe Crayne <joe@jerkface.net> 2019-04-29 16:44:20 -0400
committer: Joe Crayne <joe@jerkface.net> 2019-04-29 16:44:20 -0400
commit: 2c277a7d3c25aa792c9d2d324b8e70296d4b453c (patch)
tree: 3f156ff2a984bfea7f14e0d80f54ec18a6ad0418 /mainObj.hs
parent: edbc09c280c1699933c443795686394c1e9e8de5 (diff)
1 files changed, 22 insertions, 120 deletions
diff --git a/mainObj.hs b/mainObj.hs
index 970f94c..caf6501 100644
--- a/mainObj.hs
+++ b/mainObj.hs
@@ -1,127 +1,29 @@
-{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedLabels  #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards   #-}
-{-# LANGUAGE RecordWildCards #-}
 module Main where
-import Codec.Picture             as Juicy
+import qualified GI.Gtk as Gtk (main)
-import Control.Concurrent
+         ;import GI.Gtk as Gtk hiding (main)
-import Control.Monad
-import Data.Word
-import Data.Function
-import Data.Text (Text)
-import Data.Map.Strict (Map)
-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 Numeric.LinearAlgebra hiding ((<>))
-import System.Environment
-import System.IO
-import System.IO.Error
-import GLWidget
+import qualified MeshSketch
-import LambdaCube.GL.HMatrix
-import LambdaCubeWidget
-import TimeKeeper
-import LoadMesh
-import InfinitePlane
-import MtlParser (ObjMaterial(..))
-import Matrix
-- State created by uploadState.
-data State = State
-    { stTimeKeeper   :: TimeKeeper
-    , stTickCallback :: TickCallbackHandle
-    }
-addOBJToObjectArray :: GLStorage -> String -> [(GPUMesh, Maybe Text)] -> Map Text (ObjMaterial,TextureData) -> IO [LC.Object]
-addOBJToObjectArray storage slotName objMesh mtlLib = forM objMesh $ \(mesh,mat) -> do
-  obj <- LC.addMeshToObjectArray storage slotName ["diffuseTexture","diffuseColor"] mesh
-         -- diffuseTexture and diffuseColor values can change on each model
-  case mat >>= flip Map.lookup mtlLib of
-    Nothing -> return ()
-    Just (ObjMaterial{..},t) -> LC.updateObjectUniforms obj $ do
-      "diffuseTexture" @= return t -- set model's diffuse texture
-      "diffuseColor" @= let (r,g,b) = mtl_Kd in return (V4 r g b mtl_Tr)
-  return obj
-uploadState :: IsWidget glarea => MeshData -> glarea -> GLStorage -> IO State
-uploadState obj glarea storage = do
-    -- load OBJ geometry and material descriptions
-    (objMesh,mtlLib) <- uploadOBJToGPU obj
-    -- load materials textures
-    gpuMtlLib <- uploadMtlLib mtlLib
-    -- add OBJ to pipeline input
-    addOBJToObjectArray storage "objects" objMesh gpuMtlLib
-    -- grid plane
-    uploadMeshToGPU xzplane >>= addMeshToObjectArray storage "plane" []
-    -- setup FrameClock
-    tm <- newTimeKeeper
-    tickcb <- widgetAddTickCallback glarea (tick tm)
-    return State
-        { stTimeKeeper   = tm
-        , stTickCallback = tickcb
-        }
-destroyState :: GLArea -> State -> IO ()
-destroyState glarea st = do
-    widgetRemoveTickCallback glarea (stTickCallback st)
-deg30 :: Float
-deg30 = pi/6
-setUniforms :: glctx -> GLStorage -> State -> IO ()
-setUniforms gl storage st = do
-    t <- (/ 10.0) <$> getSeconds (stTimeKeeper st)
-    let tf = realToFrac t :: Float
-        rot = rotMatrixZ (-tf) <> rotMatrixX (-tf)
-        pos = rot #> fromList [2,2,10]
-        up = rot #> fromList [0,1,0]
-        cam = lookat pos 0 up
-        aspect = 1
-        proj = perspective 0.1 100 deg30 aspect
-        mvp = proj <> cam
-    LC.updateUniforms storage $ do
-      "CameraPosition" @= return (pos :: Vector Float)
-      "ViewProjection" @= return (mvp :: Matrix Float)
 main :: IO ()
 main = do
-    m <- do
+        _ <- Gtk.init Nothing
-        objName <- head . (++ ["cube.obj"]) <$> getArgs
-        mobj <- loadOBJ objName
+        let mkChild = MeshSketch.mmWidget <$> MeshSketch.new
-        mpipeline <- loadPipeline "hello_obj2.json" $ do
-          defObjectArray "objects" Triangles $ do
+        window <- do
-            "position"  @: Attribute_V4F
+            w <- Gtk.windowNew WindowTypeToplevel
-            "normal"    @: Attribute_V3F
+            windowSetDefaultSize    w 720 720
-            "uvw"       @: Attribute_V3F
+            Gtk.windowSetTitle      w "MeshSketch"
-          defObjectArray "plane" Triangles $ do
+            containerSetBorderWidth w 0
-            "position"  @: Attribute_V4F
+            _ <- on w #deleteEvent $ \_ -> mainQuit >> return True
-          defUniforms $ do
+            child <- mkChild
-            "CameraPosition"  @: V3F
+            containerAdd w child
-            "ViewProjection"  @: M44F
+            return w
-            "diffuseTexture"  @: FTexture2D
-            "diffuseColor"    @: V4F
+        widgetShowAll window
-        return $ (,) <$> mobj <*> mpipeline
+        Gtk.main
-    either (\e _ -> hPutStrLn stderr e) (&) m $ \(obj,pipeline) -> do
-        app <- do
-            mvar <- newEmptyMVar
-            return $ \glarea -> LCMethods
-                { lcRealized     = mvar
-                , lcUploadState  = uploadState obj glarea
-                , lcDestroyState = destroyState glarea
-                , lcSetUniforms  = setUniforms
-                , lcPipeline     = pipeline
-                }
-        runGLApp return (lambdaRender app glmethods)
-            { glTitle = "LambdaCube 3D DSL OBJ viewer"
-            }
author	Joe Crayne <joe@jerkface.net>	2019-04-29 16:44:20 -0400
committer	Joe Crayne <joe@jerkface.net>	2019-04-29 16:44:20 -0400
commit	2c277a7d3c25aa792c9d2d324b8e70296d4b453c (patch)
tree	3f156ff2a984bfea7f14e0d80f54ec18a6ad0418 /mainObj.hs
parent	edbc09c280c1699933c443795686394c1e9e8de5 (diff)

diff --git a/mainObj.hs b/mainObj.hs index 970f94c..caf6501 100644 --- a/mainObj.hs +++ b/mainObj.hs
@@ -1,127 +1,29 @@
1	{-# LANGUAGE OverloadedLabels #-}	1	{-# LANGUAGE LambdaCase #-}
		2	{-# LANGUAGE OverloadedLabels #-}
2	{-# LANGUAGE OverloadedStrings #-}	3	{-# LANGUAGE OverloadedStrings #-}
3	{-# LANGUAGE LambdaCase #-}	4	{-# LANGUAGE RecordWildCards #-}
4	{-# LANGUAGE RecordWildCards #-}
5	module Main where	5	module Main where
6		6
7	import Codec.Picture as Juicy	7	import qualified GI.Gtk as Gtk (main)
8	import Control.Concurrent	8	;import GI.Gtk as Gtk hiding (main)
9	import Control.Monad
10	import Data.Word
11	import Data.Function
12	import Data.Text (Text)
13	import Data.Map.Strict (Map)
14	import qualified Data.Map.Strict as Map
15	import qualified Data.Vector as V
16	import GI.Gdk.Objects
17	import GI.GLib.Constants
18	import GI.Gtk as Gtk hiding (main)
19	import LambdaCube.GL as LC
20	import LambdaCube.GL.Mesh as LC
21	import Numeric.LinearAlgebra hiding ((<>))
22	import System.Environment
23	import System.IO
24	import System.IO.Error
25		9
26	import GLWidget	10	import qualified MeshSketch
27	import LambdaCube.GL.HMatrix
28	import LambdaCubeWidget
29	import TimeKeeper
30	import LoadMesh
31	import InfinitePlane
32	import MtlParser (ObjMaterial(..))
33	import Matrix
34
35	-- State created by uploadState.
36	data State = State
37	{ stTimeKeeper :: TimeKeeper
38	, stTickCallback :: TickCallbackHandle
39	}
40
41	addOBJToObjectArray :: GLStorage -> String -> [(GPUMesh, Maybe Text)] -> Map Text (ObjMaterial,TextureData) -> IO [LC.Object]
42	addOBJToObjectArray storage slotName objMesh mtlLib = forM objMesh $ \(mesh,mat) -> do
43	obj <- LC.addMeshToObjectArray storage slotName ["diffuseTexture","diffuseColor"] mesh
44	-- diffuseTexture and diffuseColor values can change on each model
45	case mat >>= flip Map.lookup mtlLib of
46	Nothing -> return ()
47	Just (ObjMaterial{..},t) -> LC.updateObjectUniforms obj $ do
48	"diffuseTexture" @= return t -- set model's diffuse texture
49	"diffuseColor" @= let (r,g,b) = mtl_Kd in return (V4 r g b mtl_Tr)
50	return obj
51
52
53	uploadState :: IsWidget glarea => MeshData -> glarea -> GLStorage -> IO State
54	uploadState obj glarea storage = do
55	-- load OBJ geometry and material descriptions
56	(objMesh,mtlLib) <- uploadOBJToGPU obj
57	-- load materials textures
58	gpuMtlLib <- uploadMtlLib mtlLib
59	-- add OBJ to pipeline input
60	addOBJToObjectArray storage "objects" objMesh gpuMtlLib
61	-- grid plane
62	uploadMeshToGPU xzplane >>= addMeshToObjectArray storage "plane" []
63
64	-- setup FrameClock
65	tm <- newTimeKeeper
66	tickcb <- widgetAddTickCallback glarea (tick tm)
67
68	return State
69	{ stTimeKeeper = tm
70	, stTickCallback = tickcb
71	}
72
73	destroyState :: GLArea -> State -> IO ()
74	destroyState glarea st = do
75	widgetRemoveTickCallback glarea (stTickCallback st)
76
77	deg30 :: Float
78	deg30 = pi/6
79
80	setUniforms :: glctx -> GLStorage -> State -> IO ()
81	setUniforms gl storage st = do
82	t <- (/ 10.0) <$> getSeconds (stTimeKeeper st)
83	let tf = realToFrac t :: Float
84	rot = rotMatrixZ (-tf) <> rotMatrixX (-tf)
85	pos = rot #> fromList [2,2,10]
86	up = rot #> fromList [0,1,0]
87	cam = lookat pos 0 up
88	aspect = 1
89	proj = perspective 0.1 100 deg30 aspect
90	mvp = proj <> cam
91
92	LC.updateUniforms storage $ do
93	"CameraPosition" @= return (pos :: Vector Float)
94	"ViewProjection" @= return (mvp :: Matrix Float)
95		11
96	main :: IO ()	12	main :: IO ()
97	main = do	13	main = do
98	m <- do	14	_ <- Gtk.init Nothing
99	objName <- head . (++ ["cube.obj"]) <$> getArgs	15
100	mobj <- loadOBJ objName	16	let mkChild = MeshSketch.mmWidget <$> MeshSketch.new
101	mpipeline <- loadPipeline "hello_obj2.json" $ do	17
102	defObjectArray "objects" Triangles $ do	18	window <- do
103	"position" @: Attribute_V4F	19	w <- Gtk.windowNew WindowTypeToplevel
104	"normal" @: Attribute_V3F	20	windowSetDefaultSize w 720 720
105	"uvw" @: Attribute_V3F	21	Gtk.windowSetTitle w "MeshSketch"
106	defObjectArray "plane" Triangles $ do	22	containerSetBorderWidth w 0
107	"position" @: Attribute_V4F	23	_ <- on w #deleteEvent $ \_ -> mainQuit >> return True
108	defUniforms $ do	24	child <- mkChild
109	"CameraPosition" @: V3F	25	containerAdd w child
110	"ViewProjection" @: M44F	26	return w
111	"diffuseTexture" @: FTexture2D	27
112	"diffuseColor" @: V4F	28	widgetShowAll window
113	return $ (,) <$> mobj <*> mpipeline	29	Gtk.main
114	either (\e _ -> hPutStrLn stderr e) (&) m $ \(obj,pipeline) -> do
115	app <- do
116	mvar <- newEmptyMVar
117	return $ \glarea -> LCMethods
118	{ lcRealized = mvar
119	, lcUploadState = uploadState obj glarea
120	, lcDestroyState = destroyState glarea
121	, lcSetUniforms = setUniforms
122	, lcPipeline = pipeline
123	}
124
125	runGLApp return (lambdaRender app glmethods)
126	{ glTitle = "LambdaCube 3D DSL OBJ viewer"
127	}