From a506cd60536c3dd5420a093c3b52d002f77fd44c Mon Sep 17 00:00:00 2001 From: Frank Staals Date: Sat, 23 Nov 2024 18:48:35 +0100 Subject: [PATCH] updates to the ply writer --- hgeometry-examples/lowerEnv/Main.hs | 51 ++++++++++++++++++++++------- hgeometry/ply/src/PLY/Writer.hs | 48 ++++++++++++++------------- 2 files changed, 64 insertions(+), 35 deletions(-) diff --git a/hgeometry-examples/lowerEnv/Main.hs b/hgeometry-examples/lowerEnv/Main.hs index 234b58f84..2f08ebb26 100644 --- a/hgeometry-examples/lowerEnv/Main.hs +++ b/hgeometry-examples/lowerEnv/Main.hs @@ -3,19 +3,25 @@ module Main(main) where import Control.Lens import qualified Data.Foldable as F +import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map as Map +import HGeometry.Box import HGeometry.Ext +import HGeometry.HyperPlane.NonVertical import HGeometry.Number.Real.Rational import HGeometry.Plane.LowerEnvelope +import HGeometry.Plane.LowerEnvelope.Connected import HGeometry.PlaneGraph import HGeometry.PlaneGraph.Instances import HGeometry.Point -import HGeometry.Triangle -import HGeometry.VoronoiDiagram.ViaLowerEnvelope +import HGeometry.Transformation +import HGeometry.Vector +import HGeometry.VoronoiDiagram.ViaLowerEnvelope (pointToPlane) import Ipe import PLY.Writer import System.OsPath -import Test.QuickCheck +-- import Test.QuickCheck -------------------------------------------------------------------------------- @@ -32,16 +38,37 @@ myPlanes = NonEmpty.fromList $ zipWith (\i p -> pointToPlane p :+ (i,p)) [0..] , Point2 48 144 ] -verticesOf = NonEmpty.fromList . foldMap F.toList . trianglesOf -trianglesOf _ = [ Triangle (origin :+ 0) (Point3 10 0 1 :+ 1) (Point3 0 10 2 :+ 2) ] +-- verticesOf = NonEmpty.fromList . foldMap F.toList . trianglesOf +-- trianglesOf _ = [ Triangle (origin :+ 0) (Point3 10 0 1 :+ 1) (Point3 0 10 2 :+ 2) ] - -- \case - -- ParallelStrips _ -> undefined - -- ConnectedEnvelope env -> undefined - --- trianglesOf env = [] +-- | Render a minimization diagram +renderMinimizationDiagram :: (Plane_ plane r, Ord r, Fractional r) + => MinimizationDiagram r plane + -> ( NonEmpty (Point 3 r :+ Int) + , NonEmpty (NonEmpty Int) + ) +renderMinimizationDiagram env = (NonEmpty.fromList vs, NonEmpty.fromList fs) + where + (_,vs,fs) = foldr f (0,[],[]) . Map.toAscList . asMap $ env + f (h,reg) acc@(i,vsAcc,fsAcc) = case reg of + Bounded pts -> let k = length pts + vs' = zipWith (\q@(Point2 x y) j -> + let z = evalAt q h + in Point3 x y z :+ j) pts face' + face' = take k [i,(i+1)..] + in ( i+k + , vs' <> vsAcc + , NonEmpty.fromList face' : fsAcc + ) + Unbounded _ _ _ -> acc main :: IO () -main = renderOutputToFile [osp|myLowerEnv.ply|] (verticesOf $ lowerEnvelope myPlanes) - (trianglesOf $ lowerEnvelope myPlanes) +main = case lowerEnvelope myPlanes of + ParallelStrips _ -> pure () + ConnectedEnvelope env -> renderOutputToFile [osp|myLowerEnv.ply|] vs' fs + where + m = 20 + maxP = Point3 m m m + vs' = fitToBox (Box (maxP&vector %~ negated) maxP) vs + (vs,fs) = renderMinimizationDiagram env diff --git a/hgeometry/ply/src/PLY/Writer.hs b/hgeometry/ply/src/PLY/Writer.hs index dcc2a6c10..7cd587f2c 100644 --- a/hgeometry/ply/src/PLY/Writer.hs +++ b/hgeometry/ply/src/PLY/Writer.hs @@ -21,48 +21,50 @@ import qualified Data.Foldable as F import Data.Foldable1 import HGeometry.Ext import HGeometry.Point -import HGeometry.Triangle import qualified System.File.OsPath as File import System.OsPath -------------------------------------------------------------------------------- -- | Writes the the points and triangles to a file in PLY format. -renderOutputToFile :: (Foldable1 f, Point_ point 3 r, Show r) - => OsPath -> f (point :+ Int) - -> [Triangle (point :+ Int)] - -> IO () +renderOutputToFile :: ( Foldable1 f, Foldable1 g, Foldable1 face + , Point_ point 3 r, Show r) + => OsPath -> f (point :+ Int) -> g (face Int) -> IO () renderOutputToFile fp pts ts = File.writeFile fp $ renderOutput pts ts --- | Generates the content of the PLY file for the given non-empty list of points and the --- list of triangles --- assumes points are 0 indexed. -renderOutput :: (Foldable1 f, Point_ point 3 r, Show r) - => f (point :+ Int) -> [Triangle (point :+ Int)] - -> Char8.ByteString -renderOutput (F.toList -> pts) ts = - Char8.unlines $ hdr <> map renderPt pts <> map renderTri ts +-- | Generates the content of the PLY file for the given non-empty list of vertices and +-- the non-empty list of convex faces. +-- +-- Each face is given by a non-empty list of vertexId's, which are assumed to be +-- 0-indexed. +-- +renderOutput :: ( Foldable1 f, Foldable1 g + , Foldable1 face + , Point_ point 3 r + , Show r) + => f (point :+ Int) -> g (face Int) -> Char8.ByteString +renderOutput vertices faces = + Char8.unlines $ hdr <> map renderVtx (F.toList vertices) <> map renderFace (F.toList faces) where hdr = ["ply" , "format ascii 1.0" - ,"element vertex " <> (showT $ length pts) + ,"element vertex " <> (showT $ F.length vertices) ,"property float32 x" ,"property float32 y" ,"property float32 z" - ,"element face " <> (showT $ length ts) + ,"element face " <> (showT $ F.length faces) ,"property list uchar int vertex_index" ,"end_header" ] --- | Writes a Point to ply format -renderPt :: (Point_ point 3 r, Show r) => (point :+ extra) -> Char8.ByteString -renderPt (p :+ _) = let Point3 x y z = over coordinates showT $ p^.asPoint - in Char8.unwords [x,y,z] +-- | Writes a vertex to ply format +renderVtx :: (Point_ point 3 r, Show r) => (point :+ extra) -> Char8.ByteString +renderVtx (p :+ _) = let Point3 x y z = over coordinates showT $ p^.asPoint + in Char8.unwords [x,y,z] --- | Writes a triangle to ply format -renderTri :: (Point_ point 3 r, Show r) - => Triangle (point :+ Int) -> Char8.ByteString -renderTri (Triangle p q r) = let i a = showT $ a^.extra in Char8.unwords ["3",i p, i q, i r] +-- | Writes a face to ply format. +renderFace :: Foldable1 face => face Int -> Char8.ByteString +renderFace face = Char8.unwords . map showT $ (F.length face) : (F.toList face) -- | Helper to output stuff to bytestrings showT :: Show a => a -> Char8.ByteString