fiddling

cabal.project

@@ -1,6 +1,7 @@
 write-ghc-environment-files: always
 tests: true
 benchmarks: true
+multi-repl: true
 packages:
   hgeometry-combinatorial
   hgeometry

hgeometry-examples/lowerEnv/Main.hs

@@ -6,10 +6,12 @@ import           Data.Colour
 import           Data.Colour.Names
 import           Data.Colour.SRGB (RGB(..),toSRGB24)
 import qualified Data.Foldable as F
+import           Data.Foldable1
 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.Maybe (fromMaybe)
 import           Data.Ord (comparing)
 import           HGeometry.Box
 import           HGeometry.Ext
@@ -22,6 +24,7 @@ import           HGeometry.PlaneGraph.Instances
 import           HGeometry.Point
 import           HGeometry.Polygon
 import           HGeometry.Polygon.Convex
+import           HGeometry.Polygon.Simple.Class
 import           HGeometry.Transformation
 import           HGeometry.Vector
 import           HGeometry.VoronoiDiagram.ViaLowerEnvelope (pointToPlane, voronoiDiagram)
@@ -30,6 +33,7 @@ import           PLY.Writer
 import           System.OsPath
 -- import           Test.QuickCheck
 
+import Debug.Trace
 --------------------------------------------------------------------------------
 
 type R = RealNumber 5
@@ -46,12 +50,14 @@ instance Ord (Colour Double) where
                       )
 
 pointToPlane' :: (Fractional r, Ord r) => Point 2 r -> Plane r
-pointToPlane' = fmap (/ 10) . pointToPlane
-
+pointToPlane' = fmap (/ 100) . pointToPlane
 
 
+myPlanes :: NonEmpty (Plane R :+ (Int, Point 2 R, Colour Double))
 myPlanes = NonEmpty.zipWith (\i (p :+ c) -> pointToPlane' p :+ (i,p,c)) (NonEmpty.fromList [0..])
          $ myPoints
+
+myPoints :: NonEmpty (Point 2 R :+ Colour Double)
 myPoints = NonEmpty.fromList $
            [ Point2 10 0   :+ red
            , Point2 0  10  :+ green
@@ -72,17 +78,32 @@ myPoints = NonEmpty.fromList $
 -- verticesOf    = NonEmpty.fromList . foldMap F.toList . trianglesOf
 -- trianglesOf _ = [ Triangle (origin :+ 0) (Point3 10 0 1  :+ 1) (Point3 0 10 2  :+ 2) ]
 
+
+-- | Renders the a plane
+renderPlaneIn             :: (Plane_ plane r, Point_ corner 2 r, Num r, Ord r
+                             , Show corner, Show r)
+                          => Rectangle corner -> plane -> ConvexPolygonF NonEmpty (corner :+ r)
+renderPlaneIn rect' h = uncheckedFromCCWPoints
+                      . NonEmpty.reverse . toNonEmpty -- the corners are listed in CW order
+                      . fmap eval
+                      $ corners rect'
+  where
+    eval p = p :+ evalAt p h
+
 toPolygons :: (Plane_ plane r, Ord r, Fractional r)
            => MinimizationDiagram r plane
            -> NonEmpty (plane, ConvexPolygonF NonEmpty (Point 2 r :+ r))
 toPolygons = fmap render . NEMap.toAscList . asMap
   where
-    render (h,reg) = (h, case toConvexPolygonIn rect reg of
+    render (h,reg) = (h, case toConvexPolygonIn myRect reg of
                            Left pg  -> pg&vertices %~ \v -> (v^.asPoint :+ evalAt v h)
                            Right pg -> pg&vertices %~ \v -> (v^.asPoint :+ evalAt v h)
                      )
-    m = 100
-    rect = Box (Point2 (negate m) (negate m)) (Point2 m m)
+
+
+myRect :: Num r => Rectangle (Point 2 r)
+myRect = let m = 100 in Box (Point2 (negate m) (negate m)) (Point2 m m)
+
 
 type Vtx r = (Int, Point 3 r :+ VertexAttributes 'Coloured)
 
@@ -104,12 +125,31 @@ renderMinimizationDiagram env = (NonEmpty.fromList vs, NonEmpty.fromList fs)
                                       -> (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' = fst <$> vs
-          ats   = VertexAttributes (colourOf h)
-      in (i + length vs, F.toList vs <> vsAcc, face' : fsAcc)
+      let vs'    = (\(j, Point2 x y :+ z) -> (i+j, Point3 x y z :+ ats))
+                   <$> toNonEmptyOf (vertices.withIndex) pg
+          face'  = fst <$> vs'
+          ats    = VertexAttributes (colourOf h)
+      in (i + length vs', F.toList vs' <> vsAcc, face' : fsAcc)
+
+-- | Draws all the planes
+renderPlanes    :: (Plane_ plane r, Ord r, Fractional r, HasColour plane, Foldable1 nonEmpty
+
+                   , Show r
+                   )
+                => nonEmpty plane -> ( NonEmpty (Vtx r)
+                                     , NonEmpty (NonEmpty Int)
+                                     )
+renderPlanes hs = (NonEmpty.fromList vs, NonEmpty.fromList fs)
+  where
+    (_,vs,fs) = foldr render (0,[],[]) hs
 
+    render h acc@(i,vsAcc,fsAcc) =
+      let pg  = renderPlaneIn myRect h
+          vs'    = (\(j, Point2 x y :+ z) -> (i+j, Point3 x y z :+ ats))
+                   <$> toNonEmptyOf (vertices.withIndex) pg
+          face'  = fst <$> vs'
+          ats    = VertexAttributes (colourOf h)
+      in (i + length vs', F.toList vs' <> vsAcc, face' : fsAcc)
 
 main :: IO ()
 main = do
@@ -133,14 +173,25 @@ main = do
            ConnectedEnvelope env -> do
                                       putStrLn "Regions:"
                                       mapM_ print $ toPolygons env
+                                      mapM_ (\xs@(h,_) ->
+                                               print $ (h, verifyOnPlane xs)
+                                            ) $ toPolygons env
                                       -- print vs
 
                                       renderOutputToFile [osp|myLowerEnv.ply|] vs fs
+                                      renderOutputToFile [osp|planes.ply|] vs' fs'
              where
                -- vs'     = vs&traverse._2 %~ scaleBy (Vector3 1 1 (1/100))
-               (vs,fs) = renderMinimizationDiagram env
+               (vs,fs)   = renderMinimizationDiagram env
+               (vs',fs') = renderPlanes . NEMap.keys . asMap $ env
 
 
+-- | make sure that all vertices lie on the plane
+verifyOnPlane        :: (Plane_ plane r, Ord r, Fractional r)
+                     => (plane, ConvexPolygonF NonEmpty (Point 2 r :+ r)) -> Bool
+verifyOnPlane (h,pg) = allOf vertices onPlane pg
+  where
+    onPlane (Point2 x y :+ z) = onHyperPlane (Point3 x y z) h
 
 -- boundedVertices   :: Fold (MinimizationDiagram r plane) (Point 2 r)
 boundedVertices f = foldMap (\case