swapping to voroni diagram

.envrc

@@ -0,0 +1 @@
+use flake;

.gitignore

@@ -1,4 +1 @@
-.stack-work/*
-dist/*
 /dist-newstyle/
-/cabal.project.local

README.md

@@ -1,9 +1,9 @@
 # image-triangles
 ### examples
 ![Sierra mountains original](examples/sierra.jpg)
-![Sierra mountains post-filter](examples/sierra-result.webp)
+![Sierra mountains post-filter](examples/sierra-result.svg)
 ![Dog original](examples/luna.jpeg)
-![Dog post-filter](examples/luna-result.webp)
+![Dog post-filter](examples/luna-result.svg)
 
 ### to run:
 
@@ -11,5 +11,5 @@ Install [cabal & ghc](https://www.haskell.org/ghcup/) if you don't have them.
 
 ```
 cabal update
-cabal run image-triangles -- --cornerCount 1000 --input examples/sierra.jpg --output output.png
+cabal run image-triangles -- --cornerCount 800 --input examples/sierra.jpg --output output.svg
 ```

cabal.project

@@ -0,0 +1,5 @@
+packages:
+         ./
+
+-- package repa
+--         ghc-options: -fincomplete-uni-patterns

flake.lock

@@ -0,0 +1,134 @@
+{
+  "nodes": {
+    "flake-parts": {
+      "inputs": {
+        "nixpkgs-lib": "nixpkgs-lib"
+      },
+      "locked": {
+        "lastModified": 1704982712,
+        "narHash": "sha256-2Ptt+9h8dczgle2Oo6z5ni5rt/uLMG47UFTR1ry/wgg=",
+        "owner": "hercules-ci",
+        "repo": "flake-parts",
+        "rev": "07f6395285469419cf9d078f59b5b49993198c00",
+        "type": "github"
+      },
+      "original": {
+        "owner": "hercules-ci",
+        "repo": "flake-parts",
+        "type": "github"
+      }
+    },
+    "haskell-flake": {
+      "locked": {
+        "lastModified": 1705079807,
+        "narHash": "sha256-8snpmo0PGMqirgVnw9OnHF2FtsVkcdWLup+TzV3PCIE=",
+        "owner": "srid",
+        "repo": "haskell-flake",
+        "rev": "55efd0cbf1b5b4a402dc88c3c962c24e13f0fd8b",
+        "type": "github"
+      },
+      "original": {
+        "owner": "srid",
+        "repo": "haskell-flake",
+        "type": "github"
+      }
+    },
+    "hip": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1680449103,
+        "narHash": "sha256-7mO0EifBLn16iTCxiOF74Ek89TDj4na6O7/WgAxKcp0=",
+        "owner": "lehins",
+        "repo": "hip",
+        "rev": "05adf58fa2581f4940e8d1b28280f64aea02f3ee",
+        "type": "github"
+      },
+      "original": {
+        "owner": "lehins",
+        "repo": "hip",
+        "type": "github"
+      }
+    },
+    "nixpkgs": {
+      "locked": {
+        "lastModified": 1704290814,
+        "narHash": "sha256-LWvKHp7kGxk/GEtlrGYV68qIvPHkU9iToomNFGagixU=",
+        "owner": "nixos",
+        "repo": "nixpkgs",
+        "rev": "70bdadeb94ffc8806c0570eb5c2695ad29f0e421",
+        "type": "github"
+      },
+      "original": {
+        "owner": "nixos",
+        "ref": "nixos-23.05",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "nixpkgs-lib": {
+      "locked": {
+        "dir": "lib",
+        "lastModified": 1703961334,
+        "narHash": "sha256-M1mV/Cq+pgjk0rt6VxoyyD+O8cOUiai8t9Q6Yyq4noY=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "b0d36bd0a420ecee3bc916c91886caca87c894e9",
+        "type": "github"
+      },
+      "original": {
+        "dir": "lib",
+        "owner": "NixOS",
+        "ref": "nixos-unstable",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "root": {
+      "inputs": {
+        "flake-parts": "flake-parts",
+        "haskell-flake": "haskell-flake",
+        "hip": "hip",
+        "nixpkgs": "nixpkgs",
+        "systems": "systems",
+        "treefmt-nix": "treefmt-nix"
+      }
+    },
+    "systems": {
+      "locked": {
+        "lastModified": 1681028828,
+        "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
+        "owner": "nix-systems",
+        "repo": "default",
+        "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
+        "type": "github"
+      },
+      "original": {
+        "owner": "nix-systems",
+        "repo": "default",
+        "type": "github"
+      }
+    },
+    "treefmt-nix": {
+      "inputs": {
+        "nixpkgs": [
+          "nixpkgs"
+        ]
+      },
+      "locked": {
+        "lastModified": 1704649711,
+        "narHash": "sha256-+qxqJrZwvZGilGiLQj3QbYssPdYCwl7ejwMImgH7VBQ=",
+        "owner": "numtide",
+        "repo": "treefmt-nix",
+        "rev": "04f25d7bec9fb29d2c3bacaa48a3304840000d36",
+        "type": "github"
+      },
+      "original": {
+        "owner": "numtide",
+        "repo": "treefmt-nix",
+        "type": "github"
+      }
+    }
+  },
+  "root": "root",
+  "version": 7
+}

flake.nix

@@ -0,0 +1,104 @@
+{
+  description = "srid/haskell-template: Nix template for Haskell projects";
+  inputs = {
+    nixpkgs.url = "github:nixos/nixpkgs/nixos-23.05";
+    systems.url = "github:nix-systems/default";
+    flake-parts.url = "github:hercules-ci/flake-parts";
+    haskell-flake.url = "github:srid/haskell-flake";
+    treefmt-nix.url = "github:numtide/treefmt-nix";
+    treefmt-nix.inputs.nixpkgs.follows = "nixpkgs";
+    hip.url = "github:lehins/hip";
+    hip.flake = false;
+  };
+
+  outputs = inputs:
+    inputs.flake-parts.lib.mkFlake { inherit inputs; } {
+      systems = import inputs.systems;
+      imports = [
+        inputs.haskell-flake.flakeModule
+        inputs.treefmt-nix.flakeModule
+      ];
+      perSystem = { self', system, lib, config, pkgs, ... }: {
+        # Our only Haskell project. You can have multiple projects, but this template
+        # has only one.
+        # See https://github.com/srid/haskell-flake/blob/master/example/flake.nix
+        haskellProjects.default = {
+          # The base package set (this value is the default)
+          # basePackages = pkgs.haskellPackages;
+
+          # Packages to add on top of `basePackages`
+          packages = {
+            # Add source or Hackage overrides here
+            # (Local packages are added automatically)
+            # https://github.com/lehins/hip.git
+            # hip.source = inputs.hip + "/hip";
+          };
+
+          # Add your package overrides here
+          settings = {
+
+            /*
+            haskell-template = {
+              haddock = false;
+            };
+            aeson = {
+              check = false;
+            };
+            */
+            hip = {
+              jailbreak = true;
+              broken = false;
+              failOnAllWarnings = false;
+              check = false;
+              # extraBuildFlags = ["--ghc-option=-Wno-incomplete-uni-patterns"];
+            };
+          };
+
+          # Development shell configuration
+          devShell = {
+            hlsCheck.enable = false;
+          };
+
+          # What should haskell-flake add to flake outputs?
+          autoWire = [ "packages" "apps" "checks" ]; # Wire all but the devShell
+        };
+
+        # Auto formatters. This also adds a flake check to ensure that the
+        # source tree was auto formatted.
+        treefmt.config = {
+          projectRootFile = "flake.nix";
+
+          programs.ormolu.enable = true;
+          programs.nixpkgs-fmt.enable = true;
+          programs.cabal-fmt.enable = true;
+          programs.hlint.enable = true;
+
+          # We use fourmolu
+          # programs.ormolu.package = pkgs.haskellPackages.fourmolu;
+          # settings.formatter.ormolu = {
+          #   options = [
+          #     "--ghc-opt"
+          #     "-XImportQualifiedPost"
+          #   ];
+          # };
+        };
+
+        # Default package & app.
+        packages.default = self'.packages.image-triangles;
+        apps.default = self'.apps.image-triangles;
+
+        # Default shell.
+        devShells.default = pkgs.mkShell {
+          name = "haskell-template";
+          meta.description = "Haskell development environment";
+          # See https://zero-to-flakes.com/haskell-flake/devshell#composing-devshells
+          inputsFrom = [
+            config.haskellProjects.default.outputs.devShell
+            config.treefmt.build.devShell
+          ];
+          nativeBuildInputs = with pkgs; [
+          ];
+        };
+      };
+    };
+}

