From 5b8cf0fcb93c5d6e288e4426189a1564e318927a Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Thu, 11 Apr 2019 20:07:27 -0400 Subject: Modified version of HelloOBJ that renders transparent grid plane. --- HelloOBJ2.hs | 163 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ hello_obj2.lc | 47 +++++++++++++++++ 2 files changed, 210 insertions(+) create mode 100644 HelloOBJ2.hs create mode 100644 hello_obj2.lc diff --git a/HelloOBJ2.hs b/HelloOBJ2.hs new file mode 100644 index 0000000..24d0843 --- /dev/null +++ b/HelloOBJ2.hs @@ -0,0 +1,163 @@ +{-# 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 +import InfinitePlane + +---------------------------------------------------- +-- 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_obj2.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 + defObjectArray "plane" Triangles $ do + "position" @: Attribute_V4F + defUniforms $ do + "time" @: Float + "diffuseTexture" @: FTexture2D + "diffuseColor" @: V4F + + storage <- LambdaCubeGL.allocStorage inputSchema + + objName <- head . (++ ["cube.obj"]) <$> getArgs + -- load OBJ geometry and material descriptions + loadOBJToGPU objName >>= \x -> case x of + { Left e -> \_ -> putStrLn e + ; Right (objMesh,mtlLib) -> \f -> f objMesh mtlLib } $ \objMesh mtlLib -> do + -- load materials textures + gpuMtlLib <- uploadMtlLib mtlLib + -- add OBJ to pipeline input + addOBJToObjectArray storage "objects" objMesh gpuMtlLib + + uploadMeshToGPU xyplane >>= addMeshToObjectArray storage "plane" [] + + -- 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/hello_obj2.lc b/hello_obj2.lc new file mode 100644 index 0000000..a6c40ff --- /dev/null +++ b/hello_obj2.lc @@ -0,0 +1,47 @@ +coordmap (time::Float) (p::Vec 4 Float) + = perspective 0.1 100 30 1 + *. lookat (V3 0 0 5) (V3 0 0 0) (V3 0 1 0) + *. rotMatrixX time + *. rotMatrixZ time + *. p + +blendplane = -- NoBlending -- BlendLogicOp Xor + Blend (FuncAdd,FuncAdd) + ((OneBF,SrcAlpha),(DstAlpha,DstAlpha)) + (V4 0 0 0 0) + +makeFrame (time :: Float) + (color :: Vec 4 Float) + (texture :: Texture) + (prims :: PrimitiveStream Triangle (Vec 4 Float, Vec 3 Float, Vec 3 Float)) + (plane :: PrimitiveStream Triangle ((Vec 4 Float))) + + = imageFrame (emptyDepthImage 1, emptyColorImage (V4 0 0 0.4 1)) + `overlay` + prims + & mapPrimitives (\(p,n,uvw) -> ( coordmap 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)) + `overlay` + plane + & mapPrimitives (\((p)) -> (coordmap time p, p%xy )) + & rasterizePrimitives (TriangleCtx CullNone PolygonFill NoOffset LastVertex) ((Smooth)) + -- & mapFragments (\((uv)) -> ((texture2D (Sampler PointFilter MirroredRepeat texture) uv ))) + -- & mapFragments (\((uv)) -> ((V4 uv%x uv%y 0 1))) -- ((rgb 1 0 0))) + & mapFragments (\((uv)) -> let k=cos(g *! (8 * pi / 4)) + g=uv -- *! (1 + sqrt (abs (t%x * t%y))) + t=normalize uv + c=k -- *! ( t%x * t%y) -- /! ((k%x + k%y) / k%x) + r = V4 1 1 1 0 *! smoothstepS 0.99 1.0 (max c%x c%y) + in ((r + V4 0 0 0 (0.8)))) + & accumulateWith (DepthOp Less True, ColorOp blendplane (V4 True True True True)) + + +main = renderFrame $ + makeFrame (Uniform "time") + (Uniform "diffuseColor") + (Texture2DSlot "diffuseTexture") + (fetch "objects" (Attribute "position", Attribute "normal", Attribute "uvw")) + (fetch "plane" ((Attribute "position"))) + -- cgit v1.2.3