├── .gitignore ├── Geometry.cabal ├── LICENSE ├── README.md ├── Setup.hs ├── app └── Main.hs ├── squarelimit1.png ├── squarelimit2.png ├── squarelimit3.png ├── squarelimit4.png ├── src └── Geometry.hs ├── stack.yaml └── test └── Spec.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | -------------------------------------------------------------------------------- /Geometry.cabal: -------------------------------------------------------------------------------- 1 | name: Geometry 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | homepage: https://github.com/githubuser/Geometry#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Author name here 9 | maintainer: example@example.com 10 | copyright: 2017 Author name here 11 | category: Web 12 | build-type: Simple 13 | extra-source-files: README.md 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: Geometry 19 | build-depends: base >= 4.7 && < 5 20 | , Rasterific 21 | default-language: Haskell2010 22 | 23 | executable Geometry-exe 24 | hs-source-dirs: app 25 | main-is: Main.hs 26 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 27 | build-depends: base 28 | , Geometry 29 | , Rasterific 30 | , JuicyPixels 31 | default-language: Haskell2010 32 | 33 | test-suite Geometry-test 34 | type: exitcode-stdio-1.0 35 | hs-source-dirs: test 36 | main-is: Spec.hs 37 | build-depends: base 38 | , Geometry 39 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 40 | default-language: Haskell2010 41 | 42 | source-repository head 43 | type: git 44 | location: https://github.com/githubuser/Geometry 45 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2017 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # FunctionalGeometry 2 | 3 | A simple Haskell implementation of the algebra of pictures outlined in Peter Henderson's [Functional Geometry](http://eprints.soton.ac.uk/257577/1/funcgeo2.pdf). 4 | 5 | ## Sample generated images: 6 | 7 | ### Square Limit (n = 1): 8 | ![Square Limit (n = 1)](squarelimit1.png?raw=true "Square Limit (n = 1)") 9 | 10 | ### Square Limit (n = 2): 11 | ![Square Limit (n = 2)](squarelimit2.png?raw=true "Square Limit (n = 2)") 12 | 13 | ### Square Limit (n = 3): 14 | ![Square Limit (n = 3)](squarelimit3.png?raw=true "Square Limit (n = 3)") 15 | 16 | ### Square Limit (n = 4): 17 | ![Square Limit (n = 4)](squarelimit4.png?raw=true "Square Limit (n = 4)") 18 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Codec.Picture( PixelRGBA8( .. ), writePng ) 4 | import Graphics.Rasterific 5 | import Graphics.Rasterific.Texture 6 | 7 | import Geometry as G 8 | import Control.Monad as M 9 | 10 | main :: IO () 11 | main = do 12 | let white = PixelRGBA8 255 255 255 255 13 | black = PixelRGBA8 0 0 0 255 14 | img = renderDrawing 1000 1000 white $ 15 | withTexture (uniformTexture black) $ do 16 | mconcat $ fmap (\b -> stroke 1 JoinRound (CapRound, CapRound) b) G.scaledImage 17 | 18 | writePng "test.png" img -------------------------------------------------------------------------------- /squarelimit1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/micahhahn/FunctionalGeometry/b5fcaea9f82b2fca90659f5b2bbf9954e9901641/squarelimit1.png -------------------------------------------------------------------------------- /squarelimit2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/micahhahn/FunctionalGeometry/b5fcaea9f82b2fca90659f5b2bbf9954e9901641/squarelimit2.png -------------------------------------------------------------------------------- /squarelimit3.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/micahhahn/FunctionalGeometry/b5fcaea9f82b2fca90659f5b2bbf9954e9901641/squarelimit3.png -------------------------------------------------------------------------------- /squarelimit4.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/micahhahn/FunctionalGeometry/b5fcaea9f82b2fca90659f5b2bbf9954e9901641/squarelimit4.png -------------------------------------------------------------------------------- /src/Geometry.hs: -------------------------------------------------------------------------------- 1 | module Geometry 2 | ( Image (..) 3 | , scaledImage 4 | ) where 5 | 6 | import Prelude hiding (flip, cycle) 7 | import Graphics.Rasterific 8 | 9 | type Image = [CubicBezier] 10 | 11 | applyB f (CubicBezier p1 p2 p3 p4) = CubicBezier (f p1) (f p2) (f p3) (f p4) 12 | 13 | applyI :: (Point -> Point) -> Image -> Image 14 | applyI f = fmap (applyB f) 15 | 16 | flip :: Image -> Image 17 | flip = applyI (\(V2 x y) -> V2 (1.0 - x) y) 18 | 19 | besideS :: Float -> Float -> Image -> Image -> Image 20 | besideS lr rr l r = sl ++ sr 21 | where sl = applyI (\(V2 x y) -> V2 (x * lr) y) l 22 | sr = applyI (\(V2 x y) -> V2 (x * rr + lr) y) r 23 | 24 | beside :: Image -> Image -> Image 25 | beside = besideS 0.5 0.5 26 | 27 | aboveS :: Float -> Float -> Image -> Image -> Image 28 | aboveS tr br t b = st ++ sb 29 | where st = applyI (\(V2 x y) -> V2 x (y * tr)) t 30 | sb = applyI (\(V2 x y) -> V2 x (y * br + tr)) b 31 | 32 | above :: Image -> Image -> Image 33 | above = aboveS 0.5 0.5 34 | 35 | rot :: Image -> Image 36 | rot = applyI (\(V2 x y) -> V2 y (1.0 - x)) 37 | 38 | rot45 :: Image -> Image 39 | rot45 = applyI (\(V2 x y) -> V2 ((x + y) / 2) ((y - x) / 2)) 40 | 41 | over :: Image -> Image -> Image 42 | over i1 i2 = i1 ++ i2 43 | 44 | quartet :: Image -> Image -> Image -> Image -> Image 45 | quartet p q r s = above (beside p q) (beside r s) 46 | 47 | cycle :: Image -> Image 48 | cycle i = quartet (rot i) i (rot (rot i)) (rot (rot (rot i))) 49 | 50 | blank = [] :: Image 51 | 52 | fish = [ (CubicBezier (V2 0.00 0.00) (V2 0.08 0.02) (V2 0.22 0.18) (V2 0.29 0.28)) 53 | , (CubicBezier (V2 0.29 0.28) (V2 0.30 0.36) (V2 0.29 0.43) (V2 0.30 0.50)) 54 | , (CubicBezier (V2 0.30 0.50) (V2 0.34 0.60) (V2 0.43 0.68) (V2 0.50 0.74)) 55 | , (CubicBezier (V2 0.50 0.74) (V2 0.58 0.79) (V2 0.66 0.78) (V2 0.76 0.80)) 56 | , (CubicBezier (V2 0.76 0.80) (V2 0.82 0.88) (V2 0.94 0.95) (V2 1.00 1.00)) 57 | , (CubicBezier (V2 1.00 1.00) (V2 0.90 0.97) (V2 0.81 0.96) (V2 0.76 0.95)) 58 | , (CubicBezier (V2 0.76 0.95) (V2 0.69 0.96) (V2 0.62 0.96) (V2 0.55 0.96)) 59 | , (CubicBezier (V2 0.55 0.96) (V2 0.49 0.90) (V2 0.40 0.83) (V2 0.35 0.80)) 60 | , (CubicBezier (V2 0.35 0.80) (V2 0.29 0.76) (V2 0.19 0.72) (V2 0.14 0.69)) 61 | , (CubicBezier (V2 0.14 0.69) (V2 0.09 0.65) (V2 (-0.03) 0.57) (V2 (-0.05) 0.28)) 62 | , (CubicBezier (V2 (-0.05) 0.28) (V2 (-0.04) 0.18) (V2 (-0.02) 0.05) (V2 0.00 0.00)) 63 | 64 | , (CubicBezier (V2 0.10 0.15) (V2 0.14 0.18) (V2 0.18 0.22) (V2 0.18 0.25)) 65 | , (CubicBezier (V2 0.18 0.25) (V2 0.16 0.26) (V2 0.14 0.27) (V2 0.12 0.27)) 66 | , (CubicBezier (V2 0.12 0.27) (V2 0.11 0.23) (V2 0.11 0.19) (V2 0.10 0.15)) 67 | 68 | , (CubicBezier (V2 0.05 0.18) (V2 0.10 0.20) (V2 0.08 0.26) (V2 0.09 0.30)) 69 | , (CubicBezier (V2 0.09 0.30) (V2 0.07 0.32) (V2 0.06 0.34) (V2 0.04 0.33)) 70 | , (CubicBezier (V2 0.04 0.33) (V2 0.04 0.27) (V2 0.04 0.19) (V2 0.05 0.18)) 71 | 72 | , (CubicBezier (V2 0.11 0.30) (V2 0.16 0.44) (V2 0.24 0.61) (V2 0.30 0.66)) 73 | , (CubicBezier (V2 0.30 0.66) (V2 0.41 0.78) (V2 0.62 0.84) (V2 0.80 0.92)) 74 | 75 | , (CubicBezier (V2 0.23 0.20) (V2 0.35 0.20) (V2 0.44 0.22) (V2 0.50 0.25)) 76 | , (CubicBezier (V2 0.50 0.25) (V2 0.50 0.33) (V2 0.50 0.41) (V2 0.50 0.49)) 77 | , (CubicBezier (V2 0.50 0.49) (V2 0.46 0.53) (V2 0.42 0.57) (V2 0.38 0.61)) 78 | 79 | , (CubicBezier (V2 0.29 0.29) (V2 0.36 0.26) (V2 0.43 0.27) (V2 0.48 0.31)) 80 | 81 | , (CubicBezier (V2 0.34 0.39) (V2 0.38 0.34) (V2 0.44 0.36) (V2 0.48 0.37)) 82 | 83 | , (CubicBezier (V2 0.34 0.49) (V2 0.38 0.44) (V2 0.41 0.42) (V2 0.48 0.43)) 84 | 85 | , (CubicBezier (V2 0.45 0.58) (V2 0.46 0.60) (V2 0.47 0.61) (V2 0.48 0.61)) 86 | 87 | , (CubicBezier (V2 0.42 0.61) (V2 0.43 0.64) (V2 0.46 0.68) (V2 0.48 0.67)) 88 | 89 | , (CubicBezier (V2 0.25 0.74) (V2 0.17 0.83) (V2 0.08 0.91) (V2 0.00 0.99)) 90 | , (CubicBezier (V2 0.00 0.99) (V2 (-0.08) 0.91) (V2 (-0.17) 0.82) (V2 (-0.25) 0.74)) 91 | , (CubicBezier (V2 (-0.25) 0.74) (V2 (-0.20) 0.63) (V2 (-0.11) 0.53) (V2 (-0.03) 0.43)) 92 | 93 | , (CubicBezier (V2 (-0.17) 0.74) (V2 (-0.13) 0.66) (V2 (-0.08) 0.60) (V2 (-0.01) 0.56)) 94 | 95 | , (CubicBezier (V2 (-0.12) 0.79) (V2 (-0.07) 0.71) (V2 (-0.02) 0.66) (V2 0.05 0.60)) 96 | 97 | , (CubicBezier (V2 (-0.06) 0.86) (V2 (-0.03) 0.77) (V2 0.03 0.72) (V2 0.10 0.66)) 98 | 99 | , (CubicBezier (V2 (-0.02) 0.92) (V2 0.02 0.84) (V2 0.09 0.77) (V2 0.16 0.70)) 100 | ] 101 | 102 | testImage = [(CubicBezier (V2 0 0) (V2 1 0) (V2 0 1) (V2 1 1))] 103 | baseImage = beside testImage (flip testImage) 104 | 105 | 106 | scale s = applyI (\(V2 x y) -> V2 (x * s) (y * s)) 107 | 108 | fish2 = flip $ rot45 fish 109 | fish3 = rot $ rot $ rot fish2 110 | t = over fish (over fish2 fish3) 111 | u = over (over fish2 (rot fish2)) (over (rot (rot fish2)) (rot (rot (rot fish2)))) 112 | 113 | side 0 = blank 114 | side n = quartet (side (n-1)) (side (n-1)) (rot t) t 115 | 116 | corner 0 = blank 117 | corner n = quartet (corner (n-1)) (side (n-1)) (rot (side (n-1))) u 118 | 119 | nonet p q r s t u v w x = aboveS 0.34 0.66 (besideS 0.34 0.66 p (beside q r)) (above (besideS 0.34 0.66 s (beside t u)) (besideS 0.34 0.66 v (beside w x))) 120 | 121 | squarelimit n = nonet (corner n) (side n) (rot $ rot $ rot $ corner n) (rot $ side n) u (rot $ rot $ rot $ side n) (rot $ corner n) (rot $ rot $ side n) (rot $ rot $ corner n) 122 | 123 | scaledImage = scale 1000 $ squarelimit 3 -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-8.2 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.1" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | --------------------------------------------------------------------------------