diff --git a/.envrc b/.envrc new file mode 100644 index 0000000..44610e5 --- /dev/null +++ b/.envrc @@ -0,0 +1 @@ +use flake; diff --git a/.gitignore b/.gitignore index 8795412..2022b2b 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1 @@ -.stack-work/* -dist/* /dist-newstyle/ -/cabal.project.local diff --git a/README.md b/README.md index d814879..5167203 100644 --- a/README.md +++ b/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 ``` diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..4fff92c --- /dev/null +++ b/cabal.project @@ -0,0 +1,5 @@ +packages: + ./ + +-- package repa +-- ghc-options: -fincomplete-uni-patterns diff --git a/examples/luna-result.svg b/examples/luna-result.svg new file mode 100644 index 0000000..400ec40 --- /dev/null +++ b/examples/luna-result.svg @@ -0,0 +1,3 @@ + + \ No newline at end of file diff --git a/examples/luna-result.webp b/examples/luna-result.webp deleted file mode 100644 index eddbf4d..0000000 Binary files a/examples/luna-result.webp and /dev/null differ diff --git a/examples/sierra-result.svg b/examples/sierra-result.svg new file mode 100644 index 0000000..0a6176b --- /dev/null +++ b/examples/sierra-result.svg @@ -0,0 +1,3 @@ + + \ No newline at end of file diff --git a/examples/sierra-result.webp b/examples/sierra-result.webp deleted file mode 100644 index 76eb4a3..0000000 Binary files a/examples/sierra-result.webp and /dev/null differ diff --git a/flake.lock b/flake.lock new file mode 100644 index 0000000..f07fab7 --- /dev/null +++ b/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 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..0e4d0ce --- /dev/null +++ b/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; [ + ]; + }; + }; + }; +} diff --git a/image-triangles.cabal b/image-triangles.cabal index 1a18a68..741bc5a 100644 --- a/image-triangles.cabal +++ b/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 diff --git a/src/CircumCircle.hs b/src/CircumCircle.hs new file mode 100644 index 0000000..a59e44f --- /dev/null +++ b/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 diff --git a/src/Main.hs b/src/Main.hs index 9a20b7d..d13c1e0 100644 --- a/src/Main.hs +++ b/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)) diff --git a/src/Main.log b/src/Main.log new file mode 100644 index 0000000..a8a0300 --- /dev/null +++ b/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 for immediate help. + ... + +l.1 m + odule Main where +? +! Emergency stop. + ... + +l.1 m + odule Main where +You're in trouble here. Try typing to proceed. +If that doesn't work, type X 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! diff --git a/src/Render.hs b/src/Render.hs index 35960fa..059410e 100644 --- a/src/Render.hs +++ b/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 diff --git a/src/Triangles.hs b/src/Triangles.hs index 18d3225..672d3d4 100644 --- a/src/Triangles.hs +++ b/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 -getTriangleAverageRGB image (y', x') triangle = blendEqually pixels +getShapeAverageRGB :: Image_ -> (Int, Int) -> [P2 Int] -> C.Colour Double +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 diff --git a/src/dist-newstyle/cache/compiler b/src/dist-newstyle/cache/compiler new file mode 100644 index 0000000..0d1f30c Binary files /dev/null and b/src/dist-newstyle/cache/compiler differ