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.
14
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.
|
Makes a [voroni diagram](https://en.wikipedia.org/wiki/Voronoi_diagram) and fills each cell with the average color the image below in.
|
||||||
|
|
||||||
### examples
|
### examples
|
||||||

|

|
||||||

|

|
||||||

|

|
||||||

|

|
||||||

|

|
||||||

|

|
||||||
|
|
||||||
|
|
||||||
### to run:
|
### to run:
|
||||||
|
|
@ -16,7 +16,7 @@ Makes a [voroni diagram](https://en.wikipedia.org/wiki/Voronoi_diagram) and fill
|
||||||
#### with nix
|
#### 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
|
#### with cabal
|
||||||
|
|
@ -24,6 +24,6 @@ Install [cabal & ghc](https://www.haskell.org/ghcup/) if you don't have them.
|
||||||
|
|
||||||
```
|
```
|
||||||
cabal update
|
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
|
||||||
```
|
```
|
||||||
|
|
||||||
|
|
|
||||||
BIN
examples/birds-eye-view-result.jpeg
Normal file
|
After Width: | Height: | Size: 4.9 MiB |
|
Before Width: | Height: | Size: 5.4 MiB |
BIN
examples/luna-result.jpeg
Normal file
|
After Width: | Height: | Size: 4.4 MiB |
|
Before Width: | Height: | Size: 820 KiB After Width: | Height: | Size: 820 KiB |
|
Before Width: | Height: | Size: 9.1 MiB |
BIN
examples/sierra-result.jpeg
Normal file
|
After Width: | Height: | Size: 2.3 MiB |
|
Before Width: | Height: | Size: 7.8 MiB |
|
Before Width: | Height: | Size: 372 KiB After Width: | Height: | Size: 372 KiB |
48
flake.lock
generated
|
|
@ -5,11 +5,11 @@
|
||||||
"nixpkgs-lib": "nixpkgs-lib"
|
"nixpkgs-lib": "nixpkgs-lib"
|
||||||
},
|
},
|
||||||
"locked": {
|
"locked": {
|
||||||
"lastModified": 1706830856,
|
"lastModified": 1717285511,
|
||||||
"narHash": "sha256-a0NYyp+h9hlb7ddVz4LUn1vT/PLwqfrWYcHMvFB1xYg=",
|
"narHash": "sha256-iKzJcpdXih14qYVcZ9QC9XuZYnPc6T8YImb6dX166kw=",
|
||||||
"owner": "hercules-ci",
|
"owner": "hercules-ci",
|
||||||
"repo": "flake-parts",
|
"repo": "flake-parts",
|
||||||
"rev": "b253292d9c0a5ead9bc98c4e9a26c6312e27d69f",
|
"rev": "2a55567fcf15b1b1c7ed712a2c6fadaec7412ea8",
|
||||||
"type": "github"
|
"type": "github"
|
||||||
},
|
},
|
||||||
"original": {
|
"original": {
|
||||||
|
|
@ -23,11 +23,11 @@
|
||||||
"systems": "systems"
|
"systems": "systems"
|
||||||
},
|
},
|
||||||
"locked": {
|
"locked": {
|
||||||
"lastModified": 1705309234,
|
"lastModified": 1710146030,
|
||||||
"narHash": "sha256-uNRRNRKmJyCRC/8y1RqBkqWBLM034y4qN7EprSdmgyA=",
|
"narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=",
|
||||||
"owner": "numtide",
|
"owner": "numtide",
|
||||||
"repo": "flake-utils",
|
"repo": "flake-utils",
|
||||||
"rev": "1ef2e671c3b0c19053962c07dbda38332dcebf26",
|
"rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a",
|
||||||
"type": "github"
|
"type": "github"
|
||||||
},
|
},
|
||||||
"original": {
|
"original": {
|
||||||
|
|
@ -38,11 +38,11 @@
|
||||||
},
|
},
|
||||||
"haskell-flake": {
|
"haskell-flake": {
|
||||||
"locked": {
|
"locked": {
|
||||||
"lastModified": 1708536395,
|
"lastModified": 1717339509,
|
||||||
"narHash": "sha256-z6rxsqQ9/xS3FWc2iLvFnElNt45XehD7bzPe4Yooz08=",
|
"narHash": "sha256-ySll9pAYK78v8GY5wrCFLg2iMI6Ms/4tNfrvlMaUQ1M=",
|
||||||
"owner": "srid",
|
"owner": "srid",
|
||||||
"repo": "haskell-flake",
|
"repo": "haskell-flake",
|
||||||
"rev": "1e297173b23c5113dd90a2d299d6e0d864af35f1",
|
"rev": "cfb7db6b7b66cb7d1499dd53b8aeaa7c866f565f",
|
||||||
"type": "github"
|
"type": "github"
|
||||||
},
|
},
|
||||||
"original": {
|
"original": {
|
||||||
|
|
@ -53,11 +53,11 @@
|
||||||
},
|
},
|
||||||
"nixpkgs": {
|
"nixpkgs": {
|
||||||
"locked": {
|
"locked": {
|
||||||
"lastModified": 1708475490,
|
"lastModified": 1717602782,
|
||||||
"narHash": "sha256-g1v0TsWBQPX97ziznfJdWhgMyMGtoBFs102xSYO4syU=",
|
"narHash": "sha256-pL9jeus5QpX5R+9rsp3hhZ+uplVHscNJh8n8VpqscM0=",
|
||||||
"owner": "nixos",
|
"owner": "nixos",
|
||||||
"repo": "nixpkgs",
|
"repo": "nixpkgs",
|
||||||
"rev": "0e74ca98a74bc7270d28838369593635a5db3260",
|
"rev": "e8057b67ebf307f01bdcc8fba94d94f75039d1f6",
|
||||||
"type": "github"
|
"type": "github"
|
||||||
},
|
},
|
||||||
"original": {
|
"original": {
|
||||||
|
|
@ -69,20 +69,14 @@
|
||||||
},
|
},
|
||||||
"nixpkgs-lib": {
|
"nixpkgs-lib": {
|
||||||
"locked": {
|
"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": {
|
"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": {
|
"root": {
|
||||||
|
|
@ -116,11 +110,11 @@
|
||||||
]
|
]
|
||||||
},
|
},
|
||||||
"locked": {
|
"locked": {
|
||||||
"lastModified": 1708335038,
|
"lastModified": 1717278143,
|
||||||
"narHash": "sha256-ETLZNFBVCabo7lJrpjD6cAbnE11eDOjaQnznmg/6hAE=",
|
"narHash": "sha256-u10aDdYrpiGOLoxzY/mJ9llST9yO8Q7K/UlROoNxzDw=",
|
||||||
"owner": "numtide",
|
"owner": "numtide",
|
||||||
"repo": "treefmt-nix",
|
"repo": "treefmt-nix",
|
||||||
"rev": "e504621290a1fd896631ddbc5e9c16f4366c9f65",
|
"rev": "3eb96ca1ae9edf792a8e0963cc92fddfa5a87706",
|
||||||
"type": "github"
|
"type": "github"
|
||||||
},
|
},
|
||||||
"original": {
|
"original": {
|
||||||
|
|
|
||||||
|
|
@ -64,6 +64,7 @@ executable image-triangles
|
||||||
MultiParamTypeClasses
|
MultiParamTypeClasses
|
||||||
OverloadedLabels
|
OverloadedLabels
|
||||||
OverloadedStrings
|
OverloadedStrings
|
||||||
|
StrictData
|
||||||
RankNTypes
|
RankNTypes
|
||||||
RecordWildCards
|
RecordWildCards
|
||||||
RecursiveDo
|
RecursiveDo
|
||||||
|
|
@ -82,17 +83,19 @@ executable image-triangles
|
||||||
, Color
|
, Color
|
||||||
, colour
|
, colour
|
||||||
, containers
|
, containers
|
||||||
, diagrams-cairo
|
|
||||||
, diagrams-contrib
|
, diagrams-contrib
|
||||||
, diagrams-lib
|
, diagrams-lib
|
||||||
, diagrams-svg
|
, diagrams-rasterific
|
||||||
, linear
|
, linear
|
||||||
, massiv
|
, massiv
|
||||||
, massiv-io
|
, massiv-io
|
||||||
, monad-parallel
|
, monad-parallel
|
||||||
, optparse-generic
|
, optparse-generic
|
||||||
, parallel
|
, parallel
|
||||||
|
, pqueue
|
||||||
|
, psqueues
|
||||||
, random
|
, random
|
||||||
|
, heaps
|
||||||
, splitmix
|
, splitmix
|
||||||
, vector
|
, vector
|
||||||
, vector-th-unbox
|
, vector-th-unbox
|
||||||
|
|
@ -102,7 +105,5 @@ executable image-triangles
|
||||||
|
|
||||||
-- Base language which the package is written in.
|
-- Base language which the package is written in.
|
||||||
default-language: GHC2021
|
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"
|
|
||||||
|
|
|
||||||
84
src/Main.hs
|
|
@ -25,10 +25,9 @@ import Debug.Trace qualified as D
|
||||||
import Debug.Trace qualified as DT
|
import Debug.Trace qualified as DT
|
||||||
import Debug.Trace qualified as T
|
import Debug.Trace qualified as T
|
||||||
import Diagrams qualified as DP
|
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 GHC.Generics
|
||||||
import Graphics.Color.Space qualified as Co
|
import Graphics.Color.Space qualified as Co
|
||||||
import MinDistanceSample qualified as MDS
|
import MinDistanceSample qualified as MDS
|
||||||
|
|
@ -49,24 +48,27 @@ corners = (,) <$> [0, 1] <*> [0, 1]
|
||||||
shapeCircumference :: [Point V2 Double] -> Double
|
shapeCircumference :: [Point V2 Double] -> Double
|
||||||
shapeCircumference = Data.List.sum . map D.norm . loopOffsets . fromVertices
|
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 =
|
genImage image dimensionsVec minDistance gen =
|
||||||
scaleX widthHeightRatio
|
scaleX widthHeightRatio
|
||||||
. reflectY
|
. reflectY
|
||||||
. rectEnvelope (mkP2 0 0) (1 ^& 1)
|
. rectEnvelope (mkP2 0 0) (1 ^& 1)
|
||||||
. mconcat
|
. mconcat
|
||||||
. map drawVoroniRegion
|
. map ((\x -> drawVoroniRegion x <> overlayEdges x) . uncurry Tri.voroniDiagramCorners)
|
||||||
. sortOn shapeCircumference
|
$ voroni
|
||||||
. withStrategy (parListChunk 200 rdeepseq)
|
|
||||||
. map (uncurry Tri.voroniDiagramCorners)
|
|
||||||
$ voroni
|
|
||||||
where
|
where
|
||||||
|
overlayEdges =
|
||||||
|
lw 3.0
|
||||||
|
. lc black
|
||||||
|
. strokeLocLoop
|
||||||
|
. fromVertices
|
||||||
|
|
||||||
drawVoroniRegion shape =
|
drawVoroniRegion shape =
|
||||||
lw 0
|
lw 0
|
||||||
. fillColor (Tri.voroniRegionAverageColor image dimensions shape)
|
. fillColor (Tri.voroniRegionAverageColor image dimensions shape)
|
||||||
. strokeLocLoop
|
. strokeLocLoop
|
||||||
. fromVertices
|
. fromVertices
|
||||||
$ shape
|
$ shape
|
||||||
|
|
||||||
widthHeightRatio :: Double
|
widthHeightRatio :: Double
|
||||||
widthHeightRatio = (dimensionsVec ^. _x) / (dimensionsVec ^. _y)
|
widthHeightRatio = (dimensionsVec ^. _x) / (dimensionsVec ^. _y)
|
||||||
|
|
@ -76,19 +78,7 @@ genImage image dimensionsVec minDistance gen =
|
||||||
|
|
||||||
singleVoroni = last voroni
|
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
|
averageSideSize = (fromIntegral (uncurry (+) dimensions)) / 2
|
||||||
|
|
||||||
|
|
@ -96,9 +86,9 @@ genImage image dimensionsVec minDistance gen =
|
||||||
|
|
||||||
corners' :: [P2 Double]
|
corners' :: [P2 Double]
|
||||||
corners' =
|
corners' =
|
||||||
map (p2 . Bi.first (/ widthHeightRatio) . unp2 . (.-^ ((/ 2) <$> padding)))
|
map (p2 . Bi.first (/ widthHeightRatio) . unp2 . (.-^ ((/ 2) <$> padding)))
|
||||||
. MDS.randomPoints ((mkP2 widthHeightRatio 1) .+^ padding) (minDistance * widthHeightRatio)
|
. MDS.randomPoints ((mkP2 widthHeightRatio 1) .+^ padding) (minDistance * widthHeightRatio)
|
||||||
$ gen
|
$ gen
|
||||||
|
|
||||||
deriving instance Generic (CL.RGB a)
|
deriving instance Generic (CL.RGB a)
|
||||||
|
|
||||||
|
|
@ -106,22 +96,22 @@ deriving instance (NFData a) => NFData (CL.RGB a)
|
||||||
|
|
||||||
toDimensionVector :: (Ma.Size r, Fractional a) => Ma.Array r Ma.Ix2 e -> V2 a
|
toDimensionVector :: (Ma.Size r, Fractional a) => Ma.Array r Ma.Ix2 e -> V2 a
|
||||||
toDimensionVector image =
|
toDimensionVector image =
|
||||||
p2 (fromIntegral cols, fromIntegral rows) .-. p2 (0.0, 0.0)
|
p2 (fromIntegral cols, fromIntegral rows) .-. p2 (0.0, 0.0)
|
||||||
where
|
where
|
||||||
(M.Sz2 rows cols) = Ma.size image
|
(M.Sz2 rows cols) = Ma.size image
|
||||||
|
|
||||||
data CLIOptions = CLIOptions
|
data CLIOptions = CLIOptions
|
||||||
{ input :: FilePath,
|
{ input :: FilePath,
|
||||||
output :: FilePath,
|
output :: FilePath,
|
||||||
minDistance :: Double
|
minDistance :: Double
|
||||||
}
|
}
|
||||||
deriving (Generic, ParseRecord)
|
deriving (Generic, ParseRecord)
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
CLIOptions {..} <- getRecord "image options"
|
CLIOptions {..} <- getRecord "image options"
|
||||||
gen' <- getStdGen -- for consistency, swap with something like: pure . mkStdGen $ 2344
|
gen' <- getStdGen
|
||||||
print gen'
|
print gen'
|
||||||
image :: M.Image M.S (Co.SRGB 'Co.Linear) Double <- M.readImageAuto input
|
image :: M.Image M.S (Co.SRGB 'Co.Linear) Double <- M.readImageAuto input
|
||||||
let dims = toDimensionVector image
|
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')
|
||||||
|
|
|
||||||
174
src/Triangles.hs
|
|
@ -17,7 +17,9 @@ import Data.Massiv.Array qualified as Ma
|
||||||
import Data.Massiv.Array.IO qualified as Ma
|
import Data.Massiv.Array.IO qualified as Ma
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.Ord qualified as O
|
import Data.Ord qualified as O
|
||||||
|
import Data.PQueue.Prio.Min qualified as PQ
|
||||||
import Data.Ratio
|
import Data.Ratio
|
||||||
|
import Diagrams.Prelude
|
||||||
import Data.Set qualified as S
|
import Data.Set qualified as S
|
||||||
import Data.Vector.Generic.Base (Vector)
|
import Data.Vector.Generic.Base (Vector)
|
||||||
import Data.Vector.Generic.Mutable (MVector)
|
import Data.Vector.Generic.Mutable (MVector)
|
||||||
|
|
@ -26,13 +28,14 @@ import Data.Vector.Unboxed.Deriving
|
||||||
import Debug.Trace (traceShow)
|
import Debug.Trace (traceShow)
|
||||||
import Debug.Trace qualified
|
import Debug.Trace qualified
|
||||||
import Debug.Trace qualified as D
|
import Debug.Trace qualified as D
|
||||||
import Diagrams.Prelude
|
|
||||||
import Diagrams.Trail (trailPoints)
|
import Diagrams.Trail (trailPoints)
|
||||||
import Diagrams.TwoD
|
import Diagrams.TwoD
|
||||||
|
import Data.Heap qualified as H
|
||||||
import Diagrams.TwoD.Path.IntersectionExtras qualified as I
|
import Diagrams.TwoD.Path.IntersectionExtras qualified as I
|
||||||
import Diagrams.TwoD.Segment.Bernstein (listToBernstein)
|
import Diagrams.TwoD.Segment.Bernstein (listToBernstein)
|
||||||
import Graphics.Color.Space qualified as Co
|
import Graphics.Color.Space qualified as Co
|
||||||
import System.Random
|
import System.Random
|
||||||
|
import Data.Containers.ListUtils (nubOrd)
|
||||||
|
|
||||||
toColour :: (Fractional a) => Co.Color (Co.SRGB Co.Linear) a -> Colour a
|
toColour :: (Fractional a) => Co.Color (Co.SRGB Co.Linear) a -> Colour a
|
||||||
toColour (Co.ColorSRGB r g b) = CL.rgb r g b
|
toColour (Co.ColorSRGB r g b) = CL.rgb r g b
|
||||||
|
|
@ -49,28 +52,26 @@ randomPoints = map (bimap toZeroToOneTuple toZeroToOneTuple) . randomRs ((0 :: W
|
||||||
|
|
||||||
combinations :: (Ord b, Floating b, NFData b) => [P2 b] -> [(P2 b, P2 b)]
|
combinations :: (Ord b, Floating b, NFData b) => [P2 b] -> [(P2 b, P2 b)]
|
||||||
combinations =
|
combinations =
|
||||||
sortOn (abs . uncurry distanceA)
|
sortOn (abs . uncurry distanceA)
|
||||||
. S.toList -- deduplicate
|
. nubOrd
|
||||||
. S.fromList
|
. filter (uncurry (/=))
|
||||||
. filter (uncurry (/=))
|
. concat
|
||||||
. concat
|
. map (\(x : xs) -> takeSortOn 10 (abs . uncurry distanceA) . map (x,) $ xs)
|
||||||
. withStrategy (parListChunk 50 rdeepseq)
|
. init -- last output of tails is empty list
|
||||||
. map (\(x : xs) -> take 10 . sortOn (abs . uncurry distanceA) . map (x,) $ xs)
|
. tails
|
||||||
. init -- last output of tails is empty list
|
|
||||||
. tails
|
|
||||||
|
|
||||||
toPlanarGraph :: forall n. (NFData n, Floating n, Ord n) => [P2 n] -> [(Point V2 n, Point V2 n)]
|
toPlanarGraph :: forall n. (NFData n, Floating n, Ord n) => [P2 n] -> [(Point V2 n, Point V2 n)]
|
||||||
toPlanarGraph =
|
toPlanarGraph =
|
||||||
removeIntersections
|
removeIntersections
|
||||||
. sortOn (abs . uncurry distanceA)
|
. sortOn (abs . uncurry distanceA)
|
||||||
. combinations
|
. combinations
|
||||||
where
|
where
|
||||||
removeIntersections :: [(Point V2 n, Point V2 n)] -> [(Point V2 n, Point V2 n)]
|
removeIntersections :: [(Point V2 n, Point V2 n)] -> [(Point V2 n, Point V2 n)]
|
||||||
removeIntersections = foldl' addIfNoIntersection []
|
removeIntersections = foldl' addIfNoIntersection []
|
||||||
|
|
||||||
addIfNoIntersection xs x
|
addIfNoIntersection xs x
|
||||||
| all (noIntersection x) xs = x : xs
|
| all (noIntersection x) xs = x : xs
|
||||||
| otherwise = xs
|
| otherwise = xs
|
||||||
|
|
||||||
noIntersection l1 l2 = sharedEndPoint || (null $ intersectPointsT (uncurry toLocatedTrail l1) (uncurry toLocatedTrail l2))
|
noIntersection l1 l2 = sharedEndPoint || (null $ intersectPointsT (uncurry toLocatedTrail l1) (uncurry toLocatedTrail l2))
|
||||||
where
|
where
|
||||||
|
|
@ -88,12 +89,14 @@ sortOnAngle center = sortOn (normalizeAngle . signedAngleBetweenDirs xDir . dirB
|
||||||
|
|
||||||
voroniDiagramCorners :: (RealFloat n) => Point V2 n -> [Point V2 n] -> [Point V2 n]
|
voroniDiagramCorners :: (RealFloat n) => Point V2 n -> [Point V2 n] -> [Point V2 n]
|
||||||
voroniDiagramCorners center midpoints =
|
voroniDiagramCorners center midpoints =
|
||||||
sortOnAngle center
|
sortOnAngle center
|
||||||
. filter isValidMidpoint
|
. filter isValidMidpoint
|
||||||
. concat
|
. concat
|
||||||
$ [intersectPointsT l0 l1 | l0 <- tangentTrails, l1 <- tangentTrails]
|
$ [intersectPointsT l0 l1 | l0 <- tangentTrails, l1 <- tangentTrails]
|
||||||
where
|
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
|
tangentTrails = map tangentTrail midpoints
|
||||||
|
|
||||||
|
|
@ -102,42 +105,83 @@ voroniDiagramCorners center midpoints =
|
||||||
isValidMidpoint candidate = all isNonObtuseMidpoint . filter (/= candidate) $ midpoints
|
isValidMidpoint candidate = all isNonObtuseMidpoint . filter (/= candidate) $ midpoints
|
||||||
where
|
where
|
||||||
isNonObtuseMidpoint m =
|
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]
|
tangentTrail midpoint = fromVertices [midpoint .-^ tangentVec, midpoint .+^ tangentVec]
|
||||||
where
|
where
|
||||||
-- implicitly uses the unit vector * 8 as an infinitely long vector
|
-- implicitly uses the unit vector * 8 as an infinitely long vector
|
||||||
tangentVec =
|
tangentVec =
|
||||||
scale 2
|
scale 2
|
||||||
. fromDirection
|
. fromDirection
|
||||||
. rotateBy (1 / 4)
|
. rotateBy (1 / 4)
|
||||||
$ dirBetween midpoint center
|
$ 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 :: (RealFloat n) => [(Point V2 n, Point V2 n)] -> [(Point V2 n, [Point V2 n])]
|
||||||
findVoroniDiagram =
|
findVoroniDiagram =
|
||||||
M.toList
|
M.toList
|
||||||
. M.mapWithKey
|
. M.mapWithKey
|
||||||
( \key ->
|
( \key ->
|
||||||
L.sortOn (normalizeAngle . signedAngleBetweenDirs xDir . dirBetween key)
|
L.sortOn (normalizeAngle . signedAngleBetweenDirs xDir . dirBetween key)
|
||||||
. map (pointBetween key)
|
. map (pointBetween key)
|
||||||
. S.toList
|
. S.toList
|
||||||
)
|
)
|
||||||
. adjacencyMapOf
|
. 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 :: (Ord b) => [(b, b)] -> S.Set (S.Set b)
|
||||||
findTriangles edges = S.unions . S.map threeCyclesOf . M.keysSet $ adjacencyMap
|
findTriangles edges = S.unions . S.map threeCyclesOf . M.keysSet $ adjacencyMap
|
||||||
where
|
where
|
||||||
threeCyclesOf node =
|
threeCyclesOf node =
|
||||||
S.unions
|
S.unions
|
||||||
. S.map (\x -> S.map (\y -> S.fromList [node, x, y]) $ S.delete node . S.intersection originalNodeNeighbors . (M.!) adjacencyMap $ x)
|
. S.map (\x -> S.map (\y -> S.fromList [node, x, y]) $ S.delete node . S.intersection originalNodeNeighbors . (M.!) adjacencyMap $ x)
|
||||||
$ originalNodeNeighbors
|
$ originalNodeNeighbors
|
||||||
where
|
where
|
||||||
originalNodeNeighbors = fromMaybe S.empty (adjacencyMap M.!? node)
|
originalNodeNeighbors = fromMaybe S.empty (adjacencyMap M.!? node)
|
||||||
|
|
||||||
adjacencyMap = adjacencyMapOf edges
|
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)
|
adjacencyMapOf edges = M.fromListWith S.union . map (second S.singleton) $ (edges ++ edgesReversed)
|
||||||
where
|
where
|
||||||
edgesReversed = map (\(a, b) -> (b, a)) edges
|
edgesReversed = map (\(a, b) -> (b, a)) edges
|
||||||
|
|
@ -147,11 +191,11 @@ triangleAdjacencyMap s = M.fromListWith S.union . concatMap (\s' -> map (,S.sing
|
||||||
|
|
||||||
getPointsInTriangle :: p -> S.Set (P2 Int) -> [(Int, Int)]
|
getPointsInTriangle :: p -> S.Set (P2 Int) -> [(Int, Int)]
|
||||||
getPointsInTriangle image pts =
|
getPointsInTriangle image pts =
|
||||||
S.toList . S.unions . map S.fromList $
|
S.toList . S.unions . map S.fromList $
|
||||||
[ ptsBtween (makeLine p1 p3) (makeLine p1 p2),
|
[ ptsBtween (makeLine p1 p3) (makeLine p1 p2),
|
||||||
ptsBtween (makeLine p1 p3) (makeLine p2 p3),
|
ptsBtween (makeLine p1 p3) (makeLine p2 p3),
|
||||||
ptsBtween (makeLine p1 p2) (makeLine p2 p3)
|
ptsBtween (makeLine p1 p2) (makeLine p2 p3)
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
[p1, p2, p3] = sortOn fst . map unp2 . S.toList $ pts
|
[p1, p2, p3] = sortOn fst . map unp2 . S.toList $ pts
|
||||||
|
|
||||||
|
|
@ -162,13 +206,13 @@ blendEqually colors = C.affineCombo (map (fraction,) colors) C.white
|
||||||
|
|
||||||
voroniRegionAverageColor :: (Integral a, Integral b) => Ma.Image Ma.S (Co.SRGB 'Co.Linear) Double -> (a, b) -> [P2 Double] -> Colour Double
|
voroniRegionAverageColor :: (Integral a, Integral b) => Ma.Image Ma.S (Co.SRGB 'Co.Linear) Double -> (a, b) -> [P2 Double] -> Colour Double
|
||||||
voroniRegionAverageColor image (x', y') =
|
voroniRegionAverageColor image (x', y') =
|
||||||
blendEqually
|
blendEqually
|
||||||
. concatMap (getColorsInTriangle image (x', y'))
|
. concatMap (getColorsInTriangle image (x', y'))
|
||||||
. filter ((== 3) . S.size)
|
. filter ((== 3) . S.size)
|
||||||
. map (S.fromList . take 3)
|
. map (S.fromList . take 3)
|
||||||
. tails
|
. tails
|
||||||
. L.nub
|
. nubOrd
|
||||||
. map scaleToImageCoords
|
. map scaleToImageCoords
|
||||||
where
|
where
|
||||||
scaleToImageCoords :: P2 Double -> P2 Int
|
scaleToImageCoords :: P2 Double -> P2 Int
|
||||||
scaleToImageCoords p = round <$> p2 (fromIntegral x' * p ^. _x, fromIntegral y' * p ^. _y)
|
scaleToImageCoords p = round <$> p2 (fromIntegral x' * p ^. _x, fromIntegral y' * p ^. _y)
|
||||||
|
|
@ -208,22 +252,22 @@ yAt (LineMXB {..}) x = round $ (m * (fromIntegral x)) + b
|
||||||
|
|
||||||
makeLine :: (Int, Int) -> (Int, Int) -> LineMXB
|
makeLine :: (Int, Int) -> (Int, Int) -> LineMXB
|
||||||
makeLine (x1, y1) (x2, y2) =
|
makeLine (x1, y1) (x2, y2) =
|
||||||
LineMXB
|
LineMXB
|
||||||
{ m = slope,
|
{ m = slope,
|
||||||
b = (fromIntegral y1) - (slope * (fromIntegral x1)),
|
b = (fromIntegral y1) - (slope * (fromIntegral x1)),
|
||||||
startX = min x1 x2,
|
startX = min x1 x2,
|
||||||
endX = max x1 x2
|
endX = max x1 x2
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
slope =
|
slope =
|
||||||
if x1 /= x2
|
if x1 /= x2
|
||||||
then (fromIntegral $ y1 - y2) % (fromIntegral $ x1 - x2)
|
then (fromIntegral $ y1 - y2) % (fromIntegral $ x1 - x2)
|
||||||
else fromIntegral . ceiling $ ((10.0 :: Double) ** 100.0)
|
else fromIntegral . ceiling $ ((10.0 :: Double) ** 100.0)
|
||||||
|
|
||||||
data LineMXB = LineMXB
|
data LineMXB = LineMXB
|
||||||
{ m :: Rational,
|
{ m :: Rational,
|
||||||
b :: Rational,
|
b :: Rational,
|
||||||
startX :: Int,
|
startX :: Int,
|
||||||
endX :: Int
|
endX :: Int
|
||||||
}
|
}
|
||||||
deriving (Show, Ord, Eq)
|
deriving (Show, Ord, Eq)
|
||||||
|
|
|
||||||