colors in the ply writer + some fiddling

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
 
 

hgeometry/hgeometry.cabal

@@ -616,6 +616,7 @@ library ply-writer
     build-depends:
          hgeometry:point
        , hgeometry:kernel
+       , colour                  >= 2.3.6         && < 3
 
 --------------------------------------------------------------------------------
 -- * Test Suites

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
 
 

hgeometry/ply/src/PLY/Writer.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TemplateHaskell #-}
 --------------------------------------------------------------------------------
 -- |
 -- Module      :  Ply.Writer
@@ -13,23 +15,54 @@
 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
 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

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)

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
 

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