image-triangles.cabal

@@ -1,3 +1,4 @@
+cabal-version:       3.4
 -- Initial image-triangles.cabal generated by cabal init.  For further
 -- documentation, see http://haskell.org/cabal/users-guide/
 
@@ -19,7 +20,7 @@ version:             0.1.0.0
 -- description:
 
 -- The license under which the package is released.
-license:             BSD3
+license:             BSD-3-Clause
 
 -- The file containing the license text.
 license-file:        LICENSE
@@ -40,10 +41,8 @@ build-type:          Simple
 
 -- Extra files to be distributed with the package, such as examples or a
 -- README.
-extra-source-files:  CHANGELOG.md, README.md
+extra-source-files:  README.md
 
--- Constraint on the version of Cabal needed to build this package.
-cabal-version:       >=1.10
 
 
 executable image-triangles
@@ -51,7 +50,7 @@ executable image-triangles
   main-is:             Main.hs
 
   -- Modules included in this executable, other than Main.
-  other-modules: Render, Triangles
+  other-modules: Render, Triangles, CircumCircle
 
   -- LANGUAGE extensions used by modules in this package.
   default-extensions:  ScopedTypeVariables,
@@ -84,7 +83,6 @@ executable image-triangles
                      , diagrams-cairo
                      , diagrams-svg
                      , parallel
