Render curve from obj file.

3 files changed, 89 insertions, 13 deletions

diff --git a/Bezier.hs b/Bezier.hs
index e526608..b93196d 100644
--- a/Bezier.hs
+++ b/Bezier.hs
@@ -32,6 +32,8 @@ data Curve = Curve
     , curveSegments :: Maybe Polygonization
     }
 
+-- Although this function accepts an index, 'subdivideCurve' increases the
+-- index by one after each call, so it is safe to ignore the index passed.
 type StorePoint m = BufferID -> Int -> Vector Float {- 3d -} -> m ()
 
 xz :: Vector Float -> (Float,Float)
diff --git a/LoadMesh.hs b/LoadMesh.hs
index aaf0e06..cd7a8ad 100644
--- a/LoadMesh.hs
+++ b/LoadMesh.hs
@@ -18,6 +18,7 @@ import Data.Maybe
 import Data.Map (Map)
 import qualified Data.Map as Map
 import qualified Data.Vector as V
+import qualified Data.Vector.Storable as StorableV
 import qualified Data.ByteString as SB
 import qualified Data.ByteString.Lazy.Char8 as L
 import Data.Text (unpack,Text,pack)
@@ -37,10 +38,19 @@ data MaterialMesh m = MaterialMesh
     , materialMasks :: Map Text Mask
     }
 
-type MeshData = ( [MaterialMesh Mesh]  -- List of uniform-material meshes (and the name of the material).
-                , ( V.Vector MtlLib    -- Material definitions.
-                  , FilePath )         -- Path to wavefront obj file.
-                )
+data CurveData = CurveData
+    { curves   :: [Curve]
+    , curvePt  :: Int -> Location
+    , curveMax :: Int
+    }
+
+
+data MeshData = MeshData
+    { matMeshes :: [MaterialMesh Mesh]  -- List of uniform-material meshes (and the name of the material).
+    , matLib    :: ( V.Vector MtlLib    -- Material definitions.
+                   , FilePath )         -- Path to wavefront obj file.
+    , matCurves :: CurveData
+    }
 
 relativeFrom :: FilePath -> FilePath -> FilePath
 relativeFrom path file | isAbsolute file = file
@@ -51,7 +61,12 @@ loadOBJ fname = L.readFile fname >>= \bs -> do
     let  obj@OBJ{..} = Wavefront.parse bs
     -- load materials
     mtlLib <- mapM (readMtlWithFallback . relativeFrom fname . unpack) objMtlLibs
-    return $ Right (objToMesh obj,(mtlLib,fname))
+    return $ Right MeshData
+        { matMeshes = objToMesh obj
+        , matLib    = (mtlLib,fname)
+        , matCurves = objToCurveData obj
+        }
+
 
 
 data BoundingBox = BoundingBox
@@ -122,22 +137,37 @@ transformMesh t m = m
     { mAttributes = Map.adjust (tranformAttribute t) "position" (mAttributes m)
     }
 
-uploadOBJToGPU :: Maybe BoundingBox -> MeshData -> IO ([MaterialMesh GPUMesh],Matrix Float)
-uploadOBJToGPU scalebb (subModels,(mtlLib,objpath)) = do
-    let meshbb = foldMap (attribBoundingBox . mAttributes . materialMesh) subModels :: BoundingBox
+transformLocation :: Matrix Float -> Location -> Location
+transformLocation t (Location x y z w) = Location xx yy zz ww
+ where
+    [xx,yy,zz,ww] = toList $ t #> fromList [x,y,z,w]
+
+locationBoundingBox :: Location -> BoundingBox
+locationBoundingBox (Location x y z w) = BoundingBox x x y y z z
+
+uploadOBJToGPU :: Maybe BoundingBox -> MeshData -> IO (([MaterialMesh GPUMesh],CurveData),Matrix Float)
+uploadOBJToGPU scalebb (MeshData subModels (mtlLib,objpath) curveData) = do
+    let meshbb = foldMap (attribBoundingBox . mAttributes . materialMesh) subModels
+                 <> foldMap (foldMap (locationBoundingBox . curvePt curveData) . curvePoints)
+                            (curves curveData)
         m = maybe (ident 4) (scaleWithin meshbb) scalebb
+        curveData' = case scalebb of
+            Just _  -> curveData { curvePt = transformLocation m . curvePt curveData }
+            Nothing -> curveData
     putStrLn $ show meshbb
     gpuSubModels <- forM subModels $ \matmesh -> do
         a <- LambdaCubeGL.uploadMeshToGPU (transformMesh m (materialMesh matmesh))
         return matmesh { materialMesh = a }
