add Wavefron OBJ loader example

author: Csaba Hruska <csaba.hruska@gmail.com> 2016-07-10 15:06:54 +0200
committer: Csaba Hruska <csaba.hruska@gmail.com> 2016-07-10 15:06:54 +0200
commit: 9a1a4f3fd29d9f329fa62e9e00d5b6804545bdc3 (patch)
tree: 868c8238afda8acec2a594d834c7b75c084adfe1
parent: 9d06d5a3b467ddf56147f87531fb56b35375dbd2 (diff)
6 files changed, 305 insertions, 0 deletions
diff --git a/examples/HelloOBJ.hs b/examples/HelloOBJ.hs
new file mode 100644
index 0000000..10bf248
--- /dev/null
+++ b/examples/HelloOBJ.hs
@@ -0,0 +1,154 @@
+{-# LANGUAGE PackageImports, LambdaCase, OverloadedStrings, RecordWildCards #-}
+import System.Environment
+import "GLFW-b" Graphics.UI.GLFW as GLFW
+import Data.Text (unpack,Text)
+import Data.List (groupBy,nub)
+import Data.Maybe
+import Control.Monad
+import Data.Map (Map)
+import qualified Data.Map as Map
+import qualified Data.Vector as V
+import qualified Data.ByteString as SB
+import LambdaCube.GL as LambdaCubeGL -- renderer
+import LambdaCube.GL.Mesh as LambdaCubeGL
+import Codec.Picture as Juicy
+import Data.Aeson
+import Codec.Wavefront
+import MtlParser
+----------------------------------------------------
+--  See:  http://lambdacube3d.com/getting-started
+----------------------------------------------------
+objToMesh :: WavefrontOBJ -> [(Mesh,Maybe Text)]
+objToMesh WavefrontOBJ{..} = [(toMesh faceGroup, elMtl . head $ faceGroup) | faceGroup <- faces] where
+  faces = groupBy (\a b -> elMtl a == elMtl b) (V.toList objFaces)
+  toMesh l = Mesh
+    { mAttributes   = Map.fromList
+        [ ("position",  A_V4F position)
+        , ("normal",    A_V3F normal)
+        , ("uvw",       A_V3F texcoord)
+        ]
+    , mPrimitive    = P_Triangles
+    } where
+        triangulate (Triangle a b c) = [a,b,c]
+        triangulate (Quad a b c d) = [a,b,c, c,d,a]
+        triangulate _ = []
+        defaultPosition = Location 0 0 0 0
+        defaultNormal = Normal 0 0 0
+        defaultTexCoord = TexCoord 0 0 0
+        v !- i = v V.!? (i-1)
+        toVertex FaceIndex{..} = ( let Location x y z w = fromMaybe defaultPosition (objLocations !- faceLocIndex)            in V4 x y z w
+                                 , let Normal x y z     = fromMaybe defaultNormal ((objNormals !-) =<< faceNorIndex)          in V3 x y z
+                                 , let TexCoord x y z   = fromMaybe defaultTexCoord ((objTexCoords !-) =<< faceTexCoordIndex) in V3 x y z
+                                 )
+        (position,normal,texcoord) = V.unzip3 . V.concat . map (V.fromList . map toVertex . triangulate . elValue) $ l
+loadOBJ :: String -> IO (Either String ([(Mesh,Maybe Text)],MtlLib))
+loadOBJ fname = fromFile fname >>= \case -- load geometry
+  Left err -> putStrLn err >> return (Left err)
+  Right obj@WavefrontOBJ{..} -> do
+    -- load materials
+    mtlLib <- mconcat . V.toList <$> mapM (readMtl . unpack) objMtlLibs
+    return $ Right (objToMesh obj,mtlLib)
+loadOBJToGPU :: String -> IO (Either String ([(GPUMesh, Maybe Text)], MtlLib))
+loadOBJToGPU fname = loadOBJ fname >>= \case
+  Left err -> return $ Left err
+  Right (subModels,mtlLib) -> do
+    gpuSubModels <- forM subModels $ \(mesh,mat) -> LambdaCubeGL.uploadMeshToGPU mesh >>= \a -> return (a,mat)
+    return $ Right (gpuSubModels,mtlLib)
+uploadMtlLib :: MtlLib -> IO (Map Text TextureData)
+uploadMtlLib mtlLib = do
+  -- collect used textures
+  let usedTextures = nub . concatMap (maybeToList . mtl_map_Kd) $ Map.elems mtlLib
+      whiteImage = Juicy.ImageRGB8 $ Juicy.generateImage (\_ _ -> Juicy.PixelRGB8 255 255 255) 1 1
+      checkerImage = Juicy.ImageRGB8 $ Juicy.generateImage (\x y -> if mod (x + y) 2 == 0 then Juicy.PixelRGB8 0 0 0 else Juicy.PixelRGB8 255 255 0) 2 2
+  checkerTex <- LambdaCubeGL.uploadTexture2DToGPU checkerImage
+  -- load images and upload to gpu
+  textureLib <- forM (Map.fromList $ zip usedTextures usedTextures) $ \fname -> Juicy.readImage fname >>= \case
+    Left err  -> putStrLn err >> return checkerTex
+    Right img -> LambdaCubeGL.uploadTexture2DToGPU img
+  whiteTex <- LambdaCubeGL.uploadTexture2DToGPU whiteImage
+  -- pair textures and materials
+  return $ maybe whiteTex (fromMaybe checkerTex . flip Map.lookup textureLib) . mtl_map_Kd <$> mtlLib
+addOBJToObjectArray :: GLStorage -> String -> [(GPUMesh, Maybe Text)] -> Map Text TextureData -> IO [LambdaCubeGL.Object]
+addOBJToObjectArray storage slotName objMesh mtlLib = forM objMesh $ \(mesh,mat) -> do
+  obj <- LambdaCubeGL.addMeshToObjectArray storage slotName ["diffuseTexture"] mesh -- diffuseTexture value can change on each model
+  case mat >>= flip Map.lookup mtlLib of
+    Nothing -> return ()
+    Just t -> LambdaCubeGL.updateObjectUniforms obj $ do
+                "diffuseTexture" @= return t -- set model's diffuse texture
+  return obj
+main :: IO ()
+main = do
+    Just pipelineDesc <- decodeStrict <$> SB.readFile "hello_obj.json"
+    win <- initWindow "LambdaCube 3D DSL OBJ viewer" 640 640
+    -- setup render data
+    let inputSchema = makeSchema $ do
+          defObjectArray "objects" Triangles $ do
+            "position"  @: Attribute_V4F
+            "normal"    @: Attribute_V3F
+            "uvw"       @: Attribute_V3F
+          defUniforms $ do
+            "time"            @: Float
+            "diffuseTexture"  @: FTexture2D
+    storage <- LambdaCubeGL.allocStorage inputSchema
+    objName <- head . (++ ["cube.obj"]) <$> getArgs
+    -- load OBJ geometry and material descriptions
+    Right (objMesh,mtlLib) <- loadOBJToGPU objName
+    -- load materials textures
+    gpuMtlLib <- uploadMtlLib mtlLib
+    -- add OBJ to pipeline input
+    addOBJToObjectArray storage "objects" objMesh gpuMtlLib
+    -- allocate GL pipeline
+    renderer <- LambdaCubeGL.allocRenderer pipelineDesc
+    LambdaCubeGL.setStorage renderer storage >>= \case -- check schema compatibility
+      Just err -> putStrLn err
+      Nothing  -> loop
+        where loop = do
+                -- update graphics input
+                GLFW.getWindowSize win >>= \(w,h) -> LambdaCubeGL.setScreenSize storage (fromIntegral w) (fromIntegral h)
+                LambdaCubeGL.updateUniforms storage $ do
+                  "time" @= do
+                              Just t <- GLFW.getTime
+                              return (realToFrac t :: Float)
+                -- render
+                LambdaCubeGL.renderFrame renderer
+                GLFW.swapBuffers win
+                GLFW.pollEvents
+                let keyIsPressed k = fmap (==KeyState'Pressed) $ GLFW.getKey win k
+                escape <- keyIsPressed Key'Escape
+                if escape then return () else loop
+    LambdaCubeGL.disposeRenderer renderer
+    LambdaCubeGL.disposeStorage storage
+    GLFW.destroyWindow win
+    GLFW.terminate
+initWindow :: String -> Int -> Int -> IO Window
+initWindow title width height = do
+    GLFW.init
+    GLFW.defaultWindowHints
+    mapM_ GLFW.windowHint
+      [ WindowHint'ContextVersionMajor 3
+      , WindowHint'ContextVersionMinor 3
+      , WindowHint'OpenGLProfile OpenGLProfile'Core
+      , WindowHint'OpenGLForwardCompat True
+      ]
+    Just win <- GLFW.createWindow width height title Nothing Nothing
+    GLFW.makeContextCurrent $ Just win
+    return win
diff --git a/examples/MtlParser.hs b/examples/MtlParser.hs
new file mode 100644
index 0000000..b57a7f0
--- /dev/null
+++ b/examples/MtlParser.hs
@@ -0,0 +1,74 @@
+module MtlParser
+  ( ObjMaterial (..)
+  , MtlLib
+  , parseMtl
+  , readMtl
+  ) where
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe
+import Control.Monad.State.Strict
+import Control.Monad.Writer
+import Data.Text (pack,Text)
+type Vec3 = (Float,Float,Float)
+type MtlLib = Map Text ObjMaterial
+data ObjMaterial
+  = ObjMaterial
+  { mtl_Name    :: Text
+  , mtl_Ka      :: Vec3   -- ambient color
+  , mtl_Kd      :: Vec3   -- diffuse color
+  , mtl_Ks      :: Vec3   -- specular color
+  , mtl_illum   :: Int
+  , mtl_Tr      :: Float  -- transparency
+  , mtl_Ns      :: Float  -- specular exponent
+  , mtl_map_Kd  :: Maybe String -- diffuse texture file name
+  }
+  deriving (Eq,Show)
+newMaterial name = ObjMaterial
+  { mtl_Name    = name
+  , mtl_Ka      = (1, 1, 1)
+  , mtl_Kd      = (1, 1, 1)
+  , mtl_Ks      = (0, 0, 0)
+  , mtl_illum   = 1
+  , mtl_Tr      = 1
+  , mtl_Ns      = 0
+  , mtl_map_Kd  = Nothing
+  }
+type Mtl = WriterT [ObjMaterial] (State (Maybe ObjMaterial))
+readMaybe :: Read a => String -> Maybe a
+readMaybe s = case reads s of
+  [(val, "")] -> Just val
+  _ -> Nothing
+readVec3 :: String -> String -> String -> Maybe Vec3
+readVec3 r g b = (,,) <$> readMaybe r <*> readMaybe g <*> readMaybe b
+setAttr = modify' . fmap
+addMaterial = gets maybeToList >>= tell
+parseLine :: String -> Mtl ()
+parseLine s = case words $ takeWhile (/='#') s of
+  ["newmtl",name] -> do
+                      addMaterial
+                      put $ Just $ newMaterial $ pack name
+  ["map_Kd",textureName]                      -> setAttr (\s -> s {mtl_map_Kd = Just textureName})
+  ["Ka",r,g,b] | Just rgb <- readVec3 r g b   -> setAttr (\s -> s {mtl_Ka = rgb})
+  ["Kd",r,g,b] | Just rgb <- readVec3 r g b   -> setAttr (\s -> s {mtl_Kd = rgb})
+  ["Ks",r,g,b] | Just rgb <- readVec3 r g b   -> setAttr (\s -> s {mtl_Ks = rgb})
+  ["illum",a]  | Just v <- readMaybe a        -> setAttr (\s -> s {mtl_illum = v})
+  ["Tr",a]     | Just v <- readMaybe a        -> setAttr (\s -> s {mtl_Tr = v})
+  ["Ns",a]     | Just v <- readMaybe a        -> setAttr (\s -> s {mtl_Ns = v})
+  _ -> return ()
+parseMtl :: String -> MtlLib
+parseMtl src = Map.fromList [(mtl_Name m,m) | m <- evalState (execWriterT (mapM_ parseLine (lines src) >> addMaterial)) Nothing]
+readMtl :: String -> IO MtlLib
+readMtl fname = parseMtl <$> readFile fname
diff --git a/examples/cube.mtl b/examples/cube.mtl
new file mode 100644
index 0000000..92bd13c
--- /dev/null
+++ b/examples/cube.mtl
@@ -0,0 +1,13 @@
+newmtl material0
+  Ns 10.0000
+  Ni 1.5000
+  d 1.0000
+  Tr 0.0000
+  Tf 1.0000 1.0000 1.0000 
+  illum 2
+  Ka 0.0000 0.0000 0.0000
+  Kd 0.5880 0.5880 0.5880
+  Ks 0.0000 0.0000 0.0000
+  Ke 0.0000 0.0000 0.0000
+  map_Ka logo.png
+  map_Kd logo.png
diff --git a/examples/cube.obj b/examples/cube.obj
new file mode 100644
index 0000000..9b0cb54
--- /dev/null
+++ b/examples/cube.obj
@@ -0,0 +1,47 @@
+# cube.obj
+#
+o cube
+mtllib cube.mtl
+v -0.500000 -0.500000 0.500000
+v 0.500000 -0.500000 0.500000
+v -0.500000 0.500000 0.500000
+v 0.500000 0.500000 0.500000
+v -0.500000 0.500000 -0.500000
+v 0.500000 0.500000 -0.500000
+v -0.500000 -0.500000 -0.500000
+v 0.500000 -0.500000 -0.500000
+vt 0.000000 0.000000
+vt 1.000000 0.000000
+vt 0.000000 1.000000
+vt 1.000000 1.000000
+vn 0.000000 0.000000 1.000000
+vn 0.000000 1.000000 0.000000
+vn 0.000000 0.000000 -1.000000
+vn 0.000000 -1.000000 0.000000
+vn 1.000000 0.000000 0.000000
+vn -1.000000 0.000000 0.000000
+g cube
+usemtl material0
+s 1
+f 1/1/1 2/2/1 3/3/1
+f 3/3/1 2/2/1 4/4/1
+s 2
+f 3/1/2 4/2/2 5/3/2
+f 5/3/2 4/2/2 6/4/2
+s 3
+f 5/4/3 6/3/3 7/2/3
+f 7/2/3 6/3/3 8/1/3
+s 4
+f 7/1/4 8/2/4 1/3/4
+f 1/3/4 8/2/4 2/4/4
+s 5
+f 2/1/5 8/2/5 4/3/5
+f 4/3/5 8/2/5 6/4/5
+s 6
+f 7/1/6 1/2/6 5/3/6
+f 5/3/6 1/2/6 3/4/6
diff --git a/examples/hello_obj.json b/examples/hello_obj.json
new file mode 100644
index 0000000..9c3e98f
--- /dev/null
+++ b/examples/hello_obj.json
@@ -0,0 +1 @@
+{"textures":[],"commands":[{"tag":"SetRenderTarget","arg0":0},{"tag":"ClearRenderTarget","arg0":[{"tag":"ClearImage","clearValue":{"tag":"VFloat","arg0":1},"imageSemantic":{"tag":"Depth"}},{"tag":"ClearImage","clearValue":{"tag":"VV4F","arg0":{"w":1,"z":0.4,"x":0.0,"y":0.0}},"imageSemantic":{"tag":"Color"}}]},{"tag":"SetProgram","arg0":0},{"tag":"SetSamplerUniform","arg0":"diffuseTexture","arg1":0},{"tag":"SetRasterContext","arg0":{"arg3":{"tag":"LastVertex"},"tag":"TriangleCtx","arg0":{"tag":"CullBack","arg0":{"tag":"CCW"}},"arg1":{"tag":"PolygonFill"},"arg2":{"tag":"NoOffset"}}},{"tag":"SetAccumulationContext","arg0":{"accViewportName":null,"tag":"AccumulationContext","accOperations":[{"tag":"DepthOp","arg0":{"tag":"Less"},"arg1":true},{"tag":"ColorOp","arg0":{"tag":"NoBlending"},"arg1":{"tag":"VV4B","arg0":{"w":true,"z":true,"x":true,"y":true}}}]}},{"tag":"RenderSlot","arg0":0}],"slots":[{"tag":"Slot","slotPrimitive":{"tag":"Triangles"},"slotStreams":{"normal":{"tag":"V3F"},"uvw":{"tag":"V3F"},"position":{"tag":"V4F"}},"slotName":"objects","slotUniforms":{"time":{"tag":"Float"},"diffuseTexture":{"tag":"FTexture2D"}},"slotPrograms":[0]}],"programs":[{"programInTextures":{"diffuseTexture":{"tag":"FTexture2D"}},"tag":"Program","programOutput":[{"tag":"Parameter","ty":{"tag":"V4F"},"name":"f0"}],"programStreams":{"vi3":{"tag":"Parameter","ty":{"tag":"V3F"},"name":"uvw"},"vi2":{"tag":"Parameter","ty":{"tag":"V3F"},"name":"normal"},"vi1":{"tag":"Parameter","ty":{"tag":"V4F"},"name":"position"}},"fragmentShader":"#version 330 core\nvec4 texture2D(sampler2D s,vec2 uv) {\n    return texture(s,uv);\n}\nuniform sampler2D diffuseTexture;\nsmooth in vec2 vo1;\nout vec4 f0;\nvoid main() {\n    f0 = texture2D (diffuseTexture,vo1);\n}","vertexShader":"#version 330 core\nvec4 texture2D(sampler2D s,vec2 uv) {\n    return texture(s,uv);\n}\nuniform float time;\nin vec4 vi1;\nin vec3 vi2;\nin vec3 vi3;\nsmooth out vec2 vo1;\nvec4 ext0_Float_3(vec3 z0) {\n    return vec4 ((z0).x,(z0).y,(z0).z,0.0);\n}\nvec3 neg_VecSFloat3(vec3 z0) {\n    return - (z0);\n}\nmat4 translateBefore4(vec3 z0) {\n    return mat4 (vec4 (1.0,0.0,0.0,0.0)\n                ,vec4 (0.0,1.0,0.0,0.0)\n                ,vec4 (0.0,0.0,1.0,0.0)\n                ,vec4 ((z0).x,(z0).y,(z0).z,1.0));\n}\nmat4 lookat(vec3 z0,vec3 z1,vec3 z2) {\n    return (transpose (mat4 (ext0_Float_3 (normalize (cross (z2\n                                                            ,normalize ((z0) - (z1)))))\n                            ,ext0_Float_3 (cross (normalize ((z0) - (z1))\n                                                 ,normalize (cross (z2,normalize ((z0) - (z1))))))\n                            ,ext0_Float_3 (normalize ((z0) - (z1)))\n                            ,vec4 (0.0,0.0,0.0,1.0)))) * (translateBefore4 (neg_VecSFloat3 (z0)));\n}\nmat4 perspective(float z0,float z1,float z2,float z3) {\n    return mat4 (vec4 (((2.0) * (z0)) / (((z3) * ((z0) * (tan\n                      ((z2) / (2.0))))) - ((0.0) - ((z3) * ((z0) * (tan ((z2) / (2.0)))))))\n                      ,0.0\n                      ,0.0\n                      ,0.0)\n                ,vec4 (0.0\n                      ,((2.0) * (z0)) / (((z0) * (tan ((z2) / (2.0)))) - ((0.0) - ((z0) * (tan\n                      ((z2) / (2.0))))))\n                      ,0.0\n                      ,0.0)\n                ,vec4 ((((z3) * ((z0) * (tan ((z2) / (2.0))))) + ((0.0) - ((z3) * ((z0) * (tan\n                      ((z2) / (2.0))))))) / (((z3) * ((z0) * (tan\n                      ((z2) / (2.0))))) - ((0.0) - ((z3) * ((z0) * (tan ((z2) / (2.0)))))))\n                      ,(((z0) * (tan ((z2) / (2.0)))) + ((0.0) - ((z0) * (tan\n                      ((z2) / (2.0)))))) / (((z0) * (tan ((z2) / (2.0)))) - ((0.0) - ((z0) * (tan\n                      ((z2) / (2.0))))))\n                      ,(0.0) - (((z1) + (z0)) / ((z1) - (z0)))\n                      ,-1.0)\n                ,vec4 (0.0,0.0,(0.0) - ((((2.0) * (z1)) * (z0)) / ((z1) - (z0))),0.0));\n}\nmat4 rotMatrixX(float z0) {\n    return mat4 (vec4 (1.0,0.0,0.0,0.0)\n                ,vec4 (0.0,cos (z0),sin (z0),0.0)\n                ,vec4 (0.0,(0.0) - (sin (z0)),cos (z0),0.0)\n                ,vec4 (0.0,0.0,0.0,1.0));\n}\nmat4 rotMatrixZ(float z0) {\n    return mat4 (vec4 (cos (z0),sin (z0),0.0,0.0)\n                ,vec4 ((0.0) - (sin (z0)),cos (z0),0.0,0.0)\n                ,vec4 (0.0,0.0,1.0,0.0)\n                ,vec4 (0.0,0.0,0.0,1.0));\n}\nvoid main() {\n    gl_Position = (perspective (0.1,100.0,45.0,1.0)) * ((lookat (vec3 (0.0,0.0,5.0)\n                                                                ,vec3 (0.0,0.0,0.0)\n                                                                ,vec3 (0.0,1.0,0.0))) * ((rotMatrixX (time)) * ((rotMatrixZ (time)) * (vi1))));\n    vo1 = vec2 ((vi3).x,(1.0) - ((vi3).y));\n}","geometryShader":null,"programUniforms":{"time":{"tag":"Float"},"diffuseTexture":{"tag":"FTexture2D"}}}],"samplers":[],"tag":"Pipeline","backend":{"tag":"OpenGL33"},"streams":[],"targets":[{"tag":"RenderTarget","renderTargets":[{"tag":"TargetItem","targetSemantic":{"tag":"Depth"},"targetRef":{"tag":"Framebuffer","arg0":{"tag":"Depth"}}},{"tag":"TargetItem","targetSemantic":{"tag":"Color"},"targetRef":{"tag":"Framebuffer","arg0":{"tag":"Color"}}}]}],"info":"generated by lambdacube-compiler 0.6.0.0"}
+\ No newline at end of file
diff --git a/examples/hello_obj.lc b/examples/hello_obj.lc
new file mode 100644
index 0000000..e2d7caa
--- /dev/null
+++ b/examples/hello_obj.lc
@@ -0,0 +1,16 @@
+makeFrame (time :: Float)
+          (texture :: Texture)
+          (prims :: PrimitiveStream Triangle (Vec 4 Float, Vec 3 Float, Vec 3 Float))
+    = imageFrame (emptyDepthImage 1, emptyColorImage (V4 0 0 0.4 1))
+  `overlay`
+      prims
+    & mapPrimitives (\(p,n,uvw) -> (perspective 0.1 100 45 1 *. lookat (V3 0 0 5) (V3 0 0 0) (V3 0 1 0) *. rotMatrixX time *. rotMatrixZ time *. p, V2 uvw%x (1 - uvw%y) ))
+    & rasterizePrimitives (TriangleCtx CullBack PolygonFill NoOffset LastVertex) ((Smooth))
+    & mapFragments (\((uv)) -> ((texture2D (Sampler PointFilter MirroredRepeat texture) uv )))
+    & accumulateWith (DepthOp Less True, ColorOp NoBlending (V4 True True True True))
+main = renderFrame $
+   makeFrame (Uniform "time")
+             (Texture2DSlot "diffuseTexture")
+             (fetch "objects" (Attribute "position", Attribute "normal", Attribute "uvw"))
author	Csaba Hruska <csaba.hruska@gmail.com>	2016-07-10 15:06:54 +0200
committer	Csaba Hruska <csaba.hruska@gmail.com>	2016-07-10 15:06:54 +0200
commit	9a1a4f3fd29d9f329fa62e9e00d5b6804545bdc3 (patch)
tree	868c8238afda8acec2a594d834c7b75c084adfe1
parent	9d06d5a3b467ddf56147f87531fb56b35375dbd2 (diff)

diff --git a/examples/HelloOBJ.hs b/examples/HelloOBJ.hs new file mode 100644 index 0000000..10bf248 --- /dev/null +++ b/examples/HelloOBJ.hs
@@ -0,0 +1,154 @@
	1	{-# LANGUAGE PackageImports, LambdaCase, OverloadedStrings, RecordWildCards #-}
	2	import System.Environment
	3	import "GLFW-b" Graphics.UI.GLFW as GLFW
	4	import Data.Text (unpack,Text)
	5	import Data.List (groupBy,nub)
	6	import Data.Maybe
	7	import Control.Monad
	8	import Data.Map (Map)
	9	import qualified Data.Map as Map
	10	import qualified Data.Vector as V
	11	import qualified Data.ByteString as SB
	12
	13	import LambdaCube.GL as LambdaCubeGL -- renderer
	14	import LambdaCube.GL.Mesh as LambdaCubeGL
	15
	16	import Codec.Picture as Juicy
	17	import Data.Aeson
	18	import Codec.Wavefront
	19
	20	import MtlParser
	21
	22	----------------------------------------------------
	23	-- See: http://lambdacube3d.com/getting-started
	24	----------------------------------------------------
	25
	26	objToMesh :: WavefrontOBJ -> [(Mesh,Maybe Text)]
	27	objToMesh WavefrontOBJ{..} = [(toMesh faceGroup, elMtl . head $ faceGroup) \| faceGroup <- faces] where
	28	faces = groupBy (\a b -> elMtl a == elMtl b) (V.toList objFaces)
	29	toMesh l = Mesh
	30	{ mAttributes = Map.fromList
	31	[ ("position", A_V4F position)
	32	, ("normal", A_V3F normal)
	33	, ("uvw", A_V3F texcoord)
	34	]
	35	, mPrimitive = P_Triangles
	36	} where
	37	triangulate (Triangle a b c) = [a,b,c]
	38	triangulate (Quad a b c d) = [a,b,c, c,d,a]
	39	triangulate _ = []
	40	defaultPosition = Location 0 0 0 0
	41	defaultNormal = Normal 0 0 0
	42	defaultTexCoord = TexCoord 0 0 0
	43	v !- i = v V.!? (i-1)
	44	toVertex FaceIndex{..} = ( let Location x y z w = fromMaybe defaultPosition (objLocations !- faceLocIndex) in V4 x y z w
	45	, let Normal x y z = fromMaybe defaultNormal ((objNormals !-) =<< faceNorIndex) in V3 x y z
	46	, let TexCoord x y z = fromMaybe defaultTexCoord ((objTexCoords !-) =<< faceTexCoordIndex) in V3 x y z
	47	)
	48	(position,normal,texcoord) = V.unzip3 . V.concat . map (V.fromList . map toVertex . triangulate . elValue) $ l
	49
	50
	51	loadOBJ :: String -> IO (Either String ([(Mesh,Maybe Text)],MtlLib))
	52	loadOBJ fname = fromFile fname >>= \case -- load geometry
	53	Left err -> putStrLn err >> return (Left err)
	54	Right obj@WavefrontOBJ{..} -> do
	55	-- load materials
	56	mtlLib <- mconcat . V.toList <$> mapM (readMtl . unpack) objMtlLibs
	57	return $ Right (objToMesh obj,mtlLib)
	58
	59	loadOBJToGPU :: String -> IO (Either String ([(GPUMesh, Maybe Text)], MtlLib))
	60	loadOBJToGPU fname = loadOBJ fname >>= \case
	61	Left err -> return $ Left err
	62	Right (subModels,mtlLib) -> do
	63	gpuSubModels <- forM subModels $ \(mesh,mat) -> LambdaCubeGL.uploadMeshToGPU mesh >>= \a -> return (a,mat)
	64	return $ Right (gpuSubModels,mtlLib)
	65
	66	uploadMtlLib :: MtlLib -> IO (Map Text TextureData)
	67	uploadMtlLib mtlLib = do
	68	-- collect used textures
	69	let usedTextures = nub . concatMap (maybeToList . mtl_map_Kd) $ Map.elems mtlLib
	70	whiteImage = Juicy.ImageRGB8 $ Juicy.generateImage (\_ _ -> Juicy.PixelRGB8 255 255 255) 1 1
	71	checkerImage = Juicy.ImageRGB8 $ Juicy.generateImage (\x y -> if mod (x + y) 2 == 0 then Juicy.PixelRGB8 0 0 0 else Juicy.PixelRGB8 255 255 0) 2 2
	72	checkerTex <- LambdaCubeGL.uploadTexture2DToGPU checkerImage
	73	-- load images and upload to gpu
	74	textureLib <- forM (Map.fromList $ zip usedTextures usedTextures) $ \fname -> Juicy.readImage fname >>= \case
	75	Left err -> putStrLn err >> return checkerTex
	76	Right img -> LambdaCubeGL.uploadTexture2DToGPU img
	77	whiteTex <- LambdaCubeGL.uploadTexture2DToGPU whiteImage
	78	-- pair textures and materials
	79	return $ maybe whiteTex (fromMaybe checkerTex . flip Map.lookup textureLib) . mtl_map_Kd <$> mtlLib
	80
	81	addOBJToObjectArray :: GLStorage -> String -> [(GPUMesh, Maybe Text)] -> Map Text TextureData -> IO [LambdaCubeGL.Object]
	82	addOBJToObjectArray storage slotName objMesh mtlLib = forM objMesh $ \(mesh,mat) -> do
	83	obj <- LambdaCubeGL.addMeshToObjectArray storage slotName ["diffuseTexture"] mesh -- diffuseTexture value can change on each model
	84	case mat >>= flip Map.lookup mtlLib of
	85	Nothing -> return ()
	86	Just t -> LambdaCubeGL.updateObjectUniforms obj $ do
	87	"diffuseTexture" @= return t -- set model's diffuse texture
	88	return obj
	89
	90	main :: IO ()
	91	main = do
	92	Just pipelineDesc <- decodeStrict <$> SB.readFile "hello_obj.json"
	93
	94	win <- initWindow "LambdaCube 3D DSL OBJ viewer" 640 640
	95
	96	-- setup render data
	97	let inputSchema = makeSchema $ do
	98	defObjectArray "objects" Triangles $ do
	99	"position" @: Attribute_V4F
	100	"normal" @: Attribute_V3F
	101	"uvw" @: Attribute_V3F
	102	defUniforms $ do
	103	"time" @: Float
	104	"diffuseTexture" @: FTexture2D
	105
	106	storage <- LambdaCubeGL.allocStorage inputSchema
	107
	108	objName <- head . (++ ["cube.obj"]) <$> getArgs
	109	-- load OBJ geometry and material descriptions
	110	Right (objMesh,mtlLib) <- loadOBJToGPU objName
	111	-- load materials textures
	112	gpuMtlLib <- uploadMtlLib mtlLib
	113	-- add OBJ to pipeline input
	114	addOBJToObjectArray storage "objects" objMesh gpuMtlLib
	115
	116	-- allocate GL pipeline
	117	renderer <- LambdaCubeGL.allocRenderer pipelineDesc
	118	LambdaCubeGL.setStorage renderer storage >>= \case -- check schema compatibility
	119	Just err -> putStrLn err
	120	Nothing -> loop
	121	where loop = do
	122	-- update graphics input
	123	GLFW.getWindowSize win >>= \(w,h) -> LambdaCubeGL.setScreenSize storage (fromIntegral w) (fromIntegral h)
	124	LambdaCubeGL.updateUniforms storage $ do
	125	"time" @= do
	126	Just t <- GLFW.getTime
	127	return (realToFrac t :: Float)
	128	-- render
	129	LambdaCubeGL.renderFrame renderer
	130	GLFW.swapBuffers win
	131	GLFW.pollEvents
	132
	133	let keyIsPressed k = fmap (==KeyState'Pressed) $ GLFW.getKey win k
	134	escape <- keyIsPressed Key'Escape
	135	if escape then return () else loop
	136
	137	LambdaCubeGL.disposeRenderer renderer
	138	LambdaCubeGL.disposeStorage storage
	139	GLFW.destroyWindow win
	140	GLFW.terminate
	141
	142	initWindow :: String -> Int -> Int -> IO Window
	143	initWindow title width height = do
	144	GLFW.init
	145	GLFW.defaultWindowHints
	146	mapM_ GLFW.windowHint
	147	[ WindowHint'ContextVersionMajor 3
	148	, WindowHint'ContextVersionMinor 3
	149	, WindowHint'OpenGLProfile OpenGLProfile'Core
	150	, WindowHint'OpenGLForwardCompat True
	151	]
	152	Just win <- GLFW.createWindow width height title Nothing Nothing
	153	GLFW.makeContextCurrent $ Just win
	154	return win


diff --git a/examples/MtlParser.hs b/examples/MtlParser.hs new file mode 100644 index 0000000..b57a7f0 --- /dev/null +++ b/examples/MtlParser.hs
@@ -0,0 +1,74 @@
	1	module MtlParser
	2	( ObjMaterial (..)
	3	, MtlLib
	4	, parseMtl
	5	, readMtl
	6	) where
	7
	8	import Data.Map (Map)
	9	import qualified Data.Map as Map
	10	import Data.Maybe
	11	import Control.Monad.State.Strict
	12	import Control.Monad.Writer
	13	import Data.Text (pack,Text)
	14
	15	type Vec3 = (Float,Float,Float)
	16
	17	type MtlLib = Map Text ObjMaterial
	18
	19	data ObjMaterial
	20	= ObjMaterial
	21	{ mtl_Name :: Text
	22	, mtl_Ka :: Vec3 -- ambient color
	23	, mtl_Kd :: Vec3 -- diffuse color
	24	, mtl_Ks :: Vec3 -- specular color
	25	, mtl_illum :: Int
	26	, mtl_Tr :: Float -- transparency
	27	, mtl_Ns :: Float -- specular exponent
	28	, mtl_map_Kd :: Maybe String -- diffuse texture file name
	29	}
	30	deriving (Eq,Show)
	31
	32	newMaterial name = ObjMaterial
	33	{ mtl_Name = name
	34	, mtl_Ka = (1, 1, 1)
	35	, mtl_Kd = (1, 1, 1)
	36	, mtl_Ks = (0, 0, 0)
	37	, mtl_illum = 1
	38	, mtl_Tr = 1
	39	, mtl_Ns = 0
	40	, mtl_map_Kd = Nothing
	41	}
	42
	43	type Mtl = WriterT [ObjMaterial] (State (Maybe ObjMaterial))
	44
	45	readMaybe :: Read a => String -> Maybe a
	46	readMaybe s = case reads s of
	47	[(val, "")] -> Just val
	48	_ -> Nothing
	49
	50	readVec3 :: String -> String -> String -> Maybe Vec3
	51	readVec3 r g b = (,,) <$> readMaybe r <> readMaybe g <> readMaybe b
	52
	53	setAttr = modify' . fmap
	54	addMaterial = gets maybeToList >>= tell
	55
	56	parseLine :: String -> Mtl ()
	57	parseLine s = case words $ takeWhile (/='#') s of
	58	["newmtl",name] -> do
	59	addMaterial
	60	put $ Just $ newMaterial $ pack name
	61	["map_Kd",textureName] -> setAttr (\s -> s {mtl_map_Kd = Just textureName})
	62	["Ka",r,g,b] \| Just rgb <- readVec3 r g b -> setAttr (\s -> s {mtl_Ka = rgb})
	63	["Kd",r,g,b] \| Just rgb <- readVec3 r g b -> setAttr (\s -> s {mtl_Kd = rgb})
	64	["Ks",r,g,b] \| Just rgb <- readVec3 r g b -> setAttr (\s -> s {mtl_Ks = rgb})
	65	["illum",a] \| Just v <- readMaybe a -> setAttr (\s -> s {mtl_illum = v})
	66	["Tr",a] \| Just v <- readMaybe a -> setAttr (\s -> s {mtl_Tr = v})
	67	["Ns",a] \| Just v <- readMaybe a -> setAttr (\s -> s {mtl_Ns = v})
	68	_ -> return ()
	69
	70	parseMtl :: String -> MtlLib
	71	parseMtl src = Map.fromList [(mtl_Name m,m) \| m <- evalState (execWriterT (mapM_ parseLine (lines src) >> addMaterial)) Nothing]
	72
	73	readMtl :: String -> IO MtlLib
	74	readMtl fname = parseMtl <$> readFile fname


diff --git a/examples/cube.mtl b/examples/cube.mtl new file mode 100644 index 0000000..92bd13c --- /dev/null +++ b/examples/cube.mtl
@@ -0,0 +1,13 @@
	1	newmtl material0
	2	Ns 10.0000
	3	Ni 1.5000
	4	d 1.0000
	5	Tr 0.0000
	6	Tf 1.0000 1.0000 1.0000
	7	illum 2
	8	Ka 0.0000 0.0000 0.0000
	9	Kd 0.5880 0.5880 0.5880
	10	Ks 0.0000 0.0000 0.0000
	11	Ke 0.0000 0.0000 0.0000
	12	map_Ka logo.png
	13	map_Kd logo.png


diff --git a/examples/cube.obj b/examples/cube.obj new file mode 100644 index 0000000..9b0cb54 --- /dev/null +++ b/examples/cube.obj
@@ -0,0 +1,47 @@
	1	# cube.obj
	2	#
	3
	4	o cube
	5	mtllib cube.mtl
	6
	7	v -0.500000 -0.500000 0.500000
	8	v 0.500000 -0.500000 0.500000
	9	v -0.500000 0.500000 0.500000
	10	v 0.500000 0.500000 0.500000
	11	v -0.500000 0.500000 -0.500000
	12	v 0.500000 0.500000 -0.500000
	13	v -0.500000 -0.500000 -0.500000
	14	v 0.500000 -0.500000 -0.500000
	15
	16	vt 0.000000 0.000000
	17	vt 1.000000 0.000000
	18	vt 0.000000 1.000000
	19	vt 1.000000 1.000000
	20
	21	vn 0.000000 0.000000 1.000000
	22	vn 0.000000 1.000000 0.000000
	23	vn 0.000000 0.000000 -1.000000
	24	vn 0.000000 -1.000000 0.000000
	25	vn 1.000000 0.000000 0.000000
	26	vn -1.000000 0.000000 0.000000
	27
	28	g cube
	29	usemtl material0
	30	s 1
	31	f 1/1/1 2/2/1 3/3/1
	32	f 3/3/1 2/2/1 4/4/1
	33	s 2
	34	f 3/1/2 4/2/2 5/3/2
	35	f 5/3/2 4/2/2 6/4/2
	36	s 3
	37	f 5/4/3 6/3/3 7/2/3
	38	f 7/2/3 6/3/3 8/1/3
	39	s 4
	40	f 7/1/4 8/2/4 1/3/4
	41	f 1/3/4 8/2/4 2/4/4
	42	s 5
	43	f 2/1/5 8/2/5 4/3/5
	44	f 4/3/5 8/2/5 6/4/5
	45	s 6
	46	f 7/1/6 1/2/6 5/3/6
	47	f 5/3/6 1/2/6 3/4/6


diff --git a/examples/hello_obj.json b/examples/hello_obj.json new file mode 100644 index 0000000..9c3e98f --- /dev/null +++ b/examples/hello_obj.json
@@ -0,0 +1 @@
		{"textures":[],"commands":[{"tag":"SetRenderTarget","arg0":0},{"tag":"ClearRenderTarget","arg0":[{"tag":"ClearImage","clearValue":{"tag":"VFloat","arg0":1},"imageSemantic":{"tag":"Depth"}},{"tag":"ClearImage","clearValue":{"tag":"VV4F","arg0":{"w":1,"z":0.4,"x":0.0,"y":0.0}},"imageSemantic":{"tag":"Color"}}]},{"tag":"SetProgram","arg0":0},{"tag":"SetSamplerUniform","arg0":"diffuseTexture","arg1":0},{"tag":"SetRasterContext","arg0":{"arg3":{"tag":"LastVertex"},"tag":"TriangleCtx","arg0":{"tag":"CullBack","arg0":{"tag":"CCW"}},"arg1":{"tag":"PolygonFill"},"arg2":{"tag":"NoOffset"}}},{"tag":"SetAccumulationContext","arg0":{"accViewportName":null,"tag":"AccumulationContext","accOperations":[{"tag":"DepthOp","arg0":{"tag":"Less"},"arg1":true},{"tag":"ColorOp","arg0":{"tag":"NoBlending"},"arg1":{"tag":"VV4B","arg0":{"w":true,"z":true,"x":true,"y":true}}}]}},{"tag":"RenderSlot","arg0":0}],"slots":[{"tag":"Slot","slotPrimitive":{"tag":"Triangles"},"slotStreams":{"normal":{"tag":"V3F"},"uvw":{"tag":"V3F"},"position":{"tag":"V4F"}},"slotName":"objects","slotUniforms":{"time":{"tag":"Float"},"diffuseTexture":{"tag":"FTexture2D"}},"slotPrograms":[0]}],"programs":[{"programInTextures":{"diffuseTexture":{"tag":"FTexture2D"}},"tag":"Program","programOutput":[{"tag":"Parameter","ty":{"tag":"V4F"},"name":"f0"}],"programStreams":{"vi3":{"tag":"Parameter","ty":{"tag":"V3F"},"name":"uvw"},"vi2":{"tag":"Parameter","ty":{"tag":"V3F"},"name":"normal"},"vi1":{"tag":"Parameter","ty":{"tag":"V4F"},"name":"position"}},"fragmentShader":"#version 330 core\nvec4 texture2D(sampler2D s,vec2 uv) {\n return texture(s,uv);\n}\nuniform sampler2D diffuseTexture;\nsmooth in vec2 vo1;\nout vec4 f0;\nvoid main() {\n f0 = texture2D (diffuseTexture,vo1);\n}","vertexShader":"#version 330 core\nvec4 texture2D(sampler2D s,vec2 uv) {\n return texture(s,uv);\n}\nuniform float time;\nin vec4 vi1;\nin vec3 vi2;\nin vec3 vi3;\nsmooth out vec2 vo1;\nvec4 ext0_Float_3(vec3 z0) {\n return vec4 ((z0).x,(z0).y,(z0).z,0.0);\n}\nvec3 neg_VecSFloat3(vec3 z0) {\n return - (z0);\n}\nmat4 translateBefore4(vec3 z0) {\n return mat4 (vec4 (1.0,0.0,0.0,0.0)\n ,vec4 (0.0,1.0,0.0,0.0)\n ,vec4 (0.0,0.0,1.0,0.0)\n ,vec4 ((z0).x,(z0).y,(z0).z,1.0));\n}\nmat4 lookat(vec3 z0,vec3 z1,vec3 z2) {\n return (transpose (mat4 (ext0_Float_3 (normalize (cross (z2\n ,normalize ((z0) - (z1)))))\n ,ext0_Float_3 (cross (normalize ((z0) - (z1))\n ,normalize (cross (z2,normalize ((z0) - (z1))))))\n ,ext0_Float_3 (normalize ((z0) - (z1)))\n ,vec4 (0.0,0.0,0.0,1.0)))) * (translateBefore4 (neg_VecSFloat3 (z0)));\n}\nmat4 perspective(float z0,float z1,float z2,float z3) {\n return mat4 (vec4 (((2.0) * (z0)) / (((z3) * ((z0) * (tan\n ((z2) / (2.0))))) - ((0.0) - ((z3) * ((z0) * (tan ((z2) / (2.0)))))))\n ,0.0\n ,0.0\n ,0.0)\n ,vec4 (0.0\n ,((2.0) * (z0)) / (((z0) * (tan ((z2) / (2.0)))) - ((0.0) - ((z0) * (tan\n ((z2) / (2.0))))))\n ,0.0\n ,0.0)\n ,vec4 ((((z3) * ((z0) * (tan ((z2) / (2.0))))) + ((0.0) - ((z3) * ((z0) * (tan\n ((z2) / (2.0))))))) / (((z3) * ((z0) * (tan\n ((z2) / (2.0))))) - ((0.0) - ((z3) * ((z0) * (tan ((z2) / (2.0)))))))\n ,(((z0) * (tan ((z2) / (2.0)))) + ((0.0) - ((z0) * (tan\n ((z2) / (2.0)))))) / (((z0) * (tan ((z2) / (2.0)))) - ((0.0) - ((z0) * (tan\n ((z2) / (2.0))))))\n ,(0.0) - (((z1) + (z0)) / ((z1) - (z0)))\n ,-1.0)\n ,vec4 (0.0,0.0,(0.0) - ((((2.0) * (z1)) * (z0)) / ((z1) - (z0))),0.0));\n}\nmat4 rotMatrixX(float z0) {\n return mat4 (vec4 (1.0,0.0,0.0,0.0)\n ,vec4 (0.0,cos (z0),sin (z0),0.0)\n ,vec4 (0.0,(0.0) - (sin (z0)),cos (z0),0.0)\n ,vec4 (0.0,0.0,0.0,1.0));\n}\nmat4 rotMatrixZ(float z0) {\n return mat4 (vec4 (cos (z0),sin (z0),0.0,0.0)\n ,vec4 ((0.0) - (sin (z0)),cos (z0),0.0,0.0)\n ,vec4 (0.0,0.0,1.0,0.0)\n ,vec4 (0.0,0.0,0.0,1.0));\n}\nvoid main() {\n gl_Position = (perspective (0.1,100.0,45.0,1.0)) * ((lookat (vec3 (0.0,0.0,5.0)\n ,vec3 (0.0,0.0,0.0)\n ,vec3 (0.0,1.0,0.0))) * ((rotMatrixX (time)) * ((rotMatrixZ (time)) * (vi1))));\n vo1 = vec2 ((vi3).x,(1.0) - ((vi3).y));\n}","geometryShader":null,"programUniforms":{"time":{"tag":"Float"},"diffuseTexture":{"tag":"FTexture2D"}}}],"samplers":[],"tag":"Pipeline","backend":{"tag":"OpenGL33"},"streams":[],"targets":[{"tag":"RenderTarget","renderTargets":[{"tag":"TargetItem","targetSemantic":{"tag":"Depth"},"targetRef":{"tag":"Framebuffer","arg0":{"tag":"Depth"}}},{"tag":"TargetItem","targetSemantic":{"tag":"Color"},"targetRef":{"tag":"Framebuffer","arg0":{"tag":"Color"}}}]}],"info":"generated by lambdacube-compiler 0.6.0.0"} \ No newline at end of file


diff --git a/examples/hello_obj.lc b/examples/hello_obj.lc new file mode 100644 index 0000000..e2d7caa --- /dev/null +++ b/examples/hello_obj.lc
@@ -0,0 +1,16 @@
	1	makeFrame (time :: Float)
	2	(texture :: Texture)
	3	(prims :: PrimitiveStream Triangle (Vec 4 Float, Vec 3 Float, Vec 3 Float))
	4
	5	= imageFrame (emptyDepthImage 1, emptyColorImage (V4 0 0 0.4 1))
	6	`overlay`
	7	prims
	8	& mapPrimitives (\(p,n,uvw) -> (perspective 0.1 100 45 1 . lookat (V3 0 0 5) (V3 0 0 0) (V3 0 1 0) . rotMatrixX time . rotMatrixZ time . p, V2 uvw%x (1 - uvw%y) ))
	9	& rasterizePrimitives (TriangleCtx CullBack PolygonFill NoOffset LastVertex) ((Smooth))
	10	& mapFragments (\((uv)) -> ((texture2D (Sampler PointFilter MirroredRepeat texture) uv )))
	11	& accumulateWith (DepthOp Less True, ColorOp NoBlending (V4 True True True True))
	12
	13	main = renderFrame $
	14	makeFrame (Uniform "time")
	15	(Texture2DSlot "diffuseTexture")
	16	(fetch "objects" (Attribute "position", Attribute "normal", Attribute "uvw"))