svg -> jpeg | different voronoi diagram method

Svg diagrams backend to jpeg was to make it easier to render & share.
The existing method stressed firefox if too many shapes were there.

The new voronoi diagram method is much faster. Examples now take
approximately 40 seconds to render as opposed to the 5-10 minutes
previously.

In short, it no longer makes the Delunay triangulation. It feeds the 20
closest points to the candidate midpoint. Those points turn out to be
enough, no need to construct the planar graph.

Additionally, dependencies were bumped.

README.md

@@ -3,12 +3,12 @@
 Makes a [voroni diagram](https://en.wikipedia.org/wiki/Voronoi_diagram) and fills each cell with the average color the image below in.
 
 ### examples
-![Sierra mountains original](examples/sierra.jpg)
+![Sierra mountains original](examples/sierra.jpeg)
-![Sierra mountains post-filter](examples/sierra-result.svg)
+![Sierra mountains post-filter](examples/sierra-result.jpeg)
 ![Hawaii original](examples/birds-eye-view.png)
-![Hawaii post-filter](examples/birds-eye-view.svg)
+![Hawaii post-filter](examples/birds-eye-view-result.jpeg)
-![Dog original](examples/Luna.jpeg)
+![Dog original](examples/luna.jpeg)
-![Dog post-filter](examples/luna.svg)
+![Dog post-filter](examples/luna-result.jpeg)
 
 
 ### to run:
@@ -16,7 +16,7 @@ Makes a [voroni diagram](https://en.wikipedia.org/wiki/Voronoi_diagram) and fill
 #### with nix
 
 ```
-nix run  --experimental-features "nix-command flakes" ".#" -- --minDistance 0.05 --input examples/birds-eye-view.png --output output.svg
+nix run  --experimental-features "nix-command flakes" ".#" -- --minDistance 0.02 --input examples/birds-eye-view.png --output output.jpeg
 ```
 
 #### with cabal
@@ -24,6 +24,6 @@ Install [cabal & ghc](https://www.haskell.org/ghcup/) if you don't have them.
 
 ```
 cabal update
-cabal run image-triangles -- --minDistance 0.05 --input examples/birds-eye-view.png --output output.svg
+cabal run image-triangles -- --minDistance 0.02 --input examples/birds-eye-view.png --output output.jpeg
 ```
 

flake.lock

@@ -5,11 +5,11 @@
         "nixpkgs-lib": "nixpkgs-lib"
       },
       "locked": {
-        "lastModified": 1706830856,
+        "lastModified": 1717285511,
-        "narHash": "sha256-a0NYyp+h9hlb7ddVz4LUn1vT/PLwqfrWYcHMvFB1xYg=",
+        "narHash": "sha256-iKzJcpdXih14qYVcZ9QC9XuZYnPc6T8YImb6dX166kw=",
         "owner": "hercules-ci",
         "repo": "flake-parts",
-        "rev": "b253292d9c0a5ead9bc98c4e9a26c6312e27d69f",
+        "rev": "2a55567fcf15b1b1c7ed712a2c6fadaec7412ea8",
         "type": "github"
       },
       "original": {
@@ -23,11 +23,11 @@
         "systems": "systems"
       },
       "locked": {
-        "lastModified": 1705309234,
+        "lastModified": 1710146030,
-        "narHash": "sha256-uNRRNRKmJyCRC/8y1RqBkqWBLM034y4qN7EprSdmgyA=",
+        "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=",
         "owner": "numtide",
         "repo": "flake-utils",
-        "rev": "1ef2e671c3b0c19053962c07dbda38332dcebf26",
+        "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a",
         "type": "github"
       },
       "original": {
@@ -38,11 +38,11 @@
     },
     "haskell-flake": {
       "locked": {
-        "lastModified": 1708536395,
+        "lastModified": 1717339509,
-        "narHash": "sha256-z6rxsqQ9/xS3FWc2iLvFnElNt45XehD7bzPe4Yooz08=",
+        "narHash": "sha256-ySll9pAYK78v8GY5wrCFLg2iMI6Ms/4tNfrvlMaUQ1M=",
         "owner": "srid",
         "repo": "haskell-flake",
-        "rev": "1e297173b23c5113dd90a2d299d6e0d864af35f1",
+        "rev": "cfb7db6b7b66cb7d1499dd53b8aeaa7c866f565f",
         "type": "github"
       },
       "original": {
@@ -53,11 +53,11 @@
     },
     "nixpkgs": {
       "locked": {
-        "lastModified": 1708475490,
+        "lastModified": 1717602782,
-        "narHash": "sha256-g1v0TsWBQPX97ziznfJdWhgMyMGtoBFs102xSYO4syU=",
+        "narHash": "sha256-pL9jeus5QpX5R+9rsp3hhZ+uplVHscNJh8n8VpqscM0=",
         "owner": "nixos",
         "repo": "nixpkgs",
-        "rev": "0e74ca98a74bc7270d28838369593635a5db3260",
+        "rev": "e8057b67ebf307f01bdcc8fba94d94f75039d1f6",
         "type": "github"
       },
       "original": {
@@ -69,20 +69,14 @@
     },
     "nixpkgs-lib": {
       "locked": {
-        "dir": "lib",
+        "lastModified": 1717284937,
-        "lastModified": 1706550542,
+        "narHash": "sha256-lIbdfCsf8LMFloheeE6N31+BMIeixqyQWbSr2vk79EQ=",
-        "narHash": "sha256-UcsnCG6wx++23yeER4Hg18CXWbgNpqNXcHIo5/1Y+hc=",
+        "type": "tarball",
-        "owner": "NixOS",
+        "url": "https://github.com/NixOS/nixpkgs/archive/eb9ceca17df2ea50a250b6b27f7bf6ab0186f198.tar.gz"
-        "repo": "nixpkgs",
-        "rev": "97b17f32362e475016f942bbdfda4a4a72a8a652",
-        "type": "github"
       },
       "original": {
-        "dir": "lib",
+        "type": "tarball",
-        "owner": "NixOS",
+        "url": "https://github.com/NixOS/nixpkgs/archive/eb9ceca17df2ea50a250b6b27f7bf6ab0186f198.tar.gz"
-        "ref": "nixos-unstable",
-        "repo": "nixpkgs",
-        "type": "github"
       }
     },
     "root": {
@@ -116,11 +110,11 @@
         ]
       },
       "locked": {
-        "lastModified": 1708335038,
+        "lastModified": 1717278143,
-        "narHash": "sha256-ETLZNFBVCabo7lJrpjD6cAbnE11eDOjaQnznmg/6hAE=",
+        "narHash": "sha256-u10aDdYrpiGOLoxzY/mJ9llST9yO8Q7K/UlROoNxzDw=",
         "owner": "numtide",
         "repo": "treefmt-nix",
-        "rev": "e504621290a1fd896631ddbc5e9c16f4366c9f65",
+        "rev": "3eb96ca1ae9edf792a8e0963cc92fddfa5a87706",
         "type": "github"
       },
       "original": {

image-triangles.cabal

@@ -64,6 +64,7 @@ executable image-triangles
     MultiParamTypeClasses
     OverloadedLabels
     OverloadedStrings
+    StrictData
     RankNTypes
     RecordWildCards
     RecursiveDo
@@ -82,17 +83,19 @@ executable image-triangles
     , Color
     , colour
     , containers
-    , diagrams-cairo
     , diagrams-contrib
     , diagrams-lib
-    , diagrams-svg
+    , diagrams-rasterific
     , linear
     , massiv
     , massiv-io
     , monad-parallel
     , optparse-generic
     , parallel
+    , pqueue
+    , psqueues
     , random
+    , heaps
     , splitmix
     , vector
     , vector-th-unbox
@@ -102,7 +105,5 @@ executable image-triangles
 
   -- Base language which the package is written in.
   default-language:   GHC2021
-
+  ghc-options: -threaded "-with-rtsopts=-N"
--- ghc-options:
+  -- ghc-options: -fprof-auto -threaded "-with-rtsopts=-N" "-with-rtsopts=-p"
---               -fprof-auto
---               "-with-rtsopts=-p"

src/Main.hs

@@ -25,10 +25,9 @@ import Debug.Trace qualified as D
 import Debug.Trace qualified as DT
 import Debug.Trace qualified as T
 import Diagrams qualified as DP
-import Diagrams.Backend.SVG
+import Diagrams.Backend.Rasterific
-import Diagrams.Backend.SVG.CmdLine
+import Diagrams.Backend.Rasterific.CmdLine
-import Diagrams.Prelude
+import Diagrams.Prelude as D
-import Diagrams.Prelude qualified as D
 import GHC.Generics
 import Graphics.Color.Space qualified as Co
 import MinDistanceSample qualified as MDS
@@ -49,18 +48,21 @@ corners = (,) <$> [0, 1] <*> [0, 1]
 shapeCircumference :: [Point V2 Double] -> Double
 shapeCircumference = Data.List.sum . map D.norm . loopOffsets . fromVertices
 
-genImage :: M.Image M.S (Co.SRGB 'Co.Linear) Double -> V2 Double -> Double -> StdGen -> QDiagram SVG V2 Double Any
+genImage :: M.Image M.S (Co.SRGB 'Co.Linear) Double -> V2 Double -> Double -> StdGen -> QDiagram Rasterific V2 Double Any
 genImage image dimensionsVec minDistance gen =
   scaleX widthHeightRatio
     . reflectY
     . rectEnvelope (mkP2 0 0) (1 ^& 1)
     . mconcat
-        . map drawVoroniRegion
+    . map ((\x -> drawVoroniRegion x <> overlayEdges x) . uncurry Tri.voroniDiagramCorners)
-        . sortOn shapeCircumference
-        . withStrategy (parListChunk 200 rdeepseq)
-        . map (uncurry Tri.voroniDiagramCorners)
     $ voroni
   where
+    overlayEdges =
+      lw 3.0
+        . lc black
+        . strokeLocLoop
+        . fromVertices
+
     drawVoroniRegion shape =
       lw 0
         . fillColor (Tri.voroniRegionAverageColor image dimensions shape)
@@ -76,19 +78,7 @@ genImage image dimensionsVec minDistance gen =
 
     singleVoroni = last voroni
 
-    visualizeGraph :: QDiagram SVG V2 Double Any
+    voroni = map (\x -> (x, Tri.nClosestPoints 20 x corners')) corners'
-    visualizeGraph =
-        lc red
-            . lw 1
-            . position
-            . map (\(x0, x1) -> (x0,) . strokeLine $ (x0 ~~ x1))
-            . Tri.toPlanarGraph
-            $ corners'
-
-    voroni =
-        Tri.findVoroniDiagram
-            . Tri.toPlanarGraph
-            $ corners'
 
     averageSideSize = (fromIntegral (uncurry (+) dimensions)) / 2
 
@@ -120,8 +110,8 @@ data CLIOptions = CLIOptions
 main :: IO ()
 main = do
   CLIOptions {..} <- getRecord "image options"
-    gen' <- getStdGen -- for consistency, swap with something like: pure . mkStdGen $ 2344
+  gen' <- getStdGen
   print gen'
   image :: M.Image M.S (Co.SRGB 'Co.Linear) Double <- M.readImageAuto input
   let dims = toDimensionVector image
-    renderSVG output (Diagrams.Prelude.dims dims) (genImage image dims minDistance gen')
+  renderRasterific output (D.dims dims) (genImage image dims minDistance gen')

src/Triangles.hs

@@ -17,7 +17,9 @@ import Data.Massiv.Array qualified as Ma
 import Data.Massiv.Array.IO qualified as Ma
 import Data.Maybe
 import Data.Ord qualified as O
+import Data.PQueue.Prio.Min qualified as PQ
 import Data.Ratio
+import Diagrams.Prelude
 import Data.Set qualified as S
 import Data.Vector.Generic.Base (Vector)
 import Data.Vector.Generic.Mutable (MVector)
@@ -26,13 +28,14 @@ import Data.Vector.Unboxed.Deriving
 import Debug.Trace (traceShow)
 import Debug.Trace qualified
 import Debug.Trace qualified as D
-import Diagrams.Prelude
 import Diagrams.Trail (trailPoints)
 import Diagrams.TwoD
+import Data.Heap qualified as H
 import Diagrams.TwoD.Path.IntersectionExtras qualified as I
 import Diagrams.TwoD.Segment.Bernstein (listToBernstein)
 import Graphics.Color.Space qualified as Co
 import System.Random
+import Data.Containers.ListUtils (nubOrd)
 
 toColour :: (Fractional a) => Co.Color (Co.SRGB Co.Linear) a -> Colour a
 toColour (Co.ColorSRGB r g b) = CL.rgb r g b
@@ -50,12 +53,10 @@ randomPoints = map (bimap toZeroToOneTuple toZeroToOneTuple) . randomRs ((0 :: W
 combinations :: (Ord b, Floating b, NFData b) => [P2 b] -> [(P2 b, P2 b)]
 combinations =
   sortOn (abs . uncurry distanceA)
-        . S.toList -- deduplicate
+    . nubOrd
-        . S.fromList
     . filter (uncurry (/=))
     . concat
-        . withStrategy (parListChunk 50 rdeepseq)
+    . map (\(x : xs) -> takeSortOn 10 (abs . uncurry distanceA) . map (x,) $ xs)
-        . map (\(x : xs) -> take 10 . sortOn (abs . uncurry distanceA) . map (x,) $ xs)
     . init -- last output of tails is empty list
     . tails
 
@@ -93,7 +94,9 @@ voroniDiagramCorners center midpoints =
     . concat
     $ [intersectPointsT l0 l1 | l0 <- tangentTrails, l1 <- tangentTrails]
   where
-    lessThanQuarterTurn candidate = candidate <= (10001 / 40000) @@ turn || candidate >= (29999 / 40000) @@ turn
+    lessThanQuarterTurn candidate = candidate <= quarterTurn @@ turn || candidate >= (1 - quarterTurn) @@ turn
+
+    quarterTurn = 0.251
 
     tangentTrails = map tangentTrail midpoints
 
@@ -102,7 +105,9 @@ voroniDiagramCorners center midpoints =
     isValidMidpoint candidate = all isNonObtuseMidpoint . filter (/= candidate) $ midpoints
       where
         isNonObtuseMidpoint m =
-            lessThanQuarterTurn . normalizeAngle $ angleBetweenDirs (dirBetween m center) (dirBetween m candidate)
+          lessThanQuarterTurn
+            . normalizeAngle
+            $ angleBetweenDirs (dirBetween m center) (dirBetween m candidate)
 
     tangentTrail midpoint = fromVertices [midpoint .-^ tangentVec, midpoint .+^ tangentVec]
       where
@@ -113,6 +118,43 @@ voroniDiagramCorners center midpoints =
             . rotateBy (1 / 4)
             $ dirBetween midpoint center
 
+
+
+-- real	0m47.306s
+-- user	0m45.160s
+-- sys	0m0.345s
+
+-- takeSortOn n f = map snd . H.toUnsortedList . H.take n . H.fromList . map (\x -> (f x, x))
+
+
+
+
+-- real	0m43.514s
+-- user	0m41.489s
+-- sys	0m0.271s
+
+takeSortOn :: Ord a => Int -> (b -> a) -> [b] -> [b]
+takeSortOn n f =
+  map snd
+    . PQ.take n
+    . PQ.fromList
+    . map (\x -> (f x, x))
+
+
+-- real	0m44.868s
+-- user	0m44.199s
+-- sys	0m0.322s
+-- takeSortOn :: Ord a => Int -> (b -> a) -> [b] -> [b]
+-- takeSortOn n f =
+--      take n
+--     . sortOn f
+
+nClosestPoints :: (RealFloat n) => Int -> Point V2 n -> [Point V2 n] -> [Point V2 n]
+nClosestPoints n p =
+  map (pointBetween p)
+    . takeSortOn n (abs . distanceA p)
+    . filter (/= p)
+
 findVoroniDiagram :: (RealFloat n) => [(Point V2 n, Point V2 n)] -> [(Point V2 n, [Point V2 n])]
 findVoroniDiagram =
   M.toList
@@ -123,8 +165,9 @@ findVoroniDiagram =
             . S.toList
       )
     . adjacencyMapOf
-  where
+
-    pointBetween p0 p1 = p0 .+^ ((p1 .-. p0) ^/ 2)
+pointBetween :: (Affine p, Fractional a) => p a -> p a -> p a
+pointBetween p0 p1 = p0 .+^ ((p1 .-. p0) ^/ 2)
 
 findTriangles :: (Ord b) => [(b, b)] -> S.Set (S.Set b)
 findTriangles edges = S.unions . S.map threeCyclesOf . M.keysSet $ adjacencyMap
@@ -138,6 +181,7 @@ findTriangles edges = S.unions . S.map threeCyclesOf . M.keysSet $ adjacencyMap
 
     adjacencyMap = adjacencyMapOf edges
 
+adjacencyMapOf :: Ord b => [(b, b)] -> M.Map b (S.Set b)
 adjacencyMapOf edges = M.fromListWith S.union . map (second S.singleton) $ (edges ++ edgesReversed)
   where
     edgesReversed = map (\(a, b) -> (b, a)) edges
@@ -167,7 +211,7 @@ voroniRegionAverageColor image (x', y') =
     . filter ((== 3) . S.size)
     . map (S.fromList . take 3)
     . tails
-        . L.nub
+    . nubOrd
     . map scaleToImageCoords
   where
     scaleToImageCoords :: P2 Double -> P2 Int