-    return (gpuSubModels,m)
+    return ((gpuSubModels,curveData'),m)
 
 uploadMtlLib :: (V.Vector MtlLib,FilePath) -> IO (V.Vector (Map Text (ObjMaterial,TextureData)))
 uploadMtlLib (mtlLib,objpath) = do
   -- collect used textures
   let usedTextures = nub . concatMap (maybeToList . mtl_map_Kd) $ concatMap Map.elems $ V.toList 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
+      checkerImage = Juicy.ImageRGB8 $ Juicy.generateImage mkchecker 2 2
+                    where mkchecker x y = if mod (x + y) 2 == 0 then Juicy.PixelRGB8 0 0 0
+                                                                else Juicy.PixelRGB8 255 255 0
   checkerTex <- LC.uploadTexture2DToGPU checkerImage
   -- load images and upload to gpu
   textureLib <- forM (Map.fromList $ zip usedTextures usedTextures) $ \fname -> Juicy.readImage (relativeFrom objpath fname) >>= \case
@@ -147,6 +177,16 @@ uploadMtlLib (mtlLib,objpath) = do
   -- pair textures and materials
   return $ fmap (\a -> (a, maybe whiteTex (fromMaybe checkerTex . flip Map.lookup textureLib) . mtl_map_Kd $ a)) <$> mtlLib
 
+vecLocation :: Location -> StorableV.Vector Float
+vecLocation (Location x y z w) = StorableV.fromList [x,y,z,w]
+
+objToCurveData :: WavefrontOBJ -> CurveData
+objToCurveData OBJ{..} = CurveData
+    { curves   = map elValue $ V.toList $ objCurves
+    , curvePt  = (objLocations V.!)
+    , curveMax = V.length objLocations
+    }
+
 objToMesh :: WavefrontOBJ -> [MaterialMesh Mesh]
 objToMesh OBJ{..} = [ toMesh faceGroup | faceGroup <- faces ]
  where
diff --git a/MeshSketch.hs b/MeshSketch.hs
index a51cd3d..a2e4cbe 100644
--- a/MeshSketch.hs
+++ b/MeshSketch.hs
@@ -54,6 +54,10 @@ import Text.Printf
 import qualified Foreign.C.Types
 import System.FilePath
 import System.Directory
+import Wavefront.Types
+import Wavefront.Util
+
+
 
 import CubeMap
 import GLWidget (nullableContext, withCurrentGL)
@@ -160,8 +164,8 @@ stateChangeMesh obj mm storage st = do
     let glarea = mmWidget mm
     -- load OBJ geometry and material descriptions
     let workarea = BoundingBox (-2.5) (2.5) (-2.5) 2.5 (-2.5) (2.5)
-        mtlLib = snd obj
-    (objMesh,objscale) <- uploadOBJToGPU (Just workarea) obj
+        mtlLib = matLib obj
+    ((objMesh,curveData),objscale) <- uploadOBJToGPU (Just workarea) obj
     putStrLn $ "Using object scale:\n" ++ show objscale
     -- load materials textures
     gpuMtlLib <- uploadMtlLib mtlLib
@@ -172,6 +176,36 @@ stateChangeMesh obj mm storage st = do
         addToGroupsPane (mmListStore mm) True groupname
     writeIORef (stObjects st) bufs
     writeIORef (stMasks st) $ map (objSpan . maskableObject) bufs
+    forM_ (take 1 $ curves curveData) $ \c -> do
+        let mn = minimum $ curvePoints c
+            mx = maximum $ curvePoints c
+            bs = decomposeCurve (curvePt curveData) c
+        mapM_ (putStrLn . show) bs
+        clearRing (stRingBuffer st)
+        forM_ bs $ \(BezierSegment [a,b,c,d]) -> do
+            let cv = Bezier.Curve Nothing (vecLocation a)
+                                          (vecLocation b)
+                                          (vecLocation c)
+                                          (vecLocation d)
+                                          Nothing
+                δ = 0.005 -- TODO
+                range = Polygonization
+                    { curveBufferID     = error "curveBufferID"
+                    , curveStartIndex   = 0
+                    , curveSegmentCount = ringCapacity (stRingBuffer st)
+                    }
+            r <- subdivideCurve δ cv range $ \_ _ v -> do
+                RingBuffer.pushBack (stRingBuffer st) $ \RingPoint{..} -> do
+                    rpPosition @<- v
+                    rpColor @<- yellow
+            putStrLn $ "Subdivided "++show (curveSegmentCount r)++" poly-lines."
+            return ()
+        {-
+        RingBuffer.pushBack (stRingBuffer st) $ \RingPoint{..} -> do
+            rpPosition @<- V3 0 0 (0::Float)
+            rpColor @<- red -}
+        return ()
+    putStrLn $ "Returning from stateChangeMesh."
     return st
 
 initializeState :: MeshSketch -> GLStorage -> IO State
@@ -321,7 +355,7 @@ loadInitialMesh kont = do
     objName <- head . (++ ["cube.obj"]) <$> getArgs
     putStrLn $ "Loading object "++objName++"..."
     mobj <- loadOBJ objName
-    putStrLn $ "Finisehd loading object "++objName++"."
+    putStrLn $ "Finished loading object "++objName++"."
     kont mobj
 
 new :: IO Gtk.Paned