[WIP] Uniform polygon sampling

hgeometry-showcase/hgeometry-showcase.cabal

@@ -45,7 +45,7 @@ executable showcase
                        RandomMonotone,
                        ZHashing
                        SvgPolygons
-                       -- UniformSampling
+                       UniformSampling
   -- other-extensions:
   build-depends:       base,
                        reanimate >= 1.1.3.0, reanimate-svg,

hgeometry-showcase/lib/Common.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeOperators       #-}
+{-# LANGUAGE PatternSynonyms #-}
 module Common where
 
 import           Codec.Picture             (PixelRGBA8 (..))
@@ -27,7 +28,7 @@ import Data.Ext
 import Data.Geometry.LineSegment
 import Data.Geometry.Point
 import Data.Geometry.Polygon.Bezier
-import Data.Geometry.BezierSpline
+import Data.Geometry.BezierSpline (pattern Bezier3, pattern Bezier2, quadToCubic)
 import Data.Geometry.Polygon
 import Data.Geometry.Box (Rectangle, box, minPoint, maxPoint)
 import Data.Geometry.Transformation
@@ -263,6 +264,12 @@ type SomeBezierPolygon r = SomePolygon (PathJoin r) r
 
 svgToPolygons :: SVG -> [SomeBezierPolygon Double]
 svgToPolygons = plGroupShapes . cmdsToBezier . toLineCommands . extractPath
+-- svgToPolygons svg =
+--   [ case cmdsToBezier $ toLineCommands $ extractPath (ctx glyph) of
+--       [] -> error "No polygon in glyph."
+--       [x] -> Left x
+--       (x:hs) -> Right (MultiPolygon x hs)
+--   | (ctx, _attr, glyph) <- svgGlyphs svg ]
 
 cmdsToBezier :: [LineCommand] -> [SimpleBezierPolygon Double]
 cmdsToBezier [] = []
@@ -320,7 +327,9 @@ plGroupShapes = worker
     -- This is super fragile. I wish there was a way to check for bezier-line intersections without using sqrt.
     isInsideOf :: SimpleBezierPolygon Double -> SimpleBezierPolygon Double -> Bool
     isInsideOf a b =
-      _core (CV.head (a^.outerBoundaryVector)) `insidePolygon` b
+      CV.all (\elt -> _core elt `insidePolygon` approximate eps b) ((approximate eps a)^.outerBoundaryVector)
+    eps = 0.001
+      -- _core (CV.head (a^.outerBoundaryVector)) `insidePolygon` b
 
 ------------------------------------------------------------------
 -- Random data

hgeometry-showcase/src/Showcase.hs

@@ -12,7 +12,7 @@ import FastVisibility
 import SSSP
 import RandomMonotone
 import ZHashing
--- import UniformSampling
+import UniformSampling
 import SvgPolygons
 
 import Reanimate
@@ -28,7 +28,7 @@ main = do
     "fast_visibility":rest -> withArgs rest $ runReanimate fastVisibilityShowcase
     "random_monotone":rest -> withArgs rest $ runReanimate randomMonotoneShowcase
     "zhashing":rest        -> withArgs rest $ runReanimate zHashingShowcase
-    -- "sampling":rest        -> withArgs rest $ runReanimate uniformSamplingShowcase
+    "sampling":rest        -> withArgs rest $ runReanimate uniformSamplingShowcase
     "svg":rest             -> withArgs rest $ runReanimate svgPolygonsShowcase
     _                      -> printUsage
 

hgeometry-showcase/src/UniformSampling.hs

@@ -0,0 +1,52 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+module UniformSampling (uniformSamplingShowcase) where
+
+import           Data.Geometry.Polygon.Sample
+import           Common
+import           Control.Monad.Random                       (evalRand, forM_, mkStdGen, replicateM)
+import           Data.Geometry.Point                        (Point (Point2))
+import           Data.Geometry.Polygon
+import           Data.Geometry.Polygon.Bezier               (approximateSome)
+import           Reanimate
+
+eps :: Double
+eps = 0.001
+
+svgPolygons :: [SomePolygon () Double]
+svgPolygons = map (approximateSome eps) $
+  svgToPolygons $ lowerTransformations $ scale 2 $ center $ latex "Uniform\n\nSampling"
+
+-- targetPolygon :: SomePolygon () Double
+-- targetPolygon = scaleUniformlyBy 2 $ pAtCenter $ simpleFromPoints $ map ext
+--   [ Point2 0 0
+--   , Point2 1 0
+--   , Point2 1 1, Point2 2 1, Point2 2 (-1)
+--   , Point2 0 (-1), Point2 0 (-2)
+--   , Point2 3 (-2), Point2 3 2, Point2 0 2 ]
+
+uniformSamplingShowcase :: Animation
+uniformSamplingShowcase = scene $ do
+  forM_ svgPolygons $ \svgPolygon -> fork $ do 
+    newSpriteSVG_ $ overAny (ppPolygonBody' grey) svgPolygon
+    -- newSpriteSVG_ $ overAny (ppPolygonOutline' black) targetPolygon
+    wait 1
+    forM_ (overAny points svgPolygon) $ \point -> do
+      fork $ play $ playThenReverseA $ mkAnimation 0.5 $ \t ->
+        aroundCenter (scale t) $ ppPoint point
+      wait 0.025
+
+nPoints :: Int
+nPoints = 100
+
+points :: (Show p) => Polygon t p Double -> [Point 2 Double]
+points p = flip evalRand (mkStdGen seed) $ replicateM nPoints $ samplePolygon p
+
+seed :: Int
+seed = 0xDEADBEEF
+
+ppPoint :: Real r => Point 2 r -> SVG
+ppPoint (Point2 x y) =
+  withFillColorPixel red $
+  translate (realToFrac x) (realToFrac y) $
+  mkCircle (nodeRadius/5)

hgeometry/hgeometry.cabal

@@ -85,6 +85,7 @@ library
                     Data.Geometry.Ellipse
 
                     Data.Geometry.Polygon
+                    Data.Geometry.Polygon.Sample
                     Data.Geometry.Polygon.Bezier
                     Data.Geometry.Polygon.Inflate
                     Data.Geometry.Polygon.Convex

hgeometry/src/Data/Geometry/Polygon/Sample.hs

@@ -0,0 +1,50 @@
+module Data.Geometry.Polygon.Sample where
+
+import           Algorithms.Geometry.PolygonTriangulation.Triangulate
+import           Control.Lens
+import           Control.Monad.Random
+import           Data.Ext
+import           Data.Geometry.PlanarSubdivision                      (PolygonFaceData (..))
+import           Data.Geometry.Point
+import           Data.Geometry.Polygon.Core                           as Polygon
+import           Data.Geometry.Triangle                               as Triangle
+import qualified Data.List.NonEmpty                                   as NonEmpty
+import           Data.PlaneGraph
+import           Data.Proxy
+import qualified Data.Vector                                          as V
+import           Linear.Affine                                        hiding (Point)
+import           Linear.Vector
+
+-- | Uniformly samples from a set of polygon in \(O(n \log n)\) triangles.
+samplePolygons :: (RandomGen g, Random r, Fractional r, Ord r, Real r) => NonEmpty.NonEmpty (Polygon t p r) -> Rand g (Point 2 r)
+samplePolygons ps = do
+   randTri <- fromList $ map (\tri -> (tri, toRational $ areaRatio tri)) $ concatMap toTriangles ps
+   sampleTriangle randTri
+   where
+      areaRatio tri = Triangle.area tri / sum (fmap Polygon.area ps)
+
+-- | Uniformly samples a polygon in \(O(n \log n)\).
+samplePolygon :: (RandomGen g, Random r, Fractional r, Ord r, Real r) => Polygon t p r -> Rand g (Point 2 r)
+samplePolygon p = samplePolygons $ p NonEmpty.:| []
+
+-- | Uniformly samples a triangle in \(O(1)\).
+sampleTriangle :: (RandomGen g, Random r, Fractional r, Ord r) => Triangle 2 p r -> Rand g (Point 2 r)
+sampleTriangle (Triangle v1 v2 v3) = do
+  a' <- getRandomR (0, 1)
+  b' <- getRandomR (0, 1)
+  let (a, b) = if a' + b' > 1 then (1 - a', 1 - b') else (a', b')
+  return $ v1^.core .+^ a*^u .+^ b*^v
+  where
+    u = v2^.core .-. v1^.core
+    v = v3^.core .-. v1^.core
+
+-- | Triangulates a polygon \(O(n \log n)\).
+toTriangles :: (Fractional r, Ord r) => Polygon t p r -> [Triangle 2 p r]
+toTriangles p =
+    [ (polygonToTriangle . view core . (`rawFacePolygon` g)) f
+    | (f, Inside) <- V.toList (faces g) ]
+  where
+    g = triangulate' Proxy p
+    polygonToTriangle poly = case NonEmpty.toList $ polygonVertices poly of
+      [v1, v2, v3] -> Triangle v1 v2 v3
+      _            -> error "Invalid Triangulation"

hie.yaml

@@ -135,6 +135,9 @@ cradle:
     - path: "hgeometry-showcase/src/RandomMonotone.hs"
       component: "hgeometry-showcase:exe:showcase"
 
+    - path: "hgeometry-showcase/src/UniformSampling.hs"
+      component: "hgeometry-showcase:exe:showcase"
+
     - path: "hgeometry-showcase/lib/Common.hs"
       component: "hgeometry-showcase:exe:showcase"