Added HelloOBJ example.

5 files changed, 314 insertions, 0 deletions

diff --git a/HelloOBJ.hs b/HelloOBJ.hs
new file mode 100644
index 0000000..7ab6b20
--- /dev/null
+++ b/HelloOBJ.hs
@@ -0,0 +1,156 @@
+{-# 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 (Face a b c l) = a : b : c : concatMap (\(x,y) -> [a,x,y]) (zip (c:l) l) -- should work for convex polygons without holes
+        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 (ObjMaterial,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 $ (\a -> (a, maybe whiteTex (fromMaybe checkerTex . flip Map.lookup textureLib) . mtl_map_Kd $ a)) <$> mtlLib
+
+addOBJToObjectArray :: GLStorage -> String -> [(GPUMesh, Maybe Text)] -> Map Text (ObjMaterial,TextureData) -> IO [LambdaCubeGL.Object]
+addOBJToObjectArray storage slotName objMesh mtlLib = forM objMesh $ \(mesh,mat) -> do
+  obj <- LambdaCubeGL.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) -> LambdaCubeGL.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
+
+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
+            "diffuseColor"    @: V4F
+
+    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/MtlParser.hs b/MtlParser.hs
new file mode 100644
index 0000000..b57a7f0
--- /dev/null
+++ b/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/cube.mtl b/cube.mtl
new file mode 100644
index 0000000..92bd13c
--- /dev/null
+++ b/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/cube.obj b/cube.obj
new file mode 100644
index 0000000..9b0cb54
--- /dev/null
+++ b/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/hello_obj.lc b/hello_obj.lc
new file mode 100644
index 0000000..baf0edd
--- /dev/null
+++ b/hello_obj.lc
@@ -0,0 +1,24 @@
+makeFrame (time :: Float)
+          (color :: Vec 4 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)) -> ((color * texture2D (Sampler PointFilter MirroredRepeat texture) uv )))
+    & accumulateWith (DepthOp Less True, ColorOp NoBlending (V4 True True True True))
+
+main = renderFrame $
+   makeFrame (Uniform "time")
+             (Uniform "diffuseColor")
+             (Texture2DSlot "diffuseTexture")
+             (fetch "objects" (Attribute "position", Attribute "normal", Attribute "uvw"))