From bab66f39ff58c637f8ab4301c64e8fee9e0d75a3 Mon Sep 17 00:00:00 2001 From: Frank Staals Date: Sat, 14 Dec 2024 20:42:02 +0100 Subject: [PATCH] colors in the ply writer + some fiddling --- hgeometry-examples/lowerEnv/Main.hs | 60 ++++++++---- hgeometry/hgeometry.cabal | 1 + .../kernel/test/HGeometry/LineSegmentSpec.hs | 2 +- hgeometry/ply/src/PLY/Writer.hs | 97 ++++++++++++++++--- .../LowerEnvelope/Connected/BruteForce.hs | 2 - .../Plane/LowerEnvelope/Connected/Regions.hs | 4 +- .../test/VoronoiDiagram/VoronoiSpec.hs | 2 +- 7 files changed, 129 insertions(+), 39 deletions(-) diff --git a/hgeometry-examples/lowerEnv/Main.hs b/hgeometry-examples/lowerEnv/Main.hs index 6874e84dd..819e67b8f 100644 --- a/hgeometry-examples/lowerEnv/Main.hs +++ b/hgeometry-examples/lowerEnv/Main.hs @@ -2,11 +2,15 @@ module Main(main) where import Control.Lens +import Data.Colour +import Data.Colour.Names +import Data.Colour.SRGB (RGB(..),toSRGB24) 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 qualified Data.Map.NonEmpty as NEMap +import Data.Ord (comparing) import HGeometry.Box import HGeometry.Ext import HGeometry.HyperPlane.NonVertical @@ -31,13 +35,28 @@ import System.OsPath type R = RealNumber 5 -myPlanes = NonEmpty.zipWith (\i p -> pointToPlane p :+ (i,p)) (NonEmpty.fromList [0..]) +class HasColour plane where + colourOf :: plane -> Colour Double +instance HasColour (plane :+ (i,point,Colour Double)) where + colourOf (_ :+ (_,_,c)) = c + +instance Ord (Colour Double) where + compare = comparing (\c -> case toSRGB24 c of + RGB r g b -> (r,g,b) + ) + +pointToPlane' :: (Fractional r, Ord r) => Point 2 r -> Plane r +pointToPlane' = fmap (/ 10) . pointToPlane + + + +myPlanes = NonEmpty.zipWith (\i (p :+ c) -> pointToPlane' p :+ (i,p,c)) (NonEmpty.fromList [0..]) $ myPoints myPoints = NonEmpty.fromList $ - [ Point2 10 0 - , Point2 0 10 - , Point2 30 10 - , Point2 10 30 + [ Point2 10 0 :+ red + , Point2 0 10 :+ green + , Point2 30 10 :+ blue + , Point2 10 30 :+ (yellow :: Colour Double) ] @@ -62,28 +81,33 @@ toPolygons = fmap render . NEMap.toAscList . asMap Left pg -> pg&vertices %~ \v -> (v^.asPoint :+ evalAt v h) Right pg -> pg&vertices %~ \v -> (v^.asPoint :+ evalAt v h) ) - m = 1000 + m = 100 rect = Box (Point2 (negate m) (negate m)) (Point2 m m) +type Vtx r = (Int, Point 3 r :+ VertexAttributes 'Coloured) + -- | Render a minimization diagram -renderMinimizationDiagram :: (Plane_ plane r, Ord r, Fractional r) +renderMinimizationDiagram :: (Plane_ plane r, Ord r, Fractional r, HasColour plane) => MinimizationDiagram r plane - -> ( NonEmpty (Point 3 r :+ Int) + -> ( NonEmpty (Vtx r) , NonEmpty (NonEmpty Int) ) renderMinimizationDiagram env = (NonEmpty.fromList vs, NonEmpty.fromList fs) where (_,vs,fs) = foldr render (0,[],[]) - . NonEmpty.fromList . NonEmpty.take 1 + -- . NonEmpty.fromList . NonEmpty.take 1 . toPolygons $ env - render :: (plane, ConvexPolygonF NonEmpty (Point 2 r :+ r)) - -> (Int, [Point 3 r :+ Int], [NonEmpty Int]) - -> (Int, [Point 3 r :+ Int], [NonEmpty Int]) - render (_,pg) acc@(i,vsAcc,fsAcc) = - let vs = (\(j, Point2 x y :+ z) -> Point3 x y z :+ (i+j)) + render :: HasColour plane + => ( plane + , ConvexPolygonF NonEmpty (Point 2 r :+ r)) + -> (Int, [Vtx r], [NonEmpty Int]) + -> (Int, [Vtx r], [NonEmpty Int]) + render (h,pg) acc@(i,vsAcc,fsAcc) = + let vs = (\(j, Point2 x y :+ z) -> (i+j, Point3 x y z :+ ats)) <$> toNonEmptyOf (vertices.withIndex) pg - face' = view extra <$> vs + face' = fst <$> vs + ats = VertexAttributes (colourOf h) in (i + length vs, F.toList vs <> vsAcc, face' : fsAcc) @@ -109,9 +133,11 @@ main = do ConnectedEnvelope env -> do putStrLn "Regions:" mapM_ print $ toPolygons env - renderOutputToFile [osp|myLowerEnv.ply|] vs' fs + -- print vs + + renderOutputToFile [osp|myLowerEnv.ply|] vs fs where - vs' = fitToBox box . scaleBy (Vector3 1 1 (1/100)) $ vs + -- vs' = vs&traverse._2 %~ scaleBy (Vector3 1 1 (1/100)) (vs,fs) = renderMinimizationDiagram env diff --git a/hgeometry/hgeometry.cabal b/hgeometry/hgeometry.cabal index 1f29ca69a..53ab002b1 100644 --- a/hgeometry/hgeometry.cabal +++ b/hgeometry/hgeometry.cabal @@ -616,6 +616,7 @@ library ply-writer build-depends: hgeometry:point , hgeometry:kernel + , colour >= 2.3.6 && < 3 -------------------------------------------------------------------------------- -- * Test Suites diff --git a/hgeometry/kernel/test/HGeometry/LineSegmentSpec.hs b/hgeometry/kernel/test/HGeometry/LineSegmentSpec.hs index c35a23182..b6eeaf6d8 100644 --- a/hgeometry/kernel/test/HGeometry/LineSegmentSpec.hs +++ b/hgeometry/kernel/test/HGeometry/LineSegmentSpec.hs @@ -259,7 +259,7 @@ testI = describe "some manual intersection tests" $ do describe "manual intersect with line" $ do let l = LinePV origin (Vector2 0 (1 :: Int)) it "man" $ (l `intersects` test1) `shouldBe` True - it "sideTest" $ traceShow (hyperPlaneEquation l) $ + it "sideTest" $ (onSideTest (test1^.start) l) `shouldBe` EQ diff --git a/hgeometry/ply/src/PLY/Writer.hs b/hgeometry/ply/src/PLY/Writer.hs index 7cd587f2c..bd48f28f0 100644 --- a/hgeometry/ply/src/PLY/Writer.hs +++ b/hgeometry/ply/src/PLY/Writer.hs @@ -1,5 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TemplateHaskell #-} -------------------------------------------------------------------------------- -- | -- Module : Ply.Writer @@ -13,12 +15,20 @@ module PLY.Writer ( renderOutputToFile , renderOutput + + + , Coloured(..) + , VertexAttributes(VertexAttributes), vtxColour ) where import Control.Lens import qualified Data.ByteString.Lazy.Char8 as Char8 +import Data.Colour.SRGB (Colour, RGB(..), toSRGB24) +import Data.Default.Class import qualified Data.Foldable as F import Data.Foldable1 +import Data.Kind (Type) +import Data.Proxy import HGeometry.Ext import HGeometry.Point import qualified System.File.OsPath as File @@ -26,10 +36,33 @@ import System.OsPath -------------------------------------------------------------------------------- +data Coloured = Coloured | NotColoured + deriving (Show,Eq) + +type family VtxColour (coloured :: Coloured) :: Type where + VtxColour 'Coloured = Colour Double + VtxColour NotColoured = () + +newtype VertexAttributes (coloured :: Coloured) = + VertexAttributes { _vtxColour :: (VtxColour coloured) + } +makeLenses ''VertexAttributes + + +deriving instance Show (VtxColour coloured) => Show (VertexAttributes coloured) +deriving instance Eq (VtxColour coloured) => Eq (VertexAttributes coloured) + +instance Default (VertexAttributes NotColoured) where + def = VertexAttributes () + + -- | Writes the the points and triangles to a file in PLY format. renderOutputToFile :: ( Foldable1 f, Foldable1 g, Foldable1 face - , Point_ point 3 r, Show r) - => OsPath -> f (point :+ Int) -> g (face Int) -> IO () + , Point_ point 3 r, Show r, RenderVtxColour coloured + ) + => OsPath + -> f (Int, point :+ VertexAttributes coloured) + -> 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 vertices and @@ -38,29 +71,61 @@ renderOutputToFile fp pts ts = File.writeFile fp $ renderOutput pts ts -- Each face is given by a non-empty list of vertexId's, which are assumed to be -- 0-indexed. -- -renderOutput :: ( Foldable1 f, Foldable1 g +renderOutput :: forall f g face point r coloured. + ( Foldable1 f, Foldable1 g , Foldable1 face , Point_ point 3 r - , Show r) - => f (point :+ Int) -> g (face Int) -> Char8.ByteString + , Show r, RenderVtxColour coloured + ) + => f (Int, point :+ VertexAttributes coloured) + -> g (face Int) -> Char8.ByteString renderOutput vertices faces = Char8.unlines $ hdr <> map renderVtx (F.toList vertices) <> map renderFace (F.toList faces) where - hdr = ["ply" + hdr = [ "ply" , "format ascii 1.0" - ,"element vertex " <> (showT $ F.length vertices) - ,"property float32 x" - ,"property float32 y" - ,"property float32 z" - ,"element face " <> (showT $ F.length faces) - ,"property list uchar int vertex_index" - ,"end_header" + , "element vertex " <> (showT $ F.length vertices) + , "property float32 x" + , "property float32 y" + , "property float32 z" + ] <> vtxColourHeader (Proxy @coloured) <> + [ "element face " <> (showT $ F.length faces) + , "property list uchar int vertex_index" + , "end_header" ] + +class RenderVtxColour coloured where + -- | The attributes for the vertex colour + vtxColourHeader :: proxy coloured -> [Char8.ByteString] + vtxColourHeader = const [] + -- | Renders the actual vertex color + renderVtxColour :: proxy coloured -> VtxColour coloured -> [Char8.ByteString] + renderVtxColour _ = const [] + + +instance RenderVtxColour 'Coloured where + vtxColourHeader _ = [ "property uchar red" + , "property uchar green" + , "property uchar blue" + ] + renderVtxColour _ c = case showT <$> toSRGB24 c of + RGB r g b -> [r,g,b] + +instance RenderVtxColour NotColoured + + + +renderAttributes :: forall coloured. RenderVtxColour coloured + => VertexAttributes coloured -> [Char8.ByteString] +renderAttributes (VertexAttributes c) = renderVtxColour (Proxy @coloured) c + + -- | 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] +renderVtx :: (Point_ point 3 r, Show r, RenderVtxColour coloured) + => (index, point :+ VertexAttributes coloured) -> Char8.ByteString +renderVtx (_, p :+ ats) = let Point3 x y z = over coordinates showT $ p^.asPoint + in Char8.unwords $ [x,y,z] <> renderAttributes ats -- | Writes a face to ply format. renderFace :: Foldable1 face => face Int -> Char8.ByteString diff --git a/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/BruteForce.hs b/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/BruteForce.hs index caeaef176..c1a849cea 100644 --- a/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/BruteForce.hs +++ b/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/BruteForce.hs @@ -23,7 +23,6 @@ import HGeometry.Plane.LowerEnvelope.Connected.Regions import HGeometry.Plane.LowerEnvelope.Connected.Type import HGeometry.Point -import Debug.Trace -------------------------------------------------------------------------------- -- * The naive O(n^4) time algorithm. @@ -42,7 +41,6 @@ computeVertexForm :: (Plane_ plane r, Ord plane, Ord r, Fractional r, Fol ) => set plane -> VertexForm r plane computeVertexForm planes = unionsWithKey mergeDefiners - . traceShowId . map (asVertex planes) $ uniqueTriplets planes asVertex :: (Plane_ plane r, Foldable f, Ord plane, Ord r, Fractional r) diff --git a/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Regions.hs b/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Regions.hs index a07139ba7..6e5e7e73c 100644 --- a/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Regions.hs +++ b/hgeometry/src/HGeometry/Plane/LowerEnvelope/Connected/Regions.hs @@ -44,7 +44,7 @@ import HGeometry.Plane.LowerEnvelope.Connected.VertexForm import HGeometry.Point import HGeometry.Vector -import Debug.Trace +-- import Debug.Trace ---------------------------------------- -- | returns the CCW predecessor, and CCW successor of the given plane. @@ -127,7 +127,7 @@ fromVertexForm :: (Plane_ plane r, Ord plane, Ord r, Fractional r, Show r, Show fromVertexForm = MinimizationDiagram . NEMap.mapWithKey sortAroundBoundary . mapWithKeyMerge1 (\v defs -> NEMap.fromList . fmap (,Set.singleton (v,defs)) . toNonEmpty $ defs) - . f . traceShowId + . f where f = NEMap.unsafeFromMap -- FIXME diff --git a/hgeometry/test-with-ipe/test/VoronoiDiagram/VoronoiSpec.hs b/hgeometry/test-with-ipe/test/VoronoiDiagram/VoronoiSpec.hs index ee17e21cd..2762b9777 100644 --- a/hgeometry/test-with-ipe/test/VoronoiDiagram/VoronoiSpec.hs +++ b/hgeometry/test-with-ipe/test/VoronoiDiagram/VoronoiSpec.hs @@ -121,7 +121,7 @@ degenerateTests = describe "degnereate inputs" $ do -- perm `shouldSatisfy` (\y -> f x == f y) it "buggy four points diagram" $ - numRegions (traceShowId $ voronoiDiagram bug) + numRegions (voronoiDiagram bug) `shouldBe` Just 4