-                     , repa
                      , linear
                      , vector
                      , containers

src/CircumCircle.hs

@@ -0,0 +1,65 @@
+module CircumCircle where
+import Diagrams.Prelude
+import Triangles
+import qualified Data.Set as S
+import qualified Data.List as L
+import Diagrams.TwoD
+import Diagrams.Direction
+import qualified Data.Colour.Names as CN
+import Diagrams.Backend.SVG
+import GHC.Generics
+import Data.Maybe
+
+data Circle n = Circle {
+  loc :: P2 n,
+  radius :: n
+                     }
+
+placeCircle :: Colour Double -> Circle Double -> Diagram B
+placeCircle col (Circle{..}) = circle radius # translate (loc .-. origin) # lw 0 # fc col
+
+-- placeCircle (Circle{loc = loc, radius = rad}) = circle rad $ fc blue -- # opacity .25
+
+circumCircle :: (Ord a, Floating a) => S.Set (P2 a) -> Maybe (Circle a)
+circumCircle pts = circumCircleFromLoc <$> loc
+  where
+    circumCircleFromLoc loc' = Circle loc' (magnitude $ p1 .-. loc')
+
+    loc = listToMaybe $ intersectPointsT (mapLoc (fromOffsets. L.singleton . (^* circumfrence) . fromDir) bisectP1P2)
+                                         (mapLoc (fromOffsets. L.singleton . (^* circumfrence) . fromDir) bisectP2P3)
+
+    bisectP1P2 = bisect p1 p2
+
+    bisectP2P3 = bisect p2 p3
+
+    [p1, p2, p3] = L.sortOn (snd . unp2) . S.toList $ pts
+
+    circumfrence = sum . map magnitude $ [(p2 .-. p1), (p2 .-. p3), (p1 .-. p3)]
+
+
+-- circumDebug :: (Ord a, Floating a) => S.Set (P2 a) -> Maybe (Circle a)
+circumDebug pts = (bisectP1P2, bisectP2P3)
+  where
+    circumCircleFromLoc loc' = Circle loc' (magnitude $ p1 .-. loc')
+
+    loc = listToMaybe $ intersectPointsT (mapLoc (fromOffsets. L.singleton . fromDir) bisectP1P2) (mapLoc (fromOffsets. L.singleton . fromDir) bisectP1P2)
+
+    bisectP1P2 = bisect p1 p2
+
+    bisectP2P3 = bisect p2 p3
+
+    [p1, p2, p3] = L.sortOn (snd . unp2) . S.toList $ pts
+
+    circumfrence = 400
+
+
+magnitude :: Floating a => V2 a -> a
+magnitude v = sqrt (x * x + y * y)
+  where
+    (x, y) = unr2 v
+
+-- assumes x of p1 is smaller than x of p2
+bisect :: Floating n => Point V2 n -> Point V2 n -> Located (Direction V2 n)
+bisect p1 p2 = at (rotateBy (1 / 4) $ dir bisectVec) (p1 .+^ bisectVec)
+  where
+    bisectVec = (p2 .-. p1) ^/ 2

src/Main.hs

@@ -22,7 +22,7 @@ import qualified System.Environment as Env
 import qualified Data.Map as M
 import qualified Data.Set as S
 import Diagrams.Backend.SVG
-import Diagrams.Backend.Cairo
+import qualified Data.Colour.Names as CN
 import Triangles (getTriangleAverageRGB)
 import Options.Generic
 import qualified Data.Colour.SRGB as CL
@@ -31,6 +31,7 @@ import qualified Data.Maybe as My
 import Control.Arrow
 import Data.Colour.RGBSpace (uncurryRGB)
 import qualified Control.Monad.Parallel as MP
+import qualified CircumCircle as CC
 
 data Options = Options {
                     numPoints :: Int,
@@ -55,7 +56,7 @@ corners = (,) <$> [0, 1] <*> [0, 1]
 scalePointToImage :: (Int, Int) -> Point V2 Double -> Point V2 Int
 scalePointToImage (ymax, xmax) p = round <$> (p2 (fromIntegral xmax, fromIntegral ymax) * p)
 
-genImage :: Image VU G.RGB Double -> StdGen -> Int -> QDiagram Cairo V2 Double Any
+genImage :: Image VU G.RGB Double -> StdGen -> Int -> QDiagram B V2 Double Any
 genImage image gen cornerCount =
   scaleY widthHeightRatio
   . reflectY
@@ -75,6 +76,30 @@ genImage image gen cornerCount =
       where
         scaled = S.map (scalePointToImage dimensions) tri
 
+
+
+-- genImage' :: Image VU G.RGB Double -> StdGen -> Int -> QDiagram Cairo V2 Double Any
+genImage' image gen cornerCount =  -- image gen cornerCount =
+  scaleY widthHeightRatio
+  . reflectY
+  . rectEnvelope (mkP2 0 0) (1 ^& 1)
+  . position
+  . map (\shape -> (head shape, ) . showOrigin
+                    . fillColor (Tri.getShapeAverageRGB img' dimensions . map (scalePointToImage dimensions) $ shape)
+                    . strokeLoop  . closeLine . fromVertices $ shape)
+  -- . withStrategy (parListChunk 1000 rdeepseq)
+  $ voroni
+  where
+    widthHeightRatio = (fromIntegral $ fst dimensions) / ((fromIntegral $ snd dimensions) :: Double)
+
+    triColor tri = getTriangleAverageRGB img' dimensions <$> (if S.size scaled == 3 then Just scaled else Nothing)
+      where
+        scaled = S.map (scalePointToImage dimensions) tri
+
+    img' = convImage image
+    dimensions = Img.dims image
+    voroni = take 40 . Tri.findVoroniDiagram . withStrategy (parListChunk 1000 rdeepseq) . Tri.toPlanarGraph . take cornerCount . map p2 $ corners ++ Tri.randomPoints gen
+
 deriving instance Generic (CL.RGB a)
 deriving instance NFData a => NFData (CL.RGB a)
 
@@ -93,12 +118,12 @@ main :: IO ()
 main = do
   CLIOptions{..} <- getRecord "image options"
   let (Options {gen = gen}) = defaultOpts
-  gen' <- getStdGen
+  gen' <- pure . mkStdGen $ 2345 -- getStdGen
   let gens :: [StdGen] = map fst . iterate (split . snd) . split $ gen'
   print gen'
   image <- Img.readImageRGB VU input
   let diagram = genImage image gen' cornerCount
   let nums = zip gens $ map show [0..60]
   let dimVector = toDimensionVector image
-  renderCairo output dimVector (genImage image gen' cornerCount)
+  renderSVG output dimVector (genImage' image gen' cornerCount)
   -- MP.forM_ nums (\(gen'', x) -> renderCairo ("output/" ++ x  ++ "-" ++ output) dimVector (genImage image gen'' cornerCount))

src/Main.log

@@ -0,0 +1,36 @@
+This is pdfTeX, Version 3.141592653-2.6-1.40.22 (TeX Live 2021/VoidLinux) (preloaded format=pdflatex 2023.1.13)  8 FEB 2023 18:35
+entering extended mode
+ restricted \write18 enabled.
+ %&-line parsing enabled.
+**/home/jackoe/Documents/projects/image-triangles/src/Main.hs
+(/home/jackoe/Documents/projects/image-triangles/src/Main.hs
+LaTeX2e <2020-10-01> patch level 4
+L3 programming layer <2021-02-18>
+
+! LaTeX Error: Missing \begin{document}.
+
+See the LaTeX manual or LaTeX Companion for explanation.
+Type  H <return>  for immediate help.
+ ...                                              
+                                                  
+l.1 m
+     odule Main where
+? 
+! Emergency stop.
+ ...                                              
+                                                  
+l.1 m
+     odule Main where
+You're in trouble here.  Try typing  <return>  to proceed.
+If that doesn't work, type  X <return>  to quit.
+
+ 
+Here is how much of TeX's memory you used:
+ 19 strings out of 478994
+ 669 string characters out of 5864719
+ 283044 words of memory out of 5000000
+ 17602 multiletter control sequences out of 15000+600000
+ 403430 words of font info for 27 fonts, out of 8000000 for 9000
+ 1141 hyphenation exceptions out of 8191
+ 13i,0n,15p,108b,14s stack positions out of 5000i,500n,10000p,200000b,80000s
+!  ==> Fatal error occurred, no output PDF file produced!

src/Render.hs

@@ -11,6 +11,9 @@ import qualified Data.Colour.Names as CN
 
 
 -- makeTriangle :: [Point V2 Double] -> Colour Double -> Diagram SVG
+-- makeTriangle :: (base-4.16.4.0:Data.Typeable.Internal.Typeable n, RealFloat n,
+--  Renderable (Path V2 n) b) =>
+-- [Point V2 n] -> Colour Double -> QDiagram b V2 n Any
 makeTriangle verts col = fromVertices verts
     # mapLoc closeLine
     # strokeLocLoop 

src/Triangles.hs

@@ -28,6 +28,7 @@ import Diagrams.Prelude
 import qualified Data.Map as M
 import qualified Data.Set as S
 import Control.Arrow
+import qualified Data.List as L
 -- import qualified Linear.Affine as L
 type Image_ = Vec.Vector Pixel_
 type Pixel_ = Colour Double
@@ -66,6 +67,7 @@ combinations xs =
     edgeLengthThreshold = 45
 
 -- toPlanarGraph :: (NFData n, Floating n, Ord n) => [Point V2 n] -> [(Point V2 n, Point V2 n)]
+toPlanarGraph :: (NFData n, Floating n, Ord n) => [P2 n] -> [(Point V2 n, Point V2 n)]
 toPlanarGraph points =
   removeIntersections . combinations $ points
   where
@@ -82,6 +84,14 @@ toPlanarGraph points =
 toLocatedTrail :: TrailLike a => Point (V a) (N a) -> Point (V a) (N a) -> Located a
 toLocatedTrail p1 p2 = fromVertices [p1, p2] `at` p1
 
+-- findVoroniDiagram :: (Ord (v n), Additive v, Fractional n) => [(Point v n, Point v n)] -> [[Point v n]]
+findVoroniDiagram :: (Ord n, Ord (v n), Metric v, Floating n, R1 v, Real n) => [(Point v n, Point v n)] -> [[Point v n]]
+findVoroniDiagram edges = M.elems . M.mapWithKey (\key -> L.sortOn (normalizeAngle . angleBetweenDirs xDir . dirBetween key) .
+                                                   map (pointBetween key) . S.toList) $ adjacencyMap
+  where
+    adjacencyMap = adjacencyMapOf edges
+
+    pointBetween p0 p1 = p0 .+^ ((p0 .-. p1) ^/ 2)
 
 findTriangles :: Ord b => [(b, b)] -> S.Set (S.Set b)
 findTriangles edges = S.unions . S.map threeCyclesOf . M.keysSet $ adjacencyMap
@@ -92,9 +102,14 @@ findTriangles edges = S.unions . S.map threeCyclesOf . M.keysSet $ adjacencyMap
       where
         originalNodeNeighbors = fromMaybe S.empty (adjacencyMap M.!? node)
 
-    adjacencyMap = M.fromListWith S.union . map (second S.singleton) $ (edges ++ edgesReversed)
+    adjacencyMap = adjacencyMapOf edges
+
+adjacencyMapOf edges = M.fromListWith S.union . map (second S.singleton) $ (edges ++ edgesReversed)
+  where
     edgesReversed = map (\(a, b) -> (b, a)) edges
 
+triangleAdjacencyMap :: Ord b => S.Set (S.Set b) -> M.Map b (S.Set (S.Set b))
+triangleAdjacencyMap s = M.fromListWith S.union . concatMap (\s' -> map (, S.singleton s') . S.toList $ s') $ S.toList s
 
 getPointsInTriangle :: p -> S.Set (P2 Int) -> [(Int, Int)]
 getPointsInTriangle image pts = S.toList . S.unions . map S.fromList $ [
@@ -108,8 +123,11 @@ blendEqually colors = C.affineCombo (zip (repeat fraction) colors) $ C.black
     where
         fraction = 1.0 / (fromIntegral . length $ colors)
 
-getTriangleAverageRGB :: Image_ -> (Int, Int) -> S.Set (P2 Int)  -> C.Colour Double
+getShapeAverageRGB :: Image_ -> (Int, Int) -> [P2 Int] -> C.Colour Double
-getTriangleAverageRGB image (y', x') triangle = blendEqually pixels
+getShapeAverageRGB image sizes = blendEqually . concatMap (getColorsInTriangle image sizes) . filter ((== 3) . S.size) . map (S.fromList . take 3) . tails . L.sortOn (fst . unp2)
+
+getColorsInTriangle :: Image_ -> (Int, Int) -> S.Set (P2 Int)  -> [C.Colour Double]
+getColorsInTriangle image (y', x') triangle = pixels
     where
 
         pixels :: [Pixel_]
@@ -126,6 +144,11 @@ getTriangleAverageRGB image (y', x') triangle = blendEqually pixels
             | x < 0   = Nothing
             | otherwise = image Vec.!? ((y * x') + x)
 
+
+getTriangleAverageRGB :: Image_ -> (Int, Int) -> S.Set (P2 Int)  -> C.Colour Double
+getTriangleAverageRGB image (y', x') triangle = blendEqually $ getColorsInTriangle image (y', x') triangle
+
+
 ptsBtween :: LineMXB -> LineMXB -> [(Int, Int)]
 ptsBtween l1 l2 = concatMap rasterLine . noSingletons $ [startingX .. endingX]
     where