diff --git a/.gitignore b/.gitignore index f6bf75a91..ec4435a53 100644 --- a/.gitignore +++ b/.gitignore @@ -2,5 +2,4 @@ **/*.svg **/*.png !showcases/*.png -*.cabal .vscode diff --git a/flake.lock b/flake.lock index 248cf0b65..be9265a9d 100644 --- a/flake.lock +++ b/flake.lock @@ -1,12 +1,15 @@ { "nodes": { "flake-utils": { + "inputs": { + "systems": "systems" + }, "locked": { - "lastModified": 1667395993, - "narHash": "sha256-nuEHfE/LcWyuSWnS8t12N1wc105Qtau+/OdUAjtQ0rA=", + "lastModified": 1731533236, + "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", "owner": "numtide", "repo": "flake-utils", - "rev": "5aed5285a952e0b949eb3ba02c12fa4fcfef535f", + "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", "type": "github" }, "original": { @@ -17,16 +20,16 @@ }, "nixpkgs": { "locked": { - "lastModified": 1671359686, - "narHash": "sha256-3MpC6yZo+Xn9cPordGz2/ii6IJpP2n8LE8e/ebUXLrs=", + "lastModified": 1735531152, + "narHash": "sha256-As8I+ebItDKtboWgDXYZSIjGlKeqiLBvjxsQHUmAf1Q=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "04f574a1c0fde90b51bf68198e2297ca4e7cccf4", + "rev": "3ffbbdbac0566a0977da3d2657b89cbcfe9a173b", "type": "github" }, "original": { "owner": "NixOS", - "ref": "nixos-unstable", + "ref": "nixos-24.11", "repo": "nixpkgs", "type": "github" } @@ -36,6 +39,21 @@ "flake-utils": "flake-utils", "nixpkgs": "nixpkgs" } + }, + "systems": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" + } } }, "root": "root", diff --git a/flake.nix b/flake.nix index 01415d050..376a5543f 100644 --- a/flake.nix +++ b/flake.nix @@ -1,6 +1,6 @@ { inputs = { - nixpkgs.url = "github:NixOS/nixpkgs/nixos-unstable"; + nixpkgs.url = "github:NixOS/nixpkgs/nixos-24.11"; flake-utils.url = "github:numtide/flake-utils"; }; @@ -10,7 +10,7 @@ pkgs = nixpkgs.legacyPackages.${system}; # need to match Stackage LTS version from stack.yaml resolver - hPkgs = pkgs.haskell.packages."ghc8107"; + hPkgs = pkgs.haskell.packages."ghc948"; devtools = with hPkgs; [ ghc @@ -23,10 +23,24 @@ ]; pkgconfigDeps = with pkgs; [ + brotli.dev + bzip2.dev cairo.dev + expat.dev + fontconfig.dev + freetype.dev gtk2.dev gtkd - pkgconfig + libpng.dev + pixman + pkg-config + xorg.libX11.dev + xorg.libXau.dev + xorg.libxcb.dev + xorg.libXdmcp.dev + xorg.libXext.dev + xorg.libXrender.dev + xorg.xorgproto zlib zlib.dev ]; @@ -50,7 +64,7 @@ --extra-lib-dirs=$out/lib \ --extra-include-dirs=$out/include \ " \ - --set PKG_CONFIG_PATH $out/lib/pkgconfig \ + --set PKG_CONFIG_PATH "$out/lib/pkgconfig:$out/share/pkgconfig" \ --set LD_LIBRARY_PATH ${pkgs.lib.makeLibraryPath pkgconfigDeps} ''; }; diff --git a/generative-art.cabal b/generative-art.cabal new file mode 100644 index 000000000..d77453d1e --- /dev/null +++ b/generative-art.cabal @@ -0,0 +1,263 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.35.0. +-- +-- see: https://github.com/sol/hpack + +name: generative-art +version: 0.1.0.0 +description: Generative art using Haskell. See README.md. +homepage: https://github.com/quchen/generative-art#readme +bug-reports: https://github.com/quchen/generative-art/issues +author: David »quchen« Luposchainsky – dluposchainsky (λ) gmail, + Franz Thoma – f.m.thoma (λ) gmail +maintainer: David »quchen« Luposchainsky – dluposchainsky (λ) gmail, + Franz Thoma – f.m.thoma (λ) gmail +copyright: 2018–today David Luposchainsky, + 2018–today Franz Thoma +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/quchen/generative-art + +library + exposed-modules: + Algebra.Group + Algebra.VectorSpace + Data.Crc32 + Data.List.Extended + Data.Multwomap + Data.Ord.Extended + Data.Sequential + Data.Tree.Extended + Data.Vector.Extended + Draw + Draw.Color + Draw.Color.Schemes.Continuous + Draw.Color.Schemes.Discrete + Draw.NormalizeSvg + Draw.Plotting + Draw.Plotting.CmdArgs + Draw.Plotting.GCode + Draw.Plotting.PaperSize + Draw.Text + Geometry + Geometry.Algorithms.Clipping + Geometry.Algorithms.Contour + Geometry.Algorithms.Delaunay + Geometry.Algorithms.PerlinNoise + Geometry.Algorithms.Sampling + Geometry.Algorithms.SimplexNoise + Geometry.Algorithms.Triangulate + Geometry.Bezier + Geometry.Chaotic + Geometry.Coordinates.Hexagonal + Geometry.Core + Geometry.LookupTable.Lookup1 + Geometry.LookupTable.Lookup2 + Geometry.Processes.Billard + Geometry.Processes.FlowField + Geometry.Processes.Geodesics + Geometry.Processes.Penrose + Geometry.Processes.PoissonDiscForest + Geometry.Shapes + Geometry.SvgParser + Geometry.Trajectory + Numerics.ConvergentRecursion + Numerics.DifferentialEquation + Numerics.FindRoot + Numerics.Functions + Numerics.Integrate + Numerics.Interpolation + Numerics.LinearEquationSystem + Numerics.Optimization.TSP + Numerics.VectorAnalysis + Physics + System.Random.MWC.Extended + Util + Why + other-modules: + Draw.Color.Schemes.Internal.ColorBrewer2 + Draw.Color.Schemes.Internal.Common + Draw.Color.Schemes.Internal.Haskell + Draw.Color.Schemes.Internal.MatPlotLib + Draw.Color.Schemes.Internal.Seaborn + Geometry.Algorithms.Clipping.CohenSutherland + Geometry.Algorithms.Clipping.Internal + Geometry.Algorithms.Clipping.MargalitKnott + Geometry.Algorithms.Clipping.SutherlandHodgman + Geometry.Algorithms.Contour.Internal + Geometry.Algorithms.Delaunay.Internal.Delaunator.Api + Geometry.Algorithms.Delaunay.Internal.Delaunator.Raw + Geometry.Algorithms.Sampling.PoissonDisc + Geometry.SvgParser.Common + Geometry.SvgParser.PathParser + Geometry.SvgParser.SimpleShapes + Geometry.Trajectory.PathSimplifier.Radial + Geometry.Trajectory.PathSimplifier.RamerDouglasPeucker + Geometry.Trajectory.PathSimplifier.VisvalingamWhyatt + Geometry.Trajectory.ReassembleLines + hs-source-dirs: + src + default-extensions: + BangPatterns + LambdaCase + MultiWayIf + RecordWildCards + ghc-options: -Wall -Wno-type-defaults -j -Wno-incomplete-uni-patterns + build-depends: + Noise + , alfred-margaret + , base >=4.7 && <5 + , bytestring + , cairo + , colour + , containers + , data-default-class + , deepseq + , directory + , dlist + , filepath + , formatting + , heaps + , megaparsec + , mtl + , mwc-random + , optparse-applicative + , parallel + , plotfont + , primitive + , random + , regex-tdfa + , text + , tf-random + , transformers + , vector + , vector-algorithms + default-language: Haskell2010 + +test-suite doctest + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_generative_art + hs-source-dirs: + test/doctest + default-extensions: + BangPatterns + LambdaCase + MultiWayIf + RecordWildCards + ghc-options: -Wall -Wno-type-defaults -j -Wno-incomplete-uni-patterns -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-type-defaults + build-depends: + Noise + , alfred-margaret + , base >=4.7 && <5 + , bytestring + , cairo + , colour + , containers + , data-default-class + , deepseq + , directory + , dlist + , doctest + , filepath + , formatting + , heaps + , megaparsec + , mtl + , mwc-random + , optparse-applicative + , parallel + , plotfont + , primitive + , random + , regex-tdfa + , text + , tf-random + , transformers + , vector + , vector-algorithms + default-language: Haskell2010 + +test-suite testsuite + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Test.Arbitrary + Test.Data.Tree.Extended + Test.Draw + Test.Draw.Color + Test.Draw.Plotting + Test.Draw.Text + Test.Geometry.Algorithms.Clipping + Test.Geometry.Algorithms.Contour + Test.Geometry.Coordinates.Hexagonal + Test.Geometry.Core + Test.Geometry.LookupTable.Lookup2 + Test.Geometry.Processes.Penrose + Test.Geometry.SvgParser + Test.Physics + Test.TastyAll + Test.Uncategorized.Bezier + Test.Uncategorized.ConvexHull + Test.Uncategorized.DifferentialEquation + Test.Uncategorized.GrowPolygon + Test.Uncategorized.IntersectionLL + Test.Uncategorized.Mirror + Test.Uncategorized.Properties + Test.Uncategorized.SimpleOperations + Test.Uncategorized.Trajectory + Paths_generative_art + hs-source-dirs: + test/testsuite + default-extensions: + BangPatterns + LambdaCase + MultiWayIf + RecordWildCards + ghc-options: -Wall -Wno-type-defaults -j -Wno-incomplete-uni-patterns -threaded -rtsopts -with-rtsopts=-N -Wall -j -Wno-type-defaults -Wno-incomplete-uni-patterns + build-depends: + Glob + , Noise + , QuickCheck + , alfred-margaret + , async + , base >=4.7 && <5 + , bytestring + , cairo + , colour + , containers + , data-default-class + , deepseq + , directory + , dlist + , filepath + , formatting + , generative-art + , heaps + , megaparsec + , mtl + , mwc-random + , optparse-applicative + , parallel + , plotfont + , primitive + , process + , random + , regex-tdfa + , tasty + , tasty-hunit + , tasty-quickcheck + , text + , tf-random + , transformers + , vector + , vector-algorithms + default-language: Haskell2010 diff --git a/hie.yaml b/hie.yaml index 9ed215c43..7a1736e1b 100644 --- a/hie.yaml +++ b/hie.yaml @@ -1,11 +1,159 @@ cradle: - stack: - - path: ./src - component: generative-art:lib - - path: ./test/testsuite - component: generative-art:test:testsuite - - path: ./test/doctest - component: generative-art:test:doctest + multi: + - path: ./ + config: + cradle: + stack: + - path: ./src + component: generative-art:lib + - path: ./test/testsuite + component: generative-art:test:testsuite + - path: ./test/doctest + component: generative-art:test:doctest + + - path: ./penplotting/ApollonianGasket + config: + cradle: + stack: + stackYaml: ./penplotting/ApollonianGasket/stack.yaml + - path: ./penplotting/Bezier + config: + cradle: + stack: + stackYaml: ./penplotting/Bezier/stack.yaml + - path: ./penplotting/circuits + config: + cradle: + stack: + stackYaml: ./penplotting/circuits/stack.yaml + - path: ./penplotting/DelaunayVoronoi + config: + cradle: + stack: + stackYaml: ./penplotting/DelaunayVoronoi/stack.yaml + - path: ./penplotting/dendrites + config: + cradle: + stack: + stackYaml: ./penplotting/dendrites/stack.yaml + - path: ./penplotting/FlowLines + config: + cradle: + stack: + stackYaml: ./penplotting/FlowLines/stack.yaml + - path: ./penplotting/Hatched + config: + cradle: + stack: + stackYaml: ./penplotting/Hatched/stack.yaml + - path: ./penplotting/Kilometer + config: + cradle: + stack: + stackYaml: ./penplotting/Kilometer/stack.yaml + - path: ./penplotting/PenChangeCalibration + config: + cradle: + stack: + stackYaml: ./penplotting/PenChangeCalibration/stack.yaml + - path: ./penplotting/PoissonDisc + config: + cradle: + stack: + stackYaml: ./penplotting/PoissonDisc/stack.yaml + - path: ./penplotting/Pressure + config: + cradle: + stack: + stackYaml: ./penplotting/Pressure/stack.yaml + - path: ./penplotting/SvgSource + config: + cradle: + stack: + stackYaml: ./penplotting/SvgSource/stack.yaml + - path: ./penplotting/Truchet + config: + cradle: + stack: + stackYaml: ./penplotting/Truchet/stack.yaml + components: + - path: ./penplotting/Truchet/Truchet.hs + component: penplotting-truchet:exe:penplotting-truchet + - path: ./penplotting/Truchet/Truchetti.hs + component: penplotting-truchet:exe:penplotting-truchetti + - path: ./penplotting/Typography + config: + cradle: + stack: + stackYaml: ./penplotting/Typography/stack.yaml + - path: ./penplotting/Voronoi + config: + cradle: + stack: + stackYaml: ./penplotting/Voronoi/stack.yaml + + - path: ./showcases/circuits + config: + cradle: + stack: + stackYaml: ./showcases/circuits/stack.yaml + - path: ./showcases/haskell_logo_billard + config: + cradle: + stack: + stackYaml: ./showcases/haskell_logo_billard/stack.yaml + - path: ./showcases/haskell_logo_shattered + config: + cradle: + stack: + stackYaml: ./showcases/haskell_logo_shattered/stack.yaml + - path: ./showcases/haskell_logo_voronoi + config: + cradle: + stack: + stackYaml: ./showcases/haskell_logo_voronoi/stack.yaml + - path: ./showcases/munihac_2022_logo + config: + cradle: + stack: + stackYaml: ./showcases/munihac_2022_logo/stack.yaml + - path: ./showcases/particle_shooter + config: + cradle: + stack: + stackYaml: ./showcases/particle_shooter/stack.yaml + - path: ./showcases/pulsar + config: + cradle: + stack: + stackYaml: ./showcases/pulsar/stack.yaml + - path: ./showcases/truchet + config: + cradle: + stack: + stackYaml: ./showcases/truchet/stack.yaml + - path: ./showcases/truchetti + config: + cradle: + stack: + stackYaml: ./showcases/truchetti/stack.yaml + component: truchetti:exe:truchetti + - path: ./showcases/vector_fields + config: + cradle: + stack: + stackYaml: ./showcases/vector_fields/stack.yaml + - path: ./showcases/voronoi_3d + config: + cradle: + stack: + stackYaml: ./showcases/voronoi_3d/stack.yaml + + - path: ./showcases/truchetti + config: + cradle: + stack: + stackYaml: ./showcases/truchetti/stack.yaml # - path: ./path/to/main/hs # component: name-of-the-package diff --git a/penplotting/ApollonianGasket/Main.hs b/penplotting/ApollonianGasket/Main.hs new file mode 100644 index 000000000..546d4b3f6 --- /dev/null +++ b/penplotting/ApollonianGasket/Main.hs @@ -0,0 +1,44 @@ +module Main (main) where + + + +import Data.Coerce +import Data.Default.Class +import Data.Foldable +import qualified Data.Text.Lazy.IO as T +import Data.Tree +import Draw.Plotting +import Geometry as G +import Geometry.Processes.ApollonianGasket + + + +minRadius :: Double +minRadius = 0.5 + +gen0L, gen0R, gen0B :: Circle +gen0L = Circle (Vec2 100 100) 50 +gen0R = Circle (Vec2 200 100) 50 +gen0B = Circle (G.transform (G.rotateAround (Vec2 100 100) (deg 60)) (Vec2 200 100)) 50 + +unsafelyTransform :: Transformation -> Tree Circle -> Tree Circle +unsafelyTransform t = coerce . (fmap (transform t) :: Tree UnsafeTransformCircle -> Tree UnsafeTransformCircle) . coerce + +gasket :: Tree Circle +gasket = createGasket minRadius gen0L gen0R gen0B + +pageWidth, pageHeight, margin :: Double +pageWidth = 210 +pageHeight = 291 +margin = 10 + +gasketScaled :: Tree Circle +gasketScaled = unsafelyTransform (G.transformBoundingBox (foldMap boundingBox gasket) (Vec2 margin margin, Vec2 pageWidth pageHeight -. Vec2 margin margin) def) gasket + +plotterSettings :: PlottingSettings +plotterSettings = def + +main :: IO () +main = T.putStrLn (renderGCode (_plotGCode (runPlot plotterSettings drawing))) + where + drawing = plot (toList gasketScaled) diff --git a/penplotting/ApollonianGasket/package.yaml b/penplotting/ApollonianGasket/package.yaml new file mode 100644 index 000000000..0e330977d --- /dev/null +++ b/penplotting/ApollonianGasket/package.yaml @@ -0,0 +1,21 @@ +name: penplotting-gasket +version: 0.1.0.0 +github: quchen/generative-art +license: BSD3 +author: + - David Luposchainsky +copyright: + - 2022 David Luposchainsky + +dependencies: + - generative-art + - base + - containers + - data-default-class + - text + +executables: + penplotting-gasket: + main: Main.hs + source-dirs: . + ghc-options: [-threaded, -rtsopts, -with-rtsopts=-N, -Wall, -Wno-type-defaults, -O] diff --git a/penplotting/ApollonianGasket/penplotting-gasket.cabal b/penplotting/ApollonianGasket/penplotting-gasket.cabal new file mode 100644 index 000000000..7d029bdfb --- /dev/null +++ b/penplotting/ApollonianGasket/penplotting-gasket.cabal @@ -0,0 +1,34 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: penplotting-gasket +version: 0.1.0.0 +homepage: https://github.com/quchen/generative-art#readme +bug-reports: https://github.com/quchen/generative-art/issues +author: David Luposchainsky +maintainer: David Luposchainsky +copyright: 2022 David Luposchainsky +license: BSD3 +build-type: Simple + +source-repository head + type: git + location: https://github.com/quchen/generative-art + +executable penplotting-gasket + main-is: Main.hs + other-modules: + Paths_penplotting_gasket + hs-source-dirs: + ./ + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-type-defaults -O + build-depends: + base + , containers + , data-default-class + , generative-art + , text + default-language: Haskell2010 diff --git a/penplotting/ApollonianGasket/stack.yaml b/penplotting/ApollonianGasket/stack.yaml new file mode 100644 index 000000000..c03bc81fd --- /dev/null +++ b/penplotting/ApollonianGasket/stack.yaml @@ -0,0 +1,14 @@ +flags: {} +packages: + - . +extra-deps: + - git: https://github.com/quchen/generative-art + commit: 6ac74502f1d55da60513ac7aec458e715dad6c3b + - cairo-0.13.10.0@sha256:388f39af90d50b920cad70612046041a7ffd7f5b60721862c0c797ecddf7e902,4153 + - gtk2hs-buildtools-0.13.8.2@sha256:01c4a6cc3679008bd4caec32b49843acb27a5f48ee2b22484218f097835548f6,5238 + - Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + - data-r-tree-0.6.0@sha256:10a25ef70e6779c3bf5128cd45d033482a370ea07e92ab1c82678675de01d870,3668 + - plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + - alfred-margaret-1.1.1.0@sha256:aeb2f14726e1ee70e542ecfb2a71eb14abda8303d17932bca149401edd76135b,3095 +resolver: lts-18.19 +allow-newer: true diff --git a/penplotting/ApollonianGasket/stack.yaml.lock b/penplotting/ApollonianGasket/stack.yaml.lock new file mode 100644 index 000000000..f12ab3146 --- /dev/null +++ b/penplotting/ApollonianGasket/stack.yaml.lock @@ -0,0 +1,54 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: cairo-0.13.10.0@sha256:388f39af90d50b920cad70612046041a7ffd7f5b60721862c0c797ecddf7e902,4153 + pantry-tree: + sha256: a5d7014b0df2600377d061185b104f755274935554e723e2b7b600b85ffc7ae2 + size: 2831 + original: + hackage: cairo-0.13.10.0@sha256:388f39af90d50b920cad70612046041a7ffd7f5b60721862c0c797ecddf7e902,4153 +- completed: + hackage: gtk2hs-buildtools-0.13.8.2@sha256:01c4a6cc3679008bd4caec32b49843acb27a5f48ee2b22484218f097835548f6,5238 + pantry-tree: + sha256: 1c3b449a69f4bb2d27c09a89e447552a58201a3febf5418e67af0001a0cbb0a7 + size: 3588 + original: + hackage: gtk2hs-buildtools-0.13.8.2@sha256:01c4a6cc3679008bd4caec32b49843acb27a5f48ee2b22484218f097835548f6,5238 +- completed: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + pantry-tree: + sha256: 27a9154935b4d30a22830477c60c5108fd713a184d456272c2fccbf361d2395f + size: 1176 + original: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 +- completed: + hackage: data-r-tree-0.6.0@sha256:10a25ef70e6779c3bf5128cd45d033482a370ea07e92ab1c82678675de01d870,3668 + pantry-tree: + sha256: 057a5a25c6c8fe8e60e62b9522e8f1a8be3e7470bfe44229d1e2712e6851409e + size: 614 + original: + hackage: data-r-tree-0.6.0@sha256:10a25ef70e6779c3bf5128cd45d033482a370ea07e92ab1c82678675de01d870,3668 +- completed: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + pantry-tree: + sha256: 887770effc1578682fe255d7f8b1a9801bc5a6e832aa46316782e43eecb65113 + size: 321 + original: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 +- completed: + hackage: alfred-margaret-1.1.1.0@sha256:aeb2f14726e1ee70e542ecfb2a71eb14abda8303d17932bca149401edd76135b,3095 + pantry-tree: + sha256: 44f6f77280a9984cdf7be9f2bc4804f9ba3809ab60e9a065aabb1ee3f8f92322 + size: 1087 + original: + hackage: alfred-margaret-1.1.1.0@sha256:aeb2f14726e1ee70e542ecfb2a71eb14abda8303d17932bca149401edd76135b,3095 +snapshots: +- completed: + sha256: 32716534fff554b7f90762130fdb985cabf29f157758934dd1c8f3892a646430 + size: 586103 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/19.yaml + original: lts-18.19 diff --git a/penplotting/Bezier/Main.hs b/penplotting/Bezier/Main.hs new file mode 100644 index 000000000..8613b770a --- /dev/null +++ b/penplotting/Bezier/Main.hs @@ -0,0 +1,105 @@ +module Main (main) where + + + +import Control.Monad +import Data.List +import qualified Data.Set as S +import qualified Data.Vector as V +import System.Random.MWC +import Text.Printf + +import Draw +import Draw.Plotting +import Geometry as G +import Geometry.Chaotic +import Geometry.Algorithms.PerlinNoise +import qualified Geometry.Processes.FlowField as ODE +import Numerics.DifferentialEquation +import Numerics.VectorAnalysis + + + +picWidth, picHeight :: Num a => a +picWidth = 500 +picHeight = 700 + +canvas :: Polygon +canvas = Polygon [Vec2 50 50, Vec2 50 (picHeight - 50), Vec2 (picWidth - 50) (picHeight - 50), Vec2 (picWidth - 50) 50] + +-- Higher values yield lower-frequency noise +noiseScale :: Double +noiseScale = 1 + +seeds :: [Int] +seeds = [23, 7, 16] + +main :: IO () +main = for_ (zip [1 :: Int ..] seeds) $ \(i, seed) -> do + gen <- initializeMwc seed + initialPoints <- replicateM 4 $ + uniformRM (zero, Vec2 picWidth picHeight) gen + let timeEvolution + = fitToCanvas + . minimizePenHoveringBy penHoveringSettings . S.fromList + . fmap bezierSmoothen + . transpose + . fmap (take 50 . fmap snd . spaced 2000 . fieldLine (rotationField seed)) + $ initialPoints + plottingSettings = def + { _feedrate = 10000 + , _zTravelHeight = 5 + , _zDrawingHeight = -2 + , _canvasBoundingBox = Just (boundingBox (rotateToLandscape canvas)) + } + penHoveringSettings = MinimizePenHoveringSettings + { _getStartEndPoint = \bz -> (let Bezier hd _ _ _ = V.head bz in hd, let Bezier _ _ _ tl = V.last bz in tl) + , _flipObject = Just (fmap (\(Bezier a b c d) -> Bezier d c b a) . V.reverse) + , _mergeObjects = Nothing + } + plotResult = runPlot plottingSettings $ do + comment "Plot is intended for 50x70 paper with 5cm margin" + comment "Plot size is 60x40, place origin at (margin, margin) relative to the paper" + comment "On 44x63 paper, margins are (15mm, 20mm)" + for_ timeEvolution $ plot . rotateToLandscape + renderPreview (printf "out/bezier%i.png" i) 1 plotResult + writeGCodeFile (printf "bezier%i.g" i) plotResult + +-- 2D vector potential, which in 2D is umm well a scalar potential. +vectorPotential :: Int -> Vec2 -> Double +vectorPotential seed p = noiseScale *. perlin2 params p + where + params = PerlinParameters + { _perlinFrequency = 3 / (noiseScale * min picWidth picHeight) + , _perlinLacunarity = 2 + , _perlinOctaves = 1 + , _perlinPersistence = 0.5 + , _perlinSeed = seed + } + +rotationField :: Int -> Vec2 -> Vec2 +rotationField seed = curlZ (vectorPotential seed) + +fieldLine + :: (Vec2 -> Vec2) + -> Vec2 + -> [(Double, Vec2)] +fieldLine f p0 = rungeKuttaConstantStep (ODE.fieldLine f) p0 t0 dt + where + t0 = 0 + dt = 10 + +spaced :: Double -> [(Double, a)] -> [(Double, a)] +spaced dt = go 0 + where + go _ [] = [] + go t0 ((t, a) : xs) + | t < t0 = go t0 xs + | t > t0 + dt = (t, a) : go (t0 + dt) ((t, a) : xs) + | otherwise = (t, a) : go (t0 + dt) xs + +fitToCanvas :: (HasBoundingBox geo, Transform geo) => geo -> geo +fitToCanvas geo = G.transform (scaleAround (Vec2 (picWidth/2) (picHeight/2)) 0.99 <> transformBoundingBox geo canvas def) geo + +rotateToLandscape :: Transform geo => geo -> geo +rotateToLandscape = transform (translate (Vec2 (-50) (picWidth - 50)) <> rotate (deg (-90))) diff --git a/penplotting/Bezier/package.yaml b/penplotting/Bezier/package.yaml new file mode 100644 index 000000000..b5c366823 --- /dev/null +++ b/penplotting/Bezier/package.yaml @@ -0,0 +1,27 @@ +name: penplotting-bezier +version: 0.1.0.0 +github: quchen/generative-art +license: BSD3 +author: + - Franz Thoma +copyright: + - 2022 Franz Thoma + +default-extensions: + - RecordWildCards + - OverloadedStrings + +dependencies: + - generative-art + - base + - cairo + - containers + - mwc-random + - text + - vector + +executables: + penplotting-bezier: + main: Main.hs + source-dirs: . + ghc-options: [-threaded, -rtsopts, -with-rtsopts=-N, -Wall, -Wno-type-defaults, -O] diff --git a/penplotting/Bezier/penplotting-bezier.cabal b/penplotting/Bezier/penplotting-bezier.cabal new file mode 100644 index 000000000..14b974f6d --- /dev/null +++ b/penplotting/Bezier/penplotting-bezier.cabal @@ -0,0 +1,39 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: penplotting-bezier +version: 0.1.0.0 +homepage: https://github.com/quchen/generative-art#readme +bug-reports: https://github.com/quchen/generative-art/issues +author: Franz Thoma +maintainer: Franz Thoma +copyright: 2022 Franz Thoma +license: BSD3 +build-type: Simple + +source-repository head + type: git + location: https://github.com/quchen/generative-art + +executable penplotting-bezier + main-is: Main.hs + other-modules: + Paths_penplotting_bezier + hs-source-dirs: + ./ + default-extensions: + RecordWildCards + OverloadedStrings + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-type-defaults -O + build-depends: + base + , cairo + , containers + , generative-art + , mwc-random + , text + , vector + default-language: Haskell2010 diff --git a/penplotting/Bezier/stack.yaml b/penplotting/Bezier/stack.yaml new file mode 100644 index 000000000..be0c7697d --- /dev/null +++ b/penplotting/Bezier/stack.yaml @@ -0,0 +1,11 @@ +flags: {} +packages: + - . +extra-deps: + - git: https://github.com/quchen/generative-art + commit: 3cea78bb902c023216727be16dcf8143bd62f0ae + - Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + - plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + - alfred-margaret-2.1.0.2 +resolver: lts-21.25 +allow-newer: true diff --git a/penplotting/Bezier/stack.yaml.lock b/penplotting/Bezier/stack.yaml.lock new file mode 100644 index 000000000..5963a5462 --- /dev/null +++ b/penplotting/Bezier/stack.yaml.lock @@ -0,0 +1,33 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + pantry-tree: + sha256: 27a9154935b4d30a22830477c60c5108fd713a184d456272c2fccbf361d2395f + size: 1176 + original: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 +- completed: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + pantry-tree: + sha256: 887770effc1578682fe255d7f8b1a9801bc5a6e832aa46316782e43eecb65113 + size: 321 + original: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 +- completed: + hackage: alfred-margaret-2.1.0.2@sha256:2903ce63f9054ec607c03439231cdacd0a3b731febe05f493d073bcb1a8bc1a7,4918 + pantry-tree: + sha256: f747ba440a8a87e433970d07cb1edabac770f111fec0732ee83026cf2bf7286e + size: 1938 + original: + hackage: alfred-margaret-2.1.0.2 +snapshots: +- completed: + sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd + size: 640086 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml + original: lts-21.25 diff --git a/penplotting/DelaunayVoronoi/Main.hs b/penplotting/DelaunayVoronoi/Main.hs new file mode 100644 index 000000000..5161a717a --- /dev/null +++ b/penplotting/DelaunayVoronoi/Main.hs @@ -0,0 +1,77 @@ +module Main (main) where + + + +import Control.Monad +import Control.Monad.ST +import qualified Data.Vector as V +import qualified System.Random.MWC as MWC + +import Draw as D +import Draw.Plotting +import Geometry as G +import Geometry.Algorithms.Delaunay +import Geometry.Algorithms.Sampling + + + +main :: IO () +main = do + let w = 297 + h = 210 + margin = 10 + paperBB = boundingBox [zero, Vec2 w h] + drawInsideBB = boundingBox [zero +. Vec2 margin margin, Vec2 w h -. Vec2 margin margin] + + let (delaunayPolygons, voronoiPolygons) = G.transform + (transformBoundingBox (boundingBox geometry) drawInsideBB def) + geometry + + let plotSettings = def + { _canvasBoundingBox = Just paperBB + , _previewDrawnShapesBoundingBox = True + , _previewPenTravelColor = Nothing + } + plotDelaunay = runPlot plotSettings { _previewPenColor = mma 1 } $ do + for_ delaunayPolygons plot + plotVoronoi = runPlot plotSettings { _previewPenColor = mma 0 } $ do + for_ voronoiPolygons plot + + writeGCodeFile "out/delaunay-voronoi-delaunay.g" plotDelaunay + writeGCodeFile "out/delaunay-voronoi-voronoi.g" plotVoronoi + + D.render "out/delaunay-voronoi.svg" (round w) (round h) $ do + D.coordinateSystem (D.MathStandard_ZeroBottomLeft_XRight_YUp h) + _plotPreview plotDelaunay + _plotPreview plotVoronoi + +geometry :: (V.Vector Polygon, V.Vector Polygon) +geometry = + let calcBB = boundingBox [zero, Vec2 1000 1000] + + points = V.fromList $ runST $ do + gen <- MWC.create + -- gaussianDistributedPoints gen calcBB (192 *. mempty) 192 + let poissonShape = calcBB + poissonRadius = 25 + poissonK = 3 + poissonDisc gen poissonShape poissonRadius poissonK + + delaunay = + delaunayTriangulation + . V.last + . V.iterateN 3 (lloydRelaxation calcBB 1) + $ points + + cutoffRadius = let (w,h) = boundingBoxSize calcBB + in min w h / 3 + + delaunayPolygons = flip V.filter (delaunayTriangles delaunay) $ \(Polygon corners) -> + all (\corner -> norm (corner -. boundingBoxCenter calcBB) <= cutoffRadius) corners + + voronoiPolygons = do + VoronoiFinite cell <- voronoiCells delaunay + guard (any (\(Polygon corners) -> any (\corner -> pointInPolygon corner cell) corners) delaunayPolygons) + pure cell + + in (delaunayPolygons, voronoiPolygons) diff --git a/penplotting/DelaunayVoronoi/delaunay-voronoi.cabal b/penplotting/DelaunayVoronoi/delaunay-voronoi.cabal new file mode 100644 index 000000000..12db7eafa --- /dev/null +++ b/penplotting/DelaunayVoronoi/delaunay-voronoi.cabal @@ -0,0 +1,44 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.36.0. +-- +-- see: https://github.com/sol/hpack + +name: delaunay-voronoi +version: 0.1.0.0 +homepage: https://github.com/quchen/generative-art#readme +bug-reports: https://github.com/quchen/generative-art/issues +author: David Luposchainsky, + Franz Thoma +maintainer: David Luposchainsky, + Franz Thoma +copyright: 2022 David Luposchainsky, + 2022 Franz Thoma +license: BSD3 +build-type: Simple + +source-repository head + type: git + location: https://github.com/quchen/generative-art + +executable delaunay-voronoi + main-is: Main.hs + other-modules: + Paths_delaunay_voronoi + hs-source-dirs: + ./ + default-extensions: + LambdaCase + OverloadedStrings + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-type-defaults -O + build-depends: + base + , cairo + , containers + , data-default-class + , generative-art + , mwc-random + , optparse-applicative + , text + , vector + default-language: Haskell2010 diff --git a/penplotting/DelaunayVoronoi/package.yaml b/penplotting/DelaunayVoronoi/package.yaml new file mode 100644 index 000000000..55c3a22dc --- /dev/null +++ b/penplotting/DelaunayVoronoi/package.yaml @@ -0,0 +1,31 @@ +name: delaunay-voronoi +version: 0.1.0.0 +github: quchen/generative-art +license: BSD3 +author: + - David Luposchainsky + - Franz Thoma +copyright: + - 2022 David Luposchainsky + - 2022 Franz Thoma + +default-extensions: + - LambdaCase + - OverloadedStrings + +dependencies: + - base + - generative-art + - cairo + - containers + - data-default-class + - mwc-random + - text + - vector + - optparse-applicative + +executables: + delaunay-voronoi: + main: Main.hs + source-dirs: . + ghc-options: [-threaded, -rtsopts, -with-rtsopts=-N, -Wall, -Wno-type-defaults, -O] diff --git a/penplotting/DelaunayVoronoi/stack.yaml b/penplotting/DelaunayVoronoi/stack.yaml new file mode 100644 index 000000000..be0c7697d --- /dev/null +++ b/penplotting/DelaunayVoronoi/stack.yaml @@ -0,0 +1,11 @@ +flags: {} +packages: + - . +extra-deps: + - git: https://github.com/quchen/generative-art + commit: 3cea78bb902c023216727be16dcf8143bd62f0ae + - Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + - plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + - alfred-margaret-2.1.0.2 +resolver: lts-21.25 +allow-newer: true diff --git a/penplotting/DelaunayVoronoi/stack.yaml.lock b/penplotting/DelaunayVoronoi/stack.yaml.lock new file mode 100644 index 000000000..5963a5462 --- /dev/null +++ b/penplotting/DelaunayVoronoi/stack.yaml.lock @@ -0,0 +1,33 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + pantry-tree: + sha256: 27a9154935b4d30a22830477c60c5108fd713a184d456272c2fccbf361d2395f + size: 1176 + original: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 +- completed: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + pantry-tree: + sha256: 887770effc1578682fe255d7f8b1a9801bc5a6e832aa46316782e43eecb65113 + size: 321 + original: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 +- completed: + hackage: alfred-margaret-2.1.0.2@sha256:2903ce63f9054ec607c03439231cdacd0a3b731febe05f493d073bcb1a8bc1a7,4918 + pantry-tree: + sha256: f747ba440a8a87e433970d07cb1edabac770f111fec0732ee83026cf2bf7286e + size: 1938 + original: + hackage: alfred-margaret-2.1.0.2 +snapshots: +- completed: + sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd + size: 640086 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml + original: lts-21.25 diff --git a/penplotting/FlowLines/Main.hs b/penplotting/FlowLines/Main.hs new file mode 100644 index 000000000..fcaf66aa1 --- /dev/null +++ b/penplotting/FlowLines/Main.hs @@ -0,0 +1,158 @@ +module Main (main) where + + + +import Control.Monad +import Data.List +import qualified Data.Vector as V +import Graphics.Rendering.Cairo as C hiding (height, width, x, y) +import Options.Applicative +import System.Random.MWC (initialize) + + +import qualified Data.Set as S +import Draw +import Draw.Plotting +import Draw.Plotting.CmdArgs +import Geometry as G +import Geometry.Algorithms.PerlinNoise +import Geometry.Algorithms.Sampling +import qualified Geometry.Processes.FlowField as ODE +import Numerics.DifferentialEquation +import Numerics.Functions +import Numerics.VectorAnalysis + + + +-- Higher values yield lower-frequency noise +noiseScale :: Double +noiseScale = 0.5 + +noiseSeed :: Int +noiseSeed = 519496 + +main :: IO () +main = do + options <- commandLineOptions + geometry <- mkGeometry options + + let (width, height, _) = widthHeightMargin options + render "out/vector_fields.svg" (round width) (round height) $ do + + cairoScope $ do + setColor black + C.paint + + cairoScope $ do + setColor white + setLineWidth 0.3 + for_ geometry drawFieldLine + + let drawing = sequence + [ plot (Polyline part) + | trajectory <- geometry + , part <- simplifyTrajectoryRadial 2 <$> splitIntoInsideParts options trajectory ] + + plottingSettings = def { _feedrate = 6000, _zTravelHeight = 5, _zDrawingHeight = -2 } + + writeGCodeFile (_outputFileG options) (runPlot plottingSettings drawing) + +mkGeometry :: Options -> IO [Polyline] +mkGeometry options = do + let (width_opt, height_opt, margin_opt) = widthHeightMargin options + width_mm = width_opt - 2 * margin_opt + height_mm = height_opt - 2 * margin_opt + gen <- initialize (V.fromList [fromIntegral noiseSeed]) + let poissonShape = boundingBox [ Vec2 (-50) 0, Vec2 (width_mm + 50) (height_mm / 10) ] + poissonRadius = 5 + poissonK = 3 + startPoints <- poissonDisc gen poissonShape poissonRadius poissonK + let mkTrajectory start = + Polyline + . map (\(_t, pos) -> pos) + . takeWhile + (\(t, pos) -> t <= 200 && pos `insideBoundingBox` (Vec2 (-50) (-50), Vec2 (width_mm+50) (height_mm+50))) + $ fieldLine (velocityField options) (G.transform (G.scale' 1 10) start) + pure ((fmap (Polyline . V.toList) . minimizePenHovering . S.fromList . concatMap (splitIntoInsideParts options . mkTrajectory)) startPoints) + +drawFieldLine :: Polyline -> Render () +drawFieldLine (Polyline polyLine) = cairoScope $ do + let simplified = simplifyTrajectoryRadial 2 polyLine + unless (null (drop 2 simplified)) $ do + sketch (PolyBezier (bezierSmoothen simplified)) + stroke + +groupOn :: Eq b => (a -> b) -> [a] -> [[a]] +groupOn f = groupBy (\x y -> f x == f y) + +splitIntoInsideParts :: Options -> Polyline -> [[Vec2]] +splitIntoInsideParts options (Polyline xs) = filter (\(x:_) -> x `insideBoundingBox` drawBB) . groupOn (\p -> insideBoundingBox p drawBB) . toList $ xs + where + drawBB = boundingBox (Vec2 margin margin, Vec2 (width - margin) (height - margin)) + (width, height, margin) = widthHeightMargin options + + +-- 2D vector potential, which in 2D is umm well a scalar potential. +vectorPotential :: Options -> Vec2 -> Double +vectorPotential options p = noiseScale *. perlin2 params p + where + (width, height, _) = widthHeightMargin options + params = PerlinParameters + { _perlinFrequency = 3 / (noiseScale * min width height) + , _perlinLacunarity = 2 + , _perlinOctaves = 1 + , _perlinPersistence = 0.5 + , _perlinSeed = noiseSeed + } + +rotationField :: Options -> Vec2 -> Vec2 +rotationField options = curlZ (vectorPotential options) + +velocityField :: Options -> Vec2 -> Vec2 +velocityField options p@(Vec2 x y) = Vec2 1 0 +. perturbationStrength *. rotationField options p + where + perturbationStrength = + 0.8 + * logisticRamp (0.6*width_mm) (width_mm/6) x + * gaussianFalloff (0.5*height_mm) (0.4*height_mm) y + + (width, height, margin) = widthHeightMargin options + width_mm = width - 2 * margin + height_mm = height - 2 * margin + +widthHeightMargin :: Options -> (Double, Double, Double) +widthHeightMargin Options{_canvas=Canvas{_canvasWidth=width, _canvasHeight=height, _canvasMargin=margin}} = (width, height, margin) + +fieldLine + :: (Vec2 -> Vec2) + -> Vec2 + -> [(Double, Vec2)] +fieldLine f p0 = rungeKuttaAdaptiveStep (ODE.fieldLine f) p0 t0 dt0 tolNorm tol + where + t0 = 0 + dt0 = 1 + -- Decrease exponent for more accurate results + tol = 1e-4 + tolNorm = norm + +data Options = Options + { _outputFileG :: FilePath + , _canvas :: Canvas + } deriving (Eq, Ord, Show) + +commandLineOptions :: IO Options +commandLineOptions = execParser parserOpts + where + progOpts = Options + <$> strOption (mconcat + [ long "output" + , short 'o' + , metavar "" + , help "Output GCode file" + ]) + <*> canvasP + + parserOpts = info (progOpts <**> helper) + ( fullDesc + <> progDesc "Convert SVG to GCode" + <> header "Not that much of SVG is supported, bear with me…" ) diff --git a/penplotting/FlowLines/package.yaml b/penplotting/FlowLines/package.yaml new file mode 100644 index 000000000..3dd18ea4c --- /dev/null +++ b/penplotting/FlowLines/package.yaml @@ -0,0 +1,29 @@ +name: penplotting-flowlines +version: 0.1.0.0 +github: quchen/generative-art +license: BSD3 +author: + - Franz Thoma + - David Luposchainsky +copyright: + - 2022 Franz Thoma + - 2022 David Luposchainsky + +default-extensions: + - LambdaCase + +dependencies: + - generative-art + - base + - cairo + - containers + - mwc-random + - optparse-applicative + - text + - vector + +executables: + penplotting-flowlines: + main: Main.hs + source-dirs: . + ghc-options: [-threaded, -rtsopts, -with-rtsopts=-N, -Wall, -Wno-type-defaults, -O] diff --git a/penplotting/FlowLines/penplotting-flowlines.cabal b/penplotting/FlowLines/penplotting-flowlines.cabal new file mode 100644 index 000000000..7998d7507 --- /dev/null +++ b/penplotting/FlowLines/penplotting-flowlines.cabal @@ -0,0 +1,42 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: penplotting-flowlines +version: 0.1.0.0 +homepage: https://github.com/quchen/generative-art#readme +bug-reports: https://github.com/quchen/generative-art/issues +author: Franz Thoma, + David Luposchainsky +maintainer: Franz Thoma, + David Luposchainsky +copyright: 2022 Franz Thoma, + 2022 David Luposchainsky +license: BSD3 +build-type: Simple + +source-repository head + type: git + location: https://github.com/quchen/generative-art + +executable penplotting-flowlines + main-is: Main.hs + other-modules: + Paths_penplotting_flowlines + hs-source-dirs: + ./ + default-extensions: + LambdaCase + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-type-defaults -O + build-depends: + base + , cairo + , containers + , generative-art + , mwc-random + , optparse-applicative + , text + , vector + default-language: Haskell2010 diff --git a/penplotting/FlowLines/stack.yaml b/penplotting/FlowLines/stack.yaml new file mode 100644 index 000000000..be0c7697d --- /dev/null +++ b/penplotting/FlowLines/stack.yaml @@ -0,0 +1,11 @@ +flags: {} +packages: + - . +extra-deps: + - git: https://github.com/quchen/generative-art + commit: 3cea78bb902c023216727be16dcf8143bd62f0ae + - Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + - plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + - alfred-margaret-2.1.0.2 +resolver: lts-21.25 +allow-newer: true diff --git a/penplotting/FlowLines/stack.yaml.lock b/penplotting/FlowLines/stack.yaml.lock new file mode 100644 index 000000000..5963a5462 --- /dev/null +++ b/penplotting/FlowLines/stack.yaml.lock @@ -0,0 +1,33 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + pantry-tree: + sha256: 27a9154935b4d30a22830477c60c5108fd713a184d456272c2fccbf361d2395f + size: 1176 + original: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 +- completed: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + pantry-tree: + sha256: 887770effc1578682fe255d7f8b1a9801bc5a6e832aa46316782e43eecb65113 + size: 321 + original: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 +- completed: + hackage: alfred-margaret-2.1.0.2@sha256:2903ce63f9054ec607c03439231cdacd0a3b731febe05f493d073bcb1a8bc1a7,4918 + pantry-tree: + sha256: f747ba440a8a87e433970d07cb1edabac770f111fec0732ee83026cf2bf7286e + size: 1938 + original: + hackage: alfred-margaret-2.1.0.2 +snapshots: +- completed: + sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd + size: 640086 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml + original: lts-21.25 diff --git a/penplotting/Hatched/Main.hs b/penplotting/Hatched/Main.hs new file mode 100644 index 000000000..01ce6e91b --- /dev/null +++ b/penplotting/Hatched/Main.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE TupleSections #-} +module Main (main) where + +import Data.List (sortOn) +import qualified Graphics.PlotFont as PF +import Text.Printf + +import Draw.Plotting +import Draw +import Geometry +import qualified Geometry.Shapes as Shapes (haskellLogo) + +-- DIN A4 +picWidth, picHeight :: Num a => a +picWidth = 297 +picHeight = 210 + +haskellLogo :: [Polygon] +haskellLogo = transform (translate (Vec2 15 10) <> scale (picHeight - 20) <> mirrorAlong (angledLine (Vec2 0 0.5) (deg 0) 1)) Shapes.haskellLogo + +main :: IO () +main = do + let settings = def + { _feedrate = 15000 + , _zTravelHeight = 2 + , _zDrawingHeight = -2 + , _canvasBoundingBox = Just (boundingBox [zero, Vec2 picWidth picHeight]) + } + writeGCodeFile "hatching-pen-pressure.g" $ runPlot settings penPressure + writeGCodeFile "hatching-density.g" $ runPlot settings hatchingDensity + +penPressure :: Plot () +penPressure = do + let hatches = fmap (\poly -> hatch poly zero 1 0) haskellLogo + hatchesWithPressure = concat $ zipWith (\p hs -> fmap (, p) hs) [2, 5, 10, 10] hatches + sortedHatches = sortOn (\(Line (Vec2 _ y) _, _) -> y) $ sortOn (\(Line (Vec2 x _) _, _) -> x) hatchesWithPressure + for_ sortedHatches $ \(Line p q, pressure) -> + withDrawingHeight (-pressure) $ do + repositionTo p + lineTo q + +hatchingDensity :: Plot () +hatchingDensity = do + let penName = "Pen hatching test" -- enter pen name here + heading = Polyline . fmap (uncurry Vec2) <$> PF.render' PF.canvastextFont penName + headingOrigin = Vec2 0 160 + for_ heading $ plot . transform (translate headingOrigin <> scale 0.3) + for_ (zip [ (x, y) | y <- [3,2..0], x <- [0..4]] [0.1, 0.2 :: Double ..]) $ \((x, y), density) -> do + let strokes = Polyline . fmap (uncurry Vec2) <$> PF.render' PF.canvastextFont (printf "%.1f" density) + origin = Vec2 (x * 30) (y * 40) + for_ strokes $ plot . transform (translate origin <> translate (Vec2 0 21) <> scale 0.2) + let box = transform (translate origin) (boundingBoxPolygon (boundingBox [zero, Vec2 20 20])) + hatches = zigzag (hatch box (deg 0) density 0) + plot hatches + where + zigzag = Polyline . go + where + go [] = [] + go [Line a b] = [a, b] + go (Line a b : Line c d : ls) = a : b : d : c : go ls diff --git a/penplotting/Hatched/package.yaml b/penplotting/Hatched/package.yaml new file mode 100644 index 000000000..279eb81a2 --- /dev/null +++ b/penplotting/Hatched/package.yaml @@ -0,0 +1,20 @@ +name: penplotting-hatched +version: 0.1.0.0 +github: quchen/generative-art +license: BSD3 +author: + - Franz Thoma +copyright: + - 2022 Franz Thoma + +dependencies: + - generative-art + - base + - cairo + - plotfont + +executables: + penplotting-hatched: + main: Main.hs + source-dirs: . + ghc-options: [-threaded, -rtsopts, -with-rtsopts=-N, -Wall, -Wno-type-defaults, -O] diff --git a/penplotting/Hatched/penplotting-hatched.cabal b/penplotting/Hatched/penplotting-hatched.cabal new file mode 100644 index 000000000..441de148e --- /dev/null +++ b/penplotting/Hatched/penplotting-hatched.cabal @@ -0,0 +1,33 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: penplotting-hatched +version: 0.1.0.0 +homepage: https://github.com/quchen/generative-art#readme +bug-reports: https://github.com/quchen/generative-art/issues +author: Franz Thoma +maintainer: Franz Thoma +copyright: 2022 Franz Thoma +license: BSD3 +build-type: Simple + +source-repository head + type: git + location: https://github.com/quchen/generative-art + +executable penplotting-hatched + main-is: Main.hs + other-modules: + Paths_penplotting_hatched + hs-source-dirs: + ./ + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-type-defaults -O + build-depends: + base + , cairo + , generative-art + , plotfont + default-language: Haskell2010 diff --git a/penplotting/Hatched/stack.yaml b/penplotting/Hatched/stack.yaml new file mode 100644 index 000000000..be0c7697d --- /dev/null +++ b/penplotting/Hatched/stack.yaml @@ -0,0 +1,11 @@ +flags: {} +packages: + - . +extra-deps: + - git: https://github.com/quchen/generative-art + commit: 3cea78bb902c023216727be16dcf8143bd62f0ae + - Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + - plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + - alfred-margaret-2.1.0.2 +resolver: lts-21.25 +allow-newer: true diff --git a/penplotting/Hatched/stack.yaml.lock b/penplotting/Hatched/stack.yaml.lock new file mode 100644 index 000000000..5963a5462 --- /dev/null +++ b/penplotting/Hatched/stack.yaml.lock @@ -0,0 +1,33 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + pantry-tree: + sha256: 27a9154935b4d30a22830477c60c5108fd713a184d456272c2fccbf361d2395f + size: 1176 + original: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 +- completed: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + pantry-tree: + sha256: 887770effc1578682fe255d7f8b1a9801bc5a6e832aa46316782e43eecb65113 + size: 321 + original: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 +- completed: + hackage: alfred-margaret-2.1.0.2@sha256:2903ce63f9054ec607c03439231cdacd0a3b731febe05f493d073bcb1a8bc1a7,4918 + pantry-tree: + sha256: f747ba440a8a87e433970d07cb1edabac770f111fec0732ee83026cf2bf7286e + size: 1938 + original: + hackage: alfred-margaret-2.1.0.2 +snapshots: +- completed: + sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd + size: 640086 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml + original: lts-21.25 diff --git a/penplotting/Kilometer/Main.hs b/penplotting/Kilometer/Main.hs new file mode 100644 index 000000000..e2b0534ed --- /dev/null +++ b/penplotting/Kilometer/Main.hs @@ -0,0 +1,57 @@ +module Main (main) where + + + +import Data.Default.Class +import Data.Foldable +import qualified Data.Text.Lazy.IO as TL +import Draw.Plotting +import Draw.Plotting.CmdArgs +import Geometry as G +import Numerics.Interpolation +import Options.Applicative + + + + + +data Options = Options + { _lineLength_m :: Double + + , _canvas :: Canvas + } deriving (Eq, Ord, Show) + +commandLineOptions :: IO Options +commandLineOptions = execParser parserOpts + where + progOpts = Options + <$> option auto (mconcat + [ long "length" + , short 'l' + , metavar "" + , help "Total line length" + ]) + <*> canvasP + + parserOpts = info (progOpts <**> helper) + ( fullDesc + <> progDesc "Paint a certain length of line on a piece of paper." ) + +main :: IO () +main = do + options <- commandLineOptions + let Options {_lineLength_m = totalLength_m, _canvas = Canvas {_canvasHeight=height_mm, _canvasWidth=width_mm, _canvasMargin=margin_mm}} = options + let geometry = lotsOfLines totalLength_m (boundingBox (Vec2 margin_mm margin_mm, Vec2 (width_mm - margin_mm) (height_mm-margin_mm))) + let plotResult = runPlot def $ do + let flipEveryOtherLine = zipWith ($) (cycle [id, lineReverse]) + for_ (flipEveryOtherLine geometry) plot + TL.putStrLn (renderGCode (_plotGCode plotResult)) + +lotsOfLines :: Double -> BoundingBox -> [Line] +lotsOfLines totalLength_m bb = do + let (singleLineLength, _) = boundingBoxSize bb + BoundingBox (Vec2 xMin yMin) (Vec2 xMax yMax) = bb + numLines = floor (totalLength_m * 1000 / singleLineLength) + n <- [1..numLines] + let y = lerp (1, fromIntegral numLines) (yMin, yMax) (fromIntegral n) + pure (Line (Vec2 xMin y) (Vec2 xMax y)) diff --git a/penplotting/Kilometer/README.md b/penplotting/Kilometer/README.md new file mode 100644 index 000000000..1fd9221b5 --- /dev/null +++ b/penplotting/Kilometer/README.md @@ -0,0 +1,13 @@ +Kilometer +========= + +How long is one kilometer? + +This simple picture puts x-parallell lines of a defined total length onto a +piece of paper. One project possible with this is visualizing just how much ink +is in a standard ball point pen. + +```bash +# Paint 10m onto A4 +stack run kilometer -- --a4 --landscape --length 10 +``` diff --git a/penplotting/Kilometer/kilometer.cabal b/penplotting/Kilometer/kilometer.cabal new file mode 100644 index 000000000..c8f0ae8eb --- /dev/null +++ b/penplotting/Kilometer/kilometer.cabal @@ -0,0 +1,35 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: kilometer +version: 0.1.0.0 +homepage: https://github.com/quchen/generative-art#readme +bug-reports: https://github.com/quchen/generative-art/issues +author: David Luposchainsky +maintainer: David Luposchainsky +copyright: 2022 David Luposchainsky +license: BSD3 +build-type: Simple + +source-repository head + type: git + location: https://github.com/quchen/generative-art + +executable kilometer + main-is: Main.hs + other-modules: + Paths_kilometer + hs-source-dirs: + ./ + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-type-defaults -O + build-depends: + base + , cairo + , data-default-class + , generative-art + , optparse-applicative + , text + default-language: Haskell2010 diff --git a/penplotting/Kilometer/package.yaml b/penplotting/Kilometer/package.yaml new file mode 100644 index 000000000..a8b4d04e9 --- /dev/null +++ b/penplotting/Kilometer/package.yaml @@ -0,0 +1,22 @@ +name: kilometer +version: 0.1.0.0 +github: quchen/generative-art +license: BSD3 +author: + - David Luposchainsky +copyright: + - 2022 David Luposchainsky + +dependencies: + - generative-art + - base + - cairo + - data-default-class + - text + - optparse-applicative + +executables: + kilometer: + main: Main.hs + source-dirs: . + ghc-options: [-threaded, -rtsopts, -with-rtsopts=-N, -Wall, -Wno-type-defaults, -O] diff --git a/penplotting/Kilometer/stack.yaml b/penplotting/Kilometer/stack.yaml new file mode 100644 index 000000000..be0c7697d --- /dev/null +++ b/penplotting/Kilometer/stack.yaml @@ -0,0 +1,11 @@ +flags: {} +packages: + - . +extra-deps: + - git: https://github.com/quchen/generative-art + commit: 3cea78bb902c023216727be16dcf8143bd62f0ae + - Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + - plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + - alfred-margaret-2.1.0.2 +resolver: lts-21.25 +allow-newer: true diff --git a/penplotting/Kilometer/stack.yaml.lock b/penplotting/Kilometer/stack.yaml.lock new file mode 100644 index 000000000..5963a5462 --- /dev/null +++ b/penplotting/Kilometer/stack.yaml.lock @@ -0,0 +1,33 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + pantry-tree: + sha256: 27a9154935b4d30a22830477c60c5108fd713a184d456272c2fccbf361d2395f + size: 1176 + original: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 +- completed: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + pantry-tree: + sha256: 887770effc1578682fe255d7f8b1a9801bc5a6e832aa46316782e43eecb65113 + size: 321 + original: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 +- completed: + hackage: alfred-margaret-2.1.0.2@sha256:2903ce63f9054ec607c03439231cdacd0a3b731febe05f493d073bcb1a8bc1a7,4918 + pantry-tree: + sha256: f747ba440a8a87e433970d07cb1edabac770f111fec0732ee83026cf2bf7286e + size: 1938 + original: + hackage: alfred-margaret-2.1.0.2 +snapshots: +- completed: + sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd + size: 640086 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml + original: lts-21.25 diff --git a/penplotting/PenChangeCalibration/Main.hs b/penplotting/PenChangeCalibration/Main.hs new file mode 100644 index 000000000..b3ef696af --- /dev/null +++ b/penplotting/PenChangeCalibration/Main.hs @@ -0,0 +1,62 @@ +module Main (main) where + + + +import Data.Default.Class +import Data.Foldable +import Draw +import Draw.Plotting +import Geometry as G + + + +main :: IO () +main = do + let settings = def { + _feedrate = 500 + } + plotResult = runPlot settings $ do + for_ (_nonius calibrationDrawing) plot + for_ (_circles calibrationDrawing) plot + for_ (_crosshair calibrationDrawing) plot + writeGCodeFile "out/calibration.g" plotResult + renderPreview "out/preview.svg" 1 plotResult + +data CalibrationDrawing = CalibrationDrawing + { _nonius :: [Line] + , _circles :: [Circle] + , _crosshair :: [Line] + } deriving (Eq, Ord, Show) + +calibrationDrawing :: CalibrationDrawing +calibrationDrawing = + let xNonius = G.transform (G.translate (Vec2 (-25) (-35))) xAxisNonius + yNonius = G.transform (G.rotateAround zero (deg 90) <> G.translate (Vec2 (-25) (-35))) xAxisNonius + circles = [Circle zero r | r <- scanl (+) 10 [1..5]] + + crosshairDiameter = 8 + crosshair = do + angle <- [deg 0, deg 45, deg 90, deg 135] + let horizontalLine = Line (Vec2 0 (-crosshairDiameter)) (Vec2 0 crosshairDiameter) + pure (G.transform (rotateAround zero angle) horizontalLine) + in CalibrationDrawing + { _nonius = xNonius <> yNonius + , _circles = circles + , _crosshair = crosshair + } + +xAxisNonius :: [Line] +xAxisNonius = + let yOffset = 10 + xs = [5, 10 .. 50] + offsets = map (/10) [1..] + brokenBars = concat $ zipWith + (\x dx -> + [ Line (Vec2 (x+dx) 0) (Vec2 (x+dx) (-yOffset)) + , Line (Vec2 x (-yOffset/5)) (Vec2 x (yOffset/5)) + , Line (Vec2 (x-dx) 0) (Vec2 (x-dx) yOffset) ] + ) + xs + offsets + fullBar = Line (Vec2 zero (-yOffset)) (Vec2 zero yOffset) + in fullBar : brokenBars diff --git a/penplotting/PenChangeCalibration/README.md b/penplotting/PenChangeCalibration/README.md new file mode 100644 index 000000000..78d428574 --- /dev/null +++ b/penplotting/PenChangeCalibration/README.md @@ -0,0 +1,20 @@ +Nonius +====== + +Recalibrating the plotter precisely after a pen change is not trivial. This +little calibration picture can help to pin-point the offset required for a new +pen to 0.1mm accuracy. + +The workflow is as follows: + +1. Paint the test picture somewhere outside of the canvas. Use a different + coordinate system so you don’t mess up your initial calibration (e.g. using + G54.1). +2. Revert to standard coordinates (G54) +3. Paint your picture +5. Switch pen +6. Recalibrate Z +7. Draw nonius in G54.1 coordinates again +7. Take note of the XY offset +8. Change G54 coordinates to compensate the offset +9. Draw with second color diff --git a/penplotting/PenChangeCalibration/package.yaml b/penplotting/PenChangeCalibration/package.yaml new file mode 100644 index 000000000..f73b126d8 --- /dev/null +++ b/penplotting/PenChangeCalibration/package.yaml @@ -0,0 +1,21 @@ +name: pen-change-calibration +version: 0.1.0.0 +github: quchen/generative-art +license: BSD3 +author: + - David Luposchainsky +copyright: + - 2022 David Luposchainsky + +dependencies: + - generative-art + - base + - cairo + - data-default-class + - text + +executables: + pen-change-calibration: + main: Main.hs + source-dirs: . + ghc-options: [-threaded, -rtsopts, -with-rtsopts=-N, -Wall, -Wno-type-defaults, -O] diff --git a/penplotting/PenChangeCalibration/pen-change-calibration.cabal b/penplotting/PenChangeCalibration/pen-change-calibration.cabal new file mode 100644 index 000000000..8f08aad0b --- /dev/null +++ b/penplotting/PenChangeCalibration/pen-change-calibration.cabal @@ -0,0 +1,34 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: pen-change-calibration +version: 0.1.0.0 +homepage: https://github.com/quchen/generative-art#readme +bug-reports: https://github.com/quchen/generative-art/issues +author: David Luposchainsky +maintainer: David Luposchainsky +copyright: 2022 David Luposchainsky +license: BSD3 +build-type: Simple + +source-repository head + type: git + location: https://github.com/quchen/generative-art + +executable pen-change-calibration + main-is: Main.hs + other-modules: + Paths_pen_change_calibration + hs-source-dirs: + ./ + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-type-defaults -O + build-depends: + base + , cairo + , data-default-class + , generative-art + , text + default-language: Haskell2010 diff --git a/penplotting/PenChangeCalibration/stack.yaml b/penplotting/PenChangeCalibration/stack.yaml new file mode 100644 index 000000000..be0c7697d --- /dev/null +++ b/penplotting/PenChangeCalibration/stack.yaml @@ -0,0 +1,11 @@ +flags: {} +packages: + - . +extra-deps: + - git: https://github.com/quchen/generative-art + commit: 3cea78bb902c023216727be16dcf8143bd62f0ae + - Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + - plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + - alfred-margaret-2.1.0.2 +resolver: lts-21.25 +allow-newer: true diff --git a/penplotting/PenChangeCalibration/stack.yaml.lock b/penplotting/PenChangeCalibration/stack.yaml.lock new file mode 100644 index 000000000..5963a5462 --- /dev/null +++ b/penplotting/PenChangeCalibration/stack.yaml.lock @@ -0,0 +1,33 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + pantry-tree: + sha256: 27a9154935b4d30a22830477c60c5108fd713a184d456272c2fccbf361d2395f + size: 1176 + original: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 +- completed: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + pantry-tree: + sha256: 887770effc1578682fe255d7f8b1a9801bc5a6e832aa46316782e43eecb65113 + size: 321 + original: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 +- completed: + hackage: alfred-margaret-2.1.0.2@sha256:2903ce63f9054ec607c03439231cdacd0a3b731febe05f493d073bcb1a8bc1a7,4918 + pantry-tree: + sha256: f747ba440a8a87e433970d07cb1edabac770f111fec0732ee83026cf2bf7286e + size: 1938 + original: + hackage: alfred-margaret-2.1.0.2 +snapshots: +- completed: + sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd + size: 640086 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml + original: lts-21.25 diff --git a/penplotting/PoissonDisc/Main.hs b/penplotting/PoissonDisc/Main.hs new file mode 100644 index 000000000..001f3c7a5 --- /dev/null +++ b/penplotting/PoissonDisc/Main.hs @@ -0,0 +1,96 @@ +module Main (main) where + + + +import qualified Data.Set as S +import qualified Data.Vector as V +import Prelude hiding ((**)) +import System.Random.MWC + +import Draw +import Draw.Plotting +import Geometry as G +import Geometry.Algorithms.SimplexNoise +import Graphics.Rendering.Cairo as C +import PoissonDisc + + + +picWidth, picHeight :: Num a => a +picWidth = 440 +picHeight = 440 + +main :: IO () +main = do + renderPoissonDisc "poisson-disc-radial" =<< samplesRadial + renderPoissonDisc "poisson-disc-noise" =<< samplesNoise + +samplesRadial :: IO [(Vec2, Vec2, Double)] +samplesRadial = do + gen <- initialize (V.fromList [1237]) + let center = Vec2 (picWidth / 2) (picHeight / 2) + bb = boundingBox (Vec2 50 50, Vec2 (picWidth - 50) (picHeight - 50)) + r0 = 50 + samplingProps = PoissonDiscParams + { _poissonShape = bb + , _poissonRadius = \p -> r0 / (1 + 0.01 * norm (p -. center)) + , _poissonK = 100 + } + poissonDisc gen samplingProps + +samplesNoise :: IO [(Vec2, Vec2, Double)] +samplesNoise = do + gen <- initialize (V.fromList [1237]) + noise <- simplex2 gen def { _simplexFrequency = 1/150 , _simplexOctaves = 2 } + let bb = boundingBox (Vec2 50 50, Vec2 (picWidth - 50) (picHeight - 50)) + r0 = 30 + samplingProps = PoissonDiscParams + { _poissonShape = bb + , _poissonRadius = \p -> r0 * (1 + 0.5 * noise p) + , _poissonK = 100 + } + poissonDisc gen samplingProps +renderPoissonDisc :: String -> [(Vec2, Vec2, Double)] -> IO () +renderPoissonDisc baseName samples = do + + let drawingCairo = do + setColor white + C.paint + setColor black + for_ samples drawSample + + render ("out/" <> baseName <> ".svg") picWidth picHeight drawingCairo + render ("out/" <> baseName <> ".png") picWidth picHeight drawingCairo + + let circles = minimizePenHoveringBy MinimizePenHoveringSettings { _getStartEndPoint = \(Circle c _) -> (c, c), _flipObject = Nothing, _mergeObjects = Nothing } $ S.fromList $ fmap (\(c, _, r) -> Circle c (r/2)) samples + connectingLines = fmap (Polyline . V.toList) $ minimizePenHovering $ S.fromList $ (\(to, from, _) -> [from, to]) <$> samples + drawingPlot = do + comment "Place pen on bottom left corner of the paper" + comment "Margin is roughly 4cm, and included in the plotting area" + comment "0.8mm pen for circles" + repositionTo (Vec2 40 40) + for_ circles plot + withDrawingHeight 0 $ do + repositionTo zero + penDown + pause PauseUserConfirm + comment "0.1mm pen for lines" + penUp + for_ connectingLines plot + settings = def + { _feedrate = 3000 + , _zTravelHeight = 5 + , _zDrawingHeight = -2 + , _canvasBoundingBox = Nothing + } + + writeGCodeFile (baseName <> ".g") (runPlot settings drawingPlot) + +drawSample :: (Vec2, Vec2, Double) -> Render () +drawSample (sample, parent, radius) = do + sketch (Line parent sample) + C.setLineWidth 0.1 + C.stroke + sketch (Circle sample (radius/2)) + C.setLineWidth 0.8 + C.stroke diff --git a/penplotting/PoissonDisc/PoissonDisc.hs b/penplotting/PoissonDisc/PoissonDisc.hs new file mode 100644 index 000000000..f5e4b2c28 --- /dev/null +++ b/penplotting/PoissonDisc/PoissonDisc.hs @@ -0,0 +1,149 @@ +module PoissonDisc where + + + +import Control.Monad +import Control.Monad.Primitive +import Control.Monad.Trans.Class +import qualified Control.Monad.Trans.Reader as R +import qualified Control.Monad.Trans.State as S +import Data.Heap (Entry, Heap) +import qualified Data.Heap as H +import System.Random.MWC + +import Geometry + + + +-- | Configuration for 'poissonDisc' sampling. +data PoissonDiscParams = PoissonDiscParams + { _poissonShape :: !BoundingBox -- ^ 'def'ault @boundingBox [zero, Vec2 256 256]@. + , _poissonRadius :: Vec2 -> Double -- ^ Minimum distance of a new point from this point. + , _poissonK :: !Int -- ^ How many attempts to find a neighbouring point should be made? + -- The higher this is, the denser the resulting point set will be. + } + +newtype PoissonT m a = PoissonT {runPoissonT :: R.ReaderT PoissonDiscParams (S.StateT (PoissonDiscState (PrimState m)) m) a} + +instance Monad m => Functor (PoissonT m) where + fmap f (PoissonT a) = PoissonT (fmap f a) + +instance Monad m => Applicative (PoissonT m) where + pure x = PoissonT (pure x) + PoissonT mf <*> PoissonT mx = PoissonT (mf <*> mx) + +instance Monad m => Monad (PoissonT m) where + PoissonT a >>= g = PoissonT (a >>= runPoissonT . g) + +instance MonadTrans PoissonT where + lift = PoissonT . lift . lift + +execPoissonT + :: Monad m + => PoissonT m a -- ^ Action + -> PoissonDiscParams -- ^ Config + -> PoissonDiscState (PrimState m) -- ^ Initial state + -> m (PoissonDiscState (PrimState m)) +execPoissonT (PoissonT action) params initialState = S.execStateT (R.runReaderT action params) initialState + +asks :: Monad m => (PoissonDiscParams -> a) -> PoissonT m a +asks = PoissonT . R.asks + +gets :: Monad m => (PoissonDiscState (PrimState m) -> a) -> PoissonT m a +gets = PoissonT . lift . S.gets + +modify' + :: Monad m + => (PoissonDiscState (PrimState m) -> PoissonDiscState (PrimState m)) + -> PoissonT m () +modify' = PoissonT . lift . S.modify' + +-- | Sample points using the Poisson Disc algorithm, which yields a visually +-- uniform distribution. This is opposed to uniformly distributed points yield +-- clumps and empty areas, which is often undesirable for generative art. +-- +-- <> +-- +-- === Example code +-- +-- The \(r=8\) picture is based on the following code: +-- +-- @ +-- points :: ['Vec2'] +-- points = 'Control.Monad.ST.runST' $ do +-- gen <- 'create' +-- 'poissonDisc' gen 'PoissonDiscParams' +-- { _poissonShape = boundingBox [zero, Vec2 80 80] +-- , '_poissonRadius' = 8 +-- , '_poissonK' = 4 +-- } +-- @ +poissonDisc + :: PrimMonad m + => Gen (PrimState m) -- ^ RNG from mwc-random. 'create' yields the default (static) RNG. + -> PoissonDiscParams + -> m [(Vec2, Vec2, Double)] +poissonDisc gen params = do + let PoissonDiscParams{_poissonShape = BoundingBox minV maxV, ..} = params + initialSample = 0.5 *. (minV +. maxV) + initialState = PoissonDiscState + { _gen = gen + , _allSamples = mempty + , _activeSamples = mempty + , _result = mempty + , _initialPoint = initialSample + } + + _result <$> execPoissonT (addSample (initialSample, initialSample, _poissonRadius initialSample) >> sampleLoop) params initialState + +data PoissonDiscState s = PoissonDiscState + { _gen :: !(Gen s) + , _allSamples :: !(Heap (Vec2, Double)) + , _activeSamples :: !(Heap (Entry Double (Vec2, Vec2, Double))) + , _result :: ![(Vec2, Vec2, Double)] + , _initialPoint :: !Vec2 + } + +sampleLoop :: PrimMonad m => PoissonT m () +sampleLoop = gets (H.uncons . _activeSamples) >>= \case + Nothing -> pure () + Just (H.Entry _ (closestActiveSample, parent, radius), heap') -> do + + candidates <- nextCandidates (closestActiveSample, radius) + + let validPoint (candidate, r) = do + allSamples <- gets _allSamples + pure (not (any (\(p, r') -> norm (candidate -. p) <= 0.5*(r+r')) allSamples)) + + newSample <- findM validPoint candidates + + case newSample of + Nothing -> modify' (\s -> s + { _activeSamples = heap' + , _result = (closestActiveSample, parent, radius) : _result s }) + Just (sample, radius') -> addSample (sample, closestActiveSample, radius') + + sampleLoop + +findM :: (Foldable t, Monad m) => (a -> m Bool) -> t a -> m (Maybe a) +findM p = foldr (\x xs -> p x >>= \u -> if u then pure (Just x) else xs) (pure Nothing) + +-- | http://extremelearning.com.au/an-improved-version-of-bridsons-algorithm-n-for-poisson-disc-sampling/ +nextCandidates :: PrimMonad m => (Vec2, Double) -> PoissonT m [(Vec2, Double)] +nextCandidates (v, r) = do + PoissonDiscState{..} <- gets id + PoissonDiscParams{..} <- asks id + candidates <- replicateM _poissonK $ do + phi <- lift (rad <$> uniformRM (0, 2*pi) _gen) + r' <- lift (uniformRM (0.5*r, 1.5*r) _gen) + let v' = v +. polar phi r' + pure (v', _poissonRadius v') + pure (filter ((`insideBoundingBox` _poissonShape) . fst) candidates) + +addSample :: Monad m => (Vec2, Vec2, Double) -> PoissonT m () +addSample (sample, parent, radius) = do + modify' (\s -> s { _allSamples = H.insert (sample, radius) (_allSamples s) }) + distanceFromInitial <- do + initial <- gets _initialPoint + pure (norm (sample -. initial)) + modify' (\s -> s { _activeSamples = H.insert (H.Entry distanceFromInitial (sample, parent, radius)) (_activeSamples s) }) diff --git a/penplotting/PoissonDisc/package.yaml b/penplotting/PoissonDisc/package.yaml new file mode 100644 index 000000000..e93d115d1 --- /dev/null +++ b/penplotting/PoissonDisc/package.yaml @@ -0,0 +1,32 @@ +name: penplotting-poisson-disc +version: 0.1.0.0 +github: quchen/generative-art +license: BSD3 +author: + - Franz Thoma +copyright: + - 2022 Franz Thoma + +default-extensions: + - LambdaCase + - OverloadedStrings + - RecordWildCards + +dependencies: + - generative-art + - base + - cairo + - containers + - data-default-class + - heaps + - mwc-random + - primitive + - text + - transformers + - vector + +executables: + penplotting-poisson-disc: + main: Main.hs + source-dirs: . + ghc-options: [-threaded, -rtsopts, -with-rtsopts=-N, -Wall, -Wno-type-defaults, -O] diff --git a/penplotting/PoissonDisc/penplotting-poisson-disc.cabal b/penplotting/PoissonDisc/penplotting-poisson-disc.cabal new file mode 100644 index 000000000..4bce1bd2f --- /dev/null +++ b/penplotting/PoissonDisc/penplotting-poisson-disc.cabal @@ -0,0 +1,45 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: penplotting-poisson-disc +version: 0.1.0.0 +homepage: https://github.com/quchen/generative-art#readme +bug-reports: https://github.com/quchen/generative-art/issues +author: Franz Thoma +maintainer: Franz Thoma +copyright: 2022 Franz Thoma +license: BSD3 +build-type: Simple + +source-repository head + type: git + location: https://github.com/quchen/generative-art + +executable penplotting-poisson-disc + main-is: Main.hs + other-modules: + PoissonDisc + Paths_penplotting_poisson_disc + hs-source-dirs: + ./ + default-extensions: + LambdaCase + OverloadedStrings + RecordWildCards + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-type-defaults -O + build-depends: + base + , cairo + , containers + , data-default-class + , generative-art + , heaps + , mwc-random + , primitive + , text + , transformers + , vector + default-language: Haskell2010 diff --git a/penplotting/PoissonDisc/stack.yaml b/penplotting/PoissonDisc/stack.yaml new file mode 100644 index 000000000..be0c7697d --- /dev/null +++ b/penplotting/PoissonDisc/stack.yaml @@ -0,0 +1,11 @@ +flags: {} +packages: + - . +extra-deps: + - git: https://github.com/quchen/generative-art + commit: 3cea78bb902c023216727be16dcf8143bd62f0ae + - Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + - plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + - alfred-margaret-2.1.0.2 +resolver: lts-21.25 +allow-newer: true diff --git a/penplotting/PoissonDisc/stack.yaml.lock b/penplotting/PoissonDisc/stack.yaml.lock new file mode 100644 index 000000000..5963a5462 --- /dev/null +++ b/penplotting/PoissonDisc/stack.yaml.lock @@ -0,0 +1,33 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + pantry-tree: + sha256: 27a9154935b4d30a22830477c60c5108fd713a184d456272c2fccbf361d2395f + size: 1176 + original: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 +- completed: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + pantry-tree: + sha256: 887770effc1578682fe255d7f8b1a9801bc5a6e832aa46316782e43eecb65113 + size: 321 + original: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 +- completed: + hackage: alfred-margaret-2.1.0.2@sha256:2903ce63f9054ec607c03439231cdacd0a3b731febe05f493d073bcb1a8bc1a7,4918 + pantry-tree: + sha256: f747ba440a8a87e433970d07cb1edabac770f111fec0732ee83026cf2bf7286e + size: 1938 + original: + hackage: alfred-margaret-2.1.0.2 +snapshots: +- completed: + sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd + size: 640086 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml + original: lts-21.25 diff --git a/penplotting/Pressure/Main.hs b/penplotting/Pressure/Main.hs new file mode 100644 index 000000000..27eb90b80 --- /dev/null +++ b/penplotting/Pressure/Main.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +module Main (main) where + + + +import Control.Monad +import Control.Monad.ST +import Control.Monad.State.Class +import qualified Data.Vector as V +import Formatting (format, fixed, int, (%)) +import qualified Graphics.Rendering.Cairo as C +import System.Random.MWC +import System.Random.MWC.Distributions + +import Draw +import Draw.Plotting +import Geometry +import Geometry.Algorithms.Sampling +import Numerics.DifferentialEquation +import Physics +import Draw.Plotting.GCode (GCode(G01_LinearFeedrateMove)) + +-- DIN A6 postcard format plus 5mm margin +picWidth, picHeight :: Num a => a +picWidth = 158 +picHeight = 115 + +margin :: Vec2 +margin = Vec2 5 5 + +-- DIN A6 postcard size with 5mm margin +canvas :: BoundingBox +canvas = boundingBox [margin, Vec2 picWidth picHeight -. margin] + +main :: IO () +main = for_ + [ (25, 1, "Compression") + , (14.5, 2, "Deflation") + , (20, 3, "Equilibrium") + ] $ \(pressure, index, title) -> do + let tmax = picWidth / 6 + trajectories = runSimulation pressure tmax + render ("out/pressure-" ++ show index ++ ".svg") picWidth picHeight $ do + cairoScope (setColor white >> C.paint) + C.setLineWidth 0.2 + for_ trajectories $ \((_, PhaseSpace { q = q0 }) : trajectory) -> cairoScope $ do + moveToVec q0 + for_ trajectory $ \(t, PhaseSpace {..}) -> do + lineToVec q + setColor (black `withOpacity` (1 - t/tmax)) + C.stroke + moveToVec q + sketch (boundingBoxPolygon canvas) + C.stroke + + let feedrate = 12000 + settings = def + { _feedrate = feedrate + , _zDrawingHeight = -5 + , _zTravelHeight = 5 + } + writeGCodeFile ("pressure-" ++ show index ++ ".g") $ runPlot settings $ do + let caption = "Pressure " ++ show index ++ " - " ++ title + textSettings = def + { _textStartingPoint = Vec2 picWidth 0 +. transform (mirrorXCoords <> scale' 1 1.2) margin + , _textHAlign = HRight + , _textHeight = picHeight / 55 + } + cutMark = Polyline [ Vec2 (picWidth - 5) picHeight, Vec2 picWidth picHeight, Vec2 picWidth (picHeight - 5) ] + plot (plotText textSettings caption) + plot cutMark + for_ (zip [1..] trajectories) $ \(i, trajectory) -> do + let (_, q0) : tqs = (\(t, PhaseSpace {..}) -> (t, q)) <$> trajectory + repositionTo q0 + penDown + for_ tqs $ \(t, Vec2 x y) -> + gCode [ G01_LinearFeedrateMove (Just feedrate) (Just x) (Just y) (Just ((t/tmax - 1) * 10)) ] + penUp + when (i `mod` 20 == 0) $ withDrawingHeight 0 $ do + repositionTo zero + penDown + dl <- gets _drawingDistance + comment (format ("Sharpen pencil (" % int % ") at " % fixed 1 % "m") (i `div` 10) (dl/1000)) + pause PauseUserConfirm + penUp + +gaussianVec2 + :: Vec2 -- ^ Mean + -> Double -- ^ Standard deviation + -> GenST s + -> ST s Vec2 +gaussianVec2 (Vec2 muX muY) sigma gen = Vec2 <$> normal muX sigma gen <*> normal muY sigma gen + +runSimulation :: Double -> Double -> [[(Double, PhaseSpace)]] +runSimulation pressure tmax = + let particles = runST $ do + gen <- initialize (V.fromList [134]) + let poissonShape = boundingBox [4 *. margin, Vec2 picWidth picHeight -. 4 *. margin] + poissonRadius = sqrt (picWidth * picHeight) / 18 + poissonK = 4 + qs <- poissonDisc gen poissonShape poissonRadius poissonK + ps <- replicateM (length qs) $ gaussianVec2 zero 1 gen + pure (NBody $ zipWith PhaseSpace ps qs) + masses = pure 1 + externalPotential = harmonicPotential (picWidth / pressure, picHeight / pressure) (Vec2 (picWidth/2) (picHeight/2)) + interactionPotential = coulombPotential (picWidth / 6) + toleranceNorm (NBody xs) = maximum (fmap (\PhaseSpace {..} -> max (norm p) (norm q)) xs) + tolerance = 0.005 + initialStep = 1 + t0 = 0 + insideCanvas PhaseSpace{..} = q `insideBoundingBox` canvas + in fmap (takeWhile (insideCanvas . snd)) $ getNBody $ traverse (\(t, pq) -> (t,) <$> pq) $ takeWhile (( (t - tmax, xs)) $ dropWhile (( T.putStrLn ("Parse error: " <> err) >> exitWith (ExitFailure 1) + Right svgElements -> do + let -- SVG has zero on the top left. We mirror the Y axis to align the axis before doing all the fitting transformations. + svgElementsYMirrored = G.transform mirrorYCoords svgElements + polylines = + mapMaybe (lineLongEnough options) + . map Polyline + . optimizePaths options + . G.transform (transformToWorld options svgElementsYMirrored) + . concatMap pathToPolyline + $ svgElementsYMirrored + + plottingSettings = def + { _feedrate = 1000 + , _zLoweringFeedrate = Just 1000 + , _zTravelHeight = 2 + , _zDrawingHeight = -1 + , _finishMove = Just FinishWithG28 + , _canvasBoundingBox = Just (boundingBox (_canvas options)) + } + plotResult = runPlot plottingSettings (plot polylines) + writeGCodeFile (_outputFileG options) plotResult + case _previewFile options of + Nothing -> pure () + Just svgFilePath -> renderPreview svgFilePath plotResult + +lineLongEnough :: Sequential f => Options -> Polyline f -> Maybe (Polyline f) +lineLongEnough options polyline = case _minimumLineLength options of + Just minLength + | polylineLength polyline < minLength -> Nothing + _otherwise -> Just polyline + +optimizePaths :: Options -> [[Vec2]] -> [[Vec2]] +optimizePaths options + | _minimizePenTravel options = fmap toList . minimizePenHovering . S.fromList . toList + | otherwise = id + +transformToWorld :: HasBoundingBox drawing => Options -> drawing -> Transformation +transformToWorld options drawing = G.transformBoundingBox drawing world def + where + Options{_canvas=Canvas{_canvasMargin=margin, _canvasHeight=height, _canvasWidth=width}} = options + margin2 = Vec2 margin margin + world = (zero +. margin2, Vec2 width height -. margin2) + +pathToPolyline :: SvgElement -> [[Vec2]] +pathToPolyline (SvgPath paths) = map pathToLineSegments paths +pathToPolyline (SvgLine (Line x y)) = [[x,y]] +pathToPolyline (SvgEllipse (Ellipse e)) = transform e [[x,y] | Line x y <- polygonEdges (regularPolygon 128)] + +pathToLineSegments :: [Either Line Bezier] -> [Vec2] +pathToLineSegments [] = [] +pathToLineSegments [Left (Line x y)] = [x,y] +pathToLineSegments (Left (Line x _) : xs) = x : pathToLineSegments xs +pathToLineSegments [Right bezier] = bezierSubdivideT 32 bezier +pathToLineSegments (Right bezier : xs) = init (bezierSubdivideT 32 bezier) ++ pathToLineSegments xs + +data Options = Options + { _inputFileSvg :: FilePath + , _outputFileG :: FilePath + , _previewFile :: Maybe FilePath + , _minimizePenTravel :: Bool + , _minimumLineLength :: Maybe Double + + , _canvas :: Canvas + } deriving (Eq, Ord, Show) + +commandLineOptions :: IO Options +commandLineOptions = execParser parserOpts + where + progOpts = Options + <$> (strOption . mconcat) + [ long "input" + , short 'f' + , metavar "" + , help "Input SVG file" + ] + <*> (strOption . mconcat) + [ long "output" + , short 'o' + , metavar "" + , help "Output GCode file" + ] + <*> (optional . strOption . mconcat) + [ long "preview" + , metavar "" + , help "Output preview file (.svg or .png)" + ] + <*> (switch . mconcat) + [ long "minimize-pen-travel" + , help "Reorder lines so pen travelling is minimized. Scales quadratically, so does not work well for large number of lines." + ] + <*> (optional . option auto . mconcat) + [ long "min-line-length" + , metavar "" + , help "Minimum line length: filter out polylines shorter than this" + ] + <*> canvasP + + parserOpts = info (progOpts <**> helper) + ( fullDesc + <> progDesc "Convert SVG to GCode" + <> header "Not that much of SVG is supported, bear with me…" ) diff --git a/penplotting/SvgSource/package.yaml b/penplotting/SvgSource/package.yaml new file mode 100644 index 000000000..b9dd1be0e --- /dev/null +++ b/penplotting/SvgSource/package.yaml @@ -0,0 +1,21 @@ +name: penplotting-svg +version: 0.1.0.0 +github: quchen/generative-art +license: BSD3 +author: + - David Luposchainsky +copyright: + - 2022 David Luposchainsky + +dependencies: + - generative-art + - base + - containers + - optparse-applicative + - text + +executables: + penplotting-svg: + main: Main.hs + source-dirs: . + ghc-options: [-threaded, -rtsopts, -with-rtsopts=-N, -Wall, -Wno-type-defaults, -O] diff --git a/penplotting/SvgSource/penplotting-svg.cabal b/penplotting/SvgSource/penplotting-svg.cabal new file mode 100644 index 000000000..2e4041315 --- /dev/null +++ b/penplotting/SvgSource/penplotting-svg.cabal @@ -0,0 +1,34 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: penplotting-svg +version: 0.1.0.0 +homepage: https://github.com/quchen/generative-art#readme +bug-reports: https://github.com/quchen/generative-art/issues +author: David Luposchainsky +maintainer: David Luposchainsky +copyright: 2022 David Luposchainsky +license: BSD3 +build-type: Simple + +source-repository head + type: git + location: https://github.com/quchen/generative-art + +executable penplotting-svg + main-is: Main.hs + other-modules: + Paths_penplotting_svg + hs-source-dirs: + ./ + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-type-defaults -O + build-depends: + base + , containers + , generative-art + , optparse-applicative + , text + default-language: Haskell2010 diff --git a/penplotting/SvgSource/stack.yaml b/penplotting/SvgSource/stack.yaml new file mode 100644 index 000000000..c03bc81fd --- /dev/null +++ b/penplotting/SvgSource/stack.yaml @@ -0,0 +1,14 @@ +flags: {} +packages: + - . +extra-deps: + - git: https://github.com/quchen/generative-art + commit: 6ac74502f1d55da60513ac7aec458e715dad6c3b + - cairo-0.13.10.0@sha256:388f39af90d50b920cad70612046041a7ffd7f5b60721862c0c797ecddf7e902,4153 + - gtk2hs-buildtools-0.13.8.2@sha256:01c4a6cc3679008bd4caec32b49843acb27a5f48ee2b22484218f097835548f6,5238 + - Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + - data-r-tree-0.6.0@sha256:10a25ef70e6779c3bf5128cd45d033482a370ea07e92ab1c82678675de01d870,3668 + - plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + - alfred-margaret-1.1.1.0@sha256:aeb2f14726e1ee70e542ecfb2a71eb14abda8303d17932bca149401edd76135b,3095 +resolver: lts-18.19 +allow-newer: true diff --git a/penplotting/SvgSource/stack.yaml.lock b/penplotting/SvgSource/stack.yaml.lock new file mode 100644 index 000000000..f12ab3146 --- /dev/null +++ b/penplotting/SvgSource/stack.yaml.lock @@ -0,0 +1,54 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: cairo-0.13.10.0@sha256:388f39af90d50b920cad70612046041a7ffd7f5b60721862c0c797ecddf7e902,4153 + pantry-tree: + sha256: a5d7014b0df2600377d061185b104f755274935554e723e2b7b600b85ffc7ae2 + size: 2831 + original: + hackage: cairo-0.13.10.0@sha256:388f39af90d50b920cad70612046041a7ffd7f5b60721862c0c797ecddf7e902,4153 +- completed: + hackage: gtk2hs-buildtools-0.13.8.2@sha256:01c4a6cc3679008bd4caec32b49843acb27a5f48ee2b22484218f097835548f6,5238 + pantry-tree: + sha256: 1c3b449a69f4bb2d27c09a89e447552a58201a3febf5418e67af0001a0cbb0a7 + size: 3588 + original: + hackage: gtk2hs-buildtools-0.13.8.2@sha256:01c4a6cc3679008bd4caec32b49843acb27a5f48ee2b22484218f097835548f6,5238 +- completed: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + pantry-tree: + sha256: 27a9154935b4d30a22830477c60c5108fd713a184d456272c2fccbf361d2395f + size: 1176 + original: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 +- completed: + hackage: data-r-tree-0.6.0@sha256:10a25ef70e6779c3bf5128cd45d033482a370ea07e92ab1c82678675de01d870,3668 + pantry-tree: + sha256: 057a5a25c6c8fe8e60e62b9522e8f1a8be3e7470bfe44229d1e2712e6851409e + size: 614 + original: + hackage: data-r-tree-0.6.0@sha256:10a25ef70e6779c3bf5128cd45d033482a370ea07e92ab1c82678675de01d870,3668 +- completed: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + pantry-tree: + sha256: 887770effc1578682fe255d7f8b1a9801bc5a6e832aa46316782e43eecb65113 + size: 321 + original: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 +- completed: + hackage: alfred-margaret-1.1.1.0@sha256:aeb2f14726e1ee70e542ecfb2a71eb14abda8303d17932bca149401edd76135b,3095 + pantry-tree: + sha256: 44f6f77280a9984cdf7be9f2bc4804f9ba3809ab60e9a065aabb1ee3f8f92322 + size: 1087 + original: + hackage: alfred-margaret-1.1.1.0@sha256:aeb2f14726e1ee70e542ecfb2a71eb14abda8303d17932bca149401edd76135b,3095 +snapshots: +- completed: + sha256: 32716534fff554b7f90762130fdb985cabf29f157758934dd1c8f3892a646430 + size: 586103 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/19.yaml + original: lts-18.19 diff --git a/penplotting/Truchet/Truchet.hs b/penplotting/Truchet/Truchet.hs new file mode 100644 index 000000000..a551de63c --- /dev/null +++ b/penplotting/Truchet/Truchet.hs @@ -0,0 +1,292 @@ +module Main (main) where + + + +import Control.Monad.Primitive +import Control.Monad.Reader.Class +import Control.Monad.ST +import Data.List (partition) +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import Data.Traversable +import qualified Data.Vector as V +import System.Random.MWC + +import Arc +import Draw +import Draw.Plotting +import Geometry +import Geometry.Algorithms.SimplexNoise +import Geometry.Coordinates.Hexagonal hiding (rotateAround) +import Geometry.Shapes + + + +cellSize :: Num a => a +cellSize = 5 + +main :: IO () +main = do + testplot + triptych + +testplot :: IO () +testplot = do + let picWidth, picHeight :: Num a => a + picWidth = 400 + picHeight = 250 + canvases = concat + [ [ move UR 1 $ move R n hexZero | n <- [-2..1]] + , [ move R n hexZero | n <- [-2..2]] + , [ move DR 1 $ move R n hexZero | n <- [-2..1]] + ] + configurations = zip canvases + [ V.fromList $ allRotations =<< [ mkTile [(L, UL, [1..k]), (UR, R, [1..l]), (DR, DL, [1..m])] | k <- [0..3], l <- [0..3], m <- [0..3], k+l+m >= 7] + , V.fromList $ allRotations $ mkTile [(UL, UR, [1..3]), (R, DR, [1..3]), (DL, L, [1..3])] + , V.fromList [ mkTile [(DL, DR, [1..k]), (DR, R, [1..l]), (R, UR, [1..m]), (UR, UL, [1..n]), (UL, L, [1..o]), (L, DL, [1..p])] | k <- [0..3], l <- [0..3], m <- [0..3], n <- [0..3], o <- [0..3], p <- [0..3], k+l == 3, l+m == 3, m+n == 3, n+o == 3, o+p == 3, p+k == 3 ] + , V.fromList [ mkTile [(DL, DR, [1..k]), (DR, R, [1..l]), (R, UR, [1..m]), (UR, UL, [1..n]), (UL, L, [1..o]), (L, DL, [1..p])] | k <- [1..3], l <- [1..3], m <- [1..3], n <- [1..3], o <- [1..3], p <- [1..3], k+l == 3, l+m == 3, m+n == 3, n+o == 3, o+p == 3, p+k == 3 ] + + , V.singleton $ mkTile [(L, UR, [1..3]), (R, DL, [1..2])] + , V.fromList $ allRotations =<< [ mkTile [(L, UR, [1..k]), (R, DL, [1..l])] | k <- [0..3], l <- [0..2], k+l == 5 ] + , V.fromList $ allRotations =<< concat + [ [ mkTile [(L, UR, [1..k]), (R, DL, [1..l])] | k <- [0..3], l <- [0..2], k+l == 5 ] + , [ mkTile [(L, R, [1..k]), (DL, DR, [1..l]), (UL, UR, [1..m])] | k <- [0..3], l <- [0..2], m <- [0..3], k+m <= 5, k+l+m == 7 ] + ] + , V.fromList $ allRotations $ mkTile [(L, UR, [1, 2]), (R, DL, [1, 2])] + , V.singleton $ mkTile [(R, UL, [1,2]), (R, DL, [1])] + + , V.fromList $ allRotations =<< [ mkTile [(L, R, [1..k]), (DL, DR, [1..l]), (UL, UR, [1..m])] | k <- [0..3], l <- [0..2], m <- [0..3], k+m <= 5, k+l+m == 7 ] + , V.fromList $ allRotations =<< [ mkTile [(L, R, [1..k]), (DL, DR, [1..l]), (L, UL, [1..m]), (UL, UR, [1..n]), (UR, R, [1..m])] | k <- [0..3], l <- [2..3], m <- [0..3], n <- [0..3], if k == 0 then l == 3 else l == 2, m+n <= 3, k+m <= 3, k+n >= 4, k+n <= 5 ] + , V.fromList $ allRotations =<< concat + [ [ mkTile [(L, UL, [1..k]), (UR, R, [1..l]), (DR, DL, [1..m])] | k <- [0..3], l <- [0..3], m <- [0..3], k+l+m == 9] + , [ mkTile [(L, R, [1..k]), (DL, DR, [1..l]), (UL, UR, [1..m])] | k <- [0..3], l <- [0..2], m <- [0..3], k+m <= 5, k+l+m == 7 ] + ] + , V.fromList [ mkTile [(L, R, [1,2]), (UL, UR, [1..3]), (DL, DR, [1..2])] ] + ] + + let settings = def + { _zTravelHeight = 3 + , _zDrawingHeight = -0.5 + , _feedrate = 1000 + , _previewPenTravelColor = Nothing + , _previewPenWidth = 0.5 + } + plotResult = runPlot settings $ do + let optimizationSettings = MinimizePenHoveringSettings + { _getStartEndPoint = \arcs -> (fst (arcStartEnd (V.head arcs)), snd (arcStartEnd (V.last arcs))) + , _flipObject = Just (fmap reverseArc . V.reverse) + , _mergeObjects = Nothing -- Already taken care of in 'strands' + } + optimize = concatMap V.toList . minimizePenHoveringBy optimizationSettings . S.fromList + shapes = + [ transform align + ( [mask, transform (scale 1.02) mask] + , clipArc mask <$> optimize (V.map (uncurry toArc) <$> strandsColor1) + , clipArc mask <$> optimize (V.map (uncurry toArc) <$> strandsColor2) + ) + | (hex, tiles) <- configurations + , let align = translate (toVec2 (8 * cellSize) hex +. Vec2 (picWidth/2) (picHeight/2)) <> rotate (deg 30) + , let mask = transform (scale (7.1 * cellSize)) (regularPolygon 6) + , let tiling = runST $ do + gen <- initialize (V.fromList [123, 987]) + randomTiling (const tiles) gen (hexagonsInRange 4 hexZero) + , let allStrands = strands tiling + , let (strandsColor1, strandsColor2) = partition (\xs -> let (_, (_, i, _)) = V.head xs in i == 2) allStrands + ] + penChange = withDrawingHeight 0 $ do + repositionTo zero + penDown + pause PauseUserConfirm + penUp + comment "Silver pen" + local (\s -> s { _previewPenColor = mma 2 }) $ + for_ ((\(_, x, _) -> x) <$> shapes) plot + penChange + comment "Gold pen" + local (\s -> s { _previewPenColor = mma 3, _feedrate = 500 }) $ do -- gold pen requires veeeery low feedrate + plot ((\(_, _, x) -> x) <$> shapes) + plot ((\(x, _, _) -> x) <$> shapes) + + renderPreview "out/penplotting-truchet-testplot.svg" 1 plotResult + writeGCodeFile "truchet-testplot.g" plotResult + +triptych :: IO () +triptych = do + let picWidth, picHeight :: Num a => a + picWidth = 400 + picHeight = 400 + + prototiles1 a = V.fromList $ allRotations =<< + [ mkTile [(L, UL, [1..k]), (UR, R, [1..l]), (DR, DL, [1..m])] | k <- [0..3], l <- [0..3], m <- [0..3], k+l+m == max 0 (min 9 (round (9 * a)))] + prototiles2 a = V.fromList $ allRotations =<< concat + [ [ mkTile [(L, UR, [1..k]), (R, DL, [1..l])] | k <- [0..3], l <- [0..2], k+l == max 0 (min 5 (round (5 * a))) ] + , [ mkTile [(L, R, [1..k]), (DL, DR, [1..l]), (UL, UR, [1..m])] | k <- [0..3], l <- [0..2], m <- [0..3], k+m <= 5, k+l+m == max 0 (min 7 (round (7 * a))) ] + ] + prototiles3 a = V.fromList $ allRotations =<< + [ mkTile [(L, R, [1..k]), (DL, DR, [1..l]), (UL, UR, [1..m])] | k <- [0..3], l <- [0..2], m <- [0..3], k+m <= 5, k+l+m == max 0 (min 7 (round (7 * a))) ] + + generateTiling prototiles = runST $ do + gen <- initialize (V.fromList [125]) + noise <- simplex2 gen def { _simplexFrequency = 1/50, _simplexOctaves = 4 } + let bump d p = case norm p of + r | r < d -> exp (1 - 1 / (1 - (r/d)^2)) + | otherwise -> 0 + variation p = bump (min picHeight picWidth / 2) p ** 0.4 * (1 + 0.1 * (noise p + 1) * 0.5) + randomTiling (prototiles . variation) gen (hexagonsInRange 25 hexZero) + + settings = def + { _zTravelHeight = 3 + , _zDrawingHeight = -0.5 + , _feedrate = 1000 + , _previewPenTravelColor = Nothing + } + for_ (zip [1..] (generateTiling <$> [prototiles1, prototiles2, prototiles3])) $ \(k, tiling) -> do + let plotResult = runPlot settings $ do + let allStrands = strands tiling + (strandsColor1, strandsColor2) = partition (\xs -> let (_, (_, i, _)) = V.head xs in i == 2) allStrands + optimizationSettings = MinimizePenHoveringSettings + { _getStartEndPoint = \arcs -> (fst (arcStartEnd (V.head arcs)), snd (arcStartEnd (V.last arcs))) + , _flipObject = Just (fmap reverseArc . V.reverse) + , _mergeObjects = Nothing -- Already taken care of in 'strands' + } + optimize = concatMap V.toList . minimizePenHoveringBy optimizationSettings . S.fromList + penChange = withDrawingHeight 0 $ do + repositionTo zero + penDown + pause PauseUserConfirm + penUp + comment "Silver pen" + local (\s -> s { _previewPenColor = mma 2 }) $ + for_ (transform (translate (Vec2 (picWidth/2) (picHeight/2))) $ optimize (V.map (uncurry toArc) <$> strandsColor1)) plot + penChange + comment "Gold pen" + local (\s -> s { _previewPenColor = mma 3, _feedrate = 500 }) $ -- gold pen requires veeeery low feedrate + for_ (transform (translate (Vec2 (picWidth/2) (picHeight/2))) $ optimize (V.map (uncurry toArc) <$> strandsColor2)) plot + penChange + print (_totalBoundingBox plotResult) + + renderPreview ("out/penplotting-truchet" ++ show k ++ "-preview.svg") 1 plotResult + writeGCodeFile ("truchet" ++ show k ++ ".g") plotResult + +newtype Tile = Tile (M.Map (Direction, Int) Direction) deriving (Eq, Ord, Show) + +mkTile :: [(Direction, Direction, [Int])] -> Tile +mkTile = Tile . go M.empty + where + go :: M.Map (Direction, Int) Direction -> [(Direction, Direction, [Int])] -> M.Map (Direction, Int) Direction + go m [] = m + go m ((d1, d2, is) : xs) = foldl' (addArc d1 d2) (go m xs) is + addArc :: Direction -> Direction -> M.Map (Direction, Int) Direction -> Int -> M.Map (Direction, Int) Direction + addArc d1 d2 m i = M.insert (d1, arcIndex d1 d2 i) d2 . M.insert (d2, arcIndex d2 d1 i) d1 $ m + arcIndex d1 d2 i = if cyclic d1 d2 then i else 4-i + +cyclic :: Direction -> Direction -> Bool +cyclic d1 d2 + | d1 == reverseDirection d2 = d1 < d2 + | otherwise = (6 + fromEnum d1 - fromEnum d2) `mod` 6 <= 3 + +extractArc :: Tile -> Maybe ((Direction, Int, Direction), Tile) +extractArc (Tile xs) + | M.null xs = Nothing + | otherwise = + let ((d1, i), d2) = M.findMin xs + in Just ((d1, i, d2), deleteArc (Tile xs) (d1, i, d2)) + +findArc :: Tile -> (Direction, Int) -> Maybe ((Direction, Int, Direction), Tile) +findArc (Tile xs) (d1, i) = fmap (\d2 -> ((d1, i, d2), deleteArc (Tile xs) (d1, i, d2))) (M.lookup (d1, i) xs) + +deleteArc :: Tile -> (Direction, Int, Direction) -> Tile +deleteArc (Tile xs) (d1, i, d2) = Tile $ M.delete (d1, i) $ M.delete (d2, 4-i) xs + +allRotations :: Tile -> [Tile] +allRotations tile = [ rotateTile i tile | i <- [0..6] ] + +rotateTile :: Int -> Tile -> Tile +rotateTile n (Tile xs) = Tile $ M.fromList $ (\((d1, i), d2) -> ((rotateDirection d1, i), rotateDirection d2)) <$> M.toList xs + where + rotateDirection d = toEnum ((fromEnum d + n) `mod` 6) + +type Tiling = M.Map Hex Tile + +randomTiling :: PrimMonad m => (Vec2 -> V.Vector Tile) -> Gen (PrimState m) -> [Hex] -> m Tiling +randomTiling baseTiles gen coords = fmap M.fromList $ for coords $ \hex -> do + let p = toVec2 cellSize hex + tile <- randomTile (baseTiles p) gen + pure (hex, tile) + +randomTile :: PrimMonad m => V.Vector Tile -> Gen (PrimState m) -> m Tile +randomTile baseTiles = \gen -> do + rnd <- uniformRM (0, countTiles - 1) gen + pure (baseTiles V.! rnd) + where countTiles = V.length baseTiles + +strands :: Tiling -> [V.Vector (Hex, (Direction, Int, Direction))] +strands tiling = case M.lookupMin tiling of + Nothing -> [] + Just (startHex, t) -> case extractArc t of + Nothing -> strands (M.delete startHex tiling) + Just ((d, i, d'), t') -> + let tiling' = M.insert startHex t' tiling + (s, tiling'') = strand tiling' startHex (d, i) + (s', tiling''') = strand tiling'' startHex (d', 4-i) + in V.fromList (reverseStrand s ++ [(startHex, (d, i, d'))] ++ s') : strands tiling''' + +strand :: Tiling -> Hex -> (Direction, Int) -> ([(Hex, (Direction, Int, Direction))], Tiling) +strand tiling hex (d, i) = let hex' = move d 1 hex in case M.lookup hex' tiling of + Nothing -> ([], tiling) + Just t -> case findArc t (reverseDirection d, 4-i) of + Nothing -> ([], tiling) + Just ((_, _, d'), t') -> + let (s', tiling') = strand (M.insert hex' t' tiling) hex' (d', i) + in ((hex', (reverseDirection d, 4-i, d')) : s', tiling') + +reverseStrand :: [(Hex, (Direction, Int, Direction))] -> [(Hex, (Direction, Int, Direction))] +reverseStrand = fmap (\(h, (d1, i, d2)) -> (h, (d2, 4-i, d1))) . reverse + +reverseDirection :: Direction -> Direction +reverseDirection d = toEnum ((fromEnum d + 3) `mod` 6) + +toArc :: Hex -> (Direction, Int, Direction) -> Arc +toArc hex (d1, n, d2) = sketchArc (fromIntegral n') d1 d2 + where + n' = if cyclic d1 d2 then n else 4-n + center = toVec2 cellSize hex + side d = 0.5 *. (center +. nextCenter d) + nextCenter d = toVec2 cellSize (move d 1 hex) + corner d d' = (center +. nextCenter d +. nextCenter d') /. 3 + [down, _lowerLeft, _upperLeft, _up, upperRight, lowerRight] = [ transform (rotate alpha) (Vec2 0 cellSize) | alpha <- deg <$> [0, 60 .. 300] ] + + sketchArc i DR UL = straight ((0.5 - 0.25 * i) *. upperRight +. side DR) ((0.5 - 0.25 * i) *. upperRight +. side UL) + sketchArc i UR DL = straight ((0.5 - 0.25 * i) *. lowerRight +. side UR) ((0.5 - 0.25 * i) *. lowerRight +. side DL) + sketchArc i R L = straight ((0.5 - 0.25 * i) *. down +. side R) ((0.5 - 0.25 * i) *. down +. side L) + sketchArc i UL DR = straight ((0.5 - 0.25 * i) *. upperRight +. side UL) ((0.5 - 0.25 * i) *. upperRight +. side DR) + sketchArc i DL UR = straight ((0.5 - 0.25 * i) *. lowerRight +. side DL) ((0.5 - 0.25 * i) *. lowerRight +. side UR) + sketchArc i L R = straight ((0.5 - 0.25 * i) *. down +. side L) ((0.5 - 0.25 * i) *. down +. side R) + + sketchArc i UR L = ccwArc (nextCenter UL) ((1 + 0.25 * i) * cellSize) (deg 30) (deg 90) + sketchArc i R UL = ccwArc (nextCenter UR) ((1 + 0.25 * i) * cellSize) (deg 90) (deg 150) + sketchArc i DR UR = ccwArc (nextCenter R) ((1 + 0.25 * i) * cellSize) (deg 150) (deg 210) + sketchArc i DL R = ccwArc (nextCenter DR) ((1 + 0.25 * i) * cellSize) (deg 210) (deg 270) + sketchArc i L DR = ccwArc (nextCenter DL) ((1 + 0.25 * i) * cellSize) (deg 270) (deg 330) + sketchArc i UL DL = ccwArc (nextCenter L) ((1 + 0.25 * i) * cellSize) (deg 330) (deg 30) + sketchArc i L UR = cwArc (nextCenter UL) ((1 + 0.25 * i) * cellSize) (deg 90) (deg 30) + sketchArc i UL R = cwArc (nextCenter UR) ((1 + 0.25 * i) * cellSize) (deg 150) (deg 90) + sketchArc i UR DR = cwArc (nextCenter R) ((1 + 0.25 * i) * cellSize) (deg 210) (deg 150) + sketchArc i R DL = cwArc (nextCenter DR) ((1 + 0.25 * i) * cellSize) (deg 270) (deg 210) + sketchArc i DR L = cwArc (nextCenter DL) ((1 + 0.25 * i) * cellSize) (deg 330) (deg 270) + sketchArc i DL UL = cwArc (nextCenter L) ((1 + 0.25 * i) * cellSize) (deg 30) (deg 330) + + sketchArc i UL L = ccwArc (corner L UL) (0.25 * i * cellSize) (deg 330) (deg 90) + sketchArc i UR UL = ccwArc (corner UL UR) (0.25 * i * cellSize) (deg 30) (deg 150) + sketchArc i R UR = ccwArc (corner UR R) (0.25 * i * cellSize) (deg 90) (deg 210) + sketchArc i DR R = ccwArc (corner R DR) (0.25 * i * cellSize) (deg 150) (deg 270) + sketchArc i DL DR = ccwArc (corner DR DL) (0.25 * i * cellSize) (deg 210) (deg 330) + sketchArc i L DL = ccwArc (corner DL L) (0.25 * i * cellSize) (deg 270) (deg 30) + sketchArc i L UL = cwArc (corner L UL) (0.25 * i * cellSize) (deg 90) (deg 330) + sketchArc i UL UR = cwArc (corner UL UR) (0.25 * i * cellSize) (deg 150) (deg 30) + sketchArc i UR R = cwArc (corner UR R) (0.25 * i * cellSize) (deg 210) (deg 90) + sketchArc i R DR = cwArc (corner R DR) (0.25 * i * cellSize) (deg 270) (deg 150) + sketchArc i DR DL = cwArc (corner DR DL) (0.25 * i * cellSize) (deg 330) (deg 210) + sketchArc i DL L = cwArc (corner DL L) (0.25 * i * cellSize) (deg 30) (deg 270) + + sketchArc _ d d' = error ("Illegal tile " ++ show (d, d')) diff --git a/penplotting/Truchet/Truchetti.hs b/penplotting/Truchet/Truchetti.hs new file mode 100644 index 000000000..5c6071d93 --- /dev/null +++ b/penplotting/Truchet/Truchetti.hs @@ -0,0 +1,264 @@ +module Main (main) where + + + +import Data.List +import Data.List.Extended +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Traversable +import Data.Tuple +import qualified Data.Vector as V +import Control.Monad +import qualified Graphics.Rendering.Cairo as C +import System.Random.MWC + +import Arc +import Draw +import Draw.Plotting +import Geometry +import Geometry.Coordinates.Hexagonal + + + +picWidth, picHeight :: Num a => a +picWidth = 380 +picHeight = 570 + +cellSize :: Double +-- use odd numbers for cell size b/c clipping algorithm does not cope well with cuts through vertices +cellSize = 14.78 + +main :: IO () +main = do + gen <- initialize (V.fromList [123, 986]) + tiling <- randomTiling gen plane + + let drawing = do + coordinateSystem (MathStandard_ZeroCenter_XRight_YUp picWidth picHeight) + cairoScope (setColor black >> C.paint) + for_ (strands tiling) $ drawStrand . V.toList + + render "out/penplotting-truchetti.png" picWidth picHeight drawing + render "out/penplotting-truchetti.svg" picWidth picHeight drawing + + let optimize = minimizePenHoveringBy MinimizePenHoveringSettings + { _getStartEndPoint = \xs -> + let (hex, _, _) = V.head xs + p = toVec2 cellSize hex + in (p, p) + , _flipObject = Nothing + , _mergeObjects = Nothing + } . S.fromList + settings = def + { _zTravelHeight = 2 + , _zDrawingHeight = -1 + , _feedrate = 6000 + , _previewPenTravelColor = Nothing + , _previewPenWidth = 0.5 + } + plotting = do + let xs = V.toList <$> optimize (strands tiling) + for_ (take 5 xs) plotStrandSlightlySmaller + for_ xs plotStrand + plotResult = runPlot settings plotting + renderPreview "out/penplotting-truchetti-preview.png" 1 plotResult + renderPreview "out/penplotting-truchetti-preview.svg" 1 plotResult + writeGCodeFile "truchetti.g" plotResult + +plane :: [Hex] +plane = hexagonsInRange 15 hexZero + +newtype Tile = Tile [(TileArc, [TileArc])] deriving (Eq, Ord, Show) + +tiles :: V.Vector Tile +tiles = V.fromList $ nubOrd + [ Tile + [ (tileArc, arcsAbove) + | tileArc : arcsAbove <- tails partialTile + ] + | [d1, d2, d3, d4, d5, d6] <- permutations allDirections + , let fullTile = [(d1, d2), (d3, d4), (d5, d6)] + , partialTile <- drop 2 $ inits fullTile + ] + where allDirections = [R, UR, UL, L, DL, DR] + +type Tiling = M.Map Hex Tile + +type TileArc = (Direction, Direction) + +randomTiling :: GenIO -> [Hex] -> IO Tiling +randomTiling gen coords = fmap M.fromList $ for coords $ \hex -> do + tile <- randomTile gen + pure (hex, tile) + +randomTile :: GenIO -> IO Tile +randomTile = \gen -> do + rnd <- uniformRM (0, countTiles - 1) gen + pure (tiles V.! rnd) + where countTiles = V.length tiles + +extractArc :: Tile -> Maybe (TileArc, [TileArc], Tile) +extractArc = \case + Tile [] -> Nothing + Tile (((d1, d2), ds) : xs') -> Just ((d1, d2), ds, Tile xs') + +findArc :: Tile -> Direction -> Maybe (TileArc, [TileArc], Tile) +findArc tile@(Tile xs) d1 = case lookup d1 (xs >>= \((a, b), c) -> [(a, (b, c)), (b, (a, c))]) of + Nothing -> Nothing + Just (d2, ds) -> + let tile' = deleteArc tile (d1, d2) + in Just ((d1, d2), ds, tile') + +deleteArc :: Tile -> (Direction, Direction) -> Tile +deleteArc (Tile xs) ds = Tile $ filter (not . (\(ds', _) -> ds == ds' || ds == swap ds')) xs + +strands :: Tiling -> [V.Vector (Hex, TileArc, [TileArc])] +strands tiling = case M.lookupMin tiling of + Nothing -> [] + Just (startHex, t) -> case extractArc t of + Nothing -> strands (M.delete startHex tiling) + Just ((d, d'), ds, t') -> + let tiling' = M.insert startHex t' tiling + (s, tiling'') = strand tiling' startHex d + (s', tiling''') = strand tiling'' startHex d' + in V.fromList (reverseStrand s ++ [(startHex, (d, d'), ds)] ++ s') : strands tiling''' + +strand :: Tiling -> Hex -> Direction -> ([(Hex, TileArc, [TileArc])], Tiling) +strand tiling hex d = let hex' = move d 1 hex in case M.lookup hex' tiling of + Nothing -> ([], tiling) + Just t -> case findArc t (reverseDirection d) of + Nothing -> ([], tiling) + Just ((_, d'), ds, t') -> + let (s', tiling') = strand (M.insert hex' t' tiling) hex' d' + in ((hex', (reverseDirection d, d'), ds) : s', tiling') + +reverseStrand :: [(Hex, TileArc, [TileArc])] -> [(Hex, TileArc, [TileArc])] +reverseStrand = fmap (\(h, (d1, d2), ds) -> (h, (d2, d1), ds)) . reverse + +reverseDirection :: Direction -> Direction +reverseDirection d = toEnum ((fromEnum d + 3) `mod` 6) + +toArc :: Hex -> (Direction, Double, Direction) -> Arc +toArc hex (d1, n, d2) = sketchArc n' d1 d2 + where + n' = if cyclic d1 d2 then n else 1-n + center = toVec2 cellSize hex + side d = 0.5 *. (center +. nextCenter d) + nextCenter d = toVec2 cellSize (move d 1 hex) + corner d d' = (center +. nextCenter d +. nextCenter d') /. 3 + [down, _lowerLeft, _upperLeft, _up, upperRight, lowerRight] = [ transform (rotate alpha) (Vec2 0 cellSize) | alpha <- deg <$> [0, 60 .. 300] ] + + sketchArc i DR UL = straight ((0.5 - i) *. upperRight +. side DR) ((0.5 - i) *. upperRight +. side UL) + sketchArc i UR DL = straight ((0.5 - i) *. lowerRight +. side UR) ((0.5 - i) *. lowerRight +. side DL) + sketchArc i R L = straight ((0.5 - i) *. down +. side R) ((0.5 - i) *. down +. side L) + sketchArc i UL DR = straight ((0.5 - i) *. upperRight +. side UL) ((0.5 - i) *. upperRight +. side DR) + sketchArc i DL UR = straight ((0.5 - i) *. lowerRight +. side DL) ((0.5 - i) *. lowerRight +. side UR) + sketchArc i L R = straight ((0.5 - i) *. down +. side L) ((0.5 - i) *. down +. side R) + + sketchArc i UR L = ccwArc (nextCenter UL) ((1 + i) * cellSize) (deg 30) (deg 90) + sketchArc i R UL = ccwArc (nextCenter UR) ((1 + i) * cellSize) (deg 90) (deg 150) + sketchArc i DR UR = ccwArc (nextCenter R) ((1 + i) * cellSize) (deg 150) (deg 210) + sketchArc i DL R = ccwArc (nextCenter DR) ((1 + i) * cellSize) (deg 210) (deg 270) + sketchArc i L DR = ccwArc (nextCenter DL) ((1 + i) * cellSize) (deg 270) (deg 330) + sketchArc i UL DL = ccwArc (nextCenter L) ((1 + i) * cellSize) (deg 330) (deg 30) + sketchArc i L UR = cwArc (nextCenter UL) ((1 + i) * cellSize) (deg 90) (deg 30) + sketchArc i UL R = cwArc (nextCenter UR) ((1 + i) * cellSize) (deg 150) (deg 90) + sketchArc i UR DR = cwArc (nextCenter R) ((1 + i) * cellSize) (deg 210) (deg 150) + sketchArc i R DL = cwArc (nextCenter DR) ((1 + i) * cellSize) (deg 270) (deg 210) + sketchArc i DR L = cwArc (nextCenter DL) ((1 + i) * cellSize) (deg 330) (deg 270) + sketchArc i DL UL = cwArc (nextCenter L) ((1 + i) * cellSize) (deg 30) (deg 330) + + sketchArc i UL L = ccwArc (corner L UL) (i * cellSize) (deg 330) (deg 90) + sketchArc i UR UL = ccwArc (corner UL UR) (i * cellSize) (deg 30) (deg 150) + sketchArc i R UR = ccwArc (corner UR R) (i * cellSize) (deg 90) (deg 210) + sketchArc i DR R = ccwArc (corner R DR) (i * cellSize) (deg 150) (deg 270) + sketchArc i DL DR = ccwArc (corner DR DL) (i * cellSize) (deg 210) (deg 330) + sketchArc i L DL = ccwArc (corner DL L) (i * cellSize) (deg 270) (deg 30) + sketchArc i L UL = cwArc (corner L UL) (i * cellSize) (deg 90) (deg 330) + sketchArc i UL UR = cwArc (corner UL UR) (i * cellSize) (deg 150) (deg 30) + sketchArc i UR R = cwArc (corner UR R) (i * cellSize) (deg 210) (deg 90) + sketchArc i R DR = cwArc (corner R DR) (i * cellSize) (deg 270) (deg 150) + sketchArc i DR DL = cwArc (corner DR DL) (i * cellSize) (deg 330) (deg 210) + sketchArc i DL L = cwArc (corner DL L) (i * cellSize) (deg 30) (deg 270) + + sketchArc _ d d' = error ("Illegal tile " ++ show (d, d')) + +cyclic :: Direction -> Direction -> Bool +cyclic d1 d2 + | d1 == reverseDirection d2 = d1 < d2 + | otherwise = (6 + fromEnum d1 - fromEnum d2) `mod` 6 <= 3 + +drawStrand :: [(Hex, TileArc, [TileArc])] -> C.Render () +drawStrand xs = cairoScope $ do + let arcAtThreeEights hex (d1, d2) = toArc hex (d1, 3/8, d2) + nubArcs = nubBy (\(d1, d2) (d3, d4) -> d1 == d4 && d2 == d3) + clippingMask hex (d1, d2) = + let Polyline ps1 = approximate (arcAtThreeEights hex (d1, d2)) + Polyline ps2 = approximate (arcAtThreeEights hex (d2, d1)) + in Polygon (ps1 ++ ps2) + clippedArc (hex, (d1, d2), ds) = foldr (\(d1', d2') arcs -> clipArcNegative (clippingMask hex (d1', d2')) =<< arcs) [arcAtThreeEights hex (d1, d2)] (nubArcs ds) + arcsThere = concatMap clippedArc xs + arcsBack = concatMap clippedArc (reverseStrand xs) + (p1, _) = arcStartEnd (head arcsThere) + (_, p2) = arcStartEnd (last arcsBack) + (_, p3) = arcStartEnd (last arcsThere) + (p4, _) = arcStartEnd (head arcsBack) + pathClosed = norm (p1 -. p3) < 0.1 + C.setLineWidth (1/8 * cellSize) + setColor white + for_ arcsThere sketch + unless pathClosed $ sketch (CcwArc (0.5 *. (p3 +. p4)) p3 p4) + C.stroke + for_ arcsBack sketch + unless pathClosed $ sketch (CcwArc (0.5 *. (p1 +. p2)) p2 p1) + C.stroke + +plotStrand :: [(Hex, TileArc, [TileArc])] -> Plot () +plotStrand xs = do + let align = transform (translate (Vec2 (picHeight/2) (picWidth/2)) <> rotate (deg 90)) + arcAtThreeEights hex (d1, d2) = align (toArc hex (d1, 3/8, d2)) + nubArcs = nubBy (\(d1, d2) (d3, d4) -> d1 == d4 && d2 == d3) + clippingMask hex (d1, d2) = + let Polyline ps1 = approximate (arcAtThreeEights hex (d1, d2)) + Polyline ps2 = approximate (arcAtThreeEights hex (d2, d1)) + in Polygon (ps1 ++ ps2) + clippedArc (hex, (d1, d2), ds) = foldr (\(d1', d2') arcs -> clipArcNegative (clippingMask hex (d1', d2')) =<< arcs) [arcAtThreeEights hex (d1, d2)] (nubArcs ds) + arcsThere = concatMap clippedArc xs + arcsBack = concatMap clippedArc (reverseStrand xs) + (p1, _) = arcStartEnd (head arcsThere) + (_, p2) = arcStartEnd (last arcsBack) + (_, p3) = arcStartEnd (last arcsThere) + (p4, _) = arcStartEnd (head arcsBack) + pathClosed = norm (p1 -. p3) < 0.1 + for_ (arcsThere >>= clipArc bb) plot + unless pathClosed $ plot (clipArc bb $ CcwArc (0.5 *. (p3 +. p4)) p3 p4) + for_ (arcsBack >>= clipArc bb) plot + unless pathClosed $ plot (clipArc bb $ CcwArc (0.5 *. (p1 +. p2)) p2 p1) + where + bb = boundingBoxPolygon $ boundingBox [zero, Vec2 picHeight picWidth] + +plotStrandSlightlySmaller :: [(Hex, TileArc, [TileArc])] -> Plot () +plotStrandSlightlySmaller xs = do + let align = transform (translate (Vec2 (picHeight/2) (picWidth/2)) <> rotate (deg 90)) + arcAtThreeEights hex (d1, d2) = align (toArc hex (d1, 3/8, d2)) + slightlySmallerArc hex (d1, d2) = align (toArc hex (d1, 3/8 + 0.04, d2)) + nubArcs = nubBy (\(d1, d2) (d3, d4) -> d1 == d4 && d2 == d3) + clippingMask hex (d1, d2) = + let Polyline ps1 = approximate (arcAtThreeEights hex (d1, d2)) + Polyline ps2 = approximate (arcAtThreeEights hex (d2, d1)) + in Polygon (ps1 ++ ps2) + clippedArc (hex, (d1, d2), ds) = foldr (\(d1', d2') arcs -> clipArcNegative (clippingMask hex (d1', d2')) =<< arcs) [slightlySmallerArc hex (d1, d2)] (nubArcs ds) + arcsThere = concatMap clippedArc xs + arcsBack = concatMap clippedArc (reverseStrand xs) + (p1, _) = arcStartEnd (head arcsThere) + (_, p2) = arcStartEnd (last arcsBack) + (_, p3) = arcStartEnd (last arcsThere) + (p4, _) = arcStartEnd (head arcsBack) + pathClosed = norm (p1 -. p3) < 0.1 + for_ (arcsThere >>= clipArc bb) plot + unless pathClosed $ plot (clipArc bb $ CcwArc (0.5 *. (p3 +. p4)) p3 p4) + for_ (arcsBack >>= clipArc bb) plot + unless pathClosed $ plot (clipArc bb $ CcwArc (0.5 *. (p1 +. p2)) p2 p1) + where + bb = boundingBoxPolygon $ boundingBox [zero, Vec2 picHeight picWidth] diff --git a/penplotting/Truchet/lib/Arc.hs b/penplotting/Truchet/lib/Arc.hs new file mode 100644 index 000000000..4ea82c9fb --- /dev/null +++ b/penplotting/Truchet/lib/Arc.hs @@ -0,0 +1,212 @@ +module Arc where + + + +import Control.Monad (guard) +import Control.Monad.State.Class +import Data.List (sortOn) +import Data.Ord (comparing) +import qualified Graphics.Rendering.Cairo as C + +import Draw +import Draw.Plotting +import Geometry +import Geometry.Shapes + + + +data Arc + = CwArc Vec2 Vec2 Vec2 + | CcwArc Vec2 Vec2 Vec2 + | Straight Vec2 Vec2 + deriving (Eq, Ord, Show) + +arcStartEnd :: Arc -> (Vec2, Vec2) +arcStartEnd = \case + CwArc _ start end -> (start, end) + CcwArc _ start end -> (start, end) + Straight start end -> (start, end) + +reverseArc :: Arc -> Arc +reverseArc = \case + CwArc center start end -> CcwArc center end start + CcwArc center start end -> CwArc center end start + Straight start end -> Straight end start + +cwArc :: Vec2 -> Double -> Angle -> Angle -> Arc +cwArc center radius startAngle endAngle = CwArc center start end + where + start = center +. polar startAngle radius + end = center +. polar endAngle radius + +ccwArc :: Vec2 -> Double -> Angle -> Angle -> Arc +ccwArc center radius startAngle endAngle = CcwArc center start end + where + start = center +. polar startAngle radius + end = center +. polar endAngle radius + +straight :: Vec2 -> Vec2 -> Arc +straight start end = Straight start end + +-- Valid for translation, rotation and aspect-preserving scaling, +-- but breaks down for mirroring and not-aspect-preserving scaling. +instance Transform Arc where + transform t (CwArc center start end) = CwArc (transform t center) (transform t start) (transform t end) + transform t (CcwArc center start end) = CcwArc (transform t center) (transform t start) (transform t end) + transform t (Straight start end) = Straight (transform t start) (transform t end) + +instance Sketch Arc where + sketch (CwArc center start end) = do + let radius = norm (start -. center) + startAngle = angleOfLine (Line center start) + endAngle = angleOfLine (Line center end) + moveToVec start + arcSketchNegative center radius startAngle endAngle + sketch (CcwArc center start end) = do + let radius = norm (start -. center) + startAngle = angleOfLine (Line center start) + endAngle = angleOfLine (Line center end) + moveToVec start + arcSketch center radius startAngle endAngle + sketch (Straight start end) = sketch (Line start end) + +instance Plotting Arc where + plot (CwArc center start end) = do + pos <- gets _penXY + case norm (pos -. start) of + 0 -> pure () + d | d < 0.1 -> lineTo start + _otherwise -> repositionTo start + clockwiseArcAroundTo center end + plot (CcwArc center start end) = do + pos <- gets _penXY + case norm (pos -. start) of + 0 -> pure () + d | d < 0.1 -> lineTo start + _otherwise -> repositionTo start + counterclockwiseArcAroundTo center end + plot (Straight start end) = do + pos <- gets _penXY + case norm (pos -. start) of + d | d < 0.1 -> lineTo end + _otherwise -> repositionTo start >> lineTo end + +-- | Clip an arc with a polygon mask: The result are the parts of the arc that +-- are inside the mask. +-- +-- The algorithm approximates the arc with a polyline, so it's probably not +-- suited for computations, but should be fine for drawing/plotting purposes. +-- +-- <> +clipArc :: Polygon -> Arc -> [Arc] +clipArc = genericClipArc LineInsidePolygon + +-- | Clip an arc with a polygon mask: The result are the parts of the arc that +-- are outside the mask. +-- +-- The algorithm approximates the arc with a polyline, so it's probably not +-- suited for computations, but should be fine for drawing/plotting purposes. +-- +-- <> +clipArcNegative :: Polygon -> Arc -> [Arc] +clipArcNegative = genericClipArc LineOutsidePolygon + +genericClipArc :: LineType -> Polygon -> Arc -> [Arc] +genericClipArc lineType mask (Straight start end) = + [ Straight a b + | (Line a b, lt) <- clipPolygonWithLineSegment mask (Line start end) + , lt == lineType + ] +genericClipArc lineType mask arc@CwArc{} = reverse (reverseArc <$> genericClipArc lineType mask (reverseArc arc)) +genericClipArc lineType mask (CcwArc center start end) = reconstructArcs $ sortOn (getRad . angleOf . fst) (startEndPoint ++ intersectionPoints) + where + tolerance = 0.001 + startAngle = angleOf start + endAngle = angleOf end + maskEdges = polygonEdges mask + radius = norm (start -. center) + approximateCircle = transform (translate center <> scale radius) regularPolygon 32 + startEndPoint = concat + [ [(start, Entering) | start `pointInPolygon` mask == (lineType == LineInsidePolygon)] + , [(end, Exiting) | end `pointInPolygon` mask == (lineType == LineInsidePolygon)] + ] + intersectionPoints = do + edge <- polygonEdges approximateCircle + (Line a' b', lt) <- clipPolygonWithLineSegment mask edge + guard (lt == lineType) + (approximateIntersectionPoint, intersectionClass) <- [(a', Entering), (b', Exiting)] + guard (any (\maskEdge -> distanceFromLine approximateIntersectionPoint maskEdge <= tolerance) maskEdges) + let refinedIntersectionPoint = newton approximateIntersectionPoint + alpha = angleOf refinedIntersectionPoint + guard (getRad alpha >= getRad startAngle - 2 * pi * tolerance && getRad alpha <= getRad endAngle + 2 * pi * tolerance) + pure (refinedIntersectionPoint, intersectionClass) + reconstructArcs xs = go xs + where + go = \case + [] -> [] + (p, Entering) : (q, Exiting) : rest -> CcwArc center p q : go rest + -- Be a bit lenient about common error cases due to numerical instabilities + [_] -> [] + (p, Entering) : (_, Entering) : (_, Exiting) : rest -> go ((p, Entering) : rest) + (_, Exiting) : rest -> go rest + (p, _) : (q, _) : rest | norm (p -. q) < tolerance * radius -> go rest + _ -> error ("Could not reconstruct arcs: " ++ unlines (show <$> xs)) + newton :: Vec2 -> Vec2 + newton p = + let edge = minimumBy (comparing (distanceFromLine p)) maskEdges + deviation = radius - norm (center -. p) + angle = angleBetween edge (Line center p) + in if deviation < tolerance * radius + then p + else newton (p +. deviation *. direction edge /. cos (getRad angle)) + angleOf = \p -> normalizeAngle alpha0 (angleOfLine (Line center p)) + where alpha0 = normalizeAngle zero (angleOfLine (Line center start)) + +-- Positive mathematical orientation +data IntersectionPointClass = Entering | Exiting deriving (Eq, Show) + +-- Test pic for clipping +-- Run in GHCI: +-- > stack ghci penplotting-truchet +-- > arcsClippingExample +arcsClippingExample :: IO () +arcsClippingExample = do + let arcs = + [ arcType (center +. start) (center +. end) + | center <- [Vec2 1 1, Vec2 (-40) (-40), Vec2 (-40) 40, Vec2 40 40, Vec2 40 (-40)] + , (start, end) <- [(Vec2 1 20, Vec2 1 (-20)), (Vec2 (-30) 30, Vec2 30 (-30))] + , arcType <- [CwArc center, CcwArc center, Straight] + ] + mask = transform (scale 60) $ regularPolygon 6 + drawing clip = do + coordinateSystem (MathStandard_ZeroCenter_XRight_YUp 200 200) + sketch mask + setColor (mathematica97 1) + C.stroke + for_ arcs $ \arc -> do + let color = case arc of + CcwArc{} -> mathematica97 2 + CwArc{} -> mathematica97 3 + Straight{} -> mathematica97 4 + sketch arc + setColor (color `withOpacity` 0.2) + C.stroke + for_ (clip mask arc) sketch + setColor color + C.stroke + render "docs/clipping_example.svg" 200 200 (drawing clipArc) + render "docs/negative_clipping_example.svg" 200 200 (drawing clipArcNegative) + +approximate :: Arc -> Polyline +approximate (Straight start end) = Polyline [start, end] +approximate (CwArc center start end) = + let Polyline ps = approximate (CcwArc center end start) + in Polyline (reverse ps) +approximate (CcwArc center start end) = + let radius = norm (center -. start) + startAngle = normalizeAngle zero (angleOfLine (Line center start)) + angleOf p = normalizeAngle startAngle (angleOfLine (Line center p)) + endAngle = angleOf end + Polygon ps = transform (translate center <> rotate startAngle <> scale radius) (regularPolygon 32) + supportPoints = filter (\p -> getRad (angleOf p) > getRad startAngle && getRad (angleOf p) < getRad endAngle) ps + in Polyline (start : supportPoints ++ [end]) diff --git a/penplotting/Truchet/package.yaml b/penplotting/Truchet/package.yaml new file mode 100644 index 000000000..1c9e2dfac --- /dev/null +++ b/penplotting/Truchet/package.yaml @@ -0,0 +1,43 @@ +name: penplotting-truchet +version: 0.1.0.0 +github: quchen/generative-art +license: BSD3 +author: + - Franz Thoma +copyright: + - 2022 Franz Thoma + +default-extensions: + - LambdaCase + - MultiWayIf + - OverloadedStrings + +dependencies: + - generative-art + - base + - cairo + - containers + - mtl + - mwc-random + - primitive + - vector + +extra-doc-files: + - docs/*.svg + +library: + source-dirs: lib + +executables: + penplotting-truchetti: + main: Truchetti.hs + other-modules: [] + source-dirs: . + ghc-options: [-threaded, -rtsopts, -with-rtsopts=-N, -Wall, -Wno-type-defaults, -O] + dependencies: [penplotting-truchet] + penplotting-truchet: + main: Truchet.hs + other-modules: [] + source-dirs: . + ghc-options: [-threaded, -rtsopts, -with-rtsopts=-N, -Wall, -Wno-type-defaults, -O] + dependencies: [penplotting-truchet] diff --git a/penplotting/Truchet/penplotting-truchet.cabal b/penplotting/Truchet/penplotting-truchet.cabal new file mode 100644 index 000000000..1590e15f2 --- /dev/null +++ b/penplotting/Truchet/penplotting-truchet.cabal @@ -0,0 +1,86 @@ +cabal-version: 1.18 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: penplotting-truchet +version: 0.1.0.0 +homepage: https://github.com/quchen/generative-art#readme +bug-reports: https://github.com/quchen/generative-art/issues +author: Franz Thoma +maintainer: Franz Thoma +copyright: 2022 Franz Thoma +license: BSD3 +build-type: Simple +extra-doc-files: + docs/clipping_example.svg + docs/negative_clipping_example.svg + +source-repository head + type: git + location: https://github.com/quchen/generative-art + +library + exposed-modules: + Arc + other-modules: + Paths_penplotting_truchet + hs-source-dirs: + lib + default-extensions: + LambdaCase + MultiWayIf + OverloadedStrings + build-depends: + base + , cairo + , containers + , generative-art + , mtl + , mwc-random + , primitive + , vector + default-language: Haskell2010 + +executable penplotting-truchet + main-is: Truchet.hs + hs-source-dirs: + ./ + default-extensions: + LambdaCase + MultiWayIf + OverloadedStrings + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-type-defaults -O + build-depends: + base + , cairo + , containers + , generative-art + , mtl + , mwc-random + , penplotting-truchet + , primitive + , vector + default-language: Haskell2010 + +executable penplotting-truchetti + main-is: Truchetti.hs + hs-source-dirs: + ./ + default-extensions: + LambdaCase + MultiWayIf + OverloadedStrings + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-type-defaults -O + build-depends: + base + , cairo + , containers + , generative-art + , mtl + , mwc-random + , penplotting-truchet + , primitive + , vector + default-language: Haskell2010 diff --git a/penplotting/Truchet/stack.yaml b/penplotting/Truchet/stack.yaml new file mode 100644 index 000000000..be0c7697d --- /dev/null +++ b/penplotting/Truchet/stack.yaml @@ -0,0 +1,11 @@ +flags: {} +packages: + - . +extra-deps: + - git: https://github.com/quchen/generative-art + commit: 3cea78bb902c023216727be16dcf8143bd62f0ae + - Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + - plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + - alfred-margaret-2.1.0.2 +resolver: lts-21.25 +allow-newer: true diff --git a/penplotting/Truchet/stack.yaml.lock b/penplotting/Truchet/stack.yaml.lock new file mode 100644 index 000000000..5963a5462 --- /dev/null +++ b/penplotting/Truchet/stack.yaml.lock @@ -0,0 +1,33 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + pantry-tree: + sha256: 27a9154935b4d30a22830477c60c5108fd713a184d456272c2fccbf361d2395f + size: 1176 + original: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 +- completed: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + pantry-tree: + sha256: 887770effc1578682fe255d7f8b1a9801bc5a6e832aa46316782e43eecb65113 + size: 321 + original: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 +- completed: + hackage: alfred-margaret-2.1.0.2@sha256:2903ce63f9054ec607c03439231cdacd0a3b731febe05f493d073bcb1a8bc1a7,4918 + pantry-tree: + sha256: f747ba440a8a87e433970d07cb1edabac770f111fec0732ee83026cf2bf7286e + size: 1938 + original: + hackage: alfred-margaret-2.1.0.2 +snapshots: +- completed: + sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd + size: 640086 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml + original: lts-21.25 diff --git a/penplotting/Typography/Main.hs b/penplotting/Typography/Main.hs new file mode 100644 index 000000000..9436f7675 --- /dev/null +++ b/penplotting/Typography/Main.hs @@ -0,0 +1,136 @@ +module Main where + + + +import Data.List.Extended (nubOrd) +import qualified Data.Vector.Unboxed as V +import Data.Traversable +import qualified Graphics.Rendering.Cairo as C +import qualified Graphics.Text.TrueType as TT +import System.Random.MWC + +import Draw +import Geometry +import Geometry.Algorithms.Sampling +import Geometry.Chaotic + + + +main :: IO () +main = do + Right iosevka <- TT.loadFontFile "/home/fthoma/.nix-profile/share/fonts/truetype/iosevka-custom-regular.ttf" + gen <- initializeMwc (23 :: Int) + let poissonShape = boundingBox [Vec2 100 50, Vec2 900 850] + poissonRadius = 80 + poissonK = 4 + pts <- poissonDisc gen poissonShape poissonRadius poissonK + glyphs <- for pts $ \pt -> do + char <- uniformRM ('a', 'z') gen + style <- uniformM gen + pure (char, pt, style) + render "out/typography.png" 1000 1000 $ do + cairoScope (setColor white >> C.paint) + C.setLineWidth 1 + C.translate (-50) 100 + for_ glyphs $ \(char, Vec2 x y, style) -> cairoScope $ do + C.translate x y + case style of + Outline -> sketch (fst <$> glyphOutline iosevka 200 char) + Shadow -> sketch (glyphShadow iosevka 200 char) + Hatched angle -> sketch (hatchedGlyph iosevka 200 char angle 5) + C.stroke + +data GlyphStyle + = Outline + | Shadow + | Hatched Angle + deriving (Eq, Show) + +instance Uniform GlyphStyle where + uniformM gen = uniformRM (0, 2 :: Int) gen >>= \case + 0 -> pure Outline + 1 -> pure Shadow + 2 -> Hatched . deg <$> uniformRM (0, 180) gen + +glyph :: TT.Font -> Double -> Char -> [Polygon] +glyph font size c = fmap (Polygon . fmap toVec2 . nubOrd . V.toList) polys + where + dpi = 96 + pt = TT.pixelSizeInPointAtDpi (realToFrac size) dpi + toVec2 (x, y) = Vec2 (realToFrac x) (realToFrac y) + [polys] = TT.getGlyphForStrings dpi [(font, pt, [c])] + +str :: TT.Font -> Double -> String -> [[Polygon]] +str font size t = fmap (fmap (Polygon . fmap toVec2 . nubOrd . V.toList)) glyphs + where + dpi = 96 + pt = TT.pixelSizeInPointAtDpi (realToFrac size) dpi + toVec2 (x, y) = Vec2 (realToFrac x) (realToFrac y) + glyphs = TT.getStringCurveAtPoint dpi (0, 0) [(font, pt, t)] + +hatchedGlyph + :: TT.Font + -> Double -- ^ Font size + -> Char -- ^ Glyph + -> Angle -- ^ Direction in which the lines will point. @'deg' 0@ is parallel to the x axis. + -> Double -- ^ Distance between shading lines + -> [Line] +hatchedGlyph font size c angle hatchInterval = do + let polygons = glyphOutline font size c + let polygonsAligned = fmap (\(p, ioh) -> (transform (rotate (negateV angle)) p, ioh)) polygons + horizontalScissors <- do + let BoundingBox (Vec2 xLo yLo) (Vec2 xHi yHi) = boundingBox (fst <$> polygonsAligned) + y <- takeWhile (< yHi) (tail (iterate (+ hatchInterval) yLo)) + pure (Line (Vec2 xLo y) (Vec2 xHi y)) + positiveHatches <- + [ line + | (polygonAligned, Island) <- polygonsAligned + , (line, LineInsidePolygon) <- clipPolygonWithLineSegment polygonAligned horizontalScissors + ] + horizontalHatches <- foldl' (\ls (poly, _) -> [line | (line, LineOutsidePolygon) <- ls >>= clipPolygonWithLineSegment poly]) [positiveHatches] (filter ((== Hole) . snd) polygonsAligned) + pure (transform (rotate angle) horizontalHatches) + +glyphOutline :: TT.Font -> Double -> Char -> [(Polygon, IslandOrHole)] +glyphOutline font size c = foldl' combinePolygons [p] ps + where + rawPolygons = glyph font size c + classify poly = case polygonOrientation poly of + PolygonPositive -> (poly, Island) + PolygonNegative -> (poly, Hole) + p:ps = classify <$> rawPolygons + combinePolygons :: [(Polygon, IslandOrHole)] -> (Polygon, IslandOrHole) -> [(Polygon, IslandOrHole)] + combinePolygons ps (p, ioh) = case ioh of + Island -> unionsPP ps p + Hole -> differencesPP ps p + +glyphShadow :: TT.Font -> Double -> Char -> [Line] +glyphShadow font size c = foldl' clipHatches shadow outline + where + outline = glyphOutline font size c + shadow = transform (translate (Vec2 (size/30) (size/50))) (hatchedGlyph font size c (deg 90) 1) + clipHatches hs (p, Island) = [ h' | h <- hs, (h', LineOutsidePolygon) <- clipPolygonWithLineSegment p h ] + clipHatches hs (p, Hole) = [ h' | h <- hs, (h', LineInsidePolygon) <- clipPolygonWithLineSegment p h ] + +unionsPP :: [(Polygon, IslandOrHole)] -> Polygon -> [(Polygon, IslandOrHole)] +unionsPP [] p = [(p, Island)] +unionsPP ps p = + [ q' + | (q, ioh) <- ps + , q' <- case ioh of + Island -> unionPP q p + Hole -> differencePP q p >>= \case + (x, Island) -> [(x, Hole)] + (x, Hole) -> [(x, Island)] + ] + +differencesPP :: [(Polygon, IslandOrHole)] -> Polygon -> [(Polygon, IslandOrHole)] +differencesPP [] _ = [] +differencesPP ps p = + [ q' + | (q, ioh) <- ps + , q' <- case ioh of + Island -> differencePP q p + Hole -> unionPP q p >>= \case + (x, Island) -> [(x, Hole)] + (x, Hole) -> [(x, Island)] + ] diff --git a/penplotting/Typography/package.yaml b/penplotting/Typography/package.yaml new file mode 100644 index 000000000..9a1ff7294 --- /dev/null +++ b/penplotting/Typography/package.yaml @@ -0,0 +1,28 @@ +name: penplotting-typography +version: 0.1.0.0 +github: quchen/generative-art +license: BSD3 +author: + - Franz Thoma +copyright: + - 2022 Franz Thoma + +default-extensions: + - LambdaCase + - RecordWildCards + - OverloadedStrings + +dependencies: + - generative-art + - base + - cairo + - FontyFruity + - mwc-random + - text + - vector + +executables: + penplotting-typography: + main: Main.hs + source-dirs: . + ghc-options: [-threaded, -rtsopts, -with-rtsopts=-N, -Wall, -Wno-type-defaults, -O] diff --git a/penplotting/Typography/penplotting-typography.cabal b/penplotting/Typography/penplotting-typography.cabal new file mode 100644 index 000000000..e9a50a622 --- /dev/null +++ b/penplotting/Typography/penplotting-typography.cabal @@ -0,0 +1,40 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: penplotting-typography +version: 0.1.0.0 +homepage: https://github.com/quchen/generative-art#readme +bug-reports: https://github.com/quchen/generative-art/issues +author: Franz Thoma +maintainer: Franz Thoma +copyright: 2022 Franz Thoma +license: BSD3 +build-type: Simple + +source-repository head + type: git + location: https://github.com/quchen/generative-art + +executable penplotting-typography + main-is: Main.hs + other-modules: + Paths_penplotting_typography + hs-source-dirs: + ./ + default-extensions: + LambdaCase + RecordWildCards + OverloadedStrings + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-type-defaults -O + build-depends: + FontyFruity + , base + , cairo + , generative-art + , mwc-random + , text + , vector + default-language: Haskell2010 diff --git a/penplotting/Typography/stack.yaml b/penplotting/Typography/stack.yaml new file mode 100644 index 000000000..be0c7697d --- /dev/null +++ b/penplotting/Typography/stack.yaml @@ -0,0 +1,11 @@ +flags: {} +packages: + - . +extra-deps: + - git: https://github.com/quchen/generative-art + commit: 3cea78bb902c023216727be16dcf8143bd62f0ae + - Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + - plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + - alfred-margaret-2.1.0.2 +resolver: lts-21.25 +allow-newer: true diff --git a/penplotting/Typography/stack.yaml.lock b/penplotting/Typography/stack.yaml.lock new file mode 100644 index 000000000..5963a5462 --- /dev/null +++ b/penplotting/Typography/stack.yaml.lock @@ -0,0 +1,33 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + pantry-tree: + sha256: 27a9154935b4d30a22830477c60c5108fd713a184d456272c2fccbf361d2395f + size: 1176 + original: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 +- completed: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + pantry-tree: + sha256: 887770effc1578682fe255d7f8b1a9801bc5a6e832aa46316782e43eecb65113 + size: 321 + original: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 +- completed: + hackage: alfred-margaret-2.1.0.2@sha256:2903ce63f9054ec607c03439231cdacd0a3b731febe05f493d073bcb1a8bc1a7,4918 + pantry-tree: + sha256: f747ba440a8a87e433970d07cb1edabac770f111fec0732ee83026cf2bf7286e + size: 1938 + original: + hackage: alfred-margaret-2.1.0.2 +snapshots: +- completed: + sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd + size: 640086 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml + original: lts-21.25 diff --git a/penplotting/Voronoi/Main.hs b/penplotting/Voronoi/Main.hs new file mode 100644 index 000000000..1132e55a3 --- /dev/null +++ b/penplotting/Voronoi/Main.hs @@ -0,0 +1,129 @@ +module Main (main) where + + + +import qualified Data.Text.Lazy as TL +import qualified Data.Vector as V +import Prelude hiding ((**)) +import System.Random.MWC + +import Draw +import Draw.Plotting +import Geometry as G +import Geometry.Algorithms.Delaunay +import Geometry.Algorithms.Sampling +import Geometry.Algorithms.SimplexNoise +import Geometry.Algorithms.Voronoi +import Graphics.Rendering.Cairo as C + + + +picWidth, picHeight :: Num a => a +picWidth = 500 +picHeight = 500 + +main :: IO () +main = mainVoronoiDithering >> mainVoronoiDelaunay + +mainVoronoiDithering :: IO () +mainVoronoiDithering = do + gen <- initialize (V.fromList [1237]) + let center = Vec2 (picWidth / 2) (picHeight / 2) + bb = boundingBox (Vec2 50 50, Vec2 (picWidth - 50) (picHeight - 50)) + count = 600 + -- constructed so that we have roughly `count` points + adaptiveRadius = sqrt (0.75 * picWidth * picHeight / fromIntegral count) + samplingProps = PoissonDiscParams + { _poissonShape = bb + , _poissonRadius = adaptiveRadius + , _poissonK = 4 + } + points <- poissonDisc gen samplingProps + print (length points) + let delaunay = lloydRelaxation 8 $ bowyerWatson bb points + voronoi = toVoronoi delaunay + + noise <- simplex2 def { _simplexFrequency = 1/150 , _simplexOctaves = 2 } gen + + let scaleFactor p = 0.45 * (1 + noise p) * exp (-0.00001 * norm (p -. center) ^ 2) + + let resizeCell poly@(Polygon ps) = Polygon $ fmap (\p -> G.transform (scaleAround centroid (scaleFactor (centroid +. 0.5 *. (p -. centroid)))) p) ps + where centroid = polygonCentroid poly + isInnerCell polygon = insideBoundingBox (G.transform (scaleAround center 1.05) polygon) bb + polygons = resizeCell <$> filter isInnerCell (_voronoiRegion <$> _voronoiCells voronoi) + + render "out/voronoi-dithering.svg" picWidth picHeight $ do + setColor black + C.paint + for_ polygons $ drawPoly white + + let settings = def + { _feedrate = 3000 + , _zTravelHeight = 5 + , _zDrawingHeight = -2 + , _canvasBoundingBox = Just $ boundingBox (Vec2 0 0, Vec2 400 400) + } + removeMargin = G.transform (G.translate (Vec2 (-50) (-50))) + writeGCodeFile "voronoi-dithering.g" $ runPlot settings $ do + comment "To be plotted with white, silver or gold pen on 50cmx50cm black paper, with a margin of 5cm." + comment "Place the origin on the inside of the margin, i.e. at X50 Y50 from the paper corner." + for_ (removeMargin polygons) plot + totalLength <- drawingDistance + comment ("Total length: " <> TL.pack (show (round (totalLength/10))) <> "cm") + + +mainVoronoiDelaunay :: IO () +mainVoronoiDelaunay = do + gen <- initialize (V.fromList [1234]) + let center = Vec2 (picWidth / 2) (picHeight / 2) + count = 200 + -- constructed so that we have roughly `count` points + adaptiveRadius = sqrt (0.75 * picWidth * picHeight / fromIntegral count) + samplingProps = PoissonDiscParams + { _poissonShape = boundingBox (Vec2 50 50, Vec2 (picWidth - 50) (picHeight - 50)) + , _poissonRadius = adaptiveRadius + , _poissonK = 4 + } + points <- poissonDisc gen samplingProps + print (length points) + let delaunay = lloydRelaxation 8 $ bowyerWatson (boundingBox (Vec2 0 0, Vec2 picWidth picHeight)) points + voronoi = toVoronoi delaunay + polygonInRange (Polygon xs) = all (\p -> norm (center -. p) < 200) xs + + render "out/voronoi-delaunay.png" picWidth picHeight $ do + setColor grey + C.paint + for_ (filter polygonInRange $ getPolygons delaunay) (drawPoly black) + for_ (filter polygonInRange $ _voronoiRegion <$> _voronoiCells voronoi) (drawPoly white) + + let settings = def + { _feedrate = 6000 + , _zTravelHeight = 5 + , _zDrawingHeight = -2 + , _canvasBoundingBox = Just $ boundingBox (Vec2 0 0, Vec2 400 400) + } + removeMargin = G.transform (G.translate (Vec2 (-50) (-50))) + writeGCodeFile "voronoi-delaunay.g" $ runPlot settings $ do + comment "To be plotted on 50cmx50cm grey paper, with a margin of 5cm." + comment "Place the origin on the inside of the margin, i.e. at X50 Y50 from the paper corner." + comment "Start with a black pen." + for_ (removeMargin $ filter polygonInRange $ getPolygons delaunay) plot + repositionTo zero + withDrawingHeight 0 penDown + pause PauseUserConfirm + comment "Now change to a white pen." + penUp + withFeedrate 3000 $ do -- Lower feedrate for white pen, and draw twice + for_ (removeMargin $ filter polygonInRange $ _voronoiRegion <$> _voronoiCells voronoi) plot + for_ (removeMargin $ filter polygonInRange $ _voronoiRegion <$> _voronoiCells voronoi) plot + +drawPoly :: Color Double -> Polygon -> Render () +drawPoly _ (Polygon []) = pure () +drawPoly color poly = do + sketch poly + setColor color + setLineWidth 0.5 + stroke + +grey :: Color Double +grey = hsv 0 0 0.5 diff --git a/penplotting/Voronoi/package.yaml b/penplotting/Voronoi/package.yaml new file mode 100644 index 000000000..f7e2ebc14 --- /dev/null +++ b/penplotting/Voronoi/package.yaml @@ -0,0 +1,26 @@ +name: penplotting-voronoi +version: 0.1.0.0 +github: quchen/generative-art +license: BSD3 +author: + - Franz Thoma +copyright: + - 2022 Franz Thoma + +default-extensions: + - RecordWildCards + - OverloadedStrings + +dependencies: + - generative-art + - base + - cairo + - mwc-random + - text + - vector + +executables: + penplotting-voronoi: + main: Main.hs + source-dirs: . + ghc-options: [-threaded, -rtsopts, -with-rtsopts=-N, -Wall, -Wno-type-defaults, -O] diff --git a/penplotting/Voronoi/penplotting-voronoi.cabal b/penplotting/Voronoi/penplotting-voronoi.cabal new file mode 100644 index 000000000..a603778c3 --- /dev/null +++ b/penplotting/Voronoi/penplotting-voronoi.cabal @@ -0,0 +1,38 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: penplotting-voronoi +version: 0.1.0.0 +homepage: https://github.com/quchen/generative-art#readme +bug-reports: https://github.com/quchen/generative-art/issues +author: Franz Thoma +maintainer: Franz Thoma +copyright: 2022 Franz Thoma +license: BSD3 +build-type: Simple + +source-repository head + type: git + location: https://github.com/quchen/generative-art + +executable penplotting-voronoi + main-is: Main.hs + other-modules: + Paths_penplotting_voronoi + hs-source-dirs: + ./ + default-extensions: + RecordWildCards + OverloadedStrings + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-type-defaults -O + build-depends: + base + , cairo + , generative-art + , mwc-random + , text + , vector + default-language: Haskell2010 diff --git a/penplotting/Voronoi/stack.yaml b/penplotting/Voronoi/stack.yaml new file mode 100644 index 000000000..c03bc81fd --- /dev/null +++ b/penplotting/Voronoi/stack.yaml @@ -0,0 +1,14 @@ +flags: {} +packages: + - . +extra-deps: + - git: https://github.com/quchen/generative-art + commit: 6ac74502f1d55da60513ac7aec458e715dad6c3b + - cairo-0.13.10.0@sha256:388f39af90d50b920cad70612046041a7ffd7f5b60721862c0c797ecddf7e902,4153 + - gtk2hs-buildtools-0.13.8.2@sha256:01c4a6cc3679008bd4caec32b49843acb27a5f48ee2b22484218f097835548f6,5238 + - Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + - data-r-tree-0.6.0@sha256:10a25ef70e6779c3bf5128cd45d033482a370ea07e92ab1c82678675de01d870,3668 + - plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + - alfred-margaret-1.1.1.0@sha256:aeb2f14726e1ee70e542ecfb2a71eb14abda8303d17932bca149401edd76135b,3095 +resolver: lts-18.19 +allow-newer: true diff --git a/penplotting/Voronoi/stack.yaml.lock b/penplotting/Voronoi/stack.yaml.lock new file mode 100644 index 000000000..f12ab3146 --- /dev/null +++ b/penplotting/Voronoi/stack.yaml.lock @@ -0,0 +1,54 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: cairo-0.13.10.0@sha256:388f39af90d50b920cad70612046041a7ffd7f5b60721862c0c797ecddf7e902,4153 + pantry-tree: + sha256: a5d7014b0df2600377d061185b104f755274935554e723e2b7b600b85ffc7ae2 + size: 2831 + original: + hackage: cairo-0.13.10.0@sha256:388f39af90d50b920cad70612046041a7ffd7f5b60721862c0c797ecddf7e902,4153 +- completed: + hackage: gtk2hs-buildtools-0.13.8.2@sha256:01c4a6cc3679008bd4caec32b49843acb27a5f48ee2b22484218f097835548f6,5238 + pantry-tree: + sha256: 1c3b449a69f4bb2d27c09a89e447552a58201a3febf5418e67af0001a0cbb0a7 + size: 3588 + original: + hackage: gtk2hs-buildtools-0.13.8.2@sha256:01c4a6cc3679008bd4caec32b49843acb27a5f48ee2b22484218f097835548f6,5238 +- completed: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + pantry-tree: + sha256: 27a9154935b4d30a22830477c60c5108fd713a184d456272c2fccbf361d2395f + size: 1176 + original: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 +- completed: + hackage: data-r-tree-0.6.0@sha256:10a25ef70e6779c3bf5128cd45d033482a370ea07e92ab1c82678675de01d870,3668 + pantry-tree: + sha256: 057a5a25c6c8fe8e60e62b9522e8f1a8be3e7470bfe44229d1e2712e6851409e + size: 614 + original: + hackage: data-r-tree-0.6.0@sha256:10a25ef70e6779c3bf5128cd45d033482a370ea07e92ab1c82678675de01d870,3668 +- completed: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + pantry-tree: + sha256: 887770effc1578682fe255d7f8b1a9801bc5a6e832aa46316782e43eecb65113 + size: 321 + original: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 +- completed: + hackage: alfred-margaret-1.1.1.0@sha256:aeb2f14726e1ee70e542ecfb2a71eb14abda8303d17932bca149401edd76135b,3095 + pantry-tree: + sha256: 44f6f77280a9984cdf7be9f2bc4804f9ba3809ab60e9a065aabb1ee3f8f92322 + size: 1087 + original: + hackage: alfred-margaret-1.1.1.0@sha256:aeb2f14726e1ee70e542ecfb2a71eb14abda8303d17932bca149401edd76135b,3095 +snapshots: +- completed: + sha256: 32716534fff554b7f90762130fdb985cabf29f157758934dd1c8f3892a646430 + size: 586103 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/19.yaml + original: lts-18.19 diff --git a/penplotting/circuits/Circuits/GrowingProcess.hs b/penplotting/circuits/Circuits/GrowingProcess.hs new file mode 100644 index 000000000..bb7b3330b --- /dev/null +++ b/penplotting/circuits/Circuits/GrowingProcess.hs @@ -0,0 +1,235 @@ +module Circuits.GrowingProcess ( + circuitProcess + , CellState(..) + , Circuits(..) + , ProcessGeometry(..) +) where + + + +import Control.DeepSeq +import Control.Monad +import Control.Monad.ST +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as S +import qualified Data.Vector.Extended as V +import qualified System.Random.MWC as MWC + +import Geometry.Coordinates.Hexagonal as Hex + + + +-- | The geometry in which a circuit growing process takes place. +data ProcessGeometry = ProcessGeometry + { _inside :: Set Hex + , _edge :: Set Hex + } deriving (Eq, Ord, Show) + +data CellState + = WireTo Hex + | WireEnd + deriving (Eq, Ord, Show) + +instance NFData CellState where + rnf (WireTo target) = rnf target + rnf WireEnd = () + +data MoveConstraints = MoveConstraints + { _isInBounds :: Hex -> Bool + , _acceptStep :: CellState -> Circuits -> Maybe CellState + } + +-- | All existing circuits. The wires can be reconstructed from this. +data Circuits = Circuits + { _starts :: Set Hex + , _nodes :: Map Hex CellState + } deriving (Eq, Ord, Show) + +instance NFData Circuits where + rnf Circuits{_starts=starts, _nodes=nodes} + = rnf starts `seq` rnf nodes + +emptyCircuits :: Circuits +emptyCircuits = Circuits + { _starts = S.empty + , _nodes = M.empty + } + +insertNode :: Hex -> CellState -> Circuits -> Circuits +insertNode cellPos cellState circuits = circuits { _nodes = M.insert cellPos cellState (_nodes circuits) } + +insertStart :: Hex -> Circuits -> Circuits +insertStart start circuits = circuits { _starts = S.insert start (_starts circuits) } + +-- | Grow circuits inside a geometry. +circuitProcess + :: ProcessGeometry + -> Circuits +circuitProcess processGeometry = runST $ do + gen <- MWC.initialize (V.fromList [252,231233,2333,233,1]) + k <- replicateM 1000 (MWC.uniformM gen) -- Warm up MWC gen + let _ = k :: [Int] + + let acceptStep WireEnd _ = Just WireEnd + acceptStep step@(WireTo target) knownCircuits + | target `M.notMember` _nodes knownCircuits + && (target `S.member` _inside processGeometry || target `S.member` _edge processGeometry) + = Just step + acceptStep _ _ = Nothing + + isInBounds p = p `S.member` _inside processGeometry + || p `S.member` _edge processGeometry + + constraints = MoveConstraints + { _acceptStep = acceptStep + , _isInBounds = isInBounds + } + + (_starts, result) <- iterateUntilNothingM + (growSingleCircuit gen constraints) + (_inside processGeometry <> _edge processGeometry, emptyCircuits) + pure result + +iterateUntilNothingM + :: Monad m + => (a -> m (Maybe a)) + -> a + -> m a +iterateUntilNothingM f = go + where + go x = f x >>= \case + Nothing -> pure x + Just x' -> go x' + +growSingleCircuit + :: MWC.Gen s + -> MoveConstraints + -> (Set Hex, Circuits) + -> ST s (Maybe (Set Hex, Circuits)) +growSingleCircuit gen constraints (startingCandidates, knownCircuits) = + pickStartAndFirstStep gen constraints (startingCandidates, knownCircuits) >>= \case + NoFirstStepPossible -> pure Nothing + FirstStepIs thinnedOutSCs start firstStep -> do + grownCircuit <- growCircuit gen start firstStep constraints knownCircuits + pure (Just (thinnedOutSCs, grownCircuit)) + +data FirstStep + = NoFirstStepPossible -- ^ Given the geometry and already existing circuits, we can’t grow any circuits + | FirstStepIs (Set Hex) Hex Hex -- ^ Remaining start position candidates, starting position, first step + deriving (Eq, Ord, Show) + +-- | Pick a starting point and a first step. If a listed point is an impossible +-- start, remove it from the list of possible starts. +pickStartAndFirstStep + :: MWC.GenST s + -> MoveConstraints + -> (Set Hex, Circuits) -- ^ Starting point candidates, existing circuits + -> ST s FirstStep +pickStartAndFirstStep gen constraints (startingCandidates, knownCircuits) = + let allowedSCs = S.filter (\start -> fieldIsAllowed start knownCircuits constraints) startingCandidates + loop thinnedOutSCs = randomEntry gen thinnedOutSCs >>= \case + Nothing -> pure NoFirstStepPossible + Just start -> randomFirstStep gen start knownCircuits constraints >>= \case + Nothing -> loop (S.delete start thinnedOutSCs) + Just firstStep -> pure (FirstStepIs thinnedOutSCs start firstStep) + in loop allowedSCs + +-- | Random uniform choice of a 'Set' element. +randomEntry :: MWC.GenST s -> Set a -> ST s (Maybe a) +randomEntry gen xs = do + let n = S.size xs + if n <= 0 then + pure Nothing + else do + i <- MWC.uniformRM (0,n-1) gen + pure (Just (S.elemAt i xs)) + +-- Take an allowed first step +randomFirstStep + :: MWC.Gen s -- ^ RNG + -> Hex -- ^ Starting position + -> Circuits -- ^ Existing geometry + -> MoveConstraints -- ^ Collision detection + -> ST s (Maybe Hex) -- ^ Destination for the first step +randomFirstStep gen start knownCircuits constraints = do + let neighbours = V.fromList (ring 1 start) + scrambledNeighbours <- do + vMut <- V.thaw neighbours + V.fisherYatesShuffle gen vMut + V.unsafeFreeze vMut + pure (V.find (\firstStep -> fieldIsAllowed firstStep knownCircuits constraints) scrambledNeighbours) + +-- | Check whether a field can house another piece of wire +fieldIsAllowed :: Hex -> Circuits -> MoveConstraints -> Bool +fieldIsAllowed hex circuits constraints = not inAnyCircuit && inBounds + where + inAnyCircuit = hex `M.member` _nodes circuits + inBounds = _isInBounds constraints hex + +growCircuit + :: MWC.Gen s + -> Hex + -> Hex + -> MoveConstraints + -> Circuits + -> ST s Circuits +growCircuit gen start firstStep constraints knownCircuits = do + let knownCircuitsBeforeProcess = insertStart start (insertNode start (WireTo firstStep) knownCircuits) + loop newKnownCircuits lastPos currentPos = do + action <- randomPossibleAction gen constraints newKnownCircuits lastPos currentPos + case action of + WireTo target -> loop (insertNode currentPos action newKnownCircuits) currentPos target + WireEnd -> pure (insertNode currentPos WireEnd newKnownCircuits) + loop knownCircuitsBeforeProcess start firstStep + +randomPossibleAction + :: MWC.GenST s + -> MoveConstraints + -> Circuits + -> Hex + -> Hex + -> ST s CellState +randomPossibleAction gen constraints knownCircuits lastPos currentPos = weightedRandom gen possibleActions + where + actions = + [ (100, continueStraight) + , (25, continueRight) + , (25, continueLeft) + , (5, terminate) -- This needs to be a valid choice as a fallback if nothing else goes + ] + + possibleActions = flip filter actions $ \(_weight, action) -> + isJust (_acceptStep constraints action knownCircuits) + + straightOn i = currentPos `hexAdd` hexTimes i (hexSubtract currentPos lastPos) + right = Hex.rotateAround currentPos 1 (straightOn 1) + left = Hex.rotateAround currentPos (-1) (straightOn 1) + + continueStraight = WireTo (straightOn 1) + continueRight = WireTo right + continueLeft = WireTo left + terminate = WireEnd + +-- | Pick an element from a list with a certain weight. +-- +-- The probability of an entry is thus \(\frac\text{weight}\text{\sum weights}}\). +weightedRandom :: MWC.GenST s -> [(Int, a)] -> ST s a +weightedRandom _ [] + = error "weightedRandom: empty list of choices" +weightedRandom _ choices + | any (< 0) weights = error ("weightedRandom: negative weight, " ++ show weights) + | all (== 0) weights = error ("weightedRandom: all weights were zero, " ++ show weights) + where + weights = [weight | (weight, _val) <- choices] +weightedRandom gen choices = do + let total = sum [weight | (weight, _val) <- choices] + i <- MWC.uniformRM (1, total) gen + pure (pick i choices) + where + pick n ((weight, x):xs) + | n <= weight = x + | otherwise = pick (n-weight) xs + pick _ _ = error "weightedRandom.pick used with empty list" diff --git a/penplotting/circuits/Circuits/ReconstructWires.hs b/penplotting/circuits/Circuits/ReconstructWires.hs new file mode 100644 index 000000000..529f96825 --- /dev/null +++ b/penplotting/circuits/Circuits/ReconstructWires.hs @@ -0,0 +1,24 @@ +module Circuits.ReconstructWires (reconstructWires) where + + + +import Data.Map (Map) +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S + +import Circuits.GrowingProcess +import Geometry.Coordinates.Hexagonal as Hex + + + +reconstructSingleWire :: Map Hex CellState -> Hex -> [Hex] +reconstructSingleWire cellMap start = start : case M.lookup start cellMap of + Nothing -> error "Reached end of wire unexpectedly" + Just (WireTo next) -> reconstructSingleWire cellMap next + Just WireEnd -> [] + +-- | Convert the (rather abstract) result of the circuit growing process into a set +-- of hex-polylines, which are much simpler to work with. +reconstructWires :: Circuits -> Set [Hex] +reconstructWires circuits = S.map (reconstructSingleWire (_nodes circuits)) (_starts circuits) diff --git a/penplotting/circuits/Main.hs b/penplotting/circuits/Main.hs new file mode 100644 index 000000000..5a4ef1266 --- /dev/null +++ b/penplotting/circuits/Main.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + + + +import Data.Default.Class +import Data.Foldable +import Data.List +import Data.Set (Set) +import qualified Data.Set as S +import Data.Traversable +import Formatting +import Options.Applicative +import System.FilePath +import qualified System.Random.MWC as MWC + +import Draw.Plotting +import Draw.Plotting.CmdArgs +import Draw.Plotting.GCode +import Geometry as G +import Geometry.Coordinates.Hexagonal as Hex + +import Circuits.GrowingProcess +import Circuits.ReconstructWires + + + +main :: IO () +main = do + options <- commandLineOptions + + let lambdaScale = _lambdaScale options + numColors = _numColors options + + let lambdaGeometry = hexLambda lambdaScale + hexCircuits = reconstructWires (circuitProcess lambdaGeometry) + vecCircuits = fitToPaper options (hex2wire hexCircuits) + settings = def + circuitsList = toList vecCircuits + + gen <- MWC.create + colorIndexedCircuits <- for circuitsList $ \circuit -> do + i <- MWC.uniformRM (1,numColors) gen + pure (i::Int, circuit) + + let partitionByIndex + = (map.map) snd + . groupBy (\(i,_) (j,_) -> i == j) + . sortBy (\(i, Wire xs) (j, Wire ys) -> compare i j <> compare (length xs) (length ys)) + + for_ (zip [1..] (partitionByIndex colorIndexedCircuits)) $ \(i, wires) -> do + let filename = formatToString (string%"_scale-"%int%"_color-"%int%"-"%int%".g") (dropExtension (_outputFileG options)) lambdaScale (i::Int) numColors + writeGCodeFile filename (runPlot settings (plot wires)) + +hex2wire :: Set [Hex] -> Set Wire +hex2wire = G.transform mirrorYCoords (S.map (Wire . map (toVec2 1))) + +fitToPaper :: (Transform geo, HasBoundingBox geo) => Options -> geo -> geo +fitToPaper opts geo = G.transform (G.transformBoundingBox geo (Vec2 margin margin, Vec2 w h -. Vec2 margin margin) def) geo + where + Options {_canvas=Canvas{_canvasWidth=w, _canvasHeight=h, _canvasMargin=margin}} = opts + +newtype Wire = Wire [Vec2] + deriving (Eq, Ord, Show) + +instance HasBoundingBox Wire where + boundingBox (Wire xs) = boundingBox xs + +instance Transform Wire where + transform t (Wire xs) = Wire (transform t xs) + +drawWire :: Wire -> Plot () +drawWire (Wire ws) = case ws of + [] -> error "Bad circuit algorithm! :-C" + [_] -> error "Bad circuit algorithm! :-C" + xs@(start:_) -> do + repositionTo start + block (go xs) + where + go :: [Vec2] -> Plot () + go [start,target] = do + let cellSize = norm (start -. target)/2 + circleRadius = cellSize/2 + Line _ intersection = resizeLine (\d -> d - circleRadius) (Line start target) + Vec2 centerDX centerDY = target -. intersection + plot (Line start intersection) + gCode + [ G91_RelativeMovement + , G02_ArcClockwise Nothing centerDX centerDY 0 0 + , G90_AbsoluteMovement + ] + go (_:rest@(target:_)) = lineTo target >> go rest + go _ = error "Can’t happen because go is only called with lists of at least two elements" + +instance Plotting Wire where + plot = block . drawWire + +-- | A lambda in hexagonal coordinates. +hexLambda + :: Int -- ^ Scale parameter. c*10 will be the total height. + -> ProcessGeometry +hexLambda c | c <= 0 = ProcessGeometry S.empty S.empty +hexLambda c = ProcessGeometry + { _inside = pointsOnInside + , _edge = pointsOnEdge + } + where + polygon = Hex.HexPolygon corners + corners = walkInSteps + [ id + , move R (c*2) + , move DR (c*10) + , move L (c*2) + , move UL (c*3) + , move DL (c*3) + , move L (c*2) + , move UR (c*5) + ] + (move UL (c*5) (move L c hexZero)) + walkInSteps [] _pos = [] + walkInSteps (f:fs) pos = + let newPoint = f pos + in newPoint : walkInSteps fs newPoint + + floodFillStart = hexZero + floodFilled = floodFill floodFillStart (edgePoints polygon) + pointsOnInside = floodFilled `S.difference` pointsOnEdge + pointsOnEdge = edgePoints polygon + +data Options = Options + { _outputFileG :: FilePath + + , _numColors :: Int + , _lambdaScale :: Int + + , _canvas :: Canvas + } deriving (Eq, Ord, Show) + +commandLineOptions :: IO Options +commandLineOptions = execParser parserOpts + where + progOpts = Options + <$> strOption (mconcat + [ long "output" + , short 'o' + , metavar "" + , help "Output GCode file" + ]) + <*> option auto (mconcat + [ long "colors" + , metavar "n" + , value 1 + , showDefault + , help "Number of colors" + ]) + <*> option auto (mconcat + [ long "scale" + , metavar "n" + , value 10 + , showDefault + , help "Fineness of the circuit pattern. Higher is finer." + ]) + <*> canvasP + + parserOpts = info (progOpts <**> helper) + ( fullDesc + <> progDesc "Convert SVG to GCode" + <> header "Not that much of SVG is supported, bear with me…" ) diff --git a/penplotting/circuits/package.yaml b/penplotting/circuits/package.yaml new file mode 100644 index 000000000..351c3a2d1 --- /dev/null +++ b/penplotting/circuits/package.yaml @@ -0,0 +1,29 @@ +name: penplotting-circuits +version: 0.1.0.0 +github: quchen/generative-art +license: BSD3 +author: + - David Luposchainsky +copyright: + - 2022 David Luposchainsky + +default-extensions: + - LambdaCase + +dependencies: + - generative-art + - base + - containers + - data-default-class + - deepseq + - filepath + - formatting + - mwc-random + - optparse-applicative + - text + +executables: + penplotting-circuits: + main: Main.hs + source-dirs: . + ghc-options: [-threaded, -rtsopts, -with-rtsopts=-N, -Wall, -Wno-type-defaults, -O] diff --git a/penplotting/circuits/penplotting-circuits.cabal b/penplotting/circuits/penplotting-circuits.cabal new file mode 100644 index 000000000..ac7619016 --- /dev/null +++ b/penplotting/circuits/penplotting-circuits.cabal @@ -0,0 +1,43 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: penplotting-circuits +version: 0.1.0.0 +homepage: https://github.com/quchen/generative-art#readme +bug-reports: https://github.com/quchen/generative-art/issues +author: David Luposchainsky +maintainer: David Luposchainsky +copyright: 2022 David Luposchainsky +license: BSD3 +build-type: Simple + +source-repository head + type: git + location: https://github.com/quchen/generative-art + +executable penplotting-circuits + main-is: Main.hs + other-modules: + Circuits.GrowingProcess + Circuits.ReconstructWires + Paths_penplotting_circuits + hs-source-dirs: + ./ + default-extensions: + LambdaCase + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-type-defaults -O + build-depends: + base + , containers + , data-default-class + , deepseq + , filepath + , formatting + , generative-art + , mwc-random + , optparse-applicative + , text + default-language: Haskell2010 diff --git a/penplotting/circuits/stack.yaml b/penplotting/circuits/stack.yaml new file mode 100644 index 000000000..be0c7697d --- /dev/null +++ b/penplotting/circuits/stack.yaml @@ -0,0 +1,11 @@ +flags: {} +packages: + - . +extra-deps: + - git: https://github.com/quchen/generative-art + commit: 3cea78bb902c023216727be16dcf8143bd62f0ae + - Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + - plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + - alfred-margaret-2.1.0.2 +resolver: lts-21.25 +allow-newer: true diff --git a/penplotting/circuits/stack.yaml.lock b/penplotting/circuits/stack.yaml.lock new file mode 100644 index 000000000..5963a5462 --- /dev/null +++ b/penplotting/circuits/stack.yaml.lock @@ -0,0 +1,33 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + pantry-tree: + sha256: 27a9154935b4d30a22830477c60c5108fd713a184d456272c2fccbf361d2395f + size: 1176 + original: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 +- completed: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + pantry-tree: + sha256: 887770effc1578682fe255d7f8b1a9801bc5a6e832aa46316782e43eecb65113 + size: 321 + original: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 +- completed: + hackage: alfred-margaret-2.1.0.2@sha256:2903ce63f9054ec607c03439231cdacd0a3b731febe05f493d073bcb1a8bc1a7,4918 + pantry-tree: + sha256: f747ba440a8a87e433970d07cb1edabac770f111fec0732ee83026cf2bf7286e + size: 1938 + original: + hackage: alfred-margaret-2.1.0.2 +snapshots: +- completed: + sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd + size: 640086 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml + original: lts-21.25 diff --git a/penplotting/dendrites/Main.hs b/penplotting/dendrites/Main.hs new file mode 100644 index 000000000..85001a082 --- /dev/null +++ b/penplotting/dendrites/Main.hs @@ -0,0 +1,144 @@ +module Main (main) where + + + +import Control.Monad +import qualified Data.Heap as H +import Data.Maybe +import qualified Data.Set as S +import qualified Data.Vector as V +import qualified Graphics.Rendering.Cairo as C +import System.Random.MWC +import System.Random.MWC.Distributions + +import Draw +import Draw.Plotting +import Geometry +import Geometry.Shapes + + + +picWidth, picHeight :: Num a => a +picWidth = 200 +picHeight = 200 + +canvas :: Polygon +canvas = transform (translate (Vec2 (picWidth/2) (picHeight/2)) <> scale' (picWidth/2) (picHeight/2)) (regularPolygon 32) + +main :: IO () +main = do + gen <- create + let seeds = [Vec2 (0.1 * picWidth) (0.5 * picHeight), Vec2 (0.9 * picWidth) (0.5 * picHeight)] + radius = 2 + dendrites <- growDendrites gen seeds radius + + render "out/dendrites.png" picWidth picHeight $ do + coordinateSystem (MathStandard_ZeroBottomLeft_XRight_YUp picHeight) + cairoScope (setColor white >> C.paint) + for_ (zip [0..] dendrites) $ \(c, d) -> do + setColor (mma c) + drawDendrite (root d) d + + let settings = def + { _feedrate = 3000 + , _zTravelHeight = 3 + , _zDrawingHeight = -2 + } + + penChange = withDrawingHeight 0 $ do + repositionTo zero + penDown + pause PauseUserConfirm + penUp + plotResult = runPlot settings $ + for_ dendrites $ \dendrite -> do + penChange + plotDendrite (root dendrite) dendrite + + renderPreview "out/dendrites.png" 1 plotResult + writeGCodeFile "dendrites.g" plotResult + +drawDendrite :: Vec2 -> Dendrite -> C.Render () +drawDendrite parent (Node p children) = do + sketch (Line parent p) + C.stroke + when (null children) $ do + sketch (Circle p 2) + C.stroke + for_ children $ drawDendrite p + +plotDendrite :: Vec2 -> Dendrite -> Plot () +plotDendrite parent (Node p children) = do + let branch = Line parent p + plot branch + when (null children) $ do + plot (Line p (p +. 0.4 *. direction branch)) + plot (Circle p 0.4) + for_ children $ plotDendrite p + +growDendrites :: GenIO -> [Vec2] -> Double -> IO [Dendrite] +growDendrites gen seeds radius = fmap _result <$> loop (S.fromList seeds) (V.fromList (initialState <$> seeds)) + where + initialState p = GrowthState + { _result = seed p + , _activeBranches = H.singleton (H.Entry 0 p) + , _allNodes = S.singleton p + , _radius = radius + } + loop allNodes states = do + index <- categorical (V.map (fromIntegral . H.size . _activeBranches) states) gen + let item = states V.! index + if H.null (_activeBranches item) + then pure (V.toList states) + else do + (allNodes', item') <- growCell allNodes item + loop allNodes' (states V.// [(index, item')]) + + growCell allNodes state = do + state' <- grow gen state { _allNodes = allNodes } + pure (allNodes `S.union` _allNodes state', state') + +data Dendrite = Node Vec2 [Dendrite] + +seed :: Vec2 -> Dendrite +seed p = Node p [] + +root :: Dendrite -> Vec2 +root (Node p _) = p + +insertAt :: Vec2 -> Vec2 -> Dendrite -> Dendrite +insertAt target newItem (Node p nodes) + | p == target + = Node p (seed newItem : nodes) + | otherwise + = Node p (insertAt target newItem <$> nodes) + +data GrowthState = GrowthState + { _result :: Dendrite + , _activeBranches :: H.Heap (H.Entry Double Vec2) + , _allNodes :: S.Set Vec2 + , _radius :: Double + } + +grow :: GenIO -> GrowthState -> IO GrowthState +grow gen s@GrowthState{..} = case H.uncons _activeBranches of + Nothing -> pure s + Just (H.Entry _ closestActiveBranch, activeBranches') -> candidates gen s closestActiveBranch >>= \case + [] -> pure s { _activeBranches = activeBranches' } + p : _ -> pure s + { _result = insertAt closestActiveBranch p _result + , _allNodes = S.insert p _allNodes + , _activeBranches = H.insert (H.Entry (norm (p -. root _result)) p) _activeBranches + } + +candidates :: GenIO -> GrowthState -> Vec2 -> IO [Vec2] +candidates gen GrowthState{..} p = fmap catMaybes $ replicateM 20 $ do + phi <- rad <$> uniformRM (0, 2*pi) gen + r' <- uniformRM (_radius, 2*_radius) gen + let p' = p +. polar phi r' + pure $ do + guard (p' `pointInPolygon` canvas) + guard (not (any (\q -> norm (p' -. q) <= _radius) _allNodes)) + Just p' + + diff --git a/penplotting/dendrites/package.yaml b/penplotting/dendrites/package.yaml new file mode 100644 index 000000000..be55ff66e --- /dev/null +++ b/penplotting/dendrites/package.yaml @@ -0,0 +1,32 @@ +name: penplotting-dendrites +version: 0.1.0.0 +github: quchen/generative-art +license: BSD3 +author: + - Franz Thoma +copyright: + - 2022 Franz Thoma + +default-extensions: + - LambdaCase + - OverloadedStrings + - RecordWildCards + +dependencies: + - generative-art + - base + - cairo + - containers + - data-default-class + - heaps + - mwc-random + - primitive + - text + - transformers + - vector + +executables: + penplotting-dendrites: + main: Main.hs + source-dirs: . + ghc-options: [-threaded, -rtsopts, -with-rtsopts=-N, -Wall, -Wno-type-defaults, -O] diff --git a/penplotting/dendrites/penplotting-dendrites.cabal b/penplotting/dendrites/penplotting-dendrites.cabal new file mode 100644 index 000000000..15660d0b7 --- /dev/null +++ b/penplotting/dendrites/penplotting-dendrites.cabal @@ -0,0 +1,44 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: penplotting-dendrites +version: 0.1.0.0 +homepage: https://github.com/quchen/generative-art#readme +bug-reports: https://github.com/quchen/generative-art/issues +author: Franz Thoma +maintainer: Franz Thoma +copyright: 2022 Franz Thoma +license: BSD3 +build-type: Simple + +source-repository head + type: git + location: https://github.com/quchen/generative-art + +executable penplotting-dendrites + main-is: Main.hs + other-modules: + Paths_penplotting_dendrites + hs-source-dirs: + ./ + default-extensions: + LambdaCase + OverloadedStrings + RecordWildCards + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-type-defaults -O + build-depends: + base + , cairo + , containers + , data-default-class + , generative-art + , heaps + , mwc-random + , primitive + , text + , transformers + , vector + default-language: Haskell2010 diff --git a/penplotting/dendrites/stack.yaml b/penplotting/dendrites/stack.yaml new file mode 100644 index 000000000..be0c7697d --- /dev/null +++ b/penplotting/dendrites/stack.yaml @@ -0,0 +1,11 @@ +flags: {} +packages: + - . +extra-deps: + - git: https://github.com/quchen/generative-art + commit: 3cea78bb902c023216727be16dcf8143bd62f0ae + - Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + - plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + - alfred-margaret-2.1.0.2 +resolver: lts-21.25 +allow-newer: true diff --git a/penplotting/dendrites/stack.yaml.lock b/penplotting/dendrites/stack.yaml.lock new file mode 100644 index 000000000..5963a5462 --- /dev/null +++ b/penplotting/dendrites/stack.yaml.lock @@ -0,0 +1,33 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + pantry-tree: + sha256: 27a9154935b4d30a22830477c60c5108fd713a184d456272c2fccbf361d2395f + size: 1176 + original: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 +- completed: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + pantry-tree: + sha256: 887770effc1578682fe255d7f8b1a9801bc5a6e832aa46316782e43eecb65113 + size: 321 + original: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 +- completed: + hackage: alfred-margaret-2.1.0.2@sha256:2903ce63f9054ec607c03439231cdacd0a3b731febe05f493d073bcb1a8bc1a7,4918 + pantry-tree: + sha256: f747ba440a8a87e433970d07cb1edabac770f111fec0732ee83026cf2bf7286e + size: 1938 + original: + hackage: alfred-margaret-2.1.0.2 +snapshots: +- completed: + sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd + size: 640086 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml + original: lts-21.25 diff --git a/showcases/circuits/Circuits/GrowingProcess.hs b/showcases/circuits/Circuits/GrowingProcess.hs new file mode 100644 index 000000000..bb7b3330b --- /dev/null +++ b/showcases/circuits/Circuits/GrowingProcess.hs @@ -0,0 +1,235 @@ +module Circuits.GrowingProcess ( + circuitProcess + , CellState(..) + , Circuits(..) + , ProcessGeometry(..) +) where + + + +import Control.DeepSeq +import Control.Monad +import Control.Monad.ST +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as S +import qualified Data.Vector.Extended as V +import qualified System.Random.MWC as MWC + +import Geometry.Coordinates.Hexagonal as Hex + + + +-- | The geometry in which a circuit growing process takes place. +data ProcessGeometry = ProcessGeometry + { _inside :: Set Hex + , _edge :: Set Hex + } deriving (Eq, Ord, Show) + +data CellState + = WireTo Hex + | WireEnd + deriving (Eq, Ord, Show) + +instance NFData CellState where + rnf (WireTo target) = rnf target + rnf WireEnd = () + +data MoveConstraints = MoveConstraints + { _isInBounds :: Hex -> Bool + , _acceptStep :: CellState -> Circuits -> Maybe CellState + } + +-- | All existing circuits. The wires can be reconstructed from this. +data Circuits = Circuits + { _starts :: Set Hex + , _nodes :: Map Hex CellState + } deriving (Eq, Ord, Show) + +instance NFData Circuits where + rnf Circuits{_starts=starts, _nodes=nodes} + = rnf starts `seq` rnf nodes + +emptyCircuits :: Circuits +emptyCircuits = Circuits + { _starts = S.empty + , _nodes = M.empty + } + +insertNode :: Hex -> CellState -> Circuits -> Circuits +insertNode cellPos cellState circuits = circuits { _nodes = M.insert cellPos cellState (_nodes circuits) } + +insertStart :: Hex -> Circuits -> Circuits +insertStart start circuits = circuits { _starts = S.insert start (_starts circuits) } + +-- | Grow circuits inside a geometry. +circuitProcess + :: ProcessGeometry + -> Circuits +circuitProcess processGeometry = runST $ do + gen <- MWC.initialize (V.fromList [252,231233,2333,233,1]) + k <- replicateM 1000 (MWC.uniformM gen) -- Warm up MWC gen + let _ = k :: [Int] + + let acceptStep WireEnd _ = Just WireEnd + acceptStep step@(WireTo target) knownCircuits + | target `M.notMember` _nodes knownCircuits + && (target `S.member` _inside processGeometry || target `S.member` _edge processGeometry) + = Just step + acceptStep _ _ = Nothing + + isInBounds p = p `S.member` _inside processGeometry + || p `S.member` _edge processGeometry + + constraints = MoveConstraints + { _acceptStep = acceptStep + , _isInBounds = isInBounds + } + + (_starts, result) <- iterateUntilNothingM + (growSingleCircuit gen constraints) + (_inside processGeometry <> _edge processGeometry, emptyCircuits) + pure result + +iterateUntilNothingM + :: Monad m + => (a -> m (Maybe a)) + -> a + -> m a +iterateUntilNothingM f = go + where + go x = f x >>= \case + Nothing -> pure x + Just x' -> go x' + +growSingleCircuit + :: MWC.Gen s + -> MoveConstraints + -> (Set Hex, Circuits) + -> ST s (Maybe (Set Hex, Circuits)) +growSingleCircuit gen constraints (startingCandidates, knownCircuits) = + pickStartAndFirstStep gen constraints (startingCandidates, knownCircuits) >>= \case + NoFirstStepPossible -> pure Nothing + FirstStepIs thinnedOutSCs start firstStep -> do + grownCircuit <- growCircuit gen start firstStep constraints knownCircuits + pure (Just (thinnedOutSCs, grownCircuit)) + +data FirstStep + = NoFirstStepPossible -- ^ Given the geometry and already existing circuits, we can’t grow any circuits + | FirstStepIs (Set Hex) Hex Hex -- ^ Remaining start position candidates, starting position, first step + deriving (Eq, Ord, Show) + +-- | Pick a starting point and a first step. If a listed point is an impossible +-- start, remove it from the list of possible starts. +pickStartAndFirstStep + :: MWC.GenST s + -> MoveConstraints + -> (Set Hex, Circuits) -- ^ Starting point candidates, existing circuits + -> ST s FirstStep +pickStartAndFirstStep gen constraints (startingCandidates, knownCircuits) = + let allowedSCs = S.filter (\start -> fieldIsAllowed start knownCircuits constraints) startingCandidates + loop thinnedOutSCs = randomEntry gen thinnedOutSCs >>= \case + Nothing -> pure NoFirstStepPossible + Just start -> randomFirstStep gen start knownCircuits constraints >>= \case + Nothing -> loop (S.delete start thinnedOutSCs) + Just firstStep -> pure (FirstStepIs thinnedOutSCs start firstStep) + in loop allowedSCs + +-- | Random uniform choice of a 'Set' element. +randomEntry :: MWC.GenST s -> Set a -> ST s (Maybe a) +randomEntry gen xs = do + let n = S.size xs + if n <= 0 then + pure Nothing + else do + i <- MWC.uniformRM (0,n-1) gen + pure (Just (S.elemAt i xs)) + +-- Take an allowed first step +randomFirstStep + :: MWC.Gen s -- ^ RNG + -> Hex -- ^ Starting position + -> Circuits -- ^ Existing geometry + -> MoveConstraints -- ^ Collision detection + -> ST s (Maybe Hex) -- ^ Destination for the first step +randomFirstStep gen start knownCircuits constraints = do + let neighbours = V.fromList (ring 1 start) + scrambledNeighbours <- do + vMut <- V.thaw neighbours + V.fisherYatesShuffle gen vMut + V.unsafeFreeze vMut + pure (V.find (\firstStep -> fieldIsAllowed firstStep knownCircuits constraints) scrambledNeighbours) + +-- | Check whether a field can house another piece of wire +fieldIsAllowed :: Hex -> Circuits -> MoveConstraints -> Bool +fieldIsAllowed hex circuits constraints = not inAnyCircuit && inBounds + where + inAnyCircuit = hex `M.member` _nodes circuits + inBounds = _isInBounds constraints hex + +growCircuit + :: MWC.Gen s + -> Hex + -> Hex + -> MoveConstraints + -> Circuits + -> ST s Circuits +growCircuit gen start firstStep constraints knownCircuits = do + let knownCircuitsBeforeProcess = insertStart start (insertNode start (WireTo firstStep) knownCircuits) + loop newKnownCircuits lastPos currentPos = do + action <- randomPossibleAction gen constraints newKnownCircuits lastPos currentPos + case action of + WireTo target -> loop (insertNode currentPos action newKnownCircuits) currentPos target + WireEnd -> pure (insertNode currentPos WireEnd newKnownCircuits) + loop knownCircuitsBeforeProcess start firstStep + +randomPossibleAction + :: MWC.GenST s + -> MoveConstraints + -> Circuits + -> Hex + -> Hex + -> ST s CellState +randomPossibleAction gen constraints knownCircuits lastPos currentPos = weightedRandom gen possibleActions + where + actions = + [ (100, continueStraight) + , (25, continueRight) + , (25, continueLeft) + , (5, terminate) -- This needs to be a valid choice as a fallback if nothing else goes + ] + + possibleActions = flip filter actions $ \(_weight, action) -> + isJust (_acceptStep constraints action knownCircuits) + + straightOn i = currentPos `hexAdd` hexTimes i (hexSubtract currentPos lastPos) + right = Hex.rotateAround currentPos 1 (straightOn 1) + left = Hex.rotateAround currentPos (-1) (straightOn 1) + + continueStraight = WireTo (straightOn 1) + continueRight = WireTo right + continueLeft = WireTo left + terminate = WireEnd + +-- | Pick an element from a list with a certain weight. +-- +-- The probability of an entry is thus \(\frac\text{weight}\text{\sum weights}}\). +weightedRandom :: MWC.GenST s -> [(Int, a)] -> ST s a +weightedRandom _ [] + = error "weightedRandom: empty list of choices" +weightedRandom _ choices + | any (< 0) weights = error ("weightedRandom: negative weight, " ++ show weights) + | all (== 0) weights = error ("weightedRandom: all weights were zero, " ++ show weights) + where + weights = [weight | (weight, _val) <- choices] +weightedRandom gen choices = do + let total = sum [weight | (weight, _val) <- choices] + i <- MWC.uniformRM (1, total) gen + pure (pick i choices) + where + pick n ((weight, x):xs) + | n <= weight = x + | otherwise = pick (n-weight) xs + pick _ _ = error "weightedRandom.pick used with empty list" diff --git a/showcases/circuits/Circuits/ReconstructWires.hs b/showcases/circuits/Circuits/ReconstructWires.hs new file mode 100644 index 000000000..529f96825 --- /dev/null +++ b/showcases/circuits/Circuits/ReconstructWires.hs @@ -0,0 +1,24 @@ +module Circuits.ReconstructWires (reconstructWires) where + + + +import Data.Map (Map) +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S + +import Circuits.GrowingProcess +import Geometry.Coordinates.Hexagonal as Hex + + + +reconstructSingleWire :: Map Hex CellState -> Hex -> [Hex] +reconstructSingleWire cellMap start = start : case M.lookup start cellMap of + Nothing -> error "Reached end of wire unexpectedly" + Just (WireTo next) -> reconstructSingleWire cellMap next + Just WireEnd -> [] + +-- | Convert the (rather abstract) result of the circuit growing process into a set +-- of hex-polylines, which are much simpler to work with. +reconstructWires :: Circuits -> Set [Hex] +reconstructWires circuits = S.map (reconstructSingleWire (_nodes circuits)) (_starts circuits) diff --git a/showcases/circuits/Circuits/Render.hs b/showcases/circuits/Circuits/Render.hs new file mode 100644 index 000000000..0597ffadc --- /dev/null +++ b/showcases/circuits/Circuits/Render.hs @@ -0,0 +1,100 @@ +module Circuits.Render ( + renderWires + , renderProcessGeometry + + , ColorScheme(..) + , purple + , grey + , pitchBlackForDebugging +) where + + + +import Data.Set (Set) +import qualified Data.Vector as V +import Graphics.Rendering.Cairo as C hiding (x, y) +import qualified System.Random.MWC as MWC + +import Circuits.GrowingProcess +import Draw as D +import Geometry as G +import Geometry.Coordinates.Hexagonal as Hex + + + +renderWire :: Double -> [Hex] -> Render () +renderWire cellSize = go . map (toVec2 cellSize) + where + circleRadius = cellSize/2 + go [] = pure () + go [x] = sketch (Circle x circleRadius) >> stroke + go [x,y] = do + let shortLine = resizeLine (\d -> d - circleRadius) (Line x y) + sketch shortLine + stroke + sketch (Circle y circleRadius) + stroke + go (x:rest@(y:_)) = do + sketch (Line x y) + go rest + +renderWires + :: ColorScheme + -> Double + -> Set [Hex] + -> Render () +renderWires scheme cellSize wires = do + gen <- liftIO MWC.create + for_ wires $ \wire -> do + randomColor gen scheme + renderWire cellSize wire + +newtype ColorScheme = ColorScheme (V.Vector (Render ())) + +purple :: ColorScheme +purple = ColorScheme (V.fromList [darker, dark, brighter]) + where + darker = setColor (haskell 0) + dark = setColor (haskell 1) + brighter = setColor (haskell 2) + +grey :: ColorScheme +grey = ColorScheme (V.fromList [setGrey x | x <- [850, 875, 900]]) + where + setGrey per1000 = + let x = fromIntegral per1000 / 1000 + in setColor (rgb x x x) + +pitchBlackForDebugging :: ColorScheme +pitchBlackForDebugging = ColorScheme (V.fromList [setColor (rgb 0 0 0)]) + +randomColor + :: MWC.GenIO + -> ColorScheme + -> Render () +randomColor gen (ColorScheme scheme) = do + n <- liftIO $ MWC.uniformRM (0, V.length scheme-1) gen + scheme V.! n + +renderProcessGeometry + :: (CairoColor filling, CairoColor edges) + => filling + -> edges + -> Double + -> ProcessGeometry + -> Render () +renderProcessGeometry insideColor edgeColor cellSize ProcessGeometry{..} = do + cairoScope $ do + for_ _inside $ \hex -> D.sketch (hexagonPoly cellSize hex) + setColor insideColor + fillPreserve + setSourceRGB 0 0 0 + stroke + + cairoScope $ do + setColor edgeColor + for_ _edge $ \hex -> D.sketch (hexagonPoly cellSize hex) + setColor edgeColor + fillPreserve + setSourceRGB 0 0 0 + stroke diff --git a/showcases/circuits/Main.hs b/showcases/circuits/Main.hs new file mode 100644 index 000000000..2c5a84edd --- /dev/null +++ b/showcases/circuits/Main.hs @@ -0,0 +1,96 @@ +module Main (main) where + + + +import Control.Parallel.Strategies +import qualified Data.Set as S +import Graphics.Rendering.Cairo as C hiding (x, y) + +import Draw as D +import Geometry.Coordinates.Hexagonal as Hex + +import Circuits.GrowingProcess +import Circuits.ReconstructWires +import Circuits.Render + + + +-- ghcid --command='stack ghci generative-art:exe:haskell-logo-circuits' --test=main --no-title --warnings +-- ghcid --command='stack ghci generative-art:lib generative-art:exe:haskell-logo-circuits --main-is=generative-art:exe:haskell-logo-circuits' --test=main --no-title --warnings +main :: IO () +main = do + let lambdaScale = 6 + lambdaGeometry = hexLambda lambdaScale + + surroundingScale = lambdaScale*8 + surroundingGeometry = largeSurroundingCircle surroundingScale lambdaGeometry + + (lambdaCircuits, surroundingCircuits) = + (reconstructWires (circuitProcess lambdaGeometry), reconstructWires (circuitProcess surroundingGeometry)) + `using` parTuple2 rdeepseq rdeepseq + let mainRender = do + let cellSize = 3 + C.translate (fromIntegral picWidth/2) (fromIntegral picHeight/2) + cairoScope $ do + setLineWidth 1 + renderWires purple cellSize lambdaCircuits + renderWires grey cellSize surroundingCircuits + render "out/circuits.svg" picWidth picHeight mainRender + render "out/circuits.png" picWidth picHeight $ do + cairoScope $ do + setSourceRGB 1 1 1 + paint + mainRender + where + picWidth = 520 + picHeight = 440 + +-- | A lambda in hexagonal coordinates. +hexLambda + :: Int -- ^ Scale parameter. c*10 will be the total height. + -> ProcessGeometry +hexLambda c | c <= 0 = ProcessGeometry S.empty S.empty +hexLambda c = ProcessGeometry + { _inside = pointsOnInside + , _edge = pointsOnEdge + } + where + polygon = Hex.HexPolygon corners + corners = walkInSteps + [ id + , move R (c*2) + , move DR (c*10) + , move L (c*2) + , move UL (c*3) + , move DL (c*3) + , move L (c*2) + , move UR (c*5) + ] + (move UL (c*5) (move L c hexZero)) + walkInSteps [] _pos = [] + walkInSteps (f:fs) pos = + let newPoint = f pos + in newPoint : walkInSteps fs newPoint + + floodFillStart = hexZero + floodFilled = floodFill floodFillStart (edgePoints polygon) + pointsOnInside = floodFilled `S.difference` pointsOnEdge + pointsOnEdge = edgePoints polygon + +-- | A large hexagon with some geometry cut out. +largeSurroundingCircle + :: Int -- ^ Radius of the hexagon + -> ProcessGeometry -- ^ Geometry to be cut out + -> ProcessGeometry +largeSurroundingCircle c excludes = + let allExcluded = _inside excludes <> _edge excludes + largeCircle = S.fromList (hexagonsInRange c hexZero) + excludesExtended = S.unions (S.map (\hex -> S.fromList (ring 1 hex)) (_edge excludes)) + edge = let outer = S.fromList (ring c hexZero) + inner = excludesExtended `S.difference` allExcluded + in outer <> inner + inside = largeCircle `S.difference` edge `S.difference` allExcluded + in ProcessGeometry + { _inside = inside + , _edge = edge + } diff --git a/showcases/circuits/circuits.cabal b/showcases/circuits/circuits.cabal new file mode 100644 index 000000000..2bea8a8e0 --- /dev/null +++ b/showcases/circuits/circuits.cabal @@ -0,0 +1,43 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: circuits +version: 0.1.0.0 +homepage: https://github.com/quchen/generative-art#readme +bug-reports: https://github.com/quchen/generative-art/issues +author: David Luposchainsky +maintainer: David Luposchainsky +copyright: 2022 David Luposchainsky +license: BSD3 +build-type: Simple + +source-repository head + type: git + location: https://github.com/quchen/generative-art + +executable circuits + main-is: Main.hs + other-modules: + Circuits.GrowingProcess + Circuits.ReconstructWires + Circuits.Render + Paths_circuits + hs-source-dirs: + ./ + default-extensions: + LambdaCase + RecordWildCards + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-type-defaults -O + build-depends: + base + , cairo + , containers + , deepseq + , generative-art + , mwc-random + , parallel + , vector + default-language: Haskell2010 diff --git a/showcases/circuits/package.yaml b/showcases/circuits/package.yaml new file mode 100644 index 000000000..e3919124c --- /dev/null +++ b/showcases/circuits/package.yaml @@ -0,0 +1,28 @@ +name: circuits +version: 0.1.0.0 +github: quchen/generative-art +license: BSD3 +author: + - David Luposchainsky +copyright: + - 2022 David Luposchainsky + +default-extensions: + - LambdaCase + - RecordWildCards + +dependencies: + - generative-art + - base + - cairo + - containers + - deepseq + - mwc-random + - parallel + - vector + +executables: + circuits: + main: Main.hs + source-dirs: . + ghc-options: [-threaded, -rtsopts, -with-rtsopts=-N, -Wall, -Wno-type-defaults, -O] diff --git a/showcases/circuits/stack.yaml b/showcases/circuits/stack.yaml new file mode 100644 index 000000000..be0c7697d --- /dev/null +++ b/showcases/circuits/stack.yaml @@ -0,0 +1,11 @@ +flags: {} +packages: + - . +extra-deps: + - git: https://github.com/quchen/generative-art + commit: 3cea78bb902c023216727be16dcf8143bd62f0ae + - Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + - plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + - alfred-margaret-2.1.0.2 +resolver: lts-21.25 +allow-newer: true diff --git a/showcases/circuits/stack.yaml.lock b/showcases/circuits/stack.yaml.lock new file mode 100644 index 000000000..5963a5462 --- /dev/null +++ b/showcases/circuits/stack.yaml.lock @@ -0,0 +1,33 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + pantry-tree: + sha256: 27a9154935b4d30a22830477c60c5108fd713a184d456272c2fccbf361d2395f + size: 1176 + original: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 +- completed: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + pantry-tree: + sha256: 887770effc1578682fe255d7f8b1a9801bc5a6e832aa46316782e43eecb65113 + size: 321 + original: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 +- completed: + hackage: alfred-margaret-2.1.0.2@sha256:2903ce63f9054ec607c03439231cdacd0a3b731febe05f493d073bcb1a8bc1a7,4918 + pantry-tree: + sha256: f747ba440a8a87e433970d07cb1edabac770f111fec0732ee83026cf2bf7286e + size: 1938 + original: + hackage: alfred-margaret-2.1.0.2 +snapshots: +- completed: + sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd + size: 640086 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml + original: lts-21.25 diff --git a/showcases/haskell_logo_billard/Main.hs b/showcases/haskell_logo_billard/Main.hs new file mode 100644 index 000000000..fd31d8365 --- /dev/null +++ b/showcases/haskell_logo_billard/Main.hs @@ -0,0 +1,79 @@ +module Main (main) where + + + +import Data.Foldable +import Graphics.Rendering.Cairo as Cairo hiding (transform) + +import Draw +import Geometry +import Geometry.Shapes + + + +picWidth, picHeight :: Num a => a +picWidth = 1000 +picHeight = 720 + +main :: IO () +main = render "out/haskell_logo_billard.svg" picWidth picHeight $ do + Cairo.scale 2 2 + drawing + +data BillardSpec = BillardSpec + { steps :: Int + , table :: [Line] + , startPos :: Vec2 + , startAngle :: Angle + } + +runBillardSpec :: BillardSpec -> [Vec2] +runBillardSpec BillardSpec{..} = + take steps (drop 1 (billard table (angledLine startPos startAngle 10))) + +drawing :: Render () +drawing = do + let [left, lambda, upper, lower] = transform (Geometry.scale 340) haskellLogo + billardLeft = BillardSpec{ steps = 256, table = polygonEdges left, startPos = Vec2 10 10, startAngle = deg 40 } + billardLambda = BillardSpec{ steps = 400, table = polygonEdges lambda, startPos = Vec2 230 175, startAngle = deg 40 } + billardUpper = BillardSpec{ steps = 120, table = polygonEdges upper, startPos = Vec2 400 120, startAngle = deg 20 } + billardLower = BillardSpec{ steps = 120, table = polygonEdges lower, startPos = Vec2 450 220, startAngle = deg 40 } + billardSketch :: BillardSpec -> (Double -> AlphaColor Double) -> Render () + billardSketch spec color = do + let points = runBillardSpec spec + billardLines = zipWith Line points (tail points) + let lengths = map lineLength billardLines + (meanLength, sigmaLength) = meanStddev lengths + for_ billardLines (\line -> + let alpha = let d = lineLength line + in min 1 (max 0.4 (abs (d - meanLength) / (3*sigmaLength))) + in setColor (color alpha) >> sketch line >> stroke) + + Cairo.translate 10 10 + + setLineWidth 1 + billardSketch billardLeft (hsva 257 0.40 0.38) >> stroke + setColor $ hsva 257 0.40 0.38 1 + sketch left >> stroke + + billardSketch billardLambda (hsva 256 0.40 0.50) + setColor $ hsva 256 0.40 0.50 1 + sketch lambda >> stroke + + billardSketch billardUpper (hsva 304 0.45 0.56) + billardSketch billardLower (hsva 304 0.45 0.56) + setColor $ hsva 304 0.45 0.56 1 + sketch upper >> stroke + sketch lower >> stroke + +-- | Mean and standard deviation, calculated in a single pass. 😎 +meanStddev :: [Double] -> (Double, Double) +meanStddev xs = (mu, sigma) + where + mu = total / count + sigma = sqrt ((totalSquares - total*mu) / (count - 1)) + (count, total, totalSquares) = foldl' + (\(!countAcc, !totalAcc, !totalSquaresAcc) x + -> (countAcc+1, totalAcc+x, totalSquaresAcc + x*x)) + (0, 0, 0) + xs diff --git a/showcases/haskell_logo_billard/haskell-logo-billard.cabal b/showcases/haskell_logo_billard/haskell-logo-billard.cabal new file mode 100644 index 000000000..82a3c036b --- /dev/null +++ b/showcases/haskell_logo_billard/haskell-logo-billard.cabal @@ -0,0 +1,37 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: haskell-logo-billard +version: 0.1.0.0 +homepage: https://github.com/quchen/generative-art#readme +bug-reports: https://github.com/quchen/generative-art/issues +author: David »quchen« Luposchainsky – dluposchainsky (λ) gmail +maintainer: David »quchen« Luposchainsky – dluposchainsky (λ) gmail +copyright: 2018 David Luposchainsky +license: BSD3 +build-type: Simple + +source-repository head + type: git + location: https://github.com/quchen/generative-art + +executable haskell-logo-billard + main-is: Main.hs + other-modules: + Paths_haskell_logo_billard + hs-source-dirs: + ./ + default-extensions: + BangPatterns + LambdaCase + MultiWayIf + RecordWildCards + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-type-defaults + build-depends: + base + , cairo + , generative-art + default-language: Haskell2010 diff --git a/showcases/haskell_logo_billard/package.yaml b/showcases/haskell_logo_billard/package.yaml new file mode 100644 index 000000000..d145fdbc0 --- /dev/null +++ b/showcases/haskell_logo_billard/package.yaml @@ -0,0 +1,23 @@ +name: haskell-logo-billard +version: 0.1.0.0 +github: quchen/generative-art +license: BSD3 +author: David »quchen« Luposchainsky – dluposchainsky (λ) gmail +copyright: "2018 David Luposchainsky" + +dependencies: + - generative-art + - base + - cairo + +default-extensions: + - BangPatterns + - LambdaCase + - MultiWayIf + - RecordWildCards + +executables: + haskell-logo-billard: + main: Main.hs + source-dirs: . + ghc-options: [-threaded, -rtsopts, -with-rtsopts=-N, -Wall, -Wno-type-defaults] diff --git a/showcases/haskell_logo_billard/stack.yaml b/showcases/haskell_logo_billard/stack.yaml new file mode 100644 index 000000000..be0c7697d --- /dev/null +++ b/showcases/haskell_logo_billard/stack.yaml @@ -0,0 +1,11 @@ +flags: {} +packages: + - . +extra-deps: + - git: https://github.com/quchen/generative-art + commit: 3cea78bb902c023216727be16dcf8143bd62f0ae + - Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + - plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + - alfred-margaret-2.1.0.2 +resolver: lts-21.25 +allow-newer: true diff --git a/showcases/haskell_logo_billard/stack.yaml.lock b/showcases/haskell_logo_billard/stack.yaml.lock new file mode 100644 index 000000000..5963a5462 --- /dev/null +++ b/showcases/haskell_logo_billard/stack.yaml.lock @@ -0,0 +1,33 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + pantry-tree: + sha256: 27a9154935b4d30a22830477c60c5108fd713a184d456272c2fccbf361d2395f + size: 1176 + original: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 +- completed: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + pantry-tree: + sha256: 887770effc1578682fe255d7f8b1a9801bc5a6e832aa46316782e43eecb65113 + size: 321 + original: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 +- completed: + hackage: alfred-margaret-2.1.0.2@sha256:2903ce63f9054ec607c03439231cdacd0a3b731febe05f493d073bcb1a8bc1a7,4918 + pantry-tree: + sha256: f747ba440a8a87e433970d07cb1edabac770f111fec0732ee83026cf2bf7286e + size: 1938 + original: + hackage: alfred-margaret-2.1.0.2 +snapshots: +- completed: + sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd + size: 640086 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml + original: lts-21.25 diff --git a/showcases/haskell_logo_shattered/Main.hs b/showcases/haskell_logo_shattered/Main.hs new file mode 100644 index 000000000..80190fca6 --- /dev/null +++ b/showcases/haskell_logo_shattered/Main.hs @@ -0,0 +1,104 @@ +module Main (main) where + + + +import Control.Monad.ST +import Data.Foldable +import Data.Traversable +import qualified Data.Vector as V +import Graphics.Rendering.Cairo as Cairo hiding (x, y) +import qualified System.Random.MWC as MWC + +import Draw +import Geometry as G +import Geometry.Shapes +import Numerics.Interpolation +import qualified Geometry.Chaotic as Chaos + + + +main :: IO () +main = do + render "out/haskell_logo_shattered.svg" picWidth picHeight $ renderDrawing + render "out/haskell_logo_shattered.png" picWidth picHeight $ do + cairoScope $ do + setColor white + paint + renderDrawing + where + picWidth = 1000 + picHeight = 720 + shattered = runST $ do + let recurse polygon = minMaxAreaRatio (polygon : haskellLogo) >= 1/128 + acceptCut polygons = minMaxAreaRatio polygons >= 1/3 + gen <- MWC.initialize (V.fromList [1]) + cutUpLogoParts <- for haskellLogo (shatterProcess gen recurse acceptCut) + let BoundingBox (Vec2 xMin _) (Vec2 xMax _) = boundingBox cutUpLogoParts + for (concat cutUpLogoParts) $ \polygon -> do + let Vec2 x _ = polygonCenter polygon + wiggleAmount = lerp (xMin, xMax) (0, 40) x + angle <- fmap deg (MWC.uniformRM (-wiggleAmount, wiggleAmount) gen) + pure (G.transform (G.rotateAround (polygonCenter polygon) angle) polygon) + + renderDrawing = do + gen <- liftIO $ Chaos.initializeMwc shattered + let fitToCanvas = G.transform (transformBoundingBox shattered (Vec2 10 10, Vec2 (fromIntegral picWidth-10) (fromIntegral picHeight-10)) def) + drawing gen (fitToCanvas shattered) + +shatterProcess + :: MWC.GenST s + -> (Polygon -> Bool) -- ^ Recursively subdivide the current polygon? + -> ([Polygon] -> Bool) -- ^ Accept the cut result, or retry with a different random cut line? + -> Polygon -- ^ Initial polygon, cut only if the recursion predicate applies + -> ST s [Polygon] +shatterProcess _ recurse _ polygon + | not (recurse polygon) = pure [polygon] +shatterProcess gen recurse acceptCut polygon = do + cutPieces <- randomCut gen polygon + let triangulated = concatMap triangulate cutPieces + if acceptCut triangulated + then do + subcuts <- traverse (shatterProcess gen recurse acceptCut) triangulated + pure (concat subcuts) + else shatterProcess gen recurse acceptCut polygon + +polygonCenter :: Polygon -> Vec2 +polygonCenter (Polygon corners) = foldl' (+.) zero corners /. fromIntegral (length corners) + +randomCut + :: MWC.Gen s + -> Polygon -- ^ Initial polygon, cut only if the recursion predicate applies + -> ST s [Polygon] +randomCut gen polygon = do + let BoundingBox vMin vMax = boundingBox polygon + p <- MWC.uniformRM (vMin, vMax) gen + angle <- MWC.uniformM gen + let scissors = angledLine p angle 1 + pure (cutPolygon scissors polygon) + +-- | Calculate the min/max ratio of the areas of a list of polygons. Useful to +-- build cutoff predicates with, e.g. +-- +-- @ +-- \polys -> 'minMaxAreaRatio' polys >= 1/3 +-- @ +minMaxAreaRatio :: [Polygon] -> Double +minMaxAreaRatio cutResult + = let cutResultAreas = map polygonArea cutResult + minA = minimum cutResultAreas + maxA = maximum cutResultAreas + in minA / maxA + +drawing :: MWC.GenIO -> [Polygon] -> Render () +drawing gen shattered = do + setLineWidth 0.5 + cairoScope $ for_ shattered $ \polygon -> do + let hue = 30 + saturation <- liftIO $ MWC.uniformRM (0.2, 0.7) gen + let value = 1 + let alpha = 1 + setColor (hsva hue saturation value alpha) + sketch polygon + fillPreserve + setColor black + stroke diff --git a/showcases/haskell_logo_shattered/haskell-logo-shattered.cabal b/showcases/haskell_logo_shattered/haskell-logo-shattered.cabal new file mode 100644 index 000000000..dd868341d --- /dev/null +++ b/showcases/haskell_logo_shattered/haskell-logo-shattered.cabal @@ -0,0 +1,39 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: haskell-logo-shattered +version: 0.1.0.0 +homepage: https://github.com/quchen/generative-art#readme +bug-reports: https://github.com/quchen/generative-art/issues +author: David »quchen« Luposchainsky – dluposchainsky (λ) gmail +maintainer: David »quchen« Luposchainsky – dluposchainsky (λ) gmail +copyright: 2018 David Luposchainsky +license: BSD3 +build-type: Simple + +source-repository head + type: git + location: https://github.com/quchen/generative-art + +executable haskell-logo-shattered + main-is: Main.hs + other-modules: + Paths_haskell_logo_shattered + hs-source-dirs: + ./ + default-extensions: + BangPatterns + LambdaCase + MultiWayIf + RecordWildCards + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-type-defaults + build-depends: + base + , cairo + , generative-art + , mwc-random + , vector + default-language: Haskell2010 diff --git a/showcases/haskell_logo_shattered/package.yaml b/showcases/haskell_logo_shattered/package.yaml new file mode 100644 index 000000000..385177620 --- /dev/null +++ b/showcases/haskell_logo_shattered/package.yaml @@ -0,0 +1,25 @@ +name: haskell-logo-shattered +version: 0.1.0.0 +github: quchen/generative-art +license: BSD3 +author: David »quchen« Luposchainsky – dluposchainsky (λ) gmail +copyright: "2018 David Luposchainsky" + +dependencies: + - generative-art + - base + - cairo + - mwc-random + - vector + +default-extensions: + - BangPatterns + - LambdaCase + - MultiWayIf + - RecordWildCards + +executables: + haskell-logo-shattered: + main: Main.hs + source-dirs: . + ghc-options: [-threaded, -rtsopts, -with-rtsopts=-N, -Wall, -Wno-type-defaults] diff --git a/showcases/haskell_logo_shattered/stack.yaml b/showcases/haskell_logo_shattered/stack.yaml new file mode 100644 index 000000000..be0c7697d --- /dev/null +++ b/showcases/haskell_logo_shattered/stack.yaml @@ -0,0 +1,11 @@ +flags: {} +packages: + - . +extra-deps: + - git: https://github.com/quchen/generative-art + commit: 3cea78bb902c023216727be16dcf8143bd62f0ae + - Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + - plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + - alfred-margaret-2.1.0.2 +resolver: lts-21.25 +allow-newer: true diff --git a/showcases/haskell_logo_shattered/stack.yaml.lock b/showcases/haskell_logo_shattered/stack.yaml.lock new file mode 100644 index 000000000..5963a5462 --- /dev/null +++ b/showcases/haskell_logo_shattered/stack.yaml.lock @@ -0,0 +1,33 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + pantry-tree: + sha256: 27a9154935b4d30a22830477c60c5108fd713a184d456272c2fccbf361d2395f + size: 1176 + original: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 +- completed: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + pantry-tree: + sha256: 887770effc1578682fe255d7f8b1a9801bc5a6e832aa46316782e43eecb65113 + size: 321 + original: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 +- completed: + hackage: alfred-margaret-2.1.0.2@sha256:2903ce63f9054ec607c03439231cdacd0a3b731febe05f493d073bcb1a8bc1a7,4918 + pantry-tree: + sha256: f747ba440a8a87e433970d07cb1edabac770f111fec0732ee83026cf2bf7286e + size: 1938 + original: + hackage: alfred-margaret-2.1.0.2 +snapshots: +- completed: + sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd + size: 640086 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml + original: lts-21.25 diff --git a/showcases/haskell_logo_voronoi/Main.hs b/showcases/haskell_logo_voronoi/Main.hs new file mode 100644 index 000000000..39ac05cb2 --- /dev/null +++ b/showcases/haskell_logo_voronoi/Main.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE RecordWildCards #-} +module Main (main) where + + + +import Data.Char +import Data.Maybe +import qualified Data.Vector as V +import Math.Noise (Perlin (..), getValue, perlin) +import Options.Applicative +import Prelude hiding ((**)) +import System.Random.MWC + +import Draw +import Geometry as G +import Geometry.Algorithms.Delaunay +import Geometry.Algorithms.Sampling +import Geometry.Algorithms.Voronoi +import Geometry.Shapes (haskellLogo) +import Graphics.Rendering.Cairo as C +import qualified Util.RTree as RT + + + +picWidth, picHeight :: Num a => a +picWidth = 1000 +picHeight = 720 + +main :: IO () +main = mainHaskellLogo + + +data Options = Options + { _count :: Int + , _file :: FilePath + } deriving (Eq, Ord, Show) + +commandLineOptions :: IO Options +commandLineOptions = execParser parserOpts + where + progOpts = Options + <$> option auto ( + long "count" + <> short 'c' + <> metavar "INT" + <> value 1000 + <> help "Number of cells" + <> showDefault) + <*> strOption ( + long "file" + <> short 'f' + <> metavar "FILE" + <> value "out/haskell_logo_voronoi.png" + <> help "Output filename" + <> showDefault) + parserOpts = info (progOpts <**> helper) + ( fullDesc + <> progDesc "Voronoi Haskell Logo" + <> header "A Haskell logo made out of Voronoi cells" ) + +mainHaskellLogo :: IO () +mainHaskellLogo = do + Options {_count=count, _file=file} <- commandLineOptions + gen <- initialize (V.fromList (map (fromIntegral . ord) (show count))) + let -- constructed so that we have roughly `count` points + adaptiveRadius = sqrt (0.75 * picWidth * picHeight / fromIntegral count) + samplingProps = PoissonDiscParams + { _poissonShape = boundingBox [zero, Vec2 picWidth picHeight] + , _poissonRadius = adaptiveRadius + , _poissonK = 4 + } + points <- poissonDisc gen samplingProps + ditheringPoints <- RT.fromList <$> poissonDisc gen samplingProps{ _poissonRadius = adaptiveRadius / 4 } + print (length points) + let voronoi = toVoronoi (bowyerWatson (BoundingBox (Vec2 0 0) (Vec2 picWidth picHeight)) points) + voronoiColorized = mapWithMetadata (\_seed polygon ann -> colorizePolygon ditheringPoints polygon ann) voronoi + + render file picWidth picHeight $ for_ (_voronoiCells voronoiColorized) drawCell + +haskellLogoWithColors :: [(Polygon, Color Double)] +haskellLogoWithColors = zip haskellLogoCentered haskellLogoColors + where + haskellLogoCentered = G.transform (G.translate (Vec2 (picWidth/2 - 480) (picHeight/2 - 340)) <> G.scale 680) haskellLogo + haskellLogoColors = [haskell 0, haskell 1, haskell 2, haskell 2] + + +findPointsInPolygon :: RT.RTree Vec2 -> Polygon -> [Vec2] +findPointsInPolygon points poly = filter (`pointInPolygon` poly) (RT.fullyContainedIn (boundingBox poly) points) + +colorizePolygon :: RT.RTree Vec2 -> Polygon -> () -> Color Double +colorizePolygon ditheringPoints voronoiRegion _ = average $ colorizePoint <$> ditheringPointsInRegion + where + ditheringPointsInRegion = findPointsInPolygon ditheringPoints voronoiRegion + colorizePoint p = + let color = case find (pointInPolygon p . fst) haskellLogoWithColors of + Just (_, c) -> c + Nothing -> darkGrey + in adjustHsl id id (+ (0.1 * noise2d p)) color + noise = perlin { perlinFrequency = 40/picWidth, perlinSeed = 12345} + noise2d (Vec2 x y) = fromMaybe 0 $ getValue noise (x, y, 0) + +drawCell :: VoronoiCell (Color Double) -> Render () +drawCell VoronoiCell{..} = drawPoly _voronoiRegion _voronoiProps + +drawPoly :: Polygon -> Color Double -> Render () +drawPoly (Polygon []) _ = pure () +drawPoly poly color = do + let fillColor = color + lineColor = blend 0.1 white color + sketch poly + setColor fillColor + fillPreserve + setColor lineColor + setLineWidth 1 + stroke + +darkGrey :: Color Double +darkGrey = hsv 0 0 0.1 diff --git a/showcases/haskell_logo_voronoi/haskell-logo-voronoi.cabal b/showcases/haskell_logo_voronoi/haskell-logo-voronoi.cabal new file mode 100644 index 000000000..cd32c7437 --- /dev/null +++ b/showcases/haskell_logo_voronoi/haskell-logo-voronoi.cabal @@ -0,0 +1,36 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: haskell-logo-voronoi +version: 0.1.0.0 +homepage: https://github.com/quchen/generative-art#readme +bug-reports: https://github.com/quchen/generative-art/issues +author: Franz Thoma +maintainer: Franz Thoma +copyright: 2018-2022 Franz Thoma +license: BSD3 +build-type: Simple + +source-repository head + type: git + location: https://github.com/quchen/generative-art + +executable haskell-logo-voronoi + main-is: Main.hs + other-modules: + Paths_haskell_logo_voronoi + hs-source-dirs: + ./ + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-type-defaults -O + build-depends: + Noise + , base + , cairo + , generative-art + , mwc-random + , optparse-applicative + , vector + default-language: Haskell2010 diff --git a/showcases/haskell_logo_voronoi/package.yaml b/showcases/haskell_logo_voronoi/package.yaml new file mode 100644 index 000000000..f9bc0e755 --- /dev/null +++ b/showcases/haskell_logo_voronoi/package.yaml @@ -0,0 +1,21 @@ +name: haskell-logo-voronoi +version: 0.1.0.0 +github: quchen/generative-art +license: BSD3 +author: Franz Thoma +copyright: "2018-2022 Franz Thoma" + +dependencies: + - generative-art + - base + - cairo + - mwc-random + - Noise + - optparse-applicative + - vector + +executables: + haskell-logo-voronoi: + main: Main.hs + source-dirs: . + ghc-options: [-threaded, -rtsopts, -with-rtsopts=-N, -Wall, -Wno-type-defaults, -O] diff --git a/showcases/haskell_logo_voronoi/stack.yaml b/showcases/haskell_logo_voronoi/stack.yaml new file mode 100644 index 000000000..c03bc81fd --- /dev/null +++ b/showcases/haskell_logo_voronoi/stack.yaml @@ -0,0 +1,14 @@ +flags: {} +packages: + - . +extra-deps: + - git: https://github.com/quchen/generative-art + commit: 6ac74502f1d55da60513ac7aec458e715dad6c3b + - cairo-0.13.10.0@sha256:388f39af90d50b920cad70612046041a7ffd7f5b60721862c0c797ecddf7e902,4153 + - gtk2hs-buildtools-0.13.8.2@sha256:01c4a6cc3679008bd4caec32b49843acb27a5f48ee2b22484218f097835548f6,5238 + - Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + - data-r-tree-0.6.0@sha256:10a25ef70e6779c3bf5128cd45d033482a370ea07e92ab1c82678675de01d870,3668 + - plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + - alfred-margaret-1.1.1.0@sha256:aeb2f14726e1ee70e542ecfb2a71eb14abda8303d17932bca149401edd76135b,3095 +resolver: lts-18.19 +allow-newer: true diff --git a/showcases/haskell_logo_voronoi/stack.yaml.lock b/showcases/haskell_logo_voronoi/stack.yaml.lock new file mode 100644 index 000000000..f12ab3146 --- /dev/null +++ b/showcases/haskell_logo_voronoi/stack.yaml.lock @@ -0,0 +1,54 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: cairo-0.13.10.0@sha256:388f39af90d50b920cad70612046041a7ffd7f5b60721862c0c797ecddf7e902,4153 + pantry-tree: + sha256: a5d7014b0df2600377d061185b104f755274935554e723e2b7b600b85ffc7ae2 + size: 2831 + original: + hackage: cairo-0.13.10.0@sha256:388f39af90d50b920cad70612046041a7ffd7f5b60721862c0c797ecddf7e902,4153 +- completed: + hackage: gtk2hs-buildtools-0.13.8.2@sha256:01c4a6cc3679008bd4caec32b49843acb27a5f48ee2b22484218f097835548f6,5238 + pantry-tree: + sha256: 1c3b449a69f4bb2d27c09a89e447552a58201a3febf5418e67af0001a0cbb0a7 + size: 3588 + original: + hackage: gtk2hs-buildtools-0.13.8.2@sha256:01c4a6cc3679008bd4caec32b49843acb27a5f48ee2b22484218f097835548f6,5238 +- completed: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + pantry-tree: + sha256: 27a9154935b4d30a22830477c60c5108fd713a184d456272c2fccbf361d2395f + size: 1176 + original: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 +- completed: + hackage: data-r-tree-0.6.0@sha256:10a25ef70e6779c3bf5128cd45d033482a370ea07e92ab1c82678675de01d870,3668 + pantry-tree: + sha256: 057a5a25c6c8fe8e60e62b9522e8f1a8be3e7470bfe44229d1e2712e6851409e + size: 614 + original: + hackage: data-r-tree-0.6.0@sha256:10a25ef70e6779c3bf5128cd45d033482a370ea07e92ab1c82678675de01d870,3668 +- completed: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + pantry-tree: + sha256: 887770effc1578682fe255d7f8b1a9801bc5a6e832aa46316782e43eecb65113 + size: 321 + original: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 +- completed: + hackage: alfred-margaret-1.1.1.0@sha256:aeb2f14726e1ee70e542ecfb2a71eb14abda8303d17932bca149401edd76135b,3095 + pantry-tree: + sha256: 44f6f77280a9984cdf7be9f2bc4804f9ba3809ab60e9a065aabb1ee3f8f92322 + size: 1087 + original: + hackage: alfred-margaret-1.1.1.0@sha256:aeb2f14726e1ee70e542ecfb2a71eb14abda8303d17932bca149401edd76135b,3095 +snapshots: +- completed: + sha256: 32716534fff554b7f90762130fdb985cabf29f157758934dd1c8f3892a646430 + size: 586103 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/19.yaml + original: lts-18.19 diff --git a/showcases/munihac_2022_logo/Circuits/GrowingProcess.hs b/showcases/munihac_2022_logo/Circuits/GrowingProcess.hs new file mode 100644 index 000000000..6a16f1a7d --- /dev/null +++ b/showcases/munihac_2022_logo/Circuits/GrowingProcess.hs @@ -0,0 +1,235 @@ +module Circuits.GrowingProcess ( + circuitProcess + , CellState(..) + , Circuits(..) + , ProcessGeometry(..) +) where + + + +import Control.DeepSeq +import Control.Monad +import Control.Monad.ST +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as S +import qualified Data.Vector.Extended as V +import qualified System.Random.MWC as MWC + +import Geometry.Coordinates.Hexagonal as Hex + + + +-- | The geometry in which a circuit growing process takes place. +data ProcessGeometry = ProcessGeometry + { _inside :: Set Hex + , _edge :: Set Hex + } deriving (Eq, Ord, Show) + +data CellState + = WireTo Hex + | WireEnd + deriving (Eq, Ord, Show) + +instance NFData CellState where + rnf (WireTo target) = rnf target + rnf WireEnd = () + +data MoveConstraints = MoveConstraints + { _isInBounds :: Hex -> Bool + , _acceptStep :: CellState -> Circuits -> Maybe CellState + } + +-- | All existing circuits. The wires can be reconstructed from this. +data Circuits = Circuits + { _starts :: Set Hex + , _nodes :: Map Hex CellState + } deriving (Eq, Ord, Show) + +instance NFData Circuits where + rnf Circuits{_starts=starts, _nodes=nodes} + = rnf starts `seq` rnf nodes + +emptyCircuits :: Circuits +emptyCircuits = Circuits + { _starts = S.empty + , _nodes = M.empty + } + +insertNode :: Hex -> CellState -> Circuits -> Circuits +insertNode cellPos cellState circuits = circuits { _nodes = M.insert cellPos cellState (_nodes circuits) } + +insertStart :: Hex -> Circuits -> Circuits +insertStart start circuits = circuits { _starts = S.insert start (_starts circuits) } + +-- | Grow circuits inside a geometry. +circuitProcess + :: ProcessGeometry + -> Circuits +circuitProcess processGeometry = runST $ do + gen <- MWC.initialize (V.fromList [252,23133,233,23,1]) + k <- replicateM 1000 (MWC.uniformM gen) -- Warm up MWC gen + let _ = k :: [Int] + + let acceptStep WireEnd _ = Just WireEnd + acceptStep step@(WireTo target) knownCircuits + | target `M.notMember` _nodes knownCircuits + && (target `S.member` _inside processGeometry || target `S.member` _edge processGeometry) + = Just step + acceptStep _ _ = Nothing + + isInBounds p = p `S.member` _inside processGeometry + || p `S.member` _edge processGeometry + + constraints = MoveConstraints + { _acceptStep = acceptStep + , _isInBounds = isInBounds + } + + (_starts, result) <- iterateUntilNothingM + (growSingleCircuit gen constraints) + (_inside processGeometry <> _edge processGeometry, emptyCircuits) + pure result + +iterateUntilNothingM + :: Monad m + => (a -> m (Maybe a)) + -> a + -> m a +iterateUntilNothingM f = go + where + go x = f x >>= \case + Nothing -> pure x + Just x' -> go x' + +growSingleCircuit + :: MWC.Gen s + -> MoveConstraints + -> (Set Hex, Circuits) + -> ST s (Maybe (Set Hex, Circuits)) +growSingleCircuit gen constraints (startingCandidates, knownCircuits) = + pickStartAndFirstStep gen constraints (startingCandidates, knownCircuits) >>= \case + NoFirstStepPossible -> pure Nothing + FirstStepIs thinnedOutSCs start firstStep -> do + grownCircuit <- growCircuit gen start firstStep constraints knownCircuits + pure (Just (thinnedOutSCs, grownCircuit)) + +data FirstStep + = NoFirstStepPossible -- ^ Given the geometry and already existing circuits, we can’t grow any circuits + | FirstStepIs (Set Hex) Hex Hex -- ^ Remaining start position candidates, starting position, first step + deriving (Eq, Ord, Show) + +-- | Pick a starting point and a first step. If a listed point is an impossible +-- start, remove it from the list of possible starts. +pickStartAndFirstStep + :: MWC.GenST s + -> MoveConstraints + -> (Set Hex, Circuits) -- ^ Starting point candidates, existing circuits + -> ST s FirstStep +pickStartAndFirstStep gen constraints (startingCandidates, knownCircuits) = + let allowedSCs = S.filter (\start -> fieldIsAllowed start knownCircuits constraints) startingCandidates + loop thinnedOutSCs = randomEntry gen thinnedOutSCs >>= \case + Nothing -> pure NoFirstStepPossible + Just start -> randomFirstStep gen start knownCircuits constraints >>= \case + Nothing -> loop (S.delete start thinnedOutSCs) + Just firstStep -> pure (FirstStepIs thinnedOutSCs start firstStep) + in loop allowedSCs + +-- | Random uniform choice of a 'Set' element. +randomEntry :: MWC.GenST s -> Set a -> ST s (Maybe a) +randomEntry gen xs = do + let n = S.size xs + if n <= 0 then + pure Nothing + else do + i <- MWC.uniformRM (0,n-1) gen + pure (Just (S.elemAt i xs)) + +-- Take an allowed first step +randomFirstStep + :: MWC.Gen s -- ^ RNG + -> Hex -- ^ Starting position + -> Circuits -- ^ Existing geometry + -> MoveConstraints -- ^ Collision detection + -> ST s (Maybe Hex) -- ^ Destination for the first step +randomFirstStep gen start knownCircuits constraints = do + let neighbours = V.fromList (ring 1 start) + scrambledNeighbours <- do + vMut <- V.thaw neighbours + V.fisherYatesShuffle gen vMut + V.unsafeFreeze vMut + pure (V.find (\firstStep -> fieldIsAllowed firstStep knownCircuits constraints) scrambledNeighbours) + +-- | Check whether a field can house another piece of wire +fieldIsAllowed :: Hex -> Circuits -> MoveConstraints -> Bool +fieldIsAllowed hex circuits constraints = not inAnyCircuit && inBounds + where + inAnyCircuit = hex `M.member` _nodes circuits + inBounds = _isInBounds constraints hex + +growCircuit + :: MWC.Gen s + -> Hex + -> Hex + -> MoveConstraints + -> Circuits + -> ST s Circuits +growCircuit gen start firstStep constraints knownCircuits = do + let knownCircuitsBeforeProcess = insertStart start (insertNode start (WireTo firstStep) knownCircuits) + loop newKnownCircuits lastPos currentPos = do + action <- randomPossibleAction gen constraints newKnownCircuits lastPos currentPos + case action of + WireTo target -> loop (insertNode currentPos action newKnownCircuits) currentPos target + WireEnd -> pure (insertNode currentPos WireEnd newKnownCircuits) + loop knownCircuitsBeforeProcess start firstStep + +randomPossibleAction + :: MWC.GenST s + -> MoveConstraints + -> Circuits + -> Hex + -> Hex + -> ST s CellState +randomPossibleAction gen constraints knownCircuits lastPos currentPos = weightedRandom gen possibleActions + where + actions = + [ (100, continueStraight) + , (25, continueRight) + , (25, continueLeft) + , (5, terminate) -- This needs to be a valid choice as a fallback if nothing else goes + ] + + possibleActions = flip filter actions $ \(_weight, action) -> + isJust (_acceptStep constraints action knownCircuits) + + straightOn i = currentPos `hexAdd` hexTimes i (hexSubtract currentPos lastPos) + right = Hex.rotateAround currentPos 1 (straightOn 1) + left = Hex.rotateAround currentPos (-1) (straightOn 1) + + continueStraight = WireTo (straightOn 1) + continueRight = WireTo right + continueLeft = WireTo left + terminate = WireEnd + +-- | Pick an element from a list with a certain weight. +-- +-- The probability of an entry is thus \(\frac\text{weight}\text{\sum weights}}\). +weightedRandom :: MWC.GenST s -> [(Int, a)] -> ST s a +weightedRandom _ [] + = error "weightedRandom: empty list of choices" +weightedRandom _ choices + | any (< 0) weights = error ("weightedRandom: negative weight, " ++ show weights) + | all (== 0) weights = error ("weightedRandom: all weights were zero, " ++ show weights) + where + weights = [weight | (weight, _val) <- choices] +weightedRandom gen choices = do + let total = sum [weight | (weight, _val) <- choices] + i <- MWC.uniformRM (1, total) gen + pure (pick i choices) + where + pick n ((weight, x):xs) + | n <= weight = x + | otherwise = pick (n-weight) xs + pick _ _ = error "weightedRandom.pick used with empty list" diff --git a/showcases/munihac_2022_logo/Circuits/ReconstructWires.hs b/showcases/munihac_2022_logo/Circuits/ReconstructWires.hs new file mode 100644 index 000000000..529f96825 --- /dev/null +++ b/showcases/munihac_2022_logo/Circuits/ReconstructWires.hs @@ -0,0 +1,24 @@ +module Circuits.ReconstructWires (reconstructWires) where + + + +import Data.Map (Map) +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S + +import Circuits.GrowingProcess +import Geometry.Coordinates.Hexagonal as Hex + + + +reconstructSingleWire :: Map Hex CellState -> Hex -> [Hex] +reconstructSingleWire cellMap start = start : case M.lookup start cellMap of + Nothing -> error "Reached end of wire unexpectedly" + Just (WireTo next) -> reconstructSingleWire cellMap next + Just WireEnd -> [] + +-- | Convert the (rather abstract) result of the circuit growing process into a set +-- of hex-polylines, which are much simpler to work with. +reconstructWires :: Circuits -> Set [Hex] +reconstructWires circuits = S.map (reconstructSingleWire (_nodes circuits)) (_starts circuits) diff --git a/showcases/munihac_2022_logo/Circuits/Render.hs b/showcases/munihac_2022_logo/Circuits/Render.hs new file mode 100644 index 000000000..d6f675abd --- /dev/null +++ b/showcases/munihac_2022_logo/Circuits/Render.hs @@ -0,0 +1,104 @@ +module Circuits.Render ( + renderWire + , renderWires + , renderProcessGeometry + + , ColorScheme(..) + , purple + , grey + , pitchBlackForDebugging +) where + + + +import Data.Set (Set) +import qualified Data.Vector as V +import Graphics.Rendering.Cairo as C hiding (x, y) +import qualified System.Random.MWC as MWC + +import Circuits.GrowingProcess +import Draw as D +import Geometry as G +import Geometry.Coordinates.Hexagonal as Hex + + + +renderWire :: Double -> Double -> [Hex] -> Render () +renderWire _ _ [] = pure () +renderWire cellSize circleRadius hexes@(first:_) = do + moveToVec (toVec2 cellSize first) + go (map (toVec2 cellSize) hexes) + where + go [] = pure () + go [x] = sketch (Circle x circleRadius) >> stroke + go [x,y] = do + let Line _ end = resizeLine (\d -> d - circleRadius) (Line x y) + lineToVec end + stroke + sketch (Circle y circleRadius) + stroke + go (_:rest@(y:_)) = do + lineToVec y + go rest + +renderWires + :: ColorScheme + -> Double + -> Double + -> Set [Hex] + -> Render () +renderWires scheme cellSize circleRadius wires = do + gen <- liftIO MWC.create + for_ wires $ \wire -> do + randomColor gen scheme + renderWire cellSize circleRadius wire + +newtype ColorScheme = ColorScheme (V.Vector (Render ())) + +purple :: ColorScheme +purple = ColorScheme (V.fromList [darker, dark, brighter]) + where + darker = setColor (haskell 0) + dark = setColor (haskell 0.5) + brighter = setColor (haskell 1) + +grey :: ColorScheme +grey = ColorScheme (V.fromList [setGrey x | x <- [850, 875, 900]]) + where + setGrey per1000 = + let x = fromIntegral per1000 / 1000 + in setColor (rgb x x x) + +pitchBlackForDebugging :: ColorScheme +pitchBlackForDebugging = ColorScheme (V.fromList [setColor (rgb 0 0 0)]) + +randomColor + :: MWC.GenIO + -> ColorScheme + -> Render () +randomColor gen (ColorScheme scheme) = do + n <- liftIO $ MWC.uniformRM (0, V.length scheme-1) gen + scheme V.! n + +renderProcessGeometry + :: (CairoColor filling, CairoColor edges) + => filling + -> edges + -> Double + -> ProcessGeometry + -> Render () +renderProcessGeometry insideColor edgeColor cellSize processGeometry = do + cairoScope $ do + for_ (_inside processGeometry) $ \hex -> D.sketch (hexagonPoly cellSize hex) + setColor insideColor + fillPreserve + setSourceRGB 0 0 0 + stroke + + cairoScope $ do + setColor edgeColor + for_ (_edge processGeometry) $ \hex -> D.sketch (hexagonPoly cellSize hex) + setColor edgeColor + fillPreserve + setSourceRGB 0 0 0 + stroke diff --git a/showcases/munihac_2022_logo/Main.hs b/showcases/munihac_2022_logo/Main.hs new file mode 100644 index 000000000..830c28eb5 --- /dev/null +++ b/showcases/munihac_2022_logo/Main.hs @@ -0,0 +1,251 @@ +module Main (main) where + + + +import qualified Data.Set as S +import qualified Data.Vector as V +import Graphics.Rendering.Cairo as C hiding (x, y, Glyph) + +import Draw as D +import Geometry.Coordinates.Hexagonal as Hex + +import Circuits.GrowingProcess +import Circuits.ReconstructWires +import Circuits.Render + + + +-- ghcid --command='stack ghci generative-art:lib munihac2022logo --main-is munihac2022logo:exe:munihac2022logo' --test=main --warnings --no-title +main :: IO () +main = do + let lambdaScale = 3 + lambdaGeometry = hexLambda lambdaScale + + lambdaCircuits = reconstructWires (circuitProcess lambdaGeometry) + let mainRender = do + let cellSize = 8 + cairoScope $ do + setLineJoin LineJoinBevel + setLineCap LineCapRound + -- cartesianCoordinateSystem def + cairoScope $ do + C.translate (20*cellSize) (fromIntegral picHeight/2) + setLineWidth 3 + renderWires purple cellSize (cellSize/2) lambdaCircuits + cairoScope $ do + C.translate (6*cellSize) (fromIntegral picHeight/2 - 13 * cellSize) + setLineWidth 6 + renderMunihacWriting purple (cellSize/1.26) + picWidth = 780 + picHeight = 380 + render "out/munihac-2022-logo.svg" picWidth picHeight mainRender + render "out/munihac-2022-logo.png" picWidth picHeight $ do + cairoScope $ do + setSourceRGB 1 1 1 + paint + mainRender + + let oneLineRender = do + let cellSize = 6 + -- cartesianCoordinateSystem def + setLineJoin LineJoinBevel + setLineCap LineCapRound + C.translate 30 54 + renderMunihacWritingOneLine purple (cellSize/2) + oneLinePicWidth = 640 + oneLinePicHeight = 60 + + render "out/munihac-2022-logo-oneline-thin.svg" oneLinePicWidth oneLinePicHeight $ do + oneLineRender + render "out/munihac-2022-logo-oneline-thin.png" oneLinePicWidth oneLinePicHeight $ do + cairoScope $ do + setSourceRGB 1 1 1 + paint + oneLineRender + render "out/munihac-2022-logo-oneline-thick.svg" oneLinePicWidth oneLinePicHeight $ do + setLineWidth 4 + oneLineRender + render "out/munihac-2022-logo-oneline-thick.png" oneLinePicWidth oneLinePicHeight $ do + setLineWidth 4 + cairoScope $ do + setSourceRGB 1 1 1 + paint + oneLineRender + + let faviconRender = do + let cellSize = 10 + smallerLambdaCircuits = reconstructWires (circuitProcess (hexLambda 2)) + cairoScope $ do + setLineJoin LineJoinBevel + setLineCap LineCapRound + cairoScope $ do + C.translate (17*cellSize) 160 + setLineWidth 5 + renderWires purple cellSize (cellSize/2) smallerLambdaCircuits + render "out/munihac-2022-favicon.png" 320 320 faviconRender + +newtype Glyph = Glyph [[Hex]] + +mapGlyph :: (Hex -> Hex) -> Glyph -> Glyph +mapGlyph f (Glyph wires) = Glyph ((map.map) f wires) + +letterM :: Glyph +letterM = Glyph + [ walkInSteps [id, move UL 8, move UR 2, move R 6, move DR 10] hexZero + , walkInSteps [move UL 10 . move R 4, move DR 6] hexZero + ] + +letterU :: Glyph +letterU = Glyph + [ walkInSteps [move UL 10, move DR 10, move R 6, move UR 2, move UL 8] hexZero + ] + +letterN :: Glyph +letterN = Glyph + [ walkInSteps [id, move UL 8, move UR 2, move R 6, move DR 10] hexZero + ] + +letterI :: Glyph +letterI = Glyph + [ walkInSteps [id, move UL 10] hexZero + ] + +letterH :: Glyph +letterH = Glyph + [ walkInSteps [id, move UL 10] hexZero + , walkInSteps [move UL 5, move R 6] hexZero + , walkInSteps [move R 8, move UL 10] hexZero + ] + +letterA :: Glyph +letterA = Glyph + [ walkInSteps [id, move UL 8, move UR 2, move R 6, move DR 10] hexZero + , walkInSteps [move UL 5, move R 6] hexZero + ] + +letterC :: Glyph +letterC = Glyph + [ walkInSteps [move R 8, move L 8, move UL 8, move UR 2, move R 6] hexZero + ] + +digit2 :: Glyph +digit2 = Glyph + [ walkInSteps [move R 7, move L 7, move UL 3, move UR 2, move R 3, move UR 2, move UL 3, move L 5, move DL 1] hexZero + ] + +digit0 :: Glyph +digit0 = Glyph + [ walkInSteps [id, move R 5, move UR 2, move UL 8, move L 5, move DL 2, move DR 6] hexZero + ] + +muni :: [Glyph] +muni = + [ letterM + , mapGlyph (move R 12) letterU + , mapGlyph (move R 24) letterN + , mapGlyph (move R 36) letterI + ] + +hac :: [Glyph] +hac = + [ letterH + , mapGlyph (move R 12) letterA + , mapGlyph (move R 24) letterC ] + +x2022 :: [Glyph] +x2022 = + [ digit2 + , mapGlyph (move R 10) digit0 + , mapGlyph (move R 20) digit2 + , mapGlyph (move R 30) digit2 + ] + +renderMunihacWriting :: ColorScheme -> Double -> Render () +renderMunihacWriting colorScheme cellSize = do + let ColorScheme colors = colorScheme + cairoScope $ do + colors V.! 2 + for_ muni $ \(Glyph wires) -> + for_ wires $ \wire -> + renderWire + cellSize + cellSize + (map (move DR (0+2) . move R 12) wire) + cairoScope $ do + colors V.! 1 + for_ hac $ \(Glyph wires) -> + for_ wires $ \wire -> + renderWire + cellSize + cellSize + (map (move DR (14+2) . move R 12) wire) + cairoScope $ do + colors V.! 0 + for_ x2022 $ \(Glyph wires) -> + for_ wires $ \wire -> + renderWire + cellSize + cellSize + (map (move DR (28+2) . move R 12) wire) + +renderMunihacWritingOneLine :: ColorScheme -> Double -> Render () +renderMunihacWritingOneLine colorScheme cellSize = do + let ColorScheme colors = colorScheme + cairoScope $ do + colors V.! 2 + for_ muni $ \(Glyph wires) -> + for_ wires $ \wire -> + renderWire + cellSize + cellSize + (map (move R 0) wire) + cairoScope $ do + colors V.! 1 + for_ hac $ \(Glyph wires) -> + for_ wires $ \wire -> + renderWire + cellSize + cellSize + (map (move R 40) wire) + cairoScope $ do + colors V.! 0 + for_ x2022 $ \(Glyph wires) -> + for_ wires $ \wire -> + renderWire + cellSize + cellSize + (map (move R 78) wire) + +-- | A lambda in hexagonal coordinates. +hexLambda + :: Int -- ^ Scale parameter. c*10 will be the total height. + -> ProcessGeometry +hexLambda c | c <= 0 = ProcessGeometry S.empty S.empty +hexLambda c = ProcessGeometry + { _inside = pointsOnInside + , _edge = pointsOnEdge + } + where + polygon = Hex.HexPolygon corners + corners = walkInSteps + [ id + , move R (c*2) + , move DR (c*10) + , move L (c*2) + , move UL (c*3) + , move DL (c*3) + , move L (c*2) + , move UR (c*5) + ] + (move UL (c*5) (move L c hexZero)) + + floodFillStart = hexZero + floodFilled = floodFill floodFillStart (edgePoints polygon) + pointsOnInside = floodFilled `S.difference` pointsOnEdge + pointsOnEdge = edgePoints polygon + +walkInSteps :: [hex -> hex] -> hex -> [hex] +walkInSteps [] _pos = [] +walkInSteps (f:fs) pos = + let newPoint = f pos + in newPoint : walkInSteps fs newPoint diff --git a/showcases/munihac_2022_logo/munihac2022logo.cabal b/showcases/munihac_2022_logo/munihac2022logo.cabal new file mode 100644 index 000000000..d4156e336 --- /dev/null +++ b/showcases/munihac_2022_logo/munihac2022logo.cabal @@ -0,0 +1,42 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: munihac2022logo +version: 0.1.0.0 +homepage: https://github.com/quchen/generative-art#readme +bug-reports: https://github.com/quchen/generative-art/issues +author: David Luposchainsky +maintainer: David Luposchainsky +copyright: 2022 David Luposchainsky +license: BSD3 +build-type: Simple + +source-repository head + type: git + location: https://github.com/quchen/generative-art + +executable munihac2022logo + main-is: Main.hs + other-modules: + Circuits.GrowingProcess + Circuits.ReconstructWires + Circuits.Render + Paths_munihac2022logo + hs-source-dirs: + ./ + default-extensions: + LambdaCase + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-type-defaults -O + build-depends: + base + , cairo + , containers + , deepseq + , generative-art + , mwc-random + , parallel + , vector + default-language: Haskell2010 diff --git a/showcases/munihac_2022_logo/package.yaml b/showcases/munihac_2022_logo/package.yaml new file mode 100644 index 000000000..5fa93bd88 --- /dev/null +++ b/showcases/munihac_2022_logo/package.yaml @@ -0,0 +1,27 @@ +name: munihac2022logo +version: 0.1.0.0 +github: quchen/generative-art +license: BSD3 +author: + - David Luposchainsky +copyright: + - 2022 David Luposchainsky + +default-extensions: + - LambdaCase + +dependencies: + - generative-art + - base + - cairo + - containers + - deepseq + - mwc-random + - parallel + - vector + +executables: + munihac2022logo: + main: Main.hs + source-dirs: . + ghc-options: [-threaded, -rtsopts, -with-rtsopts=-N, -Wall, -Wno-type-defaults, -O] diff --git a/showcases/munihac_2022_logo/stack.yaml b/showcases/munihac_2022_logo/stack.yaml new file mode 100644 index 000000000..be0c7697d --- /dev/null +++ b/showcases/munihac_2022_logo/stack.yaml @@ -0,0 +1,11 @@ +flags: {} +packages: + - . +extra-deps: + - git: https://github.com/quchen/generative-art + commit: 3cea78bb902c023216727be16dcf8143bd62f0ae + - Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + - plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + - alfred-margaret-2.1.0.2 +resolver: lts-21.25 +allow-newer: true diff --git a/showcases/munihac_2022_logo/stack.yaml.lock b/showcases/munihac_2022_logo/stack.yaml.lock new file mode 100644 index 000000000..5963a5462 --- /dev/null +++ b/showcases/munihac_2022_logo/stack.yaml.lock @@ -0,0 +1,33 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + pantry-tree: + sha256: 27a9154935b4d30a22830477c60c5108fd713a184d456272c2fccbf361d2395f + size: 1176 + original: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 +- completed: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + pantry-tree: + sha256: 887770effc1578682fe255d7f8b1a9801bc5a6e832aa46316782e43eecb65113 + size: 321 + original: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 +- completed: + hackage: alfred-margaret-2.1.0.2@sha256:2903ce63f9054ec607c03439231cdacd0a3b731febe05f493d073bcb1a8bc1a7,4918 + pantry-tree: + sha256: f747ba440a8a87e433970d07cb1edabac770f111fec0732ee83026cf2bf7286e + size: 1938 + original: + hackage: alfred-margaret-2.1.0.2 +snapshots: +- completed: + sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd + size: 640086 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml + original: lts-21.25 diff --git a/showcases/particle_shooter/Main.hs b/showcases/particle_shooter/Main.hs new file mode 100644 index 000000000..83feaac09 --- /dev/null +++ b/showcases/particle_shooter/Main.hs @@ -0,0 +1,183 @@ +module Main (main) where + +import Control.Monad +import Control.Monad.ST +import Control.Parallel.Strategies +import Data.Foldable +import Data.Ord.Extended +import Data.Vector (Vector) +import qualified Data.Vector as V +import Data.Word +import Graphics.Rendering.Cairo as C +import qualified System.Random.MWC as Random +import qualified System.Random.MWC.Distributions as Random + +import Draw +import Geometry as G +import Numerics.DifferentialEquation +import Numerics.Interpolation +import Numerics.VectorAnalysis + +main :: IO () +main = do + let systemResult = runST (systemSetup systemConfig) + let (w, h) = boundingBoxSize (_boundingBox systemConfig) + render + "out/particle_shooter.png" + (round w) + (round h) + (draw systemResult) + +data SystemConfig s = SystemConfig + { _seed :: V.Vector Word32 + + , _boundingBox :: BoundingBox + + , _numHills :: Int + , _hillLocation :: Random.Gen s -> ST s Vec2 + , _hillCharge :: Random.GenST s -> ST s Double + + , _numParticles :: Int + , _particleMass :: Double + , _particleCharge :: Random.GenST s -> ST s Double + } + +systemConfig :: SystemConfig s +systemConfig = SystemConfig + { _seed = V.fromList [113,5,9,1,39,45] + + , _boundingBox = + let lo = Vec2 0 0 + hi = Vec2 2560 1440 + bb = boundingBox (lo, hi) + center = G.transform (G.inverse (G.translate (boundingBoxCenter bb))) + in center bb + + , _numHills = 5000 + , _hillLocation = \gen -> gaussianVec2 (Vec2 0 0) 1500 gen + , _hillCharge = \_gen -> pure 1 + + , _numParticles = 1000 + , _particleMass = 1 + , _particleCharge = \_gen -> pure 1 + } + +data SystemResult = SystemResult + { _trajectories :: [(Vector (Vec2, Double), (Vec2, Vec2))] + , _potential :: Vec2 -> Double + } + +initializeGen + :: SystemConfig s + -> ST s (Random.Gen s) +initializeGen SystemConfig{..} = do + gen <- Random.initialize _seed + _ <- fmap (\x -> const "Warm up the generator" (x::[Int])) + (replicateM 10000 (Random.uniform gen)) + pure gen + +systemSetup :: SystemConfig s -> ST s SystemResult +systemSetup config@SystemConfig{..} = do + gen <- initializeGen config + + potential <- createPotential config gen + + particles <- do + let mkParticle = do + let x0 = Vec2 0 0 + a <- Random.uniformRM (0, 360) gen + let v0 = polar (deg a) 1 + q <- _particleCharge gen + pure ((x0, v0), q) + replicateM _numParticles mkParticle + + let odeSolutions = + [ (rungeKuttaAdaptiveStep ode ic t0 dt0 toleranceNorm tolerance, ic) + | (ic, charge) <- particles + , let ode _t (x,v) = (v, charge *. negateV (grad potential x) /. _particleMass) + , let t0 = 0 + , let dt0 = 1 + , let tolerance = 1e-2 + , let toleranceNorm (x,v) = sqrt (max (normSquare x) (normSquare v)) + ] + + let trajectoryThunks = flip map odeSolutions $ \(odeSolution, ic) -> + let getTrajectory sol = [(x, norm v) | (_t, (x, v)) <- sol] + timeCutoff = takeWhile (\(t, _) -> t < 3000) + spaceCutoff = takeWhile (\(_t, (x, _v)) -> overlappingBoundingBoxes x _boundingBox) + simplify = simplifyTrajectoryRdpBy 1 (\(x, _v) -> x) + in ((simplify . V.fromList . getTrajectory . timeCutoff . spaceCutoff) odeSolution, ic) + trajectoriesNF = trajectoryThunks `using` parListChunk 64 rdeepseq + + pure SystemResult + { _trajectories = trajectoriesNF + , _potential = potential + } + +draw :: SystemResult -> Render () +draw SystemResult{..} = do + do let BoundingBox (Vec2 x y) _ = _boundingBox systemConfig + C.translate (-x) (-y) + cairoScope $ do + setSourceRGB 1 1 1 + paint + + liftIO (putStrLn "Calculate and paint lines") + setLineWidth 1 + let isoGrid = Grid (let BoundingBox lo hi = _boundingBox systemConfig in (lo, hi)) + (let (w,h) = boundingBoxSize (_boundingBox systemConfig) in (round (w/10), round (h/10))) + isosAt = isoLines isoGrid _potential + isoThresholds = [1.0, 1.05 .. 2.5] + + isosWithThresolds = [(threshold, map (V.toList . bezierSmoothen . simplifyTrajectoryRdp 1 . V.fromList) (isosAt threshold)) | threshold <- isoThresholds] + `using` parList (evalTuple2 r0 rdeepseq) + for_ (zip [1..] isosWithThresolds) $ \(i, (isoThreshold, isos)) -> do + liftIO (putStrLn ("Paint iso line threshold " ++ show i ++ "/" ++ show (length isosWithThresolds) ++ ", threshold = " ++ show isoThreshold)) + for_ isos $ \iso -> cairoScope $ do + sketch (PolyBezier iso) + let colorValue = lerp (minimum isoThresholds, maximum isoThresholds) (0,1) isoThreshold + setColor (rocket colorValue `withOpacity` 0.3) + stroke + + let MinMax minSpeed maxSpeed = foldMap (\(xv, _ic) -> foldMap (\(_x, speed) -> MinMax speed speed) xv) _trajectories + + liftIO (putStrLn "Calculate and paint trajectories") + for_ (zip [1..] _trajectories) $ \(i, (trajectory, _ic)) -> do + when (mod i 100 == 0) (liftIO (putStrLn ("Paint trajectory " ++ show i ++ "/" ++ show (length _trajectories)))) + for_ (V.zip trajectory (V.tail trajectory)) $ \((a, speed), (b, _)) -> cairoScope $ grouped (paintWithAlpha 0.5) $ do + let colorValue = lerp (minSpeed, maxSpeed) (0,1) speed + setColor (mako colorValue `withOpacity` 0.3) + sketch (Line a b) + stroke + +gaussianVec2 + :: Vec2 -- ^ Mean + -> Double -- ^ Standard deviation + -> Random.GenST s + -> ST s Vec2 +gaussianVec2 (Vec2 muX muY) sigma gen = Vec2 <$> Random.normal muX sigma gen <*> Random.normal muY sigma gen + +createPotential + :: SystemConfig s + -> Random.Gen s + -> ST s (Vec2 -> Double) +createPotential SystemConfig{..} gen = do + hills <- do + hills' <- replicateM _numHills $ do + center <- _hillLocation gen + charge <- _hillCharge gen + pure (center, charge) + let removeOutliers = filter (\(center, _) -> overlappingBoundingBoxes center (G.transform (G.scale 1.1) _boundingBox)) + . filter (\(center, _) -> norm center > 70) + pure (V.fromList (removeOutliers hills')) + pure (\p -> sum' (V.map (\(center, charge) -> coulombPotential center charge p) hills)) + +coulombPotential + :: Vec2 -- ^ Center + -> Double -- ^ Charge + -> Vec2 -- ^ Particle location + -> Double -- ^ Magnitude of the potential +coulombPotential center charge p = charge / norm (p -. center) + +sum' :: V.Vector Double -> Double +sum' = foldl' (+) 0 diff --git a/showcases/particle_shooter/package.yaml b/showcases/particle_shooter/package.yaml new file mode 100644 index 000000000..d3a16443a --- /dev/null +++ b/showcases/particle_shooter/package.yaml @@ -0,0 +1,25 @@ +name: particle-shooter +version: 0.1.0.0 +github: quchen/generative-art +license: BSD3 +author: + - David Luposchainsky +copyright: + - 2022 David Luposchainsky + +default-extensions: + - RecordWildCards + +dependencies: + - generative-art + - base + - cairo + - mwc-random + - parallel + - vector + +executables: + particle-shooter: + main: Main.hs + source-dirs: . + ghc-options: [-threaded, -rtsopts, -with-rtsopts=-N, -Wall, -Wno-type-defaults, -O] diff --git a/showcases/particle_shooter/particle-shooter.cabal b/showcases/particle_shooter/particle-shooter.cabal new file mode 100644 index 000000000..d867fe36d --- /dev/null +++ b/showcases/particle_shooter/particle-shooter.cabal @@ -0,0 +1,37 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: particle-shooter +version: 0.1.0.0 +homepage: https://github.com/quchen/generative-art#readme +bug-reports: https://github.com/quchen/generative-art/issues +author: David Luposchainsky +maintainer: David Luposchainsky +copyright: 2022 David Luposchainsky +license: BSD3 +build-type: Simple + +source-repository head + type: git + location: https://github.com/quchen/generative-art + +executable particle-shooter + main-is: Main.hs + other-modules: + Paths_particle_shooter + hs-source-dirs: + ./ + default-extensions: + RecordWildCards + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-type-defaults -O + build-depends: + base + , cairo + , generative-art + , mwc-random + , parallel + , vector + default-language: Haskell2010 diff --git a/showcases/particle_shooter/stack.yaml b/showcases/particle_shooter/stack.yaml new file mode 100644 index 000000000..be0c7697d --- /dev/null +++ b/showcases/particle_shooter/stack.yaml @@ -0,0 +1,11 @@ +flags: {} +packages: + - . +extra-deps: + - git: https://github.com/quchen/generative-art + commit: 3cea78bb902c023216727be16dcf8143bd62f0ae + - Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + - plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + - alfred-margaret-2.1.0.2 +resolver: lts-21.25 +allow-newer: true diff --git a/showcases/particle_shooter/stack.yaml.lock b/showcases/particle_shooter/stack.yaml.lock new file mode 100644 index 000000000..5963a5462 --- /dev/null +++ b/showcases/particle_shooter/stack.yaml.lock @@ -0,0 +1,33 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + pantry-tree: + sha256: 27a9154935b4d30a22830477c60c5108fd713a184d456272c2fccbf361d2395f + size: 1176 + original: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 +- completed: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + pantry-tree: + sha256: 887770effc1578682fe255d7f8b1a9801bc5a6e832aa46316782e43eecb65113 + size: 321 + original: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 +- completed: + hackage: alfred-margaret-2.1.0.2@sha256:2903ce63f9054ec607c03439231cdacd0a3b731febe05f493d073bcb1a8bc1a7,4918 + pantry-tree: + sha256: f747ba440a8a87e433970d07cb1edabac770f111fec0732ee83026cf2bf7286e + size: 1938 + original: + hackage: alfred-margaret-2.1.0.2 +snapshots: +- completed: + sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd + size: 640086 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml + original: lts-21.25 diff --git a/showcases/pulsar/Main.hs b/showcases/pulsar/Main.hs new file mode 100644 index 000000000..121664bf5 --- /dev/null +++ b/showcases/pulsar/Main.hs @@ -0,0 +1,122 @@ +module Main (main) where + + + +import qualified Data.ByteString.Lazy as BSL +import Data.Csv +import Data.Ord.Extended +import Data.Vector (Vector) +import qualified Data.Vector as V +import qualified Data.Vector.Algorithms.Tim as Tim +import Draw +import Geometry as G +import Graphics.Rendering.Cairo as C hiding (x, y) +import Numerics.Interpolation + + + +main :: IO () +main = do + pulsarData <- getPulsarData + let w,h :: Num a => a + w = 600 + h = 800 + + graphHeight = 300 + + resizeToWidth = G.transform (transformBoundingBox pulsarData (Vec2 0 0, Vec2 w graphHeight) (TransformBBSettings FitWidthHeight IgnoreAspect FitAlignCenter)) + + layoutEvenlySpaced space xs = flip V.imap xs $ \i points -> G.transform (G.translate (Vec2 0 (fromIntegral i*space))) points + + layoutEvenlySpacedToCanvasSize = + let go spaceLo spaceHi dataset = + let middle = (spaceLo + spaceHi) / 2 + spaced = layoutEvenlySpaced middle dataset + in case boundingBoxSize spaced of + (_bbW, drawnHeight) + | abs (drawnHeight - h) <= 1e3 -> spaced + | drawnHeight > h -> go spaceLo middle dataset + | otherwise -> go middle spaceHi dataset + in go 0 h + + fitToCanvas geo = G.transform (G.transformBoundingBox geo (zero +. Vec2 0 0, Vec2 w h -. Vec2 0 0) (TransformBBSettings FitWidthHeight IgnoreAspect FitAlignCenter)) geo + + pulsarDataScaled = fitToCanvas (layoutEvenlySpacedToCanvasSize (resizeToWidth pulsarData)) + + drawing = V.iforM_ pulsarDataScaled $ \i signal -> do + cairoScope $ do + sketch (Polyline (V.singleton (Vec2 0 h) <> signal <> V.singleton (Vec2 w h))) + closePath + let colorValue = lerpID (0, length pulsarData-1) (0.2,0.8) i + setColor (inferno colorValue) + fill + cairoScope $ do + setLineWidth 1 + sketch (Polyline signal) + setColor black + stroke + + render "showcases/pulsar_cp1919.svg" w h drawing + -- render "out/pulsar.png" w h $ do + -- cairoScope $ do + -- setColor white + -- paint + -- render + + +getPulsarData :: IO (Vector (Vector Vec2)) +getPulsarData = do + -- Source: https://github.com/coolbutuseless/CP1919 + contents <- BSL.readFile "showcases/pulsar/cp1919.csv" + case decode HasHeader contents of + Left err -> error ("Error loading CSV: " ++ show err) + Right r -> pure (groupLines r) + +groupLines :: Vector (Int, Double, Double) -> Vector (Vector Vec2) +groupLines + = alignOnZero + . rescaleTime + . toVec2 + . alignBaselines + . invertY + . dropLineNumber + . groupByLine + . sortByLineAndTime + where + sortByLineAndTime = sortVecBy (comparing (\(line, _, _) -> line) <> comparing (\(_, t, _) -> t)) + groupByLine = groupVecOn (\(line, _, _) -> line) + dropLineNumber = (fmap.fmap) (\(_line, t, y) -> (t,y)) + invertY = (fmap.fmap) (\(t, y) -> (t, -y)) + alignBaselines = + let yMisalignment xs = + let firstAndLastPoints n = V.take n xs <> V.drop (V.length xs - n) xs + yValues = fmap (\(_, y) -> y) (firstAndLastPoints 3) + in mean yValues + in fmap (\signal -> fmap (\(t, y) -> (t, y - yMisalignment signal)) signal) + toVec2 = (fmap.fmap) (uncurry Vec2) + rescaleTime xs = + let MinMax tMin tMax = (foldMap.foldMap) (\(Vec2 t _) -> MinMax t t) xs + tSignalMin signal = let Vec2 t _ = V.head signal in t + tSignalMax signal = let Vec2 t _ = V.last signal in t + in V.map (\signal -> V.map (\(Vec2 t y) -> Vec2 (lerp (tSignalMin signal, tSignalMax signal) (tMin, tMax) t) y) signal) xs + alignOnZero vec = + let BoundingBox topLeft _bottomRight = boundingBox vec + in G.transform (G.translate (negateV topLeft)) vec + +mean :: Vector Double -> Double +mean vec = sum vec / fromIntegral (length vec) + +sortVecBy :: (a -> a -> Ordering) -> Vector a -> Vector a +sortVecBy cmp vec = V.create $ do + mvec <- V.thaw vec + Tim.sortBy cmp mvec + pure mvec + +groupVecOn :: Ord b => (a -> b) -> Vector a -> Vector (Vector a) +groupVecOn p = V.fromList . go + where + go v = case v V.!? 0 of + Nothing -> [] + Just x -> + let (chunk, rest) = V.span (\y -> p x == p y) v + in chunk : go rest diff --git a/showcases/pulsar/package.yaml b/showcases/pulsar/package.yaml new file mode 100644 index 000000000..63ccd2bd9 --- /dev/null +++ b/showcases/pulsar/package.yaml @@ -0,0 +1,23 @@ +name: pulsar +version: 0.1.0.0 +github: quchen/generative-art +license: BSD3 +author: + - David Luposchainsky +copyright: + - 2022 David Luposchainsky + +dependencies: + - generative-art + - base + - bytestring + - cairo + - cassava + - vector + - vector-algorithms + +executables: + pulsar: + main: Main.hs + source-dirs: . + ghc-options: [-threaded, -rtsopts, -with-rtsopts=-N, -Wall, -Wno-type-defaults, -O] diff --git a/showcases/pulsar/pulsar.cabal b/showcases/pulsar/pulsar.cabal new file mode 100644 index 000000000..b829470cf --- /dev/null +++ b/showcases/pulsar/pulsar.cabal @@ -0,0 +1,36 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: pulsar +version: 0.1.0.0 +homepage: https://github.com/quchen/generative-art#readme +bug-reports: https://github.com/quchen/generative-art/issues +author: David Luposchainsky +maintainer: David Luposchainsky +copyright: 2022 David Luposchainsky +license: BSD3 +build-type: Simple + +source-repository head + type: git + location: https://github.com/quchen/generative-art + +executable pulsar + main-is: Main.hs + other-modules: + Paths_pulsar + hs-source-dirs: + ./ + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-type-defaults -O + build-depends: + base + , bytestring + , cairo + , cassava + , generative-art + , vector + , vector-algorithms + default-language: Haskell2010 diff --git a/showcases/pulsar/stack.yaml b/showcases/pulsar/stack.yaml new file mode 100644 index 000000000..c03bc81fd --- /dev/null +++ b/showcases/pulsar/stack.yaml @@ -0,0 +1,14 @@ +flags: {} +packages: + - . +extra-deps: + - git: https://github.com/quchen/generative-art + commit: 6ac74502f1d55da60513ac7aec458e715dad6c3b + - cairo-0.13.10.0@sha256:388f39af90d50b920cad70612046041a7ffd7f5b60721862c0c797ecddf7e902,4153 + - gtk2hs-buildtools-0.13.8.2@sha256:01c4a6cc3679008bd4caec32b49843acb27a5f48ee2b22484218f097835548f6,5238 + - Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + - data-r-tree-0.6.0@sha256:10a25ef70e6779c3bf5128cd45d033482a370ea07e92ab1c82678675de01d870,3668 + - plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + - alfred-margaret-1.1.1.0@sha256:aeb2f14726e1ee70e542ecfb2a71eb14abda8303d17932bca149401edd76135b,3095 +resolver: lts-18.19 +allow-newer: true diff --git a/showcases/pulsar/stack.yaml.lock b/showcases/pulsar/stack.yaml.lock new file mode 100644 index 000000000..f12ab3146 --- /dev/null +++ b/showcases/pulsar/stack.yaml.lock @@ -0,0 +1,54 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: cairo-0.13.10.0@sha256:388f39af90d50b920cad70612046041a7ffd7f5b60721862c0c797ecddf7e902,4153 + pantry-tree: + sha256: a5d7014b0df2600377d061185b104f755274935554e723e2b7b600b85ffc7ae2 + size: 2831 + original: + hackage: cairo-0.13.10.0@sha256:388f39af90d50b920cad70612046041a7ffd7f5b60721862c0c797ecddf7e902,4153 +- completed: + hackage: gtk2hs-buildtools-0.13.8.2@sha256:01c4a6cc3679008bd4caec32b49843acb27a5f48ee2b22484218f097835548f6,5238 + pantry-tree: + sha256: 1c3b449a69f4bb2d27c09a89e447552a58201a3febf5418e67af0001a0cbb0a7 + size: 3588 + original: + hackage: gtk2hs-buildtools-0.13.8.2@sha256:01c4a6cc3679008bd4caec32b49843acb27a5f48ee2b22484218f097835548f6,5238 +- completed: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + pantry-tree: + sha256: 27a9154935b4d30a22830477c60c5108fd713a184d456272c2fccbf361d2395f + size: 1176 + original: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 +- completed: + hackage: data-r-tree-0.6.0@sha256:10a25ef70e6779c3bf5128cd45d033482a370ea07e92ab1c82678675de01d870,3668 + pantry-tree: + sha256: 057a5a25c6c8fe8e60e62b9522e8f1a8be3e7470bfe44229d1e2712e6851409e + size: 614 + original: + hackage: data-r-tree-0.6.0@sha256:10a25ef70e6779c3bf5128cd45d033482a370ea07e92ab1c82678675de01d870,3668 +- completed: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + pantry-tree: + sha256: 887770effc1578682fe255d7f8b1a9801bc5a6e832aa46316782e43eecb65113 + size: 321 + original: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 +- completed: + hackage: alfred-margaret-1.1.1.0@sha256:aeb2f14726e1ee70e542ecfb2a71eb14abda8303d17932bca149401edd76135b,3095 + pantry-tree: + sha256: 44f6f77280a9984cdf7be9f2bc4804f9ba3809ab60e9a065aabb1ee3f8f92322 + size: 1087 + original: + hackage: alfred-margaret-1.1.1.0@sha256:aeb2f14726e1ee70e542ecfb2a71eb14abda8303d17932bca149401edd76135b,3095 +snapshots: +- completed: + sha256: 32716534fff554b7f90762130fdb985cabf29f157758934dd1c8f3892a646430 + size: 586103 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/19.yaml + original: lts-18.19 diff --git a/showcases/truchet/Main.hs b/showcases/truchet/Main.hs new file mode 100644 index 000000000..cff588386 --- /dev/null +++ b/showcases/truchet/Main.hs @@ -0,0 +1,239 @@ +module Main (main) where + + + +import qualified Data.Map.Strict as M +import Data.Traversable +import qualified Data.Vector as V +import qualified Graphics.Rendering.Cairo as C +import System.Random.MWC + +import Draw +import Geometry +import Geometry.Coordinates.Hexagonal hiding (rotateAround) + + + +picWidth, picHeight :: Num a => a +picWidth = 2560 +picHeight = 1440 + +scaleFactor :: Double +scaleFactor = 0.5 + +cellSize :: Num a => a +cellSize = 32 + +canvasSize :: Num a => a +canvasSize = 8*cellSize + +main :: IO () +main = do + let file = "out/truchet.svg" + scaledWidth = round (scaleFactor * picWidth) + scaledHeight = round (scaleFactor * picHeight) + canvases = concat + [ [ move UR 1 $ move R n hexZero | n <- [-2..1]] + , [ move R n hexZero | n <- [-2..2]] + , [ move DR 1 $ move R n hexZero | n <- [-2..1]] + ] + configurations = zip canvases + [ V.fromList $ allRotations =<< [ mkTile [(L, UL, [1..k]), (UR, R, [1..l]), (DR, DL, [1..m])] | k <- [0..3], l <- [0..3], m <- [0..3], k+l+m >= 7] + , V.fromList $ allRotations $ mkTile [(UL, UR, [1..3]), (R, DR, [1..3]), (DL, L, [1..3])] + , V.fromList [ mkTile [(DL, DR, [1..k]), (DR, R, [1..l]), (R, UR, [1..m]), (UR, UL, [1..n]), (UL, L, [1..o]), (L, DL, [1..p])] | k <- [0..3], l <- [0..3], m <- [0..3], n <- [0..3], o <- [0..3], p <- [0..3], k+l == 3, l+m == 3, m+n == 3, n+o == 3, o+p == 3, p+k == 3 ] + , V.fromList [ mkTile [(DL, DR, [1..k]), (DR, R, [1..l]), (R, UR, [1..m]), (UR, UL, [1..n]), (UL, L, [1..o]), (L, DL, [1..p])] | k <- [1..3], l <- [1..3], m <- [1..3], n <- [1..3], o <- [1..3], p <- [1..3], k+l == 3, l+m == 3, m+n == 3, n+o == 3, o+p == 3, p+k == 3 ] + + , V.singleton $ mkTile [(L, UR, [1..3]), (R, DL, [1..2])] + , tiles1 + , tiles1 <> tiles4 + , V.fromList $ allRotations $ mkTile [(L, UR, [1, 2]), (R, DL, [1, 2])] + , V.singleton $ mkTile [(R, UL, [1,2]), (R, DL, [1])] + + , tiles4 + , tiles5 + , tiles2 <> tiles4 + , V.fromList [ mkTile [(L, R, [1,2]), (UL, UR, [1..3]), (DL, DR, [1..2])] ] + ] + + render file scaledWidth scaledHeight $ do + C.scale scaleFactor scaleFactor + C.translate (picWidth / 2) (picHeight / 2) + cairoScope (setColor backgroundColor >> C.paint) + + for_ configurations $ \(hex, tiles) -> cairoScope $ do + let Vec2 x y = toVec2 canvasSize hex in C.translate x y + + gen <- C.liftIO $ initialize (V.fromList [123, 987]) + tiling <- C.liftIO $ randomTiling tiles gen (hexagonsInRange 5 hexZero) + + let paintOnHexagonalCanvas = do + sketch (hexagon zero (canvasSize - 16)) + C.fillPreserve -- expects the content to be set as source + setColor (colorScheme 9) + C.setLineWidth 8 + C.stroke + drawTiling = do + setColor (blend 0.5 backgroundColor white) + C.paint + for_ (strands tiling) drawStrand + + grouped paintOnHexagonalCanvas drawTiling + +hexagon :: Vec2 -> Double -> Polygon +hexagon origin sideLength = Polygon [ transform (rotateAround origin angle) bottomCorner | angle <- deg <$> [0, 60 .. 360]] + where + bottomCorner = origin +. Vec2 0 sideLength + +colorScheme :: Int -> Color Double +colorScheme = paired + +backgroundColor :: Color Double +backgroundColor = blend 0.5 (colorScheme 8) white + +newtype Tile = Tile (M.Map (Direction, Int) Direction) deriving (Eq, Ord, Show) + +mkTile :: [(Direction, Direction, [Int])] -> Tile +mkTile = Tile . go M.empty + where + go :: M.Map (Direction, Int) Direction -> [(Direction, Direction, [Int])] -> M.Map (Direction, Int) Direction + go m [] = m + go m ((d1, d2, is) : xs) = foldl' (addArc d1 d2) (go m xs) is + addArc :: Direction -> Direction -> M.Map (Direction, Int) Direction -> Int -> M.Map (Direction, Int) Direction + addArc d1 d2 m i = M.insert (d1, arcIndex d1 d2 i) d2 . M.insert (d2, arcIndex d2 d1 i) d1 $ m + arcIndex d1 d2 i = if cyclic d1 d2 then i else 4-i + +cyclic :: Direction -> Direction -> Bool +cyclic d1 d2 + | d1 == reverseDirection d2 = d1 < d2 + | otherwise = (6 + fromEnum d1 - fromEnum d2) `mod` 6 <= 3 + +extractArc :: Tile -> Maybe ((Direction, Int, Direction), Tile) +extractArc (Tile xs) + | M.null xs = Nothing + | otherwise = + let ((d1, i), d2) = M.findMin xs + in Just ((d1, i, d2), deleteArc (Tile xs) (d1, i, d2)) + +findArc :: Tile -> (Direction, Int) -> Maybe ((Direction, Int, Direction), Tile) +findArc (Tile xs) (d1, i) = fmap (\d2 -> ((d1, i, d2), deleteArc (Tile xs) (d1, i, d2))) (M.lookup (d1, i) xs) + +deleteArc :: Tile -> (Direction, Int, Direction) -> Tile +deleteArc (Tile xs) (d1, i, d2) = Tile $ M.delete (d1, i) $ M.delete (d2, 4-i) xs + +tiles1 :: V.Vector Tile +tiles1 = V.fromList $ allRotations =<< + [ mkTile [(L, UR, [1..k]), (R, DL, [1..l])] | k <- [0..3], l <- [0..2], k+l == 5 ] + +tiles2 :: V.Vector Tile +tiles2 = V.fromList $ allRotations =<< + [ mkTile [(L, UL, [1..k]), (UR, R, [1..l]), (DR, DL, [1..m])] | k <- [0..3], l <- [0..3], m <- [0..3], k+l+m == 9] + +tiles4 :: V.Vector Tile +tiles4 = V.fromList $ allRotations =<< + [ mkTile [(L, R, [1..k]), (DL, DR, [1..l]), (UL, UR, [1..m])] | k <- [0..3], l <- [0..2], m <- [0..3], k+m <= 5, k+l+m == 7 ] + +tiles5 :: V.Vector Tile +tiles5 = V.fromList $ allRotations =<< + [ mkTile [(L, R, [1..k]), (DL, DR, [1..l]), (L, UL, [1..m]), (UL, UR, [1..n]), (UR, R, [1..m])] | k <- [0..3], l <- [2..3], m <- [0..3], n <- [0..3], if k == 0 then l == 3 else l == 2, m+n <= 3, k+m <= 3, k+n >= 4, k+n <= 5 ] + +allRotations :: Tile -> [Tile] +allRotations tile = [ rotateTile i tile | i <- [0..6] ] + +rotateTile :: Int -> Tile -> Tile +rotateTile n (Tile xs) = Tile $ M.fromList $ (\((d1, i), d2) -> ((rotateDirection d1, i), rotateDirection d2)) <$> M.toList xs + where + rotateDirection d = toEnum ((fromEnum d + n) `mod` 6) + +type Tiling = M.Map Hex Tile + +randomTiling :: V.Vector Tile -> GenIO -> [Hex] -> IO Tiling +randomTiling baseTiles gen coords = fmap M.fromList $ for coords $ \hex -> do + tile <- randomTile baseTiles gen + pure (hex, tile) + +randomTile :: V.Vector Tile -> GenIO -> IO Tile +randomTile baseTiles = \gen -> do + rnd <- uniformRM (0, countTiles - 1) gen + pure (baseTiles V.! rnd) + where countTiles = V.length baseTiles + +strands :: Tiling -> [[(Hex, (Direction, Int, Direction))]] +strands tiling = case M.lookupMin tiling of + Nothing -> [] + Just (startHex, t) -> case extractArc t of + Nothing -> strands (M.delete startHex tiling) + Just ((d, i, d'), t') -> + let (s, tiling') = strand tiling startHex (d, i) + (s', tiling'') = strand tiling' startHex (d', 4-i) + in (reverseStrand s ++ [(startHex, (d, i, d'))] ++ s') : strands (M.insert startHex t' tiling'') + +strand :: Tiling -> Hex -> (Direction, Int) -> ([(Hex, (Direction, Int, Direction))], Tiling) +strand tiling hex (d, i) = let hex' = move d 1 hex in case M.lookup hex' tiling of + Nothing -> ([], tiling) + Just t -> case findArc t (reverseDirection d, 4-i) of + Nothing -> ([], tiling) + Just ((_, _, d'), t') -> + let (s', tiling') = strand (M.insert hex' t' tiling) hex' (d', i) + in ((hex', (reverseDirection d, 4-i, d')) : s', tiling') + +reverseStrand :: [(Hex, (Direction, Int, Direction))] -> [(Hex, (Direction, Int, Direction))] +reverseStrand = fmap (\(h, (d1, i, d2)) -> (h, (d2, 4-i, d1))) . reverse + +reverseDirection :: Direction -> Direction +reverseDirection d = toEnum ((fromEnum d + 3) `mod` 6) + +drawStrand :: [(Hex, (Direction, Int, Direction))] -> C.Render () +drawStrand [] = pure () +drawStrand xs@((_, (_, n, _)):_) = do + let c = n `mod` 2 + for_ xs $ uncurry drawArc + C.setLineWidth (3/16 * cellSize) + C.setLineCap C.LineCapRound + setColor (colorScheme c) + C.stroke + +drawArc :: Hex -> (Direction, Int, Direction) -> C.Render () +drawArc hex (d1, n, d2) = cairoScope $ do + let i = if cyclic d1 d2 then n else 4-n + sketchArc (fromIntegral i) d1 d2 + where + center = toVec2 cellSize hex + side d = 0.5 *. (center +. nextCenter d) + nextCenter d = toVec2 cellSize (move d 1 hex) + corner d d' = (center +. nextCenter d +. nextCenter d') /. 3 + [down, _lowerLeft, _upperLeft, _up, upperRight, lowerRight] = [ transform (rotate alpha) (Vec2 0 cellSize) | alpha <- deg <$> [0, 60 .. 300] ] + + sketchArc i DR UL = moveToVec ((0.5 - 0.25 * i) *. upperRight +. side UL) >> lineToVec ((0.5 - 0.25 * i) *. upperRight +. side DR) + sketchArc i UR DL = moveToVec ((0.5 - 0.25 * i) *. lowerRight +. side DL) >> lineToVec ((0.5 - 0.25 * i) *. lowerRight +. side UR) + sketchArc i R L = moveToVec ((0.5 - 0.25 * i) *. down +. side L) >> lineToVec ((0.5 - 0.25 * i) *. down +. side R) + sketchArc i UL DR = moveToVec ((0.5 - 0.25 * i) *. upperRight +. side DR) >> lineToVec ((0.5 - 0.25 * i) *. upperRight +. side UL) + sketchArc i DL UR = moveToVec ((0.5 - 0.25 * i) *. lowerRight +. side UR) >> lineToVec ((0.5 - 0.25 * i) *. lowerRight +. side DL) + sketchArc i L R = moveToVec ((0.5 - 0.25 * i) *. down +. side R) >> lineToVec ((0.5 - 0.25 * i) *. down +. side L) + + sketchArc i UR L = arcSketch (nextCenter UL) ((1 + 0.25 * i) * cellSize) (deg 30) (deg 90) + sketchArc i R UL = arcSketch (nextCenter UR) ((1 + 0.25 * i) * cellSize) (deg 90) (deg 150) + sketchArc i DR UR = arcSketch (nextCenter R) ((1 + 0.25 * i) * cellSize) (deg 150) (deg 210) + sketchArc i DL R = arcSketch (nextCenter DR) ((1 + 0.25 * i) * cellSize) (deg 210) (deg 270) + sketchArc i L DR = arcSketch (nextCenter DL) ((1 + 0.25 * i) * cellSize) (deg 270) (deg 330) + sketchArc i UL DL = arcSketch (nextCenter L) ((1 + 0.25 * i) * cellSize) (deg 330) (deg 30) + sketchArc i L UR = arcSketchNegative (nextCenter UL) ((1 + 0.25 * i) * cellSize) (deg 90) (deg 30) + sketchArc i UL R = arcSketchNegative (nextCenter UR) ((1 + 0.25 * i) * cellSize) (deg 150) (deg 90) + sketchArc i UR DR = arcSketchNegative (nextCenter R) ((1 + 0.25 * i) * cellSize) (deg 210) (deg 150) + sketchArc i R DL = arcSketchNegative (nextCenter DR) ((1 + 0.25 * i) * cellSize) (deg 270) (deg 210) + sketchArc i DR L = arcSketchNegative (nextCenter DL) ((1 + 0.25 * i) * cellSize) (deg 330) (deg 270) + sketchArc i DL UL = arcSketchNegative (nextCenter L) ((1 + 0.25 * i) * cellSize) (deg 30) (deg 330) + + sketchArc i UL L = arcSketch (corner L UL) (0.25 * i * cellSize) (deg 330) (deg 90) + sketchArc i UR UL = arcSketch (corner UL UR) (0.25 * i * cellSize) (deg 30) (deg 150) + sketchArc i R UR = arcSketch (corner UR R) (0.25 * i * cellSize) (deg 90) (deg 210) + sketchArc i DR R = arcSketch (corner R DR) (0.25 * i * cellSize) (deg 150) (deg 270) + sketchArc i DL DR = arcSketch (corner DR DL) (0.25 * i * cellSize) (deg 210) (deg 330) + sketchArc i L DL = arcSketch (corner DL L) (0.25 * i * cellSize) (deg 270) (deg 30) + sketchArc i L UL = arcSketchNegative (corner L UL) (0.25 * i * cellSize) (deg 90) (deg 330) + sketchArc i UL UR = arcSketchNegative (corner UL UR) (0.25 * i * cellSize) (deg 150) (deg 30) + sketchArc i UR R = arcSketchNegative (corner UR R) (0.25 * i * cellSize) (deg 210) (deg 90) + sketchArc i R DR = arcSketchNegative (corner R DR) (0.25 * i * cellSize) (deg 270) (deg 150) + sketchArc i DR DL = arcSketchNegative (corner DR DL) (0.25 * i * cellSize) (deg 330) (deg 210) + sketchArc i DL L = arcSketchNegative (corner DL L) (0.25 * i * cellSize) (deg 30) (deg 270) + + sketchArc _ d d' = error ("Illegal tile " ++ show (d, d')) diff --git a/showcases/truchet/package.yaml b/showcases/truchet/package.yaml new file mode 100644 index 000000000..7766ab311 --- /dev/null +++ b/showcases/truchet/package.yaml @@ -0,0 +1,22 @@ +name: truchet +version: 0.1.0.0 +github: quchen/generative-art +license: BSD3 +author: + - Franz Thoma +copyright: + - 2022 Franz Thoma + +dependencies: + - generative-art + - base + - cairo + - containers + - mwc-random + - vector + +executables: + truchet: + main: Main.hs + source-dirs: . + ghc-options: [-threaded, -rtsopts, -with-rtsopts=-N, -Wall, -Wno-type-defaults, -O] diff --git a/showcases/truchet/stack.yaml b/showcases/truchet/stack.yaml new file mode 100644 index 000000000..be0c7697d --- /dev/null +++ b/showcases/truchet/stack.yaml @@ -0,0 +1,11 @@ +flags: {} +packages: + - . +extra-deps: + - git: https://github.com/quchen/generative-art + commit: 3cea78bb902c023216727be16dcf8143bd62f0ae + - Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + - plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + - alfred-margaret-2.1.0.2 +resolver: lts-21.25 +allow-newer: true diff --git a/showcases/truchet/stack.yaml.lock b/showcases/truchet/stack.yaml.lock new file mode 100644 index 000000000..5963a5462 --- /dev/null +++ b/showcases/truchet/stack.yaml.lock @@ -0,0 +1,33 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + pantry-tree: + sha256: 27a9154935b4d30a22830477c60c5108fd713a184d456272c2fccbf361d2395f + size: 1176 + original: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 +- completed: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + pantry-tree: + sha256: 887770effc1578682fe255d7f8b1a9801bc5a6e832aa46316782e43eecb65113 + size: 321 + original: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 +- completed: + hackage: alfred-margaret-2.1.0.2@sha256:2903ce63f9054ec607c03439231cdacd0a3b731febe05f493d073bcb1a8bc1a7,4918 + pantry-tree: + sha256: f747ba440a8a87e433970d07cb1edabac770f111fec0732ee83026cf2bf7286e + size: 1938 + original: + hackage: alfred-margaret-2.1.0.2 +snapshots: +- completed: + sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd + size: 640086 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml + original: lts-21.25 diff --git a/showcases/truchet/truchet.cabal b/showcases/truchet/truchet.cabal new file mode 100644 index 000000000..d841e3b1d --- /dev/null +++ b/showcases/truchet/truchet.cabal @@ -0,0 +1,35 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: truchet +version: 0.1.0.0 +homepage: https://github.com/quchen/generative-art#readme +bug-reports: https://github.com/quchen/generative-art/issues +author: Franz Thoma +maintainer: Franz Thoma +copyright: 2022 Franz Thoma +license: BSD3 +build-type: Simple + +source-repository head + type: git + location: https://github.com/quchen/generative-art + +executable truchet + main-is: Main.hs + other-modules: + Paths_truchet + hs-source-dirs: + ./ + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-type-defaults -O + build-depends: + base + , cairo + , containers + , generative-art + , mwc-random + , vector + default-language: Haskell2010 diff --git a/showcases/truchetti/Main.hs b/showcases/truchetti/Main.hs new file mode 100644 index 000000000..4197237e6 --- /dev/null +++ b/showcases/truchetti/Main.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE DeriveFunctor #-} + +module Main (main) where + + + +import Data.List +import Data.List.Extended +import qualified Data.Map as M +import Data.Traversable +import qualified Data.Vector as V +import Graphics.Rendering.Cairo as C +import System.Random.MWC + +import Draw +import Geometry +import Geometry.Coordinates.Hexagonal + + + +picWidth, picHeight :: Num a => a +picWidth = 2560 +picHeight = 1440 + +scaleFactor :: Double +scaleFactor = 0.5 + +cellSize :: Num a => a +cellSize = 64 + +main :: IO () +main = do + let scaledWidth = round (scaleFactor * picWidth) + scaledHeight = round (scaleFactor * picHeight) + + gen <- initialize (V.fromList [123, 988]) + tiling <- indexStrands <$> randomTiling gen plane + + let drawing = do + C.scale scaleFactor scaleFactor + cairoScope (setColor backgroundColor >> C.paint) + for_ (M.toList tiling) $ \(hex, tile) -> drawTile colorScheme hex tile + + render "out/penplotting-truchetti.png" scaledWidth scaledHeight drawing + render "out/penplotting-truchetti.svg" scaledWidth scaledHeight drawing + +colorScheme :: Int -> Color Double +colorScheme = twilight . (*1.21) . fromIntegral + +backgroundColor :: Color Double +backgroundColor = blend 0.5 (colorScheme 0) white + +plane :: [Hex] +plane = hexagonsInRange 15 origin + where origin = fromVec2 cellSize (Vec2 (picWidth/2) (picHeight/2)) + + +newtype Tile a = Tile [((Direction, Direction), a)] deriving (Eq, Ord, Show, Functor) + +tiles :: V.Vector (Tile ()) +tiles = V.fromList $ nubOrd + [ Tile partialTile + | [d1, d2, d3, d4, d5, d6] <- permutations allDirections + , let fullTile = [((d1, d2), ()), ((d3, d4), ()), ((d5, d6), ())] + , partialTile <- drop 2 $ inits fullTile + ] + where allDirections = [R, UR, UL, L, DL, DR] + +type Tiling a = M.Map Hex (Tile a) + +randomTiling :: GenIO -> [Hex] -> IO (Tiling ()) +randomTiling gen coords = fmap M.fromList $ for coords $ \hex -> do + tile <- randomTile gen + pure (hex, tile) + +randomTile :: GenIO -> IO (Tile ()) +randomTile = \gen -> do + rnd <- uniformRM (0, countTiles - 1) gen + pure (tiles V.! rnd) + where countTiles = V.length tiles + +indexStrands :: Tiling () -> Tiling Int +indexStrands = \tiling -> goStrands 0 (strands tiling) (fmap (fmap (const 0)) tiling) + where + goStrands _ [] t = t + goStrands n (s:ss) t = goStrand n s (goStrands (n+1) ss t) + + goStrand _ [] t = t + goStrand n ((hex, (directions, _)) : xs) t = M.adjust (updateIndex n directions) hex (goStrand n xs t) + + updateIndex n (d1, d2) (Tile xs) = Tile $ flip fmap xs $ \(directions', n') -> if + | (d1, d2) == directions' -> (directions', n) + | (d2, d1) == directions' -> (directions', n) + | otherwise -> (directions', n') + + +strands :: Tiling a -> [[(Hex, ((Direction, Direction), a))]] +strands tiling = case M.lookupMin tiling of + Nothing -> [] + Just (startHex, tile) -> case tile of + Tile [] -> strands (M.delete startHex tiling) + Tile (((d, d'), a):ts) -> + let (s, tiling') = strand tiling startHex d + (s', tiling'') = strand tiling' startHex d' + in (reverse s ++ [(startHex, ((d, d'), a))] ++ s') : strands (M.insert startHex (Tile ts) tiling'') + +strand :: Tiling a -> Hex -> Direction -> ([(Hex, ((Direction, Direction), a))], Tiling a) +strand tiling hex d = let hex' = move d 1 hex in case M.lookup hex' tiling of + Nothing -> ([], tiling) + Just (Tile ds) + | ([((_, d'), a)], ds') <- partition ((== reverseDirection d) . fst . fst) ds -> + let (s', tiling') = strand (M.insert hex' (Tile ds') tiling) hex' d' + in ((hex', ((reverseDirection d, d'), a)) : s', tiling') + | ([((d', _), a)], ds') <- partition ((== reverseDirection d) . snd . fst) ds -> + let (s', tiling') = strand (M.insert hex' (Tile ds') tiling) hex' d' + in ((hex', ((reverseDirection d, d'), a)) : s', tiling') + | otherwise -> ([], tiling) + +reverseDirection :: Direction -> Direction +reverseDirection d = toEnum ((fromEnum d + 3) `mod` 6) + +drawTile :: (Int -> Color Double) -> Hex -> Tile Int -> C.Render () +drawTile colors hex (Tile as) = for_ as $ drawArc colors hex + +drawArc :: (Int -> Color Double) -> Hex -> ((Direction, Direction), Int) -> C.Render () +drawArc colors hex ((d1, d2), i) = cairoScope $ do + sketchArc d1 d2 + C.setLineWidth (cellSize / 2) + setColor (backgroundColor `withOpacity` 0.7) + C.stroke + sketchArc d1 d2 + C.setLineWidth (3/8 * cellSize) + C.setLineCap C.LineCapRound + setColor (colors i) + C.stroke + where + center = toVec2 cellSize hex + side d = 0.5 *. (center +. nextCenter d) + nextCenter d = toVec2 cellSize (move d 1 hex) + corner d d' = (center +. nextCenter d +. nextCenter d') /. 3 + + sketchArc L R = moveToVec (side L) >> lineToVec (side R) + sketchArc UL DR = moveToVec (side UL) >> lineToVec (side DR) + sketchArc UR DL = moveToVec (side DL) >> lineToVec (side UR) + + sketchArc L UR = arcSketch (nextCenter UL) (1.5 * cellSize) (deg 30) (deg 90) + sketchArc UL R = arcSketch (nextCenter UR) (1.5 * cellSize) (deg 90) (deg 150) + sketchArc UR DR = arcSketch (nextCenter R) (1.5 * cellSize) (deg 150) (deg 210) + sketchArc R DL = arcSketch (nextCenter DR) (1.5 * cellSize) (deg 210) (deg 270) + sketchArc DR L = arcSketch (nextCenter DL) (1.5 * cellSize) (deg 270) (deg 330) + sketchArc DL UL = arcSketch (nextCenter L) (1.5 * cellSize) (deg 330) (deg 30) + + sketchArc L UL = arcSketch (corner L UL) (0.5 * cellSize) (deg 330) (deg 90) + sketchArc UL UR = arcSketch (corner UL UR) (0.5 * cellSize) (deg 30) (deg 150) + sketchArc UR R = arcSketch (corner UR R) (0.5 * cellSize) (deg 90) (deg 210) + sketchArc R DR = arcSketch (corner R DR) (0.5 * cellSize) (deg 150) (deg 270) + sketchArc DR DL = arcSketch (corner DR DL) (0.5 * cellSize) (deg 210) (deg 330) + sketchArc DL L = arcSketch (corner DL L) (0.5 * cellSize) (deg 270) (deg 30) + + sketchArc d d' | d == d' = error ("Illegal tile " ++ show (d, d')) + + sketchArc d d' = sketchArc d' d diff --git a/showcases/truchetti/package.yaml b/showcases/truchetti/package.yaml new file mode 100644 index 000000000..6adf7aa20 --- /dev/null +++ b/showcases/truchetti/package.yaml @@ -0,0 +1,25 @@ +name: truchetti +version: 0.1.0.0 +github: quchen/generative-art +license: BSD3 +author: + - Franz Thoma +copyright: + - 2022 Franz Thoma + +default-extensions: + - MultiWayIf + +dependencies: + - generative-art + - base + - cairo + - containers + - mwc-random + - vector + +executables: + truchetti: + main: Main.hs + source-dirs: . + ghc-options: [-threaded, -rtsopts, -with-rtsopts=-N, -Wall, -Wno-type-defaults, -O] diff --git a/showcases/truchetti/stack.yaml b/showcases/truchetti/stack.yaml new file mode 100644 index 000000000..be0c7697d --- /dev/null +++ b/showcases/truchetti/stack.yaml @@ -0,0 +1,11 @@ +flags: {} +packages: + - . +extra-deps: + - git: https://github.com/quchen/generative-art + commit: 3cea78bb902c023216727be16dcf8143bd62f0ae + - Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + - plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + - alfred-margaret-2.1.0.2 +resolver: lts-21.25 +allow-newer: true diff --git a/showcases/truchetti/stack.yaml.lock b/showcases/truchetti/stack.yaml.lock new file mode 100644 index 000000000..5963a5462 --- /dev/null +++ b/showcases/truchetti/stack.yaml.lock @@ -0,0 +1,33 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + pantry-tree: + sha256: 27a9154935b4d30a22830477c60c5108fd713a184d456272c2fccbf361d2395f + size: 1176 + original: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 +- completed: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + pantry-tree: + sha256: 887770effc1578682fe255d7f8b1a9801bc5a6e832aa46316782e43eecb65113 + size: 321 + original: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 +- completed: + hackage: alfred-margaret-2.1.0.2@sha256:2903ce63f9054ec607c03439231cdacd0a3b731febe05f493d073bcb1a8bc1a7,4918 + pantry-tree: + sha256: f747ba440a8a87e433970d07cb1edabac770f111fec0732ee83026cf2bf7286e + size: 1938 + original: + hackage: alfred-margaret-2.1.0.2 +snapshots: +- completed: + sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd + size: 640086 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml + original: lts-21.25 diff --git a/showcases/truchetti/truchetti.cabal b/showcases/truchetti/truchetti.cabal new file mode 100644 index 000000000..69af2d0c7 --- /dev/null +++ b/showcases/truchetti/truchetti.cabal @@ -0,0 +1,37 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: truchetti +version: 0.1.0.0 +homepage: https://github.com/quchen/generative-art#readme +bug-reports: https://github.com/quchen/generative-art/issues +author: Franz Thoma +maintainer: Franz Thoma +copyright: 2022 Franz Thoma +license: BSD3 +build-type: Simple + +source-repository head + type: git + location: https://github.com/quchen/generative-art + +executable truchetti + main-is: Main.hs + other-modules: + Paths_truchetti + hs-source-dirs: + ./ + default-extensions: + MultiWayIf + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-type-defaults -O + build-depends: + base + , cairo + , containers + , generative-art + , mwc-random + , vector + default-language: Haskell2010 diff --git a/showcases/vector_fields/Main.hs b/showcases/vector_fields/Main.hs new file mode 100644 index 000000000..a59fa7331 --- /dev/null +++ b/showcases/vector_fields/Main.hs @@ -0,0 +1,94 @@ +module Main (main) where + + + +import Control.Monad +import Graphics.Rendering.Cairo as C hiding (x, y) +import System.Random.MWC +import System.Random.MWC.Distributions + +import Draw +import Geometry as G +import Geometry.Algorithms.PerlinNoise +import qualified Geometry.Processes.FlowField as ODE +import Numerics.DifferentialEquation +import Numerics.Functions +import Numerics.VectorAnalysis + + + +picWidth, picHeight :: Num a => a +picWidth = 600 +picHeight = 400 + +-- Higher values yield lower-frequency noise +noiseScale :: Double +noiseScale = 0.5 * min picWidth picHeight + +noiseSeed :: Int +noiseSeed = 519496 + +main :: IO () +main = render "out/vector_fields.png" picWidth picHeight $ do + cairoScope $ do + setColor white + C.paint + + gen <- liftIO create + let startPoints = [Vec2 0 y | y <- [-50..picHeight+50]] + + cairoScope $ for_ startPoints $ \startPoint -> do + thickness <- liftIO (uniformR (0.1, 1.0) gen) + setLineWidth thickness + colorValue <- liftIO $ do + let Vec2 _ y = startPoint + normal (y/picHeight) 0.3 gen + setColor (rocket colorValue) + let trajectory = + takeWhile + (\(t, pos) -> t <= 1600 && pos `insideBoundingBox` (Vec2 (-50) (-50), Vec2 (picWidth+50) (picHeight+50))) + (fieldLine velocityField startPoint) + drawFieldLine trajectory + +drawFieldLine :: [(Double, Vec2)] -> Render () +drawFieldLine ps = cairoScope $ do + let polyLine = map snd ps + simplified = simplifyTrajectoryRadial 3 polyLine + when (not (null (drop 2 simplified))) $ do + sketch (PolyBezier (bezierSmoothen simplified)) + stroke + +-- 2D vector potential, which in 2D is umm well a scalar potential. +vectorPotential :: Vec2 -> Double +vectorPotential p = noiseScale *. perlin2 params p + where + params = PerlinParameters + { _perlinFrequency = 3/noiseScale + , _perlinLacunarity = 2 + , _perlinOctaves = 1 + , _perlinPersistence = 0.5 + , _perlinSeed = noiseSeed + } + +rotationField :: Vec2 -> Vec2 +rotationField = curlZ vectorPotential + +velocityField :: Vec2 -> Vec2 +velocityField p@(Vec2 x y) = Vec2 1 0 +. perturbationStrength *. rotationField p + where + perturbationStrength = + 1.4 + * logisticRamp (0.6*picWidth) (picWidth/6) x + * gaussianFalloff (0.5*picHeight) (0.4*picHeight) y + +fieldLine + :: (Vec2 -> Vec2) + -> Vec2 + -> [(Double, Vec2)] +fieldLine f p0 = rungeKuttaAdaptiveStep (ODE.fieldLine f) p0 t0 dt0 tolNorm tol + where + t0 = 0 + dt0 = 1 + -- Decrease exponent for more accurate results + tol = 1e-2 + tolNorm = norm diff --git a/showcases/vector_fields/package.yaml b/showcases/vector_fields/package.yaml new file mode 100644 index 000000000..98b5e203a --- /dev/null +++ b/showcases/vector_fields/package.yaml @@ -0,0 +1,22 @@ +name: vector-fields +version: 0.1.0.0 +github: quchen/generative-art +license: BSD3 +author: + - Franz Thoma + - David Luposchainsky +copyright: + - 2022 Franz Thoma + - 2022 David Luposchainsky + +dependencies: + - generative-art + - base + - cairo + - mwc-random + +executables: + vector-fields: + main: Main.hs + source-dirs: . + ghc-options: [-threaded, -rtsopts, -with-rtsopts=-N, -Wall, -Wno-type-defaults, -O] diff --git a/showcases/vector_fields/stack.yaml b/showcases/vector_fields/stack.yaml new file mode 100644 index 000000000..be0c7697d --- /dev/null +++ b/showcases/vector_fields/stack.yaml @@ -0,0 +1,11 @@ +flags: {} +packages: + - . +extra-deps: + - git: https://github.com/quchen/generative-art + commit: 3cea78bb902c023216727be16dcf8143bd62f0ae + - Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + - plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + - alfred-margaret-2.1.0.2 +resolver: lts-21.25 +allow-newer: true diff --git a/showcases/vector_fields/stack.yaml.lock b/showcases/vector_fields/stack.yaml.lock new file mode 100644 index 000000000..5963a5462 --- /dev/null +++ b/showcases/vector_fields/stack.yaml.lock @@ -0,0 +1,33 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + pantry-tree: + sha256: 27a9154935b4d30a22830477c60c5108fd713a184d456272c2fccbf361d2395f + size: 1176 + original: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 +- completed: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + pantry-tree: + sha256: 887770effc1578682fe255d7f8b1a9801bc5a6e832aa46316782e43eecb65113 + size: 321 + original: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 +- completed: + hackage: alfred-margaret-2.1.0.2@sha256:2903ce63f9054ec607c03439231cdacd0a3b731febe05f493d073bcb1a8bc1a7,4918 + pantry-tree: + sha256: f747ba440a8a87e433970d07cb1edabac770f111fec0732ee83026cf2bf7286e + size: 1938 + original: + hackage: alfred-margaret-2.1.0.2 +snapshots: +- completed: + sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd + size: 640086 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml + original: lts-21.25 diff --git a/showcases/vector_fields/vector-fields.cabal b/showcases/vector_fields/vector-fields.cabal new file mode 100644 index 000000000..a1684f0d8 --- /dev/null +++ b/showcases/vector_fields/vector-fields.cabal @@ -0,0 +1,36 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: vector-fields +version: 0.1.0.0 +homepage: https://github.com/quchen/generative-art#readme +bug-reports: https://github.com/quchen/generative-art/issues +author: Franz Thoma, + David Luposchainsky +maintainer: Franz Thoma, + David Luposchainsky +copyright: 2022 Franz Thoma, + 2022 David Luposchainsky +license: BSD3 +build-type: Simple + +source-repository head + type: git + location: https://github.com/quchen/generative-art + +executable vector-fields + main-is: Main.hs + other-modules: + Paths_vector_fields + hs-source-dirs: + ./ + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-type-defaults -O + build-depends: + base + , cairo + , generative-art + , mwc-random + default-language: Haskell2010 diff --git a/showcases/voronoi_3d/Main.hs b/showcases/voronoi_3d/Main.hs new file mode 100644 index 000000000..768b5c099 --- /dev/null +++ b/showcases/voronoi_3d/Main.hs @@ -0,0 +1,120 @@ +module Main (main) where + + + +import Data.List +import Data.Maybe +import Data.Ord +import qualified Data.Vector as V +import Graphics.Rendering.Cairo as C hiding (height, width, x, y) +import Math.Noise (Perlin (..), getValue, perlin) +import Prelude hiding ((**)) +import System.Random.MWC + +import Draw +import Geometry as G +import Geometry.Algorithms.Delaunay +import Geometry.Algorithms.Sampling +import Geometry.Algorithms.Voronoi + + + +picWidth, picHeight :: Num a => a +picWidth = 2560 +picHeight = 1440 + +scaleFactor :: Double +scaleFactor = 1 + +main :: IO () +main = do + let file = "out/voronoi_3d.svg" + count = 500 + scaledWidth = round (scaleFactor * picWidth) + scaledHeight = round (scaleFactor * picHeight) + + gen <- initialize (V.fromList [12, 984, 498, 498, 626, 15, 165]) + let -- constructed so that we have roughly `count` points + adaptiveRadius = 1440 * sqrt (0.75 / count) + samplingProps = PoissonDiscParams + { _poissonShape = boundingBox [zero, Vec2 1440 1440] + , _poissonRadius = adaptiveRadius + , _poissonK = 4 + } + + points <- poissonDisc gen samplingProps + print (length points) + let voronoi = toVoronoi (lloydRelaxation 4 (bowyerWatson (BoundingBox (Vec2 0 0) (Vec2 1440 1440)) points)) + voronoiWithProps = mapWithMetadata (\p _ _ -> (randomColor p, randomHeight p)) voronoi + origin = Vec2 (picWidth/2) (picHeight/2) + voronoiCells = sortOn ((\(Polygon ps) -> minimum (yCoordinate <$> ps)) . fst) $ + ( \c -> + ( G.transform + ( G.translate (Vec2 0 (picHeight/5)) + <> G.scaleAround' origin 1 0.35 + <> G.rotateAround origin (deg 45) + <> G.translate (Vec2 560 0 ) + <> G.scaleAround (_voronoiSeed c) 0.9 ) + (_voronoiRegion c) + , _voronoiProps c) ) + <$> _voronoiCells voronoiWithProps + + render file scaledWidth scaledHeight $ do + cairoScope (setColor (magma 0.05) >> paint) + for_ voronoiCells $ uncurry drawCell + +randomHeight :: Vec2 -> Double +randomHeight = \p -> 300 + 400 * noise2d p + 200 * exp(- 0.000005 * normSquare (p -. origin)) + where + noise = perlin { perlinOctaves = 4, perlinFrequency = 0.001, perlinSeed = 1980166 } + noise2d (Vec2 x y) = fromMaybe 0 $ getValue noise (x, y, 0) + origin = Vec2 720 720 + +randomColor :: Vec2 -> Color Double +randomColor = \p -> inferno (0.6 + 0.35 * noise2d p) + where + noise = perlin { perlinOctaves = 5, perlinFrequency = 0.001, perlinPersistence = 0.65, perlinSeed = 1980166 } + noise2d (Vec2 x y) = fromMaybe 0 $ getValue noise (x, y, 0) + +drawCell :: Polygon -> (Color Double, Double) -> Render () +drawCell (Polygon []) _ = pure () +drawCell poly@(Polygon ps) (color, height) = cairoScope $ do + let lineColor = blend 0.95 color white + sideColor = blend 0.1 (color `withOpacity` 0.8) (black `withOpacity` 0.3) + topColor = blend 0.7 (color `withOpacity` 0.8) (black `withOpacity` 0.3) + + C.setLineJoin C.LineJoinBevel + + for_ (zip normalizedPoints (drop 1 (cycle normalizedPoints))) $ \(p, q) -> cairoScope $ do + moveToVec p + lineToVec q + lineToVec (G.transform (G.translate (Vec2 0 (-height))) q) + lineToVec (G.transform (G.translate (Vec2 0 (-height))) p) + setColor (dissolve 0.8 sideColor) + fillPreserve + setColor lineColor + setLineWidth 2 + stroke + + cairoScope $ do + C.translate 0 (-height) + sketch poly + setColor topColor + fillPreserve + setColor lineColor + setLineWidth 2 + stroke + + where + leftmost = minimumBy (comparing xCoordinate) ps + normalizedPoints = rotateUntil (== leftmost) ps + +rotateUntil :: (a -> Bool) -> [a] -> [a] +rotateUntil p xs = zipWith + (flip const) + xs + (dropWhile (not . p) (cycle xs)) + +xCoordinate, yCoordinate :: Vec2 -> Double +xCoordinate (Vec2 x _) = x +yCoordinate (Vec2 _ y) = y diff --git a/showcases/voronoi_3d/package.yaml b/showcases/voronoi_3d/package.yaml new file mode 100644 index 000000000..4c8de07be --- /dev/null +++ b/showcases/voronoi_3d/package.yaml @@ -0,0 +1,20 @@ +name: voronoi-3d +version: 0.1.0.0 +github: quchen/generative-art +license: BSD3 +author: Franz Thoma +copyright: "2022 Franz Thoma" + +dependencies: + - generative-art + - base + - cairo + - mwc-random + - Noise + - vector + +executables: + voronoi-3d: + main: Main.hs + source-dirs: . + ghc-options: [-threaded, -rtsopts, -with-rtsopts=-N, -Wall, -Wno-type-defaults, -O] diff --git a/showcases/voronoi_3d/stack.yaml b/showcases/voronoi_3d/stack.yaml new file mode 100644 index 000000000..c03bc81fd --- /dev/null +++ b/showcases/voronoi_3d/stack.yaml @@ -0,0 +1,14 @@ +flags: {} +packages: + - . +extra-deps: + - git: https://github.com/quchen/generative-art + commit: 6ac74502f1d55da60513ac7aec458e715dad6c3b + - cairo-0.13.10.0@sha256:388f39af90d50b920cad70612046041a7ffd7f5b60721862c0c797ecddf7e902,4153 + - gtk2hs-buildtools-0.13.8.2@sha256:01c4a6cc3679008bd4caec32b49843acb27a5f48ee2b22484218f097835548f6,5238 + - Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + - data-r-tree-0.6.0@sha256:10a25ef70e6779c3bf5128cd45d033482a370ea07e92ab1c82678675de01d870,3668 + - plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + - alfred-margaret-1.1.1.0@sha256:aeb2f14726e1ee70e542ecfb2a71eb14abda8303d17932bca149401edd76135b,3095 +resolver: lts-18.19 +allow-newer: true diff --git a/showcases/voronoi_3d/stack.yaml.lock b/showcases/voronoi_3d/stack.yaml.lock new file mode 100644 index 000000000..f12ab3146 --- /dev/null +++ b/showcases/voronoi_3d/stack.yaml.lock @@ -0,0 +1,54 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: cairo-0.13.10.0@sha256:388f39af90d50b920cad70612046041a7ffd7f5b60721862c0c797ecddf7e902,4153 + pantry-tree: + sha256: a5d7014b0df2600377d061185b104f755274935554e723e2b7b600b85ffc7ae2 + size: 2831 + original: + hackage: cairo-0.13.10.0@sha256:388f39af90d50b920cad70612046041a7ffd7f5b60721862c0c797ecddf7e902,4153 +- completed: + hackage: gtk2hs-buildtools-0.13.8.2@sha256:01c4a6cc3679008bd4caec32b49843acb27a5f48ee2b22484218f097835548f6,5238 + pantry-tree: + sha256: 1c3b449a69f4bb2d27c09a89e447552a58201a3febf5418e67af0001a0cbb0a7 + size: 3588 + original: + hackage: gtk2hs-buildtools-0.13.8.2@sha256:01c4a6cc3679008bd4caec32b49843acb27a5f48ee2b22484218f097835548f6,5238 +- completed: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 + pantry-tree: + sha256: 27a9154935b4d30a22830477c60c5108fd713a184d456272c2fccbf361d2395f + size: 1176 + original: + hackage: Noise-1.0.6@sha256:7eb0d021e334ca2341a9cb51eac7d6f2c76b4e4e1a27264509b38264dc202b32,1994 +- completed: + hackage: data-r-tree-0.6.0@sha256:10a25ef70e6779c3bf5128cd45d033482a370ea07e92ab1c82678675de01d870,3668 + pantry-tree: + sha256: 057a5a25c6c8fe8e60e62b9522e8f1a8be3e7470bfe44229d1e2712e6851409e + size: 614 + original: + hackage: data-r-tree-0.6.0@sha256:10a25ef70e6779c3bf5128cd45d033482a370ea07e92ab1c82678675de01d870,3668 +- completed: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 + pantry-tree: + sha256: 887770effc1578682fe255d7f8b1a9801bc5a6e832aa46316782e43eecb65113 + size: 321 + original: + hackage: plotfont-0.1.0.1@sha256:e3b2507c6350feee8ff5a612a0ac3f5a7e8f39efb2895fbca70c0220834652a4,1155 +- completed: + hackage: alfred-margaret-1.1.1.0@sha256:aeb2f14726e1ee70e542ecfb2a71eb14abda8303d17932bca149401edd76135b,3095 + pantry-tree: + sha256: 44f6f77280a9984cdf7be9f2bc4804f9ba3809ab60e9a065aabb1ee3f8f92322 + size: 1087 + original: + hackage: alfred-margaret-1.1.1.0@sha256:aeb2f14726e1ee70e542ecfb2a71eb14abda8303d17932bca149401edd76135b,3095 +snapshots: +- completed: + sha256: 32716534fff554b7f90762130fdb985cabf29f157758934dd1c8f3892a646430 + size: 586103 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/19.yaml + original: lts-18.19 diff --git a/showcases/voronoi_3d/voronoi-3d.cabal b/showcases/voronoi_3d/voronoi-3d.cabal new file mode 100644 index 000000000..0da6d78a5 --- /dev/null +++ b/showcases/voronoi_3d/voronoi-3d.cabal @@ -0,0 +1,35 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.37.0. +-- +-- see: https://github.com/sol/hpack + +name: voronoi-3d +version: 0.1.0.0 +homepage: https://github.com/quchen/generative-art#readme +bug-reports: https://github.com/quchen/generative-art/issues +author: Franz Thoma +maintainer: Franz Thoma +copyright: 2022 Franz Thoma +license: BSD3 +build-type: Simple + +source-repository head + type: git + location: https://github.com/quchen/generative-art + +executable voronoi-3d + main-is: Main.hs + other-modules: + Paths_voronoi_3d + hs-source-dirs: + ./ + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wno-type-defaults -O + build-depends: + Noise + , base + , cairo + , generative-art + , mwc-random + , vector + default-language: Haskell2010