├── .github ├── FUNDING.yml └── workflows │ ├── ci.dhall │ ├── ci.sh │ └── ci.yaml ├── .gitignore ├── CHANGELOG.md ├── CONTRIBUTORS ├── Examples ├── example1.scad ├── example10.escad ├── example11.hs ├── example12.hs ├── example13-e.escad ├── example13.hs ├── example14.escad ├── example15.scad ├── example16.hs ├── example17.hs ├── example18.escad ├── example19.escad ├── example2.escad ├── example20.escad ├── example21.scad ├── example22.escad ├── example23.escad ├── example24.escad ├── example25.escad ├── example3.escad ├── example4.escad ├── example5.escad ├── example6.escad ├── example7.escad ├── example8.escad ├── example9.escad └── exampleMultmatrix.scad ├── Graphics ├── Implicit.hs └── Implicit │ ├── Canon.hs │ ├── Definitions.hs │ ├── Export.hs │ ├── Export │ ├── DiscreteAproxable.hs │ ├── NormedTriangleMeshFormats.hs │ ├── OutputFormat.hs │ ├── PolylineFormats.hs │ ├── RayTrace.hs │ ├── Render.hs │ ├── Render │ │ ├── Definitions.hs │ │ ├── GetLoops.hs │ │ ├── GetSegs.hs │ │ ├── HandlePolylines.hs │ │ ├── HandleSquares.hs │ │ ├── Interpolate.hs │ │ ├── RefineSegs.hs │ │ └── TesselateLoops.hs │ ├── Resolution.hs │ ├── Symbolic │ │ ├── Rebound2.hs │ │ └── Rebound3.hs │ ├── SymbolicFormats.hs │ ├── SymbolicObj2.hs │ ├── SymbolicObj3.hs │ ├── TextBuilderUtils.hs │ ├── TriangleMeshFormats.hs │ └── Util.hs │ ├── ExtOpenScad.hs │ ├── ExtOpenScad │ ├── Default.hs │ ├── Definitions.hs │ ├── Eval │ │ ├── Constant.hs │ │ ├── Expr.hs │ │ └── Statement.hs │ ├── Parser │ │ ├── Expr.hs │ │ ├── Lexer.hs │ │ ├── Statement.hs │ │ └── Util.hs │ ├── Primitives.hs │ └── Util │ │ ├── ArgParser.hs │ │ ├── OVal.hs │ │ └── StateC.hs │ ├── FastIntUtil.hs │ ├── IntegralUtil.hs │ ├── MathUtil.hs │ ├── ObjectUtil.hs │ ├── ObjectUtil │ ├── GetBox2.hs │ ├── GetBox3.hs │ ├── GetBoxShared.hs │ ├── GetImplicit2.hs │ ├── GetImplicit3.hs │ └── GetImplicitShared.hs │ ├── Primitives.hs │ └── Primitives.hs-boot ├── LICENSE ├── Makefile ├── Makefile-OldCabal ├── README.md ├── Release.md ├── Tools.md ├── cabal.project ├── cabal.project.local.ci ├── default.nix ├── docs └── hacking.md ├── implicit-interpreter ├── CHANGELOG.md ├── LICENSE ├── README.md ├── implicit-interpreter.cabal ├── src │ └── Graphics │ │ └── Implicit │ │ └── Interpreter.hs └── test │ └── Spec.hs ├── implicit.cabal ├── overlay.nix ├── programs ├── Benchmark.hs ├── docgen.hs ├── extopenscad.hs ├── implicitsnap.hs └── parser-bench.hs ├── shell.nix ├── stack.yaml └── tests ├── ExecSpec ├── Expr.hs └── Util.hs ├── GoldenSpec ├── Spec.hs └── Util.hs ├── Graphics └── Implicit │ └── Test │ ├── Instances.hs │ └── Utils.hs ├── ImplicitSpec.hs ├── Main.hs ├── MessageSpec ├── Message.hs └── Util.hs ├── NOTES ├── ParserSpec ├── Expr.hs ├── Statement.hs └── Util.hs ├── PropertySpec.hs ├── PropertySpec └── Exec.hs ├── RewriteSpec.hs ├── TesselationSpec.hs ├── golden ├── arbitrary1.ascii.stl ├── arbitrary2.ascii.stl ├── arbitrary3.ascii.stl ├── arbitrary4.ascii.stl ├── boundingBoxes.ascii.stl ├── box.ascii.stl ├── boxCylinder.ascii.stl ├── boxCylinder.obj ├── boxCylinder.scad ├── boxCylinder.stl ├── boxCylinder.three.js ├── boxFrame.ascii.stl ├── closing-paths-1.ascii.stl ├── closing-paths-2.ascii.stl ├── example13.ascii.stl ├── example16.ascii.stl ├── example17.ascii.stl ├── hook.ascii.stl ├── link.ascii.stl ├── pretty-printing.ascii.stl ├── pretty-printing.obj ├── pretty-printing.scad ├── pretty-printing.stl ├── pretty-printing.three.js ├── shell.ascii.stl ├── torusEllipsoidCone.ascii.stl ├── troublesome-polygon-under-rotation.png ├── troublesome-polygon.png └── wheel-well.ascii.stl ├── imports ├── child.scad ├── config.scad ├── neighbour.scad └── relative │ ├── deep │ └── grandparent.scad │ └── parent.scad └── tobacco_mesophyll_protoplast_fusion_device.escad /.github/FUNDING.yml: -------------------------------------------------------------------------------- 1 | # These are supported funding model platforms 2 | 3 | github: julialongtin # Replace with up to 4 GitHub Sponsors-enabled usernames e.g., [user1, user2] 4 | patreon: # Replace with a single Patreon username 5 | open_collective: # Replace with a single Open Collective username 6 | ko_fi: # Replace with a single Ko-fi username 7 | tidelift: # Replace with a single Tidelift platform-name/package-name e.g., npm/babel 8 | community_bridge: # Replace with a single Community Bridge project-name e.g., cloud-foundry 9 | liberapay: # Replace with a single Liberapay username 10 | issuehunt: # Replace with a single IssueHunt username 11 | otechie: # Replace with a single Otechie username 12 | custom: # Replace with up to 4 custom sponsorship URLs e.g., ['link1', 'link2'] 13 | -------------------------------------------------------------------------------- /.github/workflows/ci.dhall: -------------------------------------------------------------------------------- 1 | let haskellCi = 2 | https://raw.githubusercontent.com/sorki/github-actions-dhall/main/haskell-ci.dhall 3 | 4 | in haskellCi.generalCi 5 | (haskellCi.withHlint haskellCi.defaultCabalSteps) 6 | (haskellCi.DhallMatrix::{=} with ghc = haskellCi.defaultGHC3) 7 | : haskellCi.CI.Type 8 | -------------------------------------------------------------------------------- /.github/workflows/ci.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # Script by @fisx 3 | 4 | set -eo pipefail 5 | 6 | # cd into the dir where this script is placed 7 | cd "$( dirname "${BASH_SOURCE[0]}" )" 8 | 9 | echo "regenerating .github/workflows/ci.yaml" 10 | 11 | which dhall-to-yaml-ng || cabal install dhall-yaml 12 | dhall-to-yaml-ng --generated-comment --file ci.dhall > ci.yaml 13 | -------------------------------------------------------------------------------- /.github/workflows/ci.yaml: -------------------------------------------------------------------------------- 1 | # Code generated by dhall-to-yaml. DO NOT EDIT. 2 | jobs: 3 | build: 4 | name: "GHC ${{ matrix.ghc }}, Cabal ${{ matrix.cabal }}, OS ${{ matrix.os }}" 5 | "runs-on": "${{ matrix.os }}" 6 | steps: 7 | - uses: "actions/checkout@v4" 8 | with: 9 | submodules: recursive 10 | - id: "setup-haskell-cabal" 11 | uses: "haskell-actions/setup@v2" 12 | with: 13 | "cabal-version": "${{ matrix.cabal }}" 14 | "ghc-version": "${{ matrix.ghc }}" 15 | - name: Update Hackage repository 16 | run: cabal update 17 | - name: cabal.project.local.ci 18 | run: | 19 | if [ -e cabal.project.local.ci ]; then 20 | cp cabal.project.local.ci cabal.project.local 21 | fi 22 | - name: freeze 23 | run: "cabal freeze --enable-tests --enable-benchmarks" 24 | - uses: "actions/cache@v3" 25 | with: 26 | key: "${{ matrix.os }}-${{ matrix.ghc }}-${{ matrix.cabal}}-${{ hashFiles('cabal.project.freeze') }}" 27 | path: | 28 | ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 29 | dist-newstyle 30 | - name: Install dependencies 31 | run: "cabal build all --enable-tests --enable-benchmarks --only-dependencies" 32 | - name: build all 33 | run: "cabal build all --enable-tests --enable-benchmarks" 34 | - name: test all 35 | run: "cabal test all --enable-tests" 36 | - name: haddock all 37 | run: cabal haddock all 38 | - name: "Install and run hlint (optional)" 39 | run: | 40 | cabal install hlint 41 | hlint -g --no-exit-code 42 | strategy: 43 | matrix: 44 | cabal: 45 | - '3.10' 46 | ghc: 47 | - '9.6.3' 48 | - '9.4.7' 49 | - '9.2.8' 50 | os: 51 | - "ubuntu-latest" 52 | name: Haskell CI 53 | 'on': 54 | pull_request: {} 55 | push: {} 56 | schedule: 57 | - cron: "4 20 10 * *" 58 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Intermediary files 2 | *.hi 3 | *.o 4 | *.hi-boot 5 | *.o-boot 6 | # Generated by using ImplicitCAD 7 | *.dxf 8 | *.png 9 | *.ps 10 | *.stl 11 | *.svg 12 | *.ascii.stl 13 | *.asciistl 14 | *.three.js 15 | *.threejs 16 | *.obj 17 | # Don't gitignore golden preimages 18 | !tests/golden/* 19 | # Generated by the build process 20 | cabal.project.local 21 | Setup 22 | .stack-work/ 23 | Examples/example[0-9][0-9] 24 | Examples/*cachegrind* 25 | dist/ 26 | dist-newstyle/ 27 | .ghc.environment.* 28 | # Generated documentation. 29 | docs/escad.md 30 | # Generated by examples 31 | Examples/*cachegrind* 32 | Examples/example[0-9][0-9] 33 | # emacs backups 34 | *~ 35 | # Patches gone wrong. 36 | *.orig 37 | # Unknown 38 | *.log 39 | /ImplicitCAD.lkshs 40 | /ImplicitCAD.lkshw 41 | /.dist-buildwrapper 42 | /.settings 43 | /.project 44 | stack.yaml.lock 45 | /attic/ 46 | # direnv 47 | .envrc 48 | .ghci 49 | .ghci_history 50 | -------------------------------------------------------------------------------- /CONTRIBUTORS: -------------------------------------------------------------------------------- 1 | A big thanks to our past and present contributors: 2 | 3 | shkoo -- Nils McCarthy -- nils@shkoo.com 4 | diffoperator -- Nikhil Sarda -- nikhilsarda.iitkgp@gmail.com 5 | matthewSorensen -- Matthew D Sorensen 6 | krakrjak -- Zac Slade -- krakrjak@gmail.com 7 | bergey -- Daniel Bergey -- bergey@teallabs.org 8 | colah -- Chris Olah -- CristopherOlah.Co@gmail.com 9 | rotty -- Andreas Rottmann -- a.rottmann@gmx.at 10 | bgamari -- Ben Gamari -- BGamari@gmail.com 11 | TheGrum -- Howard C. Shaw III -- howardcshaw@gmail.com 12 | katee -- Kate Murphy -- hello@kate.io 13 | andres-erbsen -- Andres Erbsen -- andreser@mit.edu 14 | tolomea -- Gordon Wrigley -- Gordon.Wrigley@gmail.com 15 | silky -- Noon van der Silk -- noonsilk@gmail.com 16 | mmachenry -- Mike Machenry -- Mike.Machenry@gmail.com 17 | julialongtin -- Julia Longtin -- JuliaL@TuringLace.com 18 | chicagoduane -- Duane Johnson -- Duane.Johnson@gmail.com 19 | l29ah -- Sergey Alirzaev -- zl29ah@gmail.com 20 | firegurafiku -- Pavel Kretov -- firegurafiku@gmail.com 21 | gambogi -- Matthew Gambogi -- m@gambogi.com 22 | cookshak -- Kelvin Cookshaw -- kelvin@cookshaw.com 23 | kpe -- ?? -- ?? 24 | junjihashimoto -- ?? -- ?? 25 | afcaddy -- ?? -- ?? 26 | lepsa -- Owen Harvey -- owenlharvey@gmail.com 27 | sorki -- Richard Marko -- rmarko@fedoraproject.org 28 | Eelis -- ?? -- ?? 29 | raptortech-js -- Jackie Scholl - jackie.h.scholl@gmail.com 30 | isovector -- Sandy Maguire -- sandy@sandymaguire.me 31 | ryantrinkle -- Ryan Trinkle -- ryan.trinkle@gmail.com 32 | RealET -- Erik Trinkle -- erik.trinkle@cyboard.digital 33 | 34 | Thanks as well, to raghuugare. Due to not being contactable, 35 | his code has been removed during the license update. 36 | 37 | 38 | -------------------------------------------------------------------------------- /Examples/example1.scad: -------------------------------------------------------------------------------- 1 | union() { 2 | square([80,80]); 3 | translate ([80,80]) circle(30); 4 | } 5 | -------------------------------------------------------------------------------- /Examples/example10.escad: -------------------------------------------------------------------------------- 1 | // Example10.escad -- map!. 2 | echo(map(cos, [0, pi/2, pi])); 3 | cube(10); 4 | translate (10) cube(10); 5 | -------------------------------------------------------------------------------- /Examples/example11.hs: -------------------------------------------------------------------------------- 1 | -- Example 11 - the union of a square and a circle. 2 | import Graphics.Implicit 3 | 4 | out = union [ 5 | square True (V2 80 80) 6 | , translate (V2 40 40) $ circle 30 7 | ] 8 | 9 | main = writeSVG 2 "example11.svg" out 10 | 11 | -------------------------------------------------------------------------------- /Examples/example12.hs: -------------------------------------------------------------------------------- 1 | -- Example 12 - the rounded union of a square and a circle. 2 | import Control.Applicative (pure) 3 | import Graphics.Implicit 4 | 5 | out = unionR 14 [ 6 | square True (pure 80) -- pure 80 turns into (V2 80 80) 7 | , translate (pure 40) $ circle 30 8 | ] 9 | 10 | main = writeSVG 2 "example12.svg" out 11 | -------------------------------------------------------------------------------- /Examples/example13-e.escad: -------------------------------------------------------------------------------- 1 | /* Example 13 - The rounded union of a cube and a sphere. */ 2 | union () { 3 | cube ([20,20,20]); 4 | translate ([20,20,20]) sphere (15); 5 | } -------------------------------------------------------------------------------- /Examples/example13.hs: -------------------------------------------------------------------------------- 1 | -- Example 13 - the rounded union of a cube and a sphere. 2 | import Control.Applicative (pure) 3 | import Graphics.Implicit 4 | 5 | out = union [ 6 | cube False (pure 20) -- same as (V3 20 20 20) 7 | , translate (pure 20) $ sphere 15 8 | ] 9 | 10 | main = writeSTL 1 "example13.stl" out 11 | -------------------------------------------------------------------------------- /Examples/example14.escad: -------------------------------------------------------------------------------- 1 | // example7.escad -- A twisted rounded extrusion of the rounded union of 5 hexagonical solids. 2 | linear_extrude (height = 40, center=true, twist=90, r=5){ 3 | union ( r = 8) { 4 | circle (10,$fn=6); 5 | translate ([22,0]) circle (10,$fn=6); 6 | translate ([0,22]) circle (10,$fn=6); 7 | translate ([-22,0]) circle (10,$fn=6); 8 | translate ([0,-22]) circle (10,$fn=6); 9 | } 10 | } 11 | -------------------------------------------------------------------------------- /Examples/example15.scad: -------------------------------------------------------------------------------- 1 | difference() { 2 | sphere(20); 3 | cylinder(r=17, h=100, center = true); 4 | } 5 | -------------------------------------------------------------------------------- /Examples/example16.hs: -------------------------------------------------------------------------------- 1 | import Control.Applicative (pure) 2 | import Graphics.Implicit 3 | import Graphics.Implicit.Definitions 4 | import Graphics.Implicit.Primitives 5 | 6 | roundbox:: SymbolicObj3 7 | roundbox = 8 | implicit 9 | (\(V3 x y z) -> x^4 + y^4 + z^4 - 15000) 10 | (pure (-20), pure 20) 11 | 12 | main = writeSTL 2 "example16.stl" roundbox 13 | -------------------------------------------------------------------------------- /Examples/example17.hs: -------------------------------------------------------------------------------- 1 | -- Example 17, pulled from our benchmarking suite. 2 | import Control.Applicative (pure) 3 | import Prelude ((<$>), ($), zipWith3, fmap, fromIntegral, (*), (/), Bool(..)) 4 | import Graphics.Implicit (cube, union, translate, writeSTL, V3(..)) 5 | import Graphics.Implicit.Definitions (Fastℕ, ℝ, ℝ3, SymbolicObj3) 6 | 7 | default (Fastℕ, ℝ) 8 | 9 | object2 :: SymbolicObj3 10 | object2 = squarePipe (pure 10) 1 100 11 | where 12 | squarePipe :: ℝ3 -> ℝ -> ℝ -> SymbolicObj3 13 | squarePipe (V3 x y z) diameter precision = 14 | union 15 | ((\start -> translate start 16 | $ cube True (pure diameter) 17 | ) 18 | <$> 19 | zipWith3 20 | V3 21 | (fmap (\n -> (fromIntegral n / precision) * x) [0..100]) 22 | (fmap (\n -> (fromIntegral n / precision) * y) [0..100]) 23 | (fmap (\n -> (fromIntegral n / precision) * z) [0..100])) 24 | 25 | main = writeSTL 1 "example17.stl" object2 26 | -------------------------------------------------------------------------------- /Examples/example18.escad: -------------------------------------------------------------------------------- 1 | union () { 2 | linear_extrude (10) polygon([[7.0710678118654755,0],[0,7.0710678118654755],[7.0710678118654755,2*7.0710678118654755],[2*7.0710678118654755,7.0710678118654755]]); 3 | linear_extrude (10) translate (20,0) polygon([[0,0],[10,0],[10,10],[0,10]]); 4 | } -------------------------------------------------------------------------------- /Examples/example19.escad: -------------------------------------------------------------------------------- 1 | // Example 19 -- The union of a cube and a sphere. 2 | union() 3 | { 4 | cube(20); 5 | translate(20,20,20) sphere (15); 6 | } -------------------------------------------------------------------------------- /Examples/example2.escad: -------------------------------------------------------------------------------- 1 | //example2.escad -- A rounded union of a square and a circle. 2 | union(r=14) { 3 | square([80,80]); 4 | translate ([80,80]) circle(30); 5 | } 6 | -------------------------------------------------------------------------------- /Examples/example20.escad: -------------------------------------------------------------------------------- 1 | union() { 2 | square([10, 10]); 3 | translate([10, 5]) 4 | square([10, 20]); 5 | } 6 | -------------------------------------------------------------------------------- /Examples/example21.scad: -------------------------------------------------------------------------------- 1 | union() 2 | { 3 | cube([10,20,5]); 4 | rotate(30) 5 | translate([0,30,0]) 6 | { 7 | cube([10,20,5]); 8 | rotate(30) 9 | translate([0,30,0]) 10 | { 11 | cube([10,20,5]); 12 | } 13 | } 14 | } -------------------------------------------------------------------------------- /Examples/example22.escad: -------------------------------------------------------------------------------- 1 | cube (10); 2 | cube (10); -------------------------------------------------------------------------------- /Examples/example23.escad: -------------------------------------------------------------------------------- 1 | include ; -------------------------------------------------------------------------------- /Examples/example24.escad: -------------------------------------------------------------------------------- 1 | // example24.escad -- the variably twisted extruded product of the difference of 5 circles. 2 | linear_extrude (height = 40, center=true, twist(h) = 35*cos(h*2*pi/60)) { 3 | difference (r = 8) { 4 | circle (10); 5 | translate ([22,0]) circle (10); 6 | translate ([0,22]) circle (10); 7 | translate ([-22,0]) circle (10); 8 | translate ([0,-22]) circle (10); 9 | } 10 | } 11 | -------------------------------------------------------------------------------- /Examples/example25.escad: -------------------------------------------------------------------------------- 1 | // example25.escad -- mirroring 2 | 3 | union() { 4 | cube(4); 5 | mirror([1, 0, 0]) translate([2, 2, 0]) cube(1); 6 | mirror([0, 1, 0]) translate([2, 2, 0]) cube(2); 7 | mirror([1, 1, 0]) cube(3); 8 | } 9 | -------------------------------------------------------------------------------- /Examples/example3.escad: -------------------------------------------------------------------------------- 1 | // example3.escad -- the extruded product of the union of five circles. 2 | linear_extrude (height = 40, center=true){ 3 | union ( r = 8) { 4 | circle (10); 5 | translate ([22,0]) circle (10); 6 | translate ([0,22]) circle (10); 7 | translate ([-22,0]) circle (10); 8 | translate ([0,-22]) circle (10); 9 | } 10 | } 11 | -------------------------------------------------------------------------------- /Examples/example4.escad: -------------------------------------------------------------------------------- 1 | // example4.escad -- the twisted extruded product of the union of five circles. 2 | linear_extrude (height = 40, center=true, twist=90){ 3 | union ( r = 8) { 4 | circle (10); 5 | translate ([22,0]) circle (10); 6 | translate ([0,22]) circle (10); 7 | translate ([-22,0]) circle (10); 8 | translate ([0,-22]) circle (10); 9 | } 10 | } 11 | -------------------------------------------------------------------------------- /Examples/example5.escad: -------------------------------------------------------------------------------- 1 | // example5.escad -- the variably twisted extruded product of the union of 5 circles. 2 | linear_extrude (height = 40, center=true, twist(h) = 35*cos(h*2*pi/60)) { 3 | union ( r = 8) { 4 | circle (10); 5 | translate ([22,0]) circle (10); 6 | translate ([0,22]) circle (10); 7 | translate ([-22,0]) circle (10); 8 | translate ([0,-22]) circle (10); 9 | } 10 | } 11 | -------------------------------------------------------------------------------- /Examples/example6.escad: -------------------------------------------------------------------------------- 1 | // example6.escad -- A rounded extrusion of the rounded union of 5 circles. 2 | linear_extrude (height = 40, center=true, r=5){ 3 | union ( r = 8) { 4 | circle (10); 5 | translate ([22,0]) circle (10); 6 | translate ([0,22]) circle (10); 7 | translate ([-22,0]) circle (10); 8 | translate ([0,-22]) circle (10); 9 | } 10 | } 11 | -------------------------------------------------------------------------------- /Examples/example7.escad: -------------------------------------------------------------------------------- 1 | // example7.escad -- A twisted rounded extrusion of the rounded union of 5 circles. 2 | linear_extrude (height = 40, center=true, twist=90, r=5){ 3 | union ( r = 8) { 4 | circle (10); 5 | translate ([22,0]) circle (10); 6 | translate ([0,22]) circle (10); 7 | translate ([-22,0]) circle (10); 8 | translate ([0,-22]) circle (10); 9 | } 10 | } 11 | -------------------------------------------------------------------------------- /Examples/example8.escad: -------------------------------------------------------------------------------- 1 | // Example8.escad -- variable assignment in loops. 2 | a = 5; 3 | for (c = [1, 2, 3]) { 4 | echo(c); 5 | a = a*c; 6 | echo(a); 7 | } 8 | -------------------------------------------------------------------------------- /Examples/example9.escad: -------------------------------------------------------------------------------- 1 | // Example9.escad -- function currying. 2 | f = max(4); 3 | echo(f(5)); 4 | echo(max(4,5)); 5 | -------------------------------------------------------------------------------- /Examples/exampleMultmatrix.scad: -------------------------------------------------------------------------------- 1 | // Examples from 2 | // https://en.wikibooks.org/wiki/OpenSCAD_User_Manual/Transformations#multmatrix 3 | // CC-BY-SA 3.0 https://creativecommons.org/licenses/by-sa/3.0/ 4 | 5 | angle=PI/4; 6 | multmatrix(m = [ [cos(angle), -sin(angle), 0, 0], 7 | [sin(angle), cos(angle), 0, 30], 8 | [ 0, 0, 1, 0], 9 | [ 0, 0, 0, 1] 10 | ] ) 11 | union() { 12 | cylinder(r=10.0,h=10,center=false); 13 | cube(size=[10,10,10],center=false); 14 | } 15 | 16 | // skew 17 | M = [ [ 1 , 0 , 0 , 0 ], 18 | [ 0 , 1 , 0.7, 0 ], // The "0.7" is the skew value; pushed along the y axis as z changes. 19 | [ 0 , 0 , 1 , 0 ], 20 | [ 0 , 0 , 0 , 1 ] ] ; 21 | translate([-20,0,0]) 22 | multmatrix(M) { union() { 23 | cylinder(r=10.0,h=10,center=false); 24 | cube(size=[10,10,10],center=false); 25 | } } 26 | 27 | // same as previous example but using 3x4 matrix 28 | N = [ [ 1 , 0 , 0 , 0 ], 29 | [ 0 , 1 , 0.7, 0 ], // The "0.7" is the skew value; pushed along the y axis as z changes. 30 | [ 0 , 0 , 1 , 0 ] ] ; 31 | translate([20,0,0]) 32 | multmatrix(N) { union() { 33 | cylinder(r=10.0,h=10,center=false); 34 | cube(size=[10,10,10],center=false); 35 | } } 36 | 37 | -------------------------------------------------------------------------------- /Graphics/Implicit/Export.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright (C) 2014 2015, Julia Longtin (julial@turinglace.com) 3 | -- Copyright (C) 2015 2016, Mike MacHenry (mike.machenry@gmail.com) 4 | -- Released under the GNU AGPLV3+, see LICENSE 5 | 6 | -- Allow us to use real types in the type constraints. 7 | {-# LANGUAGE FlexibleContexts #-} 8 | -- Allows \case in export2|3 9 | {-# LANGUAGE LambdaCase #-} 10 | 11 | module Graphics.Implicit.Export ( 12 | export2, 13 | export3, 14 | OutputFormat(SVG, SCAD, PNG, GCode, ASCIISTL, STL, THREEJS, OBJ, DXF), 15 | writeObject, 16 | formatObject, 17 | writeSVG, 18 | writeSTL, 19 | writeBinSTL, 20 | writeOBJ, 21 | writeTHREEJS, 22 | writeGCodeHacklabLaser, 23 | writeDXF2, 24 | writeSCAD2, 25 | writeSCAD3, 26 | writePNG, 27 | ) 28 | where 29 | 30 | import Prelude (FilePath, IO, (.), ($), (<>), show, error) 31 | 32 | -- The types of our objects (before rendering), and the type of the resolution to render with. 33 | import Graphics.Implicit.Definitions (SymbolicObj2, SymbolicObj3, ℝ, Polyline, TriangleMesh, NormedTriangleMesh) 34 | 35 | -- functions for outputing a file, and one of the types. 36 | import Data.Text.Lazy (Text) 37 | import qualified Data.Text.Lazy.IO as LT (writeFile) 38 | import qualified Data.ByteString.Lazy as LBS (writeFile) 39 | 40 | -- Import instances of DiscreteApproxable... 41 | import Graphics.Implicit.Export.DiscreteAproxable (DiscreteAproxable, discreteAprox) 42 | 43 | -- Output file formats. 44 | import qualified Graphics.Implicit.Export.PolylineFormats as PolylineFormats (svg, hacklabLaserGCode, dxf2) 45 | import qualified Graphics.Implicit.Export.TriangleMeshFormats as TriangleMeshFormats (stl, binaryStl, jsTHREE) 46 | import qualified Graphics.Implicit.Export.NormedTriangleMeshFormats as NormedTriangleMeshFormats (obj) 47 | import qualified Graphics.Implicit.Export.SymbolicFormats as SymbolicFormats (scad2, scad3) 48 | import qualified Codec.Picture as ImageFormatCodecs (DynamicImage, savePngImage) 49 | 50 | import Graphics.Implicit.Export.OutputFormat (OutputFormat(SVG, SCAD, PNG, GCode, ASCIISTL, STL, THREEJS, OBJ, DXF)) 51 | 52 | -- | Write an object to a file with LazyText IO, using the given format writer function. 53 | writeObject :: (DiscreteAproxable obj aprox) 54 | => ℝ -- ^ Resolution 55 | -> (aprox -> Text) -- ^ File Format Writer (Function that formats) 56 | -> FilePath -- ^ File Name 57 | -> obj -- ^ Object to render 58 | -> IO () -- ^ Writing Action! 59 | writeObject res formatWriter filename obj = 60 | let 61 | aprox = formatObject res formatWriter obj 62 | in LT.writeFile filename aprox 63 | 64 | -- | Serialize an object using the given format writer, which takes the filename and writes to it.. 65 | writeObject' :: (DiscreteAproxable obj aprox) 66 | => ℝ -- ^ Resolution 67 | -> (FilePath -> aprox -> IO ()) -- ^ File Format writer 68 | -> FilePath -- ^ File Name 69 | -> obj -- ^ Object to render 70 | -> IO () -- ^ Writing Action! 71 | writeObject' res formatWriter filename obj = 72 | formatWriter filename (discreteAprox res obj) 73 | 74 | -- | Serialize an object using the given format writer. No file target is implied. 75 | formatObject :: (DiscreteAproxable obj aprox) 76 | => ℝ -- ^ Resolution 77 | -> (aprox -> Text) -- ^ File Format Writer (Function that formats) 78 | -> obj -- ^ Object to render 79 | -> Text -- ^ Result 80 | formatObject res formatWriter = formatWriter . discreteAprox res 81 | 82 | writeSVG :: DiscreteAproxable obj [Polyline] => ℝ -> FilePath -> obj -> IO () 83 | writeSVG res = writeObject res PolylineFormats.svg 84 | 85 | writeDXF2 :: DiscreteAproxable obj [Polyline] => ℝ -> FilePath -> obj -> IO () 86 | writeDXF2 res = writeObject res PolylineFormats.dxf2 87 | 88 | writeSTL :: DiscreteAproxable obj TriangleMesh => ℝ -> FilePath -> obj -> IO () 89 | writeSTL res = writeObject res TriangleMeshFormats.stl 90 | 91 | writeBinSTL :: DiscreteAproxable obj TriangleMesh => ℝ -> FilePath -> obj -> IO () 92 | writeBinSTL res file obj = LBS.writeFile file $ TriangleMeshFormats.binaryStl $ discreteAprox res obj 93 | 94 | writeOBJ :: DiscreteAproxable obj NormedTriangleMesh => ℝ -> FilePath -> obj -> IO () 95 | writeOBJ res = writeObject res NormedTriangleMeshFormats.obj 96 | 97 | writeTHREEJS :: DiscreteAproxable obj TriangleMesh => ℝ -> FilePath -> obj -> IO () 98 | writeTHREEJS res = writeObject res TriangleMeshFormats.jsTHREE 99 | 100 | writeGCodeHacklabLaser :: DiscreteAproxable obj [Polyline] => ℝ -> FilePath -> obj -> IO () 101 | writeGCodeHacklabLaser res = writeObject res PolylineFormats.hacklabLaserGCode 102 | 103 | writeSCAD3 :: ℝ -> FilePath -> SymbolicObj3 -> IO () 104 | writeSCAD3 res filename obj = LT.writeFile filename $ SymbolicFormats.scad3 res obj 105 | 106 | writeSCAD2 :: ℝ -> FilePath -> SymbolicObj2 -> IO () 107 | writeSCAD2 res filename obj = LT.writeFile filename $ SymbolicFormats.scad2 res obj 108 | 109 | writePNG :: DiscreteAproxable obj ImageFormatCodecs.DynamicImage => ℝ -> FilePath -> obj -> IO () 110 | writePNG res = writeObject' res ImageFormatCodecs.savePngImage 111 | 112 | -- | Output a file containing a 3D object. 113 | export3 :: OutputFormat -> ℝ -> FilePath -> SymbolicObj3 -> IO () 114 | export3 = \case 115 | ASCIISTL -> writeSTL 116 | STL -> writeBinSTL 117 | SCAD -> writeSCAD3 118 | OBJ -> writeOBJ 119 | PNG -> writePNG 120 | THREEJS -> writeTHREEJS 121 | fmt -> error $ "Unrecognized 3D format: " <> show fmt 122 | 123 | -- | Output a file containing a 2D object. 124 | export2 :: OutputFormat -> ℝ -> FilePath -> SymbolicObj2 -> IO () 125 | export2 = \case 126 | SVG -> writeSVG 127 | DXF -> writeDXF2 128 | SCAD -> writeSCAD2 129 | PNG -> writePNG 130 | GCode -> writeGCodeHacklabLaser 131 | fmt -> error $ "Unrecognized 2D format: " <> show fmt 132 | -------------------------------------------------------------------------------- /Graphics/Implicit/Export/DiscreteAproxable.hs: -------------------------------------------------------------------------------- 1 | -- Copyright 2016, Julia Longtin (julial@turinglace.com) 2 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | -- Allow our DiscreteAproxable class to handle multiple parameters. 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | 8 | -- For the instance declaration of DiscreteAproxable SymbolicObj2 [Polyline] 9 | {-# LANGUAGE FlexibleInstances #-} 10 | 11 | -- | A module for retrieving approximate represententations of objects. 12 | module Graphics.Implicit.Export.DiscreteAproxable (DiscreteAproxable, discreteAprox) where 13 | 14 | import Prelude(pure, (-), (/), ($), (<), round, (+), maximum, abs, (*), fromIntegral, max, realToFrac, Int) 15 | 16 | -- Definitions for our number system, objects, and the things we can use to approximately represent objects. 17 | import Graphics.Implicit.Definitions (defaultObjectContext, ℝ, ℝ2, SymbolicObj2, SymbolicObj3, Polyline, TriangleMesh(getTriangles), NormedTriangleMesh(NormedTriangleMesh)) 18 | 19 | import Graphics.Implicit.ObjectUtil (getBox2, getBox3) 20 | 21 | import Graphics.Implicit.Export.SymbolicObj3 (symbolicGetMesh) 22 | 23 | import Graphics.Implicit.Export.SymbolicObj2 (symbolicGetContour) 24 | 25 | import Graphics.Implicit.Export.Util (normTriangle) 26 | 27 | -- We are the only ones that use this. 28 | import Graphics.Implicit.Export.RayTrace (Color(Color), Camera(Camera), Light(Light), Scene(Scene), average, traceRay, cameraRay) 29 | 30 | import Codec.Picture (DynamicImage(ImageRGBA8), PixelRGBA8(PixelRGBA8), generateImage) 31 | 32 | import Control.Parallel.Strategies (using, rdeepseq, parBuffer) 33 | 34 | import Linear ( V3(V3), V2(V2), (*^), (^/) ) 35 | import Linear.Affine ( Affine((.+^), (.-^)) ) 36 | import Graphics.Implicit.Primitives (getImplicit) 37 | 38 | default (ℝ) 39 | 40 | -- | There is a discrete way to aproximate this object. 41 | -- eg. Aproximating a 3D object with a triangle mesh 42 | -- would be DiscreteApproxable Obj3 TriangleMesh 43 | class DiscreteAproxable obj aprox where 44 | discreteAprox :: ℝ -> obj -> aprox 45 | 46 | instance DiscreteAproxable SymbolicObj3 TriangleMesh where 47 | discreteAprox = symbolicGetMesh 48 | 49 | -- FIXME: number of CPUs hardcoded here. 50 | instance DiscreteAproxable SymbolicObj3 NormedTriangleMesh where 51 | discreteAprox res obj = NormedTriangleMesh 52 | ([ normTriangle res (getImplicit obj) rawMesh 53 | | rawMesh <- getTriangles $ symbolicGetMesh res obj 54 | ] `using` parBuffer 32 rdeepseq) 55 | 56 | -- FIXME: way too many magic numbers. 57 | -- FIXME: adjustable resolution! 58 | instance DiscreteAproxable SymbolicObj3 DynamicImage where 59 | discreteAprox _ symbObj = ImageRGBA8 $ generateImage pixelRenderer (round w) (round h) 60 | where 61 | -- Size of the image to produce. 62 | (V2 w h) = V2 150 150 :: ℝ2 63 | obj = getImplicit symbObj 64 | box@(V3 x1 y1 z1, V3 _ y2 z2) = getBox3 symbObj 65 | av :: ℝ -> ℝ -> ℝ 66 | av a b = (a+b)/2 67 | avY = av y1 y2 68 | avZ = av z1 z2 69 | deviation = maximum [abs $ y1 - avY, abs $ y2 - avY, abs $ z1 - avZ, abs $ z2 - avZ] 70 | camera = Camera (V3 (x1-deviation*2.2) avY avZ) (V3 0 (-1) 0) (V3 0 0 (-1)) 1.0 71 | lights = [Light (V3 (x1-deviation*1.5) (y1 - 0.4*(y2-y1)) avZ) (0.03*deviation) ] 72 | scene = Scene obj (Color 200 200 230 255) lights (Color 255 255 255 0) 73 | -- passed to generateImage, it's external, and determines this type. 74 | pixelRenderer :: Int -> Int -> PixelRGBA8 75 | pixelRenderer a b = renderScreen 76 | (fromIntegral a/w - 0.5) (fromIntegral b/h - 0.5) 77 | renderScreen :: ℝ -> ℝ -> PixelRGBA8 78 | renderScreen a b = 79 | colorToPixelRGBA8 $ 80 | average [ 81 | traceRay 82 | (cameraRay camera (V2 a b + V2 ( 0.25/w) (0.25/h))) 83 | 2 box scene, 84 | traceRay 85 | (cameraRay camera (V2 a b + V2 (-0.25/w) (0.25/h))) 86 | 0.5 box scene, 87 | traceRay 88 | (cameraRay camera (V2 a b + V2 (0.25/w) (-0.25/h))) 89 | 0.5 box scene, 90 | traceRay 91 | (cameraRay camera (V2 a b + V2 (-0.25/w) (-0.25/h))) 92 | 0.5 box scene 93 | ] 94 | where 95 | colorToPixelRGBA8 :: Color -> PixelRGBA8 96 | colorToPixelRGBA8 (Color rr gg bb aa) = PixelRGBA8 rr gg bb aa 97 | 98 | instance DiscreteAproxable SymbolicObj2 [Polyline] where 99 | discreteAprox res = symbolicGetContour res defaultObjectContext 100 | 101 | -- FIXME: way too many magic numbers. 102 | -- FIXME: adjustable resolution? 103 | instance DiscreteAproxable SymbolicObj2 DynamicImage where 104 | discreteAprox _ symbObj = ImageRGBA8 $ generateImage pixelRenderer (round w) (round h) 105 | where 106 | -- Size of the image to produce. 107 | V2 w h = pure 150 :: ℝ2 108 | obj = getImplicit symbObj 109 | (p1@(V2 x1 _), p2@(V2 _ y2)) = getBox2 symbObj 110 | V2 dx dy = p2 - p1 111 | dxy = max dx dy 112 | -- passed to generateImage, it's external, and determines this type. 113 | pixelRenderer :: Int -> Int -> PixelRGBA8 114 | pixelRenderer mya myb = mycolor 115 | where 116 | xy a b = (V2 x1 y2 .-^ V2 (dxy-dx) (dy-dxy) ^/2) .+^ dxy *^ V2 (a/w) (-b/h) 117 | s = 0.25 :: ℝ 118 | V2 a' b' = V2 (realToFrac mya) (realToFrac myb) :: ℝ2 119 | mycolor = colorToPixelRGBA8 $ average [objColor $ xy a' b', objColor $ xy a' b', 120 | objColor $ xy (a'+s) (b'+s), 121 | objColor $ xy (a'-s) (b'-s), 122 | objColor $ xy (a'+s) (b'+s), 123 | objColor $ xy (a'-s) (b'-s)] 124 | colorToPixelRGBA8 :: Color -> PixelRGBA8 125 | colorToPixelRGBA8 (Color rr gg bb aa) = PixelRGBA8 rr gg bb aa 126 | objColor p = if obj p < 0 then Color 150 150 160 255 else Color 255 255 255 0 127 | 128 | -------------------------------------------------------------------------------- /Graphics/Implicit/Export/NormedTriangleMeshFormats.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright (C) 2016 Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | -- FIXME: describe why we need this. 6 | {-# LANGUAGE OverloadedStrings #-} 7 | 8 | module Graphics.Implicit.Export.NormedTriangleMeshFormats (obj) where 9 | 10 | import Prelude(($), fmap, (+), (.), (*), length, (-), pure, (<>)) 11 | 12 | import Graphics.Implicit.Definitions (NormedTriangle(NormedTriangle), NormedTriangleMesh(getNormedTriangles), ℝ3) 13 | import Graphics.Implicit.Export.TextBuilderUtils (Text, Builder, toLazyText, bf, buildInt, fromLazyText) 14 | 15 | import Data.Foldable (fold, foldMap) 16 | import Linear (V3(V3)) 17 | 18 | -- | Generate a .obj format file from a NormedTriangleMesh 19 | -- see: https://en.wikipedia.org/wiki/Wavefront_.obj_file 20 | obj :: NormedTriangleMesh -> Text 21 | obj mesh = toLazyText $ vertcode <> normcode <> trianglecode 22 | where 23 | -- A vertex line; v (0.0, 0.0, 1.0) = "v 0.0 0.0 1.0\n" 24 | v :: ℝ3 -> Builder 25 | v (V3 x y z) = "v " <> fromLazyText (bf x) <> " " <> fromLazyText (bf y) <> " " <> fromLazyText (bf z) <> "\n" 26 | -- A normal line; n (0.0, 0.0, 1.0) = "vn 0.0 0.0 1.0\n" 27 | n :: ℝ3 -> Builder 28 | n (V3 x y z) = "vn " <> fromLazyText (bf x) <> " " <> fromLazyText (bf y) <> " " <> fromLazyText (bf z) <> "\n" 29 | verts = do 30 | -- Extract the vertices for each triangle. 31 | -- recall that a normed triangle is of the form ((vert, norm), ...) 32 | NormedTriangle ((a,_),(b,_),(c,_)) <- normedTriangles 33 | -- The vertices from each triangle take up 3 positions in the resulting list 34 | [a,b,c] 35 | norms = do 36 | -- extract the normals for each triangle 37 | NormedTriangle ((_,a),(_,b),(_,c)) <- normedTriangles 38 | -- The normals from each triangle take up 3 positions in the resulting list 39 | [a,b,c] 40 | vertcode = foldMap v verts 41 | normcode = foldMap n norms 42 | trianglecode :: Builder 43 | trianglecode = fold $ do 44 | n' <- fmap ((+1).(*3)) [0,1 .. length normedTriangles -1] 45 | let 46 | vta = buildInt n' 47 | vtb = buildInt (n'+1) 48 | vtc = buildInt (n'+2) 49 | pure $ "f " <> vta <> " " <> vtb <> " " <> vtc <> " " <> "\n" 50 | normedTriangles = getNormedTriangles mesh 51 | -------------------------------------------------------------------------------- /Graphics/Implicit/Export/OutputFormat.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright (C) 2014 2015, Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | module Graphics.Implicit.Export.OutputFormat 6 | ( OutputFormat (SVG, SCAD, PNG, GCode, ASCIISTL, STL, THREEJS, OBJ, DXF), 7 | guessOutputFormat, 8 | formatExtensions, 9 | formatExtension, 10 | formats2D, 11 | formatIs2D, 12 | def2D, 13 | formats3D, 14 | formatIs3D, 15 | def3D, 16 | ) 17 | where 18 | 19 | import Prelude (Bool, Eq, FilePath, Maybe, Read (readsPrec), Show(show), String, drop, error, flip, length, take, ($), (<>), (==)) 20 | import Control.Applicative ((<$>)) 21 | -- For making the format guesser case insensitive when looking at file extensions. 22 | import Data.Char (toLower) 23 | import Data.Default.Class (Default(def)) 24 | import Data.List (lookup, elem) 25 | import Data.Maybe (fromMaybe) 26 | import Data.Tuple (swap) 27 | -- For handling input/output files. 28 | import System.FilePath (takeExtensions) 29 | 30 | tail :: [a] -> [a] 31 | tail = drop 1 32 | 33 | -- | A type serving to enumerate our output formats. 34 | data OutputFormat 35 | = SVG 36 | | SCAD 37 | | PNG 38 | | GCode 39 | | ASCIISTL 40 | | STL 41 | | THREEJS 42 | | OBJ 43 | | DXF 44 | -- | 3MF 45 | deriving (Show, Eq) 46 | 47 | instance Default OutputFormat where 48 | def = STL 49 | 50 | -- | Default 2D output format 51 | def2D :: OutputFormat 52 | def2D = SVG 53 | 54 | -- | Default 3D output format 55 | def3D :: OutputFormat 56 | def3D = def 57 | 58 | -- | All supported 2D formats 59 | formats2D :: [OutputFormat] 60 | formats2D = [GCode, DXF, PNG, SCAD, SVG] 61 | 62 | -- | True for 2D capable `OutputFormat`s 63 | formatIs2D :: OutputFormat -> Bool 64 | formatIs2D = flip elem formats2D 65 | 66 | -- | All supported 3D formats 67 | formats3D :: [OutputFormat] 68 | formats3D = [ASCIISTL, OBJ, STL, SCAD, THREEJS] 69 | 70 | -- | True for 3D capable `OutputFormat`s 71 | formatIs3D :: OutputFormat -> Bool 72 | formatIs3D = flip elem formats3D 73 | 74 | -- | A list mapping file extensions to output formats. 75 | formatExtensions :: [(String, OutputFormat)] 76 | formatExtensions = 77 | [ ("svg", SVG), 78 | ("scad", SCAD), 79 | ("png", PNG), 80 | ("ngc", GCode), 81 | ("gcode", GCode), 82 | ("ascii.stl", ASCIISTL), 83 | ("asciistl", ASCIISTL), 84 | ("stl", STL), 85 | ("three.js", THREEJS), 86 | ("threejs", THREEJS), 87 | ("obj", OBJ), 88 | ("dxf", DXF) 89 | -- ("3mf", 3MF) 90 | ] 91 | 92 | -- | Lookup an output format for a given output file. Throw an error if one cannot be found. 93 | guessOutputFormat :: FilePath -> OutputFormat 94 | guessOutputFormat fileName = 95 | fromMaybe (error $ "Unrecognized output format: " <> ext) $ 96 | readOutputFormat $ tail ext 97 | where 98 | ext = takeExtensions fileName 99 | 100 | -- | Try to look up an output format from a supplied extension. 101 | readOutputFormat :: String -> Maybe OutputFormat 102 | readOutputFormat ext = lookup (toLower <$> ext) formatExtensions 103 | 104 | -- | A Read instance for our output format. Used by 'auto' in our command line parser. 105 | -- Reads a string, and evaluates to the appropriate OutputFormat. 106 | instance Read OutputFormat where 107 | readsPrec _ myvalue = 108 | tryParse formatExtensions 109 | where 110 | tryParse :: [(String, OutputFormat)] -> [(OutputFormat, String)] 111 | tryParse [] = [] -- If there is nothing left to try, fail 112 | tryParse ((attempt, result) : xs) = 113 | if take (length attempt) myvalue == attempt 114 | then [(result, drop (length attempt) myvalue)] 115 | else tryParse xs 116 | 117 | -- | Get filename extension for `OutputFormat` 118 | formatExtension :: OutputFormat -> String 119 | formatExtension fmt = fromMaybe 120 | (error $ "No extension defined for OutputFormat " <> show fmt) 121 | $ lookup fmt (swap <$> formatExtensions) 122 | -------------------------------------------------------------------------------- /Graphics/Implicit/Export/RayTrace.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright 2016, Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | module Graphics.Implicit.Export.RayTrace( Color(Color), average, Camera(Camera), Light(Light), Scene(Scene), traceRay, cameraRay, vectorDistance) where 6 | 7 | import Prelude(Show, RealFrac, Maybe(Just, Nothing), Bool(False, True), (-), (.), ($), (*), (/), min, fromInteger, max, round, fromIntegral, unzip, fmap, length, sum, maximum, minimum, (>), (+), (<), (==), pred, flip, not, abs, floor, toRational, otherwise, pure) 8 | 9 | -- Our number system, and the definition of a 3D object. 10 | import Graphics.Implicit.Definitions (ℝ, Fastℕ, ℝ2, ℝ3, Obj3) 11 | 12 | import Codec.Picture (Pixel8) 13 | 14 | import Control.Monad (guard) 15 | 16 | import Control.Arrow ((***)) 17 | 18 | import Linear 19 | ( V3(V3), cross, Metric(dot, norm), V2(V2), normalize, (*^) ) 20 | 21 | default (Fastℕ, ℝ) 22 | 23 | -- Definitions 24 | 25 | data Camera = Camera ℝ3 ℝ3 ℝ3 ℝ 26 | deriving Show 27 | 28 | -- | A ray. A point, and a normal pointing in the direction the ray is going. 29 | data Ray = Ray ℝ3 ℝ3 30 | deriving Show 31 | 32 | data Scene = Scene Obj3 Color [Light] Color 33 | 34 | -- | A light source. source point, and intensity. 35 | data Light = Light ℝ3 ℝ 36 | deriving Show 37 | 38 | -- | A colour. Red Green Blue and Alpha components. 39 | data Color = Color Pixel8 Pixel8 Pixel8 Pixel8 40 | 41 | -- Math 42 | 43 | -- | The distance traveled by a line segment from the first point to the second point. 44 | vectorDistance :: ℝ3 -> ℝ3 -> ℝ 45 | vectorDistance a b = norm (b-a) 46 | 47 | -- | Multiply a colour by an intensity. 48 | colorMult :: Pixel8 -> Color -> Color 49 | s `colorMult` (Color a b c d) = Color (s `mult` a) (s `mult` b) (s `mult` c) d 50 | where 51 | bound :: RealFrac a => a -> a 52 | bound = max 0 . min 255 53 | mult :: Pixel8 -> Pixel8 -> Pixel8 54 | mult x y = round . bound . toRational $ x * y 55 | 56 | -- | Average a set of colours. 57 | average :: [Color] -> Color 58 | average l = 59 | let 60 | ((rs, gs), (bs, as)) = (unzip *** unzip) . unzip $ fmap 61 | (\(Color r g b a) -> ((fromIntegral r, fromIntegral g), (fromIntegral b, fromIntegral a))) 62 | l :: (([ℝ], [ℝ]), ([ℝ], [ℝ])) 63 | n :: ℝ 64 | n = fromIntegral $ length l 65 | (r', g', b', a') = (sum rs/n, sum gs/n, sum bs/n, sum as/n) 66 | in Color 67 | (fromInteger . round $ r') (fromInteger . round $ g') (fromInteger . round $ b') (fromInteger . round $ a') 68 | 69 | -- Ray Utilities 70 | 71 | cameraRay :: Camera -> ℝ2 -> Ray 72 | cameraRay (Camera p vx vy f) (V2 x y) = 73 | let 74 | v = vx `cross` vy 75 | p' = p + f*^v + x*^vx + y*^vy 76 | n = normalize (p' - p) 77 | in 78 | Ray p' n 79 | 80 | -- | Create a ray from two points. 81 | rayFromTo :: ℝ3 -> ℝ3 -> Ray 82 | rayFromTo p1 p2 = Ray p1 (normalize $ p2 - p1) 83 | 84 | rayBounds :: Ray -> (ℝ3, ℝ3) -> ℝ2 85 | rayBounds ray box = 86 | let 87 | Ray (V3 cPx cPy cPz) (V3 cVx cVy cVz) = ray 88 | (V3 x1 y1 z1, V3 x2 y2 z2) = box 89 | xbounds = [(x1 - cPx)/cVx, (x2-cPx)/cVx] 90 | ybounds = [(y1-cPy)/cVy, (y2-cPy)/cVy] 91 | zbounds = [(z1-cPz)/cVz, (z2-cPz)/cVz] 92 | lower = maximum [minimum xbounds, minimum ybounds, minimum zbounds] 93 | upper = minimum [maximum xbounds, maximum ybounds, maximum zbounds] 94 | in 95 | V2 lower upper 96 | 97 | -- Intersection 98 | -- FIXME: magic numbers. 99 | intersection :: Ray -> ((ℝ,ℝ), ℝ) -> ℝ -> Obj3 -> Maybe ℝ3 100 | intersection r@(Ray p v) ((a, aval),b) res obj = 101 | let 102 | step | aval/4 > res = res 103 | | aval/2 > res = res/2 104 | | otherwise = res/10 105 | a' = a + step 106 | a'val = obj (p + a'*^v) 107 | in if a'val < 0 108 | then 109 | let a'' = refine (V2 a a') (\s -> obj (p + s*^v)) 110 | in Just (p + a''*^v) 111 | else if a' < b 112 | then intersection r ((a',a'val), b) res obj 113 | else Nothing 114 | 115 | refine :: ℝ2 -> (ℝ -> ℝ) -> ℝ 116 | refine (V2 a b) obj = 117 | let 118 | (aval, bval) = (obj a, obj b) 119 | in if bval < aval 120 | then refine' 10 (V2 a b) (V2 aval bval) obj 121 | else refine' 10 (V2 b a) (V2 aval bval) obj 122 | 123 | refine' :: Fastℕ -> ℝ2 -> ℝ2 -> (ℝ -> ℝ) -> ℝ 124 | refine' 0 (V2 a _) _ _ = a 125 | refine' n (V2 a b) (V2 aval bval) obj = 126 | let 127 | mid = (a+b)/2 128 | midval = obj mid 129 | in 130 | if midval == 0 131 | then mid 132 | else if midval < 0 133 | then refine' (pred n) (V2 a mid) (V2 aval midval) obj 134 | else refine' (pred n) (V2 mid b) (V2 midval bval) obj 135 | 136 | intersects :: Ray -> ((ℝ, ℝ), ℝ) -> ℝ -> Obj3 -> Bool 137 | intersects a b c d = case intersection a b c d of 138 | Nothing -> False 139 | Just _ -> True 140 | 141 | -- Trace 142 | -- FIXME: magic numbers. 143 | traceRay :: Ray -> ℝ -> (ℝ3, ℝ3) -> Scene -> Color 144 | traceRay ray@(Ray cameraP cameraV) step box (Scene obj objColor lights defaultColor) = 145 | let 146 | (V2 a b) = rayBounds ray box 147 | in case intersection ray ((a, obj (cameraP + a*^cameraV)), b) step obj of 148 | Just p -> flip colorMult objColor $ floor (sum $ 0.2 : do 149 | Light lightPos lightIntensity <- lights 150 | let 151 | ray'@(Ray _ v) = rayFromTo p lightPos 152 | v' = normalize v 153 | guard . not $ intersects ray' ((0, obj p),20) step obj 154 | let 155 | pval = obj p 156 | dirDeriv :: ℝ3 -> ℝ 157 | dirDeriv v'' = (obj (p + step*^v'') - pval)/step 158 | deriv = V3 (dirDeriv (V3 1 0 0)) (dirDeriv (V3 0 1 0)) (dirDeriv (V3 0 0 1)) 159 | normal = normalize deriv 160 | unitV = normalize v' 161 | -- proj :: InnerSpace v => v -> v -> v 162 | proj a' b' = (a' `dot` b')*^b' 163 | dist = vectorDistance p lightPos 164 | illumination = max 0 (normal `dot` unitV) * lightIntensity * (25 /dist) 165 | rV = 166 | let 167 | normalComponent = proj v' normal 168 | parComponent = v' - normalComponent 169 | in 170 | normalComponent - parComponent 171 | pure $ illumination*(3 + 0.3*abs(rV `dot` cameraV)*abs(rV `dot` cameraV)) 172 | ) 173 | Nothing -> defaultColor 174 | 175 | -------------------------------------------------------------------------------- /Graphics/Implicit/Export/Render/Definitions.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Released under the GNU AGPLV3+, see LICENSE 3 | 4 | -- We want a type that can represent squares/quads and triangles. 5 | module Graphics.Implicit.Export.Render.Definitions (TriSquare(Tris, Sq)) where 6 | 7 | -- Points/Numbers, and the concept of an array of triangles. 8 | import Graphics.Implicit.Definitions(ℝ, ℝ2, ℝ3, TriangleMesh) 9 | 10 | -- So we can use Parallel on this type. 11 | import Control.DeepSeq (NFData, rnf) 12 | 13 | data TriSquare = 14 | Sq (ℝ3,ℝ3,ℝ3) ℝ ℝ2 ℝ2 15 | | Tris TriangleMesh 16 | 17 | instance NFData TriSquare where 18 | rnf (Sq b z xS yS) = rnf (b,z,xS,yS) 19 | rnf (Tris tris) = rnf tris 20 | 21 | -------------------------------------------------------------------------------- /Graphics/Implicit/Export/Render/GetLoops.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright 2014 2015 2016, Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | module Graphics.Implicit.Export.Render.GetLoops (getLoops) where 6 | 7 | -- Explicitly include what we want from Prelude. 8 | import Prelude ((<$>), last, (==), Bool(False), (.), null, (<>), Eq, Maybe(Just, Nothing)) 9 | 10 | import Data.List (partition) 11 | 12 | -- | The goal of getLoops is to extract loops from a list of segments. 13 | -- The input is a list of segments. 14 | -- The output a list of loops, where each loop is a list of 15 | -- segments, which each piece representing a "side". 16 | -- 17 | -- For example: 18 | -- Given points [[1,2],[5,1],[2,3,4,5], ... ] 19 | -- notice that there is a loop 1,2,3,4,5... 20 | -- But we give the output [ [ [1,2], [2,3,4,5], [5,1] ], ... ] 21 | -- so that we have the loop, and also knowledge of how 22 | -- the list is built (the "sides" of it). 23 | -- 24 | getLoops :: Eq a => [[a]] -> Maybe [[[a]]] 25 | getLoops [] = Just [] 26 | getLoops (a:as) = getLoops' as [a] (last a) 27 | 28 | -- | We will be actually doing the loop extraction with 29 | -- getLoops' 30 | -- 31 | -- getLoops' has a first argument of the segments as before, 32 | -- but a *second argument* which is the loop presently being 33 | -- built. 34 | -- 35 | -- so we begin with the "building loop" being empty. 36 | -- 37 | -- see also: 'getLoops'. 38 | getLoops' 39 | :: Eq a 40 | => [[a]] -- ^ input 41 | -> [[a]] -- ^ accumulator 42 | -> a -- ^ last element in the accumulator 43 | -> Maybe [[[a]]] 44 | {-# INLINABLE getLoops' #-} 45 | 46 | -- If there aren't any segments, and the "building loop" is empty, produce no loops. 47 | getLoops' [] [] _ = Just [] 48 | 49 | -- If the building loop is empty, stick the first segment we have onto it to give us something to build on. 50 | getLoops' (x:xs) [] _ = getLoops' xs [x] (last x) 51 | 52 | -- A loop is finished if its start and end are the same. 53 | -- Return it and start searching for another loop. 54 | getLoops' segs workingLoop@((x:_):_) ultima | x == ultima = 55 | (workingLoop :) <$> getLoops' segs [] ultima 56 | 57 | -- Finally, we search for pieces that can continue the working loop, 58 | -- and stick one on if we find it. 59 | -- Otherwise... something is really screwed up. 60 | getLoops' segs workingLoop ultima = do 61 | let 62 | presEnd :: [[a]] -> a 63 | presEnd = last . last 64 | connects (x:_) = x == presEnd workingLoop 65 | -- Handle the empty case. 66 | connects [] = False 67 | -- divide our set into sequences that connect, and sequences that don't. 68 | (possibleConts, nonConts) = partition connects segs 69 | case possibleConts of 70 | [] -> Nothing 71 | (next : conts) -> do 72 | let unused = conts <> nonConts 73 | if null next 74 | then (workingLoop :) <$> getLoops' segs [] ultima 75 | else getLoops' unused (workingLoop <> [next]) (last next) 76 | 77 | -------------------------------------------------------------------------------- /Graphics/Implicit/Export/Render/GetSegs.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright (C) 2016, Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | module Graphics.Implicit.Export.Render.GetSegs (getSegs) where 6 | 7 | import Prelude((-), Bool(True, False), sqrt, (+), (*), (/=), map, (.), filter, ($), (<=)) 8 | 9 | import Graphics.Implicit.Definitions (ℝ, ℝ2, Obj2, Polyline(Polyline)) 10 | import Graphics.Implicit.Export.Render.RefineSegs (refine) 11 | import Graphics.Implicit.Export.Util (centroid) 12 | import Linear (V2(V2)) 13 | 14 | {- The goal of getSegs is to create polylines to separate 15 | the interior and exterior vertices of a square intersecting 16 | an object described by an implicit function. 17 | 18 | O.....O O.....O 19 | : : : : 20 | : * : ,--* 21 | * : => *-- : 22 | : : : : 23 | #.....# #.....# 24 | 25 | An interior point is one at which obj is negative. 26 | 27 | What are all the variables? 28 | =========================== 29 | 30 | To allow data sharing, lots of values we 31 | could calculate are instead arguments. 32 | 33 | positions obj values 34 | --------- ---------- 35 | 36 | (x1,y2) .. (x2,y2) obj x1y2 .. x2y2 37 | : : => : : 38 | (x1,y1) .. (x2,y1) x1y1 .. x2y2 39 | 40 | mid points 41 | ---------- 42 | 43 | (midy2V, y2) 44 | = midy2 45 | 46 | ......*...... 47 | : : 48 | (x1, midx1V) * * (x2, midx2V) 49 | = midx1 : : = midx2 50 | :.....*.....: 51 | 52 | (midy1V, y1) 53 | = midy1 54 | 55 | -} 56 | getSegs :: ℝ2 -> ℝ2 -> Obj2 -> (ℝ,ℝ,ℝ,ℝ) -> (ℝ,ℝ,ℝ,ℝ) -> [Polyline] 57 | getSegs p1@(V2 x y) p2 obj (x1y1, x2y1, x1y2, x2y2) (midx1V,midx2V,midy1V,midy2V) = 58 | let 59 | -- Let's evaluate obj at a few points... 60 | c = obj (centroid [p1,p2]) 61 | 62 | -- TODO(sandy): i might have swapped (^+^) for - here 63 | (V2 dx dy) = p2 - p1 64 | res = sqrt (dx*dy) 65 | 66 | midx1 = V2 x midx1V 67 | midx2 = V2 (x + dx) midx2V 68 | midy1 = V2 midy1V y 69 | midy2 = V2 midy2V (y + dy) 70 | 71 | notPointLine :: Polyline -> Bool 72 | notPointLine (Polyline [np1,np2]) = np1 /= np2 73 | notPointLine _ = False 74 | 75 | -- takes straight lines between mid points and subdivides them to 76 | -- account for sharp corners, etc. 77 | 78 | in map (refine res obj) . filter notPointLine $ case (x1y2 <= 0, x2y2 <= 0, 79 | x1y1 <= 0, x2y1 <= 0) of 80 | 81 | -- An important point here is orientation. If you imagine going along a 82 | -- generated segment, the interior should be on the left-hand side. 83 | 84 | -- Empty Cases 85 | 86 | (True, True, True, True) -> [] 87 | (False, False, False, False) -> [] 88 | 89 | -- Horizontal Cases 90 | ( True, True, False, False) -> [Polyline [midx1, midx2]] 91 | (False, False, True, True) -> [Polyline [midx2, midx1]] 92 | 93 | -- Vertical Cases 94 | (False, True, False, True) -> [Polyline [midy2, midy1]] 95 | ( True, False, True, False) -> [Polyline [midy1, midy2]] 96 | 97 | -- Corner Cases 98 | ( True, False, False, False) -> [Polyline [midx1, midy2]] 99 | (False, True, True, True) -> [Polyline [midy2, midx1]] 100 | ( True, True, False, True) -> [Polyline [midx1, midy1]] 101 | (False, False, True, False) -> [Polyline [midy1, midx1]] 102 | ( True, True, True, False) -> [Polyline [midy1, midx2]] 103 | (False, False, False, True) -> [Polyline [midx2, midy1]] 104 | ( True, False, True, True) -> [Polyline [midx2, midy2]] 105 | (False, True, False, False) -> [Polyline [midy2, midx2]] 106 | 107 | -- Dual Corner Cases 108 | (True, False, False, True) -> if c <= 0 109 | then [Polyline [midx1, midy1], Polyline [midx2, midy2]] 110 | else [Polyline [midx1, midy2], Polyline [midx2, midy1]] 111 | 112 | (False, True, True, False) -> if c <= 0 113 | then [Polyline [midy2, midx1], Polyline [midy1, midx2]] 114 | else [Polyline [midy1, midx1], Polyline [midy2, midx2]] 115 | -------------------------------------------------------------------------------- /Graphics/Implicit/Export/Render/HandlePolylines.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2012, Christopher Olah (chris@colah.ca) 2 | -- Copyright (C) 2016, Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | module Graphics.Implicit.Export.Render.HandlePolylines (cleanLoopsFromSegs) where 6 | 7 | import Prelude(Maybe(Just, Nothing), fmap, (.), (==), last, reverse, ($), (<>), (-), (/), abs, (<=), (||), (&&), (*), (>), otherwise, error) 8 | 9 | import Graphics.Implicit.Definitions (minℝ, Polyline(Polyline)) 10 | import Linear ( V2(V2) ) 11 | 12 | cleanLoopsFromSegs :: [Polyline] -> [Polyline] 13 | cleanLoopsFromSegs = fmap reducePolyline . joinSegs 14 | 15 | -- | Join polylines that connect. 16 | joinSegs :: [Polyline] -> [Polyline] 17 | joinSegs (Polyline present:remaining) = 18 | let 19 | findNext :: [Polyline] -> (Maybe Polyline, [Polyline]) 20 | findNext (Polyline (p3:ps):segs) 21 | | p3 == last present = (Just (Polyline (p3:ps)), segs) 22 | | last ps == last present = (Just (Polyline $ reverse $ p3:ps), segs) 23 | | otherwise = case findNext segs of (res1,res2) -> (res1,Polyline (p3:ps):res2) 24 | findNext [] = (Nothing, []) 25 | findNext (Polyline []:_) = (Nothing, []) 26 | in 27 | case findNext remaining of 28 | (Nothing, _) -> Polyline present: joinSegs remaining 29 | (Just (Polyline match), others) -> joinSegs $ Polyline (present <> match) : others 30 | joinSegs [] = [] 31 | 32 | -- | Simplify and sort a polyline. 33 | reducePolyline :: Polyline -> Polyline 34 | reducePolyline (Polyline (V2 x1 y1 : V2 x2 y2 : V2 x3 y3:others)) 35 | -- Remove sequential duplicate points. 36 | | (x1,y1) == (x2,y2) = reducePolyline (Polyline (V2 x2 y2 : V2 x3 y3 : others)) 37 | | abs ( (y2-y1)/(x2-x1) - (y3-y1)/(x3-x1) ) <= minℝ 38 | || ( (x2-x1) == 0 && (x3-x1) == 0 && (y2-y1)*(y3-y1) > 0) = 39 | reducePolyline (Polyline (V2 x1 y1 : V2 x3 y3 :others)) 40 | | otherwise = Polyline (V2 x1 y1 : points (reducePolyline (Polyline (V2 x2 y2 : V2 x3 y3 : others)))) 41 | where 42 | points (Polyline pts) = pts 43 | -- | remove sequential duplicate points. 44 | reducePolyline (Polyline (V2 x1 y1 : V2 x2 y2 : others)) = 45 | if (x1,y1) == (x2,y2) then reducePolyline (Polyline (V2 x2 y2 : others)) else Polyline (V2 x1 y1 : V2 x2 y2 : others) 46 | -- Return the last result. 47 | reducePolyline l@(Polyline ((_:_))) = l 48 | -- Should not happen. 49 | reducePolyline (Polyline []) = error "empty polyline" 50 | 51 | -------------------------------------------------------------------------------- /Graphics/Implicit/Export/Render/HandleSquares.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright (C) 2016, Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | {-# LANGUAGE LambdaCase #-} 6 | 7 | module Graphics.Implicit.Export.Render.HandleSquares (mergedSquareTris) where 8 | 9 | import Prelude((+), foldMap, (<>), ($), fmap, concat, (.), (==), compare, error, otherwise, concatMap) 10 | 11 | import Graphics.Implicit.Definitions (TriangleMesh(TriangleMesh, getTriangles), Triangle(Triangle)) 12 | 13 | import Graphics.Implicit.Export.Render.Definitions (TriSquare(Tris, Sq)) 14 | import Linear ( V2(V2), (*^), (^*) ) 15 | 16 | import GHC.Exts (groupWith) 17 | import Data.List (sortBy) 18 | 19 | -- We want small meshes. Essential to this, is getting rid of triangles. 20 | -- We specifically mark quads in tesselation (refer to Graphics.Implicit. 21 | -- Export.Render.Definitions, Graphics.Implicit.Export.Render.TesselateLoops) 22 | -- So that we can try and merge them together. 23 | 24 | {- Core idea of mergedSquareTris: 25 | 26 | Many Quads on Plane 27 | ____________ 28 | | | | | 29 | |____|____| | 30 | |____|____|__| 31 | 32 | | joinXaligned 33 | v 34 | ____________ 35 | | | | 36 | |_________|__| 37 | |_________|__| 38 | 39 | | joinYaligned 40 | v 41 | ____________ 42 | | | | 43 | | | | 44 | |_________|__| 45 | 46 | | joinXaligned 47 | v 48 | ____________ 49 | | | 50 | | | 51 | |____________| 52 | 53 | | squareToTri 54 | v 55 | ____________ 56 | |\ | 57 | | ---------- | 58 | |___________\| 59 | 60 | -} 61 | 62 | mergedSquareTris :: [TriSquare] -> TriangleMesh 63 | mergedSquareTris sqTris = 64 | let 65 | -- We don't need to do any work on triangles. They'll just be part of 66 | -- the list of triangles we give back. So, the triangles coming from 67 | -- triangles... 68 | triTriangles :: [Triangle] 69 | triTriangles = [tri | Tris tris <- sqTris, tri <- getTriangles tris ] 70 | -- We actually want to work on the quads, so we find those 71 | squaresFromTris :: [TriSquare] 72 | squaresFromTris = [ Sq x y z q | Sq x y z q <- sqTris ] 73 | 74 | -- Collect squares that are on the same plane. 75 | planeAligned = groupWith 76 | (\case 77 | (Sq basis z _ _) -> (basis,z) 78 | (Tris _) -> error "Unexpected Tris" 79 | ) squaresFromTris 80 | 81 | -- For each plane: 82 | -- Select for being the same range on X and then merge them on Y 83 | -- Then vice versa. 84 | joined :: [[TriSquare]] 85 | joined = fmap 86 | ( concatMap joinXaligned . groupWith 87 | (\case 88 | (Sq _ _ xS _) -> xS 89 | (Tris _) -> error "Unexpected Tris" 90 | ) 91 | . concatMap joinYaligned . groupWith 92 | (\case 93 | (Sq _ _ _ yS) -> yS 94 | (Tris _) -> error "Unexpected Tris" 95 | ) 96 | . concatMap joinXaligned . groupWith 97 | (\case 98 | (Sq _ _ xS _) -> xS 99 | (Tris _) -> error "Unexpected Tris" 100 | ) 101 | ) 102 | planeAligned 103 | -- Merge them back together, and we have the desired reult! 104 | finishedSquares = concat joined 105 | 106 | in 107 | -- merge them to triangles, and combine with the original triangles. 108 | TriangleMesh $ triTriangles <> foldMap squareToTri finishedSquares 109 | 110 | -- And now for the helper functions that do the heavy lifting... 111 | 112 | joinXaligned :: [TriSquare] -> [TriSquare] 113 | joinXaligned quads@((Sq b z xS _):_) = 114 | let 115 | orderedQuads = sortBy 116 | (\i j -> case (i, j) of 117 | (Sq _ _ _ (V2 ya _), Sq _ _ _ (V2 yb _)) -> compare ya yb 118 | _ -> error "Unexpected Tris" 119 | ) 120 | quads 121 | mergeAdjacent (pres@(Sq _ _ _ (V2 y1a y2a)) : next@(Sq _ _ _ (V2 y1b y2b)) : others) 122 | | y2a == y1b = mergeAdjacent (Sq b z xS (V2 y1a y2b) : others) 123 | | y1a == y2b = mergeAdjacent (Sq b z xS (V2 y1b y2a) : others) 124 | | otherwise = pres : mergeAdjacent (next : others) 125 | mergeAdjacent a = a 126 | in 127 | mergeAdjacent orderedQuads 128 | joinXaligned (Tris _:_) = error "Tried to join y aligned triangles." 129 | joinXaligned [] = [] 130 | 131 | joinYaligned :: [TriSquare] -> [TriSquare] 132 | joinYaligned quads@((Sq b z _ yS):_) = 133 | let 134 | orderedQuads = sortBy 135 | (\i j -> case (i, j) of 136 | (Sq _ _ (V2 xa _) _, Sq _ _ (V2 xb _) _) -> compare xa xb 137 | _ -> error "Unexpected Tris" 138 | ) 139 | quads 140 | mergeAdjacent (pres@(Sq _ _ (V2 x1a x2a) _) : next@(Sq _ _ (V2 x1b x2b) _) : others) 141 | | x2a == x1b = mergeAdjacent (Sq b z (V2 x1a x2b) yS : others) 142 | | x1a == x2b = mergeAdjacent (Sq b z (V2 x1b x2a) yS : others) 143 | | otherwise = pres : mergeAdjacent (next : others) 144 | mergeAdjacent a = a 145 | in 146 | mergeAdjacent orderedQuads 147 | joinYaligned (Tris _:_) = error "Tried to join y aligned triangles." 148 | joinYaligned [] = [] 149 | 150 | -- Deconstruct a square into two triangles. 151 | squareToTri :: TriSquare -> [Triangle] 152 | squareToTri (Sq (b1,b2,b3) z (V2 x1 x2) (V2 y1 y2)) = 153 | let 154 | zV = b3 ^* z 155 | (x1V, x2V) = (x1 *^ b1, x2 *^ b1) 156 | (y1V, y2V) = (y1 *^ b2, y2 *^ b2) 157 | a = zV + x1V + y1V 158 | b = zV + x2V + y1V 159 | c = zV + x1V + y2V 160 | d = zV + x2V + y2V 161 | in 162 | [Triangle (a,b,c), Triangle (c,b,d)] 163 | squareToTri (Tris t) = getTriangles t 164 | 165 | -------------------------------------------------------------------------------- /Graphics/Implicit/Export/Render/Interpolate.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright (C) 2016, Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | module Graphics.Implicit.Export.Render.Interpolate (interpolate) where 6 | 7 | import Prelude((*), (>), (<), (/=), (+), (-), (/), (==), (&&), abs) 8 | 9 | import Graphics.Implicit.Definitions (ℝ, Fastℕ, ℝ2) 10 | import Linear (V2(V2)) 11 | 12 | default (Fastℕ, ℝ) 13 | -- Consider a function f(x): 14 | 15 | {- 16 | | \ f(x) 17 | | - \ 18 | |_______\________ x 19 | | 20 | \ 21 | -} 22 | 23 | -- The purpose of interpolate is to find the value of x where f(x) crosses zero. 24 | -- This should be accomplished cheaply and accurately. 25 | 26 | -- We are given the constraint that x will be between a and b. 27 | 28 | -- We are also given the values of f at a and b: aval and bval. 29 | 30 | -- Additionaly, we get f (continuous and differentiable almost everywhere), 31 | -- and the resolution of the object (so that we can make decisions about 32 | -- how precise we need to be). 33 | 34 | -- While the output will never be used, interpolate will be called 35 | -- in cases where f(x) doesn't cross zero (ie. aval and bval are both 36 | -- positive or negative. 37 | 38 | -- Clarification: If f(x) crosses zero, but doesn't necessarily have 39 | -- to do so by intermediate value theorem, it is beyond the scope of this 40 | -- function. 41 | 42 | -- If it doesn't cross zero, we don't actually care what answer we give, 43 | -- just that it's cheap. 44 | 45 | -- FIXME: accept resolution on multiple axises. 46 | 47 | interpolate :: ℝ2 -> ℝ2 -> (ℝ -> ℝ) -> ℝ -> ℝ 48 | interpolate (V2 a aval) (V2 _ bval) _ _ | aval*bval > 0 = a 49 | 50 | -- The obvious: 51 | interpolate (V2 a 0) _ _ _ = a 52 | interpolate _ (V2 b 0) _ _ = b 53 | 54 | -- It may seem, at first, that our task is trivial. 55 | -- Just use linear interpolation! 56 | -- Unfortunately, there's a nasty failure case 57 | 58 | {- / 59 | / 60 | ________#________/____ 61 | ________________/ 62 | -} 63 | 64 | -- This is really common for us, for example in cubes, 65 | -- where another variable dominates. 66 | 67 | -- It may even be the case that, because we are so close 68 | -- to the side, it looks like we are really close to an 69 | -- answer... And we just give it back. 70 | 71 | -- So we need to detect this. And get free goodies while we're 72 | -- at it (shrink domain to guess within fromm (a,b) to (a',b')) 73 | -- :) 74 | 75 | interpolate (V2 a aval) (V2 b bval) f _ = 76 | -- Make sure aval > bval, then pass to interpolateLin 77 | if aval > bval 78 | then interpolateLin 0 (V2 a aval) (V2 b bval) f 79 | else interpolateLin 0 (V2 b bval) (V2 a aval) f 80 | 81 | -- Yay, linear interpolation! 82 | 83 | -- Try the answer linear interpolation gives us... 84 | -- (n is to cut us off if recursion goes too deep) 85 | interpolateLin :: Fastℕ -> ℝ2 -> ℝ2 -> (ℝ -> ℝ) -> ℝ 86 | interpolateLin n (V2 a aval) (V2 b bval) obj | aval /= bval= 87 | let 88 | -- Interpolate and evaluate 89 | mid :: ℝ 90 | mid = a + (b-a)*aval/(aval-bval) 91 | midval = obj mid 92 | -- Are we done? 93 | in if midval == 0 94 | then mid 95 | -- 96 | else let 97 | (a', a'val, b', b'val, improveRatio) = 98 | if midval > 0 99 | then (mid, midval, b, bval, midval/aval) 100 | else (a, aval, mid, midval, midval/bval) 101 | 102 | -- some times linear interpolate doesn't work, 103 | -- because one side is very close to zero and flat 104 | -- we catch it because the interval won't shrink when 105 | -- this is the case. To test this, we look at whether 106 | -- the replaced point evaluates to substantially closer 107 | -- to zero than the previous one. 108 | in if improveRatio < 0.3 && n < 4 109 | -- And we continue on. 110 | then interpolateLin (n+1) (V2 a' a'val) (V2 b' b'val) obj 111 | -- But if not, we switch to binary interpolate, which is 112 | -- immune to this problem 113 | else interpolateBin (n+1) (V2 a' a'val) (V2 b' b'val) obj 114 | 115 | -- And a fallback: 116 | interpolateLin _ (V2 a _) _ _ = a 117 | 118 | -- Now for binary searching! 119 | interpolateBin :: Fastℕ -> ℝ2 -> ℝ2 -> (ℝ -> ℝ) -> ℝ 120 | 121 | -- The termination case: 122 | 123 | interpolateBin 5 (V2 a aval) (V2 b bval) _ = 124 | if abs aval < abs bval 125 | then a 126 | else b 127 | 128 | -- Otherwise, have fun with mid! 129 | 130 | interpolateBin n (V2 a aval) (V2 b bval) f = 131 | let 132 | mid :: ℝ 133 | mid = (a+b)/2 134 | midval = f mid 135 | in if midval > 0 136 | then interpolateBin (n+1) (V2 mid midval) (V2 b bval) f 137 | else interpolateBin (n+1) (V2 a aval) (V2 mid midval) f 138 | 139 | -------------------------------------------------------------------------------- /Graphics/Implicit/Export/Render/RefineSegs.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright (C) 2016, Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | -- export one function, which refines polylines. 6 | module Graphics.Implicit.Export.Render.RefineSegs (refine) where 7 | 8 | import Prelude((<), (/), (<>), (*), ($), (&&), (-), (+), (.), (>), abs, (<=)) 9 | 10 | import Graphics.Implicit.Definitions (ℝ, ℝ2, Polyline(Polyline), minℝ, Fastℕ, Obj2) 11 | import Graphics.Implicit.Export.Util (centroid) 12 | import Linear ( Metric(norm, dot), V2(V2), normalize, (^*) ) 13 | 14 | default (Fastℕ, ℝ) 15 | 16 | -- | The purpose of refine is to add detail to a polyline aproximating 17 | -- the boundary of an implicit function and to remove redundant points. 18 | -- We break this into two steps: detail and then simplify. 19 | refine :: ℝ -> Obj2 -> Polyline -> Polyline 20 | refine res obj = simplify res . detail' res obj 21 | 22 | -- | We wrap detail to make it ignore very small segments, and to pass in 23 | -- an initial value for a depth counter argument. 24 | -- FIXME: magic number. 25 | detail' :: ℝ -> (ℝ2 -> ℝ) -> Polyline -> Polyline 26 | detail' res obj (Polyline [p1@(V2 x1 y1), p2@(V2 x2 y2)]) 27 | | (x2-x1)*(x2-x1) + (y2-y1)*(y2-y1) > res*res/200 = detail 0 res obj $ Polyline [p1,p2] 28 | detail' _ _ a = a 29 | 30 | -- | detail adds new points to a polyline to add more detail. 31 | -- FIXME: all of the magic numbers. 32 | detail :: Fastℕ -> ℝ -> (ℝ2 -> ℝ) -> Polyline -> Polyline 33 | detail n res obj (Polyline [p1, p2]) | n < 2 = 34 | let 35 | mid = centroid [p1,p2] 36 | midval = obj mid 37 | in if abs midval < res / 40 38 | then Polyline [p1, p2] 39 | else 40 | let 41 | normal = (\(V2 a b) -> V2 b (-a)) $ normalize (p2 - p1) 42 | derivN = -(obj (mid - (normal ^* (midval/2))) - midval) * (2/midval) 43 | in 44 | if abs derivN > 0.5 && abs derivN < 2 && abs (midval/derivN) < 3*res 45 | then 46 | let 47 | mid' = mid - (normal ^* (midval / derivN)) 48 | in 49 | addPolylines (detail (n+1) res obj (Polyline [p1, mid'])) (detail (n+1) res obj ( Polyline [mid', p2] )) 50 | -- NOTE: we used to have a routine for increasing the sharpness of corners here, but it was too buggy. - JEL 51 | else Polyline [p1, p2] 52 | 53 | detail _ _ _ x = x 54 | 55 | -- FIXME: re-add simplify2 and simplify3? 56 | simplify :: ℝ -> Polyline -> Polyline 57 | simplify _ = {-simplify3 . simplify2 res . -} simplify1 58 | 59 | simplify1 :: Polyline -> Polyline 60 | simplify1 (Polyline (a:b:c:xs)) = 61 | if abs ( ((b - a) `dot` (c - a)) - norm (b - a) * norm (c - a) ) <= minℝ 62 | then simplify1 (Polyline (a:c:xs)) 63 | else addPolylines (Polyline [a]) (simplify1 (Polyline (b:c:xs))) 64 | simplify1 a = a 65 | 66 | addPolylines :: Polyline -> Polyline -> Polyline 67 | addPolylines (Polyline as) (Polyline bs) = Polyline (as <> bs) 68 | 69 | {- 70 | simplify2 :: ℝ -> Polyline -> Polyline 71 | simplify2 res [a,b,c,d] = 72 | if norm (b - c) < res/10 73 | then [a, ((b + c) / (2::ℝ)), d] 74 | else [a,b,c,d] 75 | simplify2 _ a = a 76 | 77 | simplify3 (a:as) | length as > 5 = simplify3 $ a : half (init as) <> [last as] 78 | where 79 | half (a:b:xs) = a : half xs 80 | half a = a 81 | simplify3 a = a 82 | 83 | -} 84 | -------------------------------------------------------------------------------- /Graphics/Implicit/Export/Render/TesselateLoops.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright (C) 2016, Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | module Graphics.Implicit.Export.Render.TesselateLoops (tesselateLoop) where 6 | 7 | import Prelude(sum, (-), pure, ($), length, (==), zip, init, reverse, (<), (/), null, (<>), (*), abs, (+), foldMap, (&&), drop, Int) 8 | 9 | import Graphics.Implicit.Definitions (ℝ, ℕ, Obj3, ℝ3, TriangleMesh(TriangleMesh), Triangle(Triangle)) 10 | 11 | import Graphics.Implicit.Export.Render.Definitions (TriSquare(Tris)) 12 | 13 | import Graphics.Implicit.Export.Util (centroid) 14 | 15 | import Data.List (genericLength) 16 | import Linear ( cross, Metric(norm), (^*), (^/) ) 17 | 18 | tail :: [a] -> [a] 19 | tail = drop 1 20 | 21 | -- de-compose a loop into a series of triangles or squares. 22 | -- FIXME: res should be ℝ3. 23 | tesselateLoop :: ℝ -> Obj3 -> [[ℝ3]] -> [TriSquare] 24 | 25 | tesselateLoop _ _ [] = [] 26 | 27 | tesselateLoop _ _ [[a,b],[_,c],[_,_]] = [Tris $ TriangleMesh [Triangle (a,b,c)]] 28 | 29 | {- 30 | #____# #____# 31 | | | | | 32 | # # -> #____# 33 | | | | | 34 | #____# #____# 35 | -} 36 | 37 | tesselateLoop res obj [[_,_], as@(_:_:_:_),[_,_], bs@(_:_:_:_)] | length as == length bs = 38 | foldMap (tesselateLoop res obj) 39 | [[[a1,b1],[b1,b2],[b2,a2],[a2,a1]] | ((a1,b1),(a2,b2)) <- zip (init pairs) (tail pairs)] 40 | where pairs = zip (reverse as) bs 41 | 42 | tesselateLoop res obj [as@(_:_:_:_),[_,_], bs@(_:_:_:_), [_,_] ] | length as == length bs = 43 | foldMap (tesselateLoop res obj) 44 | [[[a1,b1],[b1,b2],[b2,a2],[a2,a1]] | ((a1,b1),(a2,b2)) <- zip (init pairs) (tail pairs)] 45 | where pairs = zip (reverse as) bs 46 | 47 | {- 48 | #__# 49 | | | -> if parallegram then quad 50 | #__# 51 | -} 52 | 53 | -- FIXME: this function is definately broken, resulting in floating squares. see https://github.com/colah/ImplicitCAD/issues/98 54 | 55 | {- 56 | tesselateLoop _ _ [[a,_],[b,_],[c,_],[d,_]] | centroid [a,c] == centroid [b,d] = 57 | let 58 | b1 = normalized $ a - b 59 | b2 = normalized $ c - b 60 | b3 = b1 `cross3` b2 61 | in [Sq (b1,b2,b3) (a ⋅ b3) (a ⋅ b1, c ⋅ b1) (a ⋅ b2, c ⋅ b2) ] 62 | -} 63 | 64 | {- 65 | #__# #__# 66 | | | -> | /| 67 | #__# #/_# 68 | -} 69 | -- | Create a pair of triangles from a quad. 70 | -- FIXME: magic number 71 | tesselateLoop res obj [[a,_],[b,_],[c,_],[d,_]] | obj (centroid [a,c]) < res/30 = 72 | pure $ Tris $ TriangleMesh [Triangle (a,b,c), Triangle (a,c,d)] 73 | 74 | -- Fallback case: make fans 75 | 76 | -- FIXME: magic numbers. 77 | tesselateLoop res obj pathSides = pure $ Tris $ TriangleMesh $ 78 | let 79 | path' = foldMap init pathSides 80 | (early_tris,path) = shrinkLoop 0 path' res obj 81 | in if null path 82 | then early_tris 83 | else let 84 | mid = centroid path 85 | midval = obj mid 86 | rotateList :: Int -> [a] -> [a] 87 | rotateList 0 l = l 88 | rotateList _ [] = [] 89 | rotateList _ [a] = [a] 90 | rotateList n (a:as) = rotateList (n-1) (as <> [a]) 91 | preNormal = sum 92 | [ a `cross` b | (a,b) <- zip path (rotateList 1 path) ] 93 | preNormalNorm = norm preNormal 94 | normal = preNormal ^/ preNormalNorm 95 | deriv = (obj (mid + (normal ^* (res/100)) ) - midval)/res*100 96 | mid' = mid - normal ^* (midval/deriv) 97 | midval' = obj mid' 98 | isCloserToSurface = abs midval' < abs midval 99 | isNearby = norm (mid - mid') < 2 * abs midval 100 | in if isCloserToSurface && isNearby 101 | then early_tris <> [Triangle (a,b,mid') | (a,b) <- zip path (rotateList 1 path) ] 102 | else early_tris <> [Triangle (a,b,mid) | (a,b) <- zip path (rotateList 1 path) ] 103 | 104 | shrinkLoop :: ℕ -> [ℝ3] -> ℝ -> Obj3 -> ([Triangle], [ℝ3]) 105 | 106 | shrinkLoop _ path@[a,b,c] res obj = 107 | if abs (obj $ centroid [a,b,c]) < res/50 108 | then 109 | ( [Triangle (a,b,c)], []) 110 | else 111 | ([], path) 112 | 113 | -- FIXME: magic number. 114 | shrinkLoop n path@(a:b:c:xs) res obj | n < genericLength path = 115 | if abs (obj (centroid [a,c])) < res/50 116 | then 117 | let (tris,remainder) = shrinkLoop 0 (a:c:xs) res obj 118 | in (Triangle (a,b,c):tris, remainder) 119 | else 120 | shrinkLoop (n+1) (b:c:xs <> [a]) res obj 121 | 122 | shrinkLoop _ path _ _ = ([],path) 123 | -------------------------------------------------------------------------------- /Graphics/Implicit/Export/Resolution.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright (C) 2014 2015, Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ViewPatterns #-} 7 | 8 | module Graphics.Implicit.Export.Resolution (estimateResolution) where 9 | 10 | import Prelude (min, minimum, sqrt, ($), (*), (**), (-), (/), (>)) 11 | import Data.Maybe (Maybe (Just), fromMaybe) 12 | import Graphics.Implicit (unionR) 13 | import Graphics.Implicit.Definitions (SymbolicObj2, SymbolicObj3, ℝ) 14 | import Graphics.Implicit.ExtOpenScad.Definitions (Message, OVal (ONum), VarLookup, lookupVarIn) 15 | import Graphics.Implicit.Primitives (Object (getBox)) 16 | import Linear (V2 (V2), V3 (V3)) 17 | import Linear.Affine ((.-.)) 18 | 19 | -- | Find the resolution to raytrace at. 20 | estimateResolution :: (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message]) -> ℝ 21 | estimateResolution (lookupVarIn "$res" -> Just (ONum res), _, _, _) = 22 | -- If specified, use a resolution specified by the "$res" a variable in the input file. 23 | res 24 | estimateResolution (vars, _, obj:objs, _) = 25 | -- If there was no resolution specified, use a resolution chosen for 3D objects. 26 | -- FIXME: magic numbers. 27 | let 28 | (V3 x1 y1 z1, V3 x2 y2 z2) = getBox (unionR 0 (obj:objs)) 29 | (V3 x y z) = V3 (x2-x1) (y2-y1) (z2-z1) 30 | in case fromMaybe (ONum 1) $ lookupVarIn "$quality" vars of 31 | ONum qual | qual > 0 -> min (minimum [x,y,z]/2) ((x*y*z/qual)**(1/3) / 22) 32 | _ -> min (minimum [x,y,z]/2) ((x*y*z)**(1/3) / 22) 33 | estimateResolution (vars, obj:objs, _, _) = 34 | -- ... Or use a resolution chosen for 2D objects. 35 | -- FIXME: magic numbers. 36 | let 37 | (p1,p2) = getBox (unionR 0 (obj:objs)) 38 | (V2 x y) = p2 .-. p1 39 | in case fromMaybe (ONum 1) $ lookupVarIn "$quality" vars of 40 | ONum qual | qual > 0 -> min (min x y/2) (sqrt(x*y/qual) / 30) 41 | _ -> min (min x y/2) (sqrt(x*y) / 30) 42 | estimateResolution _ = 43 | -- fallthrough value. 44 | 1 45 | -------------------------------------------------------------------------------- /Graphics/Implicit/Export/Symbolic/Rebound2.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright (C) 2016 Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | module Graphics.Implicit.Export.Symbolic.Rebound2 (rebound2) where 6 | 7 | import Graphics.Implicit.Definitions (BoxedObj2, ℝ2) 8 | 9 | import Prelude ((+), (-)) 10 | import Linear ((^/)) 11 | 12 | -- | Slightly stretch the bounding box of an object, in order to 13 | -- ensure that during mesh generation, there are no problems because 14 | -- values are right at the edge. 15 | rebound2 :: BoxedObj2 -> BoxedObj2 16 | rebound2 (obj, (a,b)) = 17 | let 18 | d :: ℝ2 19 | d = (b - a) ^/ 10 20 | in 21 | (obj, (a - d, b + d)) 22 | -------------------------------------------------------------------------------- /Graphics/Implicit/Export/Symbolic/Rebound3.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright (C) 2016 Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | module Graphics.Implicit.Export.Symbolic.Rebound3 (rebound3) where 6 | 7 | import Prelude ((-), (+)) 8 | import Graphics.Implicit.Definitions(BoxedObj3, ℝ3) 9 | import Linear ((^/)) 10 | 11 | -- | Slightly stretch the bounding box of an object, in order to 12 | -- ensure that during mesh generation, there are no problems because 13 | -- values are right at the edge. 14 | rebound3 :: BoxedObj3 -> BoxedObj3 15 | rebound3 (obj, (a,b)) = 16 | let 17 | d :: ℝ3 18 | d = (b - a) ^/ 10 19 | in 20 | (obj, (a - d, b + d)) 21 | 22 | -------------------------------------------------------------------------------- /Graphics/Implicit/Export/SymbolicObj2.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright 2016, Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | -- This file symbolicaly renders contours and contour fillings. 6 | -- If it can't, it passes the puck to a marching-squares-like 7 | -- algorithm... 8 | 9 | module Graphics.Implicit.Export.SymbolicObj2 (symbolicGetContour) where 10 | 11 | import Prelude((==), pure, fmap, ($), (/), (+), (*), cos, pi, sin, max, ceiling) 12 | 13 | import Graphics.Implicit.Definitions (objectRounding, ObjectContext, ℝ, ℝ2, Fastℕ, SymbolicObj2(Square, Circle, Shared2), SharedObj(Translate, Scale, WithRounding), Polyline(Polyline), (⋯*), fromFastℕtoℝ) 14 | 15 | import Linear ( V2(V2) ) 16 | 17 | import Graphics.Implicit.Export.Render (getContour) 18 | 19 | symbolicGetContour :: ℝ -> ObjectContext -> SymbolicObj2 -> [Polyline] 20 | symbolicGetContour _ ctx (Square (V2 dx dy)) 21 | | objectRounding ctx == 0 = [Polyline [V2 0 0, V2 dx 0, V2 dx dy, V2 0 dy, V2 0 0]] 22 | -- FIXME: magic number. 23 | symbolicGetContour res _ (Circle r) = 24 | [ Polyline 25 | [ V2 (r*cos(2*pi*fromFastℕtoℝ m/fromFastℕtoℝ n)) (r*sin(2*pi*fromFastℕtoℝ m/fromFastℕtoℝ n)) 26 | | m <- [0.. n] 27 | ] 28 | ] 29 | where 30 | n :: Fastℕ 31 | n = max 5 $ ceiling $ 2*pi*r/res 32 | symbolicGetContour res ctx (Shared2 (WithRounding r obj)) = symbolicGetContour res (ctx { objectRounding = r }) obj 33 | symbolicGetContour res ctx (Shared2 (Translate v obj)) = appOpPolylines (+ v) $ symbolicGetContour res ctx obj 34 | symbolicGetContour res ctx (Shared2 (Scale s@(V2 a b) obj)) = appOpPolylines (⋯* s) $ symbolicGetContour (res/sc) ctx obj 35 | where sc = max a b 36 | symbolicGetContour res _ obj = getContour (pure res) obj 37 | 38 | appOpPolylines :: (ℝ2 -> ℝ2) -> [Polyline] -> [Polyline] 39 | appOpPolylines op = fmap (appOpPolyline op) 40 | appOpPolyline :: (ℝ2 -> ℝ2) -> Polyline -> Polyline 41 | appOpPolyline op (Polyline xs) = Polyline $ fmap op xs 42 | 43 | -------------------------------------------------------------------------------- /Graphics/Implicit/Export/SymbolicObj3.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright 2016, Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | -- The purpose of this function is to symbolicaly compute triangle meshes using the symbolic system where possible. 6 | -- Otherwise we coerce it into an implicit function and apply our modified marching cubes algorithm. 7 | 8 | module Graphics.Implicit.Export.SymbolicObj3 (symbolicGetMesh) where 9 | 10 | import Prelude(pure, zip, length, filter, (>), ($), null, (<>), foldMap, (.), (<$>)) 11 | 12 | import Graphics.Implicit.Definitions (ℝ, ℝ3, SymbolicObj3(Shared3), SharedObj(UnionR), TriangleMesh(TriangleMesh, getTriangles)) 13 | import Graphics.Implicit.Export.Render (getMesh) 14 | import Graphics.Implicit.ObjectUtil (getBox3) 15 | import Graphics.Implicit.MathUtil(box3sWithin) 16 | 17 | import Control.Arrow(first, second) 18 | 19 | symbolicGetMesh :: ℝ -> SymbolicObj3 -> TriangleMesh 20 | symbolicGetMesh res inputObj@(Shared3 (UnionR r objs)) = TriangleMesh $ 21 | let 22 | boxes = getBox3 <$> objs 23 | boxedObjs = zip boxes objs 24 | 25 | sepFree :: [((ℝ3, ℝ3), a)] -> ([a], [a]) 26 | sepFree ((box,obj):others) = 27 | if length (filter (box3sWithin r box) boxes) > 1 28 | then first (obj : ) $ sepFree others 29 | else second (obj : ) $ sepFree others 30 | sepFree [] = ([],[]) 31 | 32 | (dependants, independents) = sepFree boxedObjs 33 | in if null independents 34 | then getTriangles $ getMesh (pure res) inputObj 35 | else if null dependants 36 | then foldMap (getTriangles . symbolicGetMesh res) independents 37 | else foldMap (getTriangles . symbolicGetMesh res) independents 38 | <> getTriangles (symbolicGetMesh res (Shared3 (UnionR r dependants))) 39 | 40 | -- If all that fails, coerce and apply marching cubes :( 41 | symbolicGetMesh res obj = getMesh (pure res) obj 42 | -------------------------------------------------------------------------------- /Graphics/Implicit/Export/TextBuilderUtils.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright 2016, Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | -- This module exists to re-export a coherent set of functions to define 6 | -- Data.Text.Lazy builders with. 7 | 8 | module Graphics.Implicit.Export.TextBuilderUtils ( 9 | -- From Data.Text.Lazy 10 | module DTL, 11 | -- From Data.Text.Lazy.Builder 12 | module DTLB, 13 | toLazyText, 14 | -- some special case Builders. 15 | bf, 16 | buildTruncFloat, 17 | buildℕ, 18 | buildInt 19 | ) where 20 | 21 | import Prelude (Maybe(Nothing, Just), Int, ($), (.)) 22 | 23 | import Graphics.Implicit.Definitions (ℝ, ℕ, fromℝtoFloat) 24 | import Data.Text.Lazy as DTL (Text, pack) 25 | 26 | import Data.Text.Internal.Lazy (defaultChunkSize) 27 | import Data.Text.Lazy.Builder as DTLB (Builder, toLazyTextWith, fromLazyText) 28 | import Data.Text.Lazy.Builder.RealFloat (formatRealFloat, FPFormat(Exponent, Fixed)) 29 | import Data.Text.Lazy.Builder.Int (decimal) 30 | 31 | -- The chunk size for toLazyText is very small (128 bytes), so we export 32 | -- a version with a much larger size (~16 K) 33 | toLazyText :: Builder -> Text 34 | toLazyText = toLazyTextWith defaultChunkSize 35 | 36 | -- | Serialize a value as a single precision float with an exponent attached. 37 | bf :: ℝ -> Text 38 | bf value = toLazyText . formatRealFloat Exponent Nothing $ fromℝtoFloat value 39 | 40 | -- | Serialize a float with four decimal places 41 | buildTruncFloat :: ℝ -> Builder 42 | buildTruncFloat = formatRealFloat Fixed $ Just 4 43 | 44 | buildℕ :: ℕ -> Builder 45 | buildℕ = decimal 46 | 47 | buildInt :: Int -> Builder 48 | buildInt = decimal 49 | 50 | -------------------------------------------------------------------------------- /Graphics/Implicit/Export/TriangleMeshFormats.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright (C) 2014, 2015, 2016 Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | -- Make string litearls more polymorphic, so we can use them with Builder. 6 | {-# LANGUAGE OverloadedStrings #-} 7 | 8 | -- This module exposes three functions, which convert a triangle mesh to an output file. 9 | module Graphics.Implicit.Export.TriangleMeshFormats (stl, binaryStl, jsTHREE) where 10 | 11 | import Prelude ((-), Float, Eq, Bool, ($), (+), (.), toEnum, length, zip, pure, (==), (||), (&&), filter, not, (<>)) 12 | 13 | import Graphics.Implicit.Definitions (Triangle(Triangle), TriangleMesh(TriangleMesh, getTriangles), ℕ, ℝ3, ℝ, fromℝtoFloat) 14 | import Graphics.Implicit.Export.TextBuilderUtils (Text, Builder, toLazyText, bf, buildℕ, fromLazyText) 15 | 16 | import Blaze.ByteString.Builder (toLazyByteString, fromByteString, fromWord32le, fromWord16le) 17 | import qualified Data.ByteString.Builder as BI (Builder, floatLE) 18 | 19 | import Data.Foldable(fold, foldMap) 20 | 21 | import Data.ByteString (replicate) 22 | import Data.ByteString.Lazy (ByteString) 23 | 24 | import Linear (normalize, cross, V3(V3)) 25 | 26 | normal :: (ℝ3,ℝ3,ℝ3) -> ℝ3 27 | normal (a,b,c) = 28 | normalize $ (b - a) `cross` (c - a) 29 | 30 | -- | Removes triangles that are empty when converting their positions to Float resolution. 31 | cleanupTris :: TriangleMesh -> TriangleMesh 32 | cleanupTris tris = 33 | let 34 | floatPoint :: V3 ℝ -> (Float, Float, Float) 35 | floatPoint (V3 a b c) = (toFloat a, toFloat b, toFloat c) 36 | 37 | -- Does this triangle fail because it is constrained on two axises? 38 | isDegenerateTri2Axis :: Eq a => ((a, a, a),(a, a, a),(a, a, a)) -> Bool 39 | isDegenerateTri2Axis tri = (ysame tri && xsame tri) || (zsame tri && ysame tri) || (zsame tri && xsame tri) 40 | where 41 | same :: Eq a => (a, a, a) -> Bool 42 | same (n1, n2, n3) = n1 == n2 && n2 == n3 43 | xsame :: Eq a => ((a, a, a), (a, a, a), (a, a, a)) -> Bool 44 | xsame ((x1,_,_),(x2,_,_),(x3,_,_)) = same (x1, x2, x3) 45 | ysame :: Eq a => ((a, a, a), (a, a, a), (a, a, a)) -> Bool 46 | ysame ((_,y1,_),(_,y2,_),(_,y3,_)) = same (y1, y2, y3) 47 | zsame :: Eq a => ((a, a, a), (a, a, a), (a, a, a)) -> Bool 48 | zsame ((_,_,z1),(_,_,z2),(_,_,z3)) = same (z1, z2, z3) 49 | isDegenerateTri :: Triangle -> Bool 50 | isDegenerateTri (Triangle (a, b, c)) = isDegenerateTri2Axis floatTri 51 | where 52 | floatTri = (floatPoint a, floatPoint b, floatPoint c) 53 | in TriangleMesh $ filter (not . isDegenerateTri) (getTriangles tris) 54 | 55 | -- | Generate an STL file is ASCII format. 56 | stl :: TriangleMesh -> Text 57 | stl triangles = toLazyText $ stlHeader <> foldMap triangle (getTriangles $ cleanupTris triangles) <> stlFooter 58 | where 59 | stlHeader :: Builder 60 | stlHeader = "solid ImplictCADExport\n" 61 | stlFooter :: Builder 62 | stlFooter = "endsolid ImplictCADExport\n" 63 | vector :: ℝ3 -> Builder 64 | vector (V3 x y z) = fromLazyText (bf x) <> " " <> fromLazyText (bf y) <> " " <> fromLazyText (bf z) 65 | vertex :: ℝ3 -> Builder 66 | vertex v = "vertex " <> vector v 67 | triangle :: Triangle -> Builder 68 | triangle (Triangle (a,b,c)) = 69 | "facet normal " <> vector (normal (a,b,c)) <> "\n" 70 | <> "outer loop\n" 71 | <> vertex a <> "\n" 72 | <> vertex b <> "\n" 73 | <> vertex c 74 | <> "\nendloop\nendfacet\n" 75 | 76 | -- | convert from ℝ to Float. 77 | toFloat :: ℝ -> Float 78 | toFloat = fromℝtoFloat 79 | 80 | -- | Generate an STL file in it's binary format. 81 | binaryStl :: TriangleMesh -> ByteString 82 | binaryStl triangles = toLazyByteString $ header <> lengthField <> foldMap triangle (getTriangles $ cleanupTris triangles) 83 | where header = fromByteString $ replicate 80 0 84 | lengthField = fromWord32le $ toEnum $ length $ getTriangles $ cleanupTris triangles 85 | triangle (Triangle (a,b,c)) = normalV (a,b,c) <> point a <> point b <> point c <> fromWord16le 0 86 | point :: ℝ3 -> BI.Builder 87 | point (V3 x y z) = BI.floatLE (toFloat x) <> BI.floatLE (toFloat y) <> BI.floatLE (toFloat z) 88 | normalV ps = point $ normal ps 89 | 90 | jsTHREE :: TriangleMesh -> Text 91 | jsTHREE triangles = toLazyText $ header <> vertcode <> facecode <> footer 92 | where 93 | -- some dense JS. Let's make helper functions so that we don't repeat code each line 94 | header :: Builder 95 | header = "var Shape = function(){\n" 96 | <> "var s = this;\n" 97 | <> "THREE.Geometry.call(this);\n" 98 | <> "function vec(x,y,z){return new THREE.Vector3(x,y,z);}\n" 99 | <> "function v(x,y,z){s.vertices.push(vec(x,y,z));}\n" 100 | <> "function f(a,b,c){" 101 | <> "s.faces.push(new THREE.Face3(a,b,c));" 102 | <> "}\n" 103 | footer :: Builder 104 | footer = "}\n" 105 | <> "Shape.prototype = new THREE.Geometry();\n" 106 | <> "Shape.prototype.constructor = Shape;\n" 107 | -- A vertex line; v (0.0, 0.0, 1.0) = "v(0.0,0.0,1.0);\n" 108 | v :: ℝ3 -> Builder 109 | v (V3 x y z) = "v(" <> fromLazyText (bf x) <> "," <> fromLazyText (bf y) <> "," <> fromLazyText (bf z) <> ");\n" 110 | -- A face line 111 | f :: ℕ -> ℕ -> ℕ -> Builder 112 | f posa posb posc = 113 | "f(" <> buildℕ posa <> "," <> buildℕ posb <> "," <> buildℕ posc <> ");" 114 | verts = do 115 | -- extract the vertices for each triangle 116 | -- recall that a normed triangle is of the form ((vert, norm), ...) 117 | (Triangle (a,b,c)) <- getTriangles $ cleanupTris triangles 118 | -- The vertices from each triangle take up 3 position in the resulting list 119 | [a,b,c] 120 | vertcode = foldMap v verts 121 | facecode = fold $ do 122 | (n,_) <- zip [0, 3 ..] $ getTriangles $ cleanupTris triangles 123 | let 124 | (posa, posb, posc) = (n, n+1, n+2) :: (ℕ, ℕ, ℕ) 125 | pure $ f posa posb posc 126 | -------------------------------------------------------------------------------- /Graphics/Implicit/Export/Util.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright 2016, Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | -- For the definition of centroid. 6 | {-# LANGUAGE FlexibleContexts #-} 7 | 8 | -- Functions to make meshes/polylines finer. 9 | 10 | module Graphics.Implicit.Export.Util (normTriangle, normVertex, centroid) where 11 | 12 | import Prelude(Num, Applicative, Foldable, pure, (+), Fractional, (/), (-), realToFrac, length) 13 | 14 | import Graphics.Implicit.Definitions (ℝ, ℝ3, Obj3, Triangle(Triangle), NormedTriangle(NormedTriangle)) 15 | import Linear ((*^), (^/), normalize, V3(V3)) 16 | import Data.List (foldl') 17 | 18 | -- Change the default for bare numbers in this file. 19 | default (ℝ) 20 | 21 | -- FIXME: magic numbers. 22 | normTriangle :: ℝ -> Obj3 -> Triangle -> NormedTriangle 23 | normTriangle res obj (Triangle (a,b,c)) = 24 | NormedTriangle ((a, normify a'), (b, normify b'), (c, normify c')) 25 | where 26 | normify = normVertex res obj 27 | a' = (a + r*^b + r*^c) ^/ 1.02 28 | b' = (b + r*^a + r*^c) ^/ 1.02 29 | c' = (c + r*^b + r*^a) ^/ 1.02 30 | r :: ℝ 31 | r = 0.01 32 | 33 | -- FIXME: magic numbers. 34 | normVertex :: ℝ -> Obj3 -> ℝ3 -> ℝ3 35 | normVertex res obj p = 36 | let 37 | -- D_vf(p) = ( f(p) - f(p+v) ) /|v| 38 | -- but we'll actually scale v by res, so then |v| = res 39 | -- and that f is obj 40 | -- and is fixed at p 41 | -- so actually: d v = ... 42 | d :: ℝ3 -> ℝ 43 | d v = ( obj (p + (res/100)*^v) - obj (p - (res/100)*^v) ) / (res/50) 44 | dx = d (V3 1 0 0) 45 | dy = d (V3 0 1 0) 46 | dz = d (V3 0 0 1) 47 | in normalize (V3 dx dy dz) 48 | 49 | -- Get a centroid of a series of points. 50 | centroid :: (Fractional a, Foldable t, Applicative f, Num (f a)) => t (f a) -> f a 51 | centroid pts = foldl' (+) (pure 0) pts ^/ realToFrac (length pts) 52 | {-# INLINABLE centroid #-} 53 | 54 | -------------------------------------------------------------------------------- /Graphics/Implicit/ExtOpenScad.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright (C) 2014 2015 2016, Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | -- An executor, which parses openscad code, and executes it. 6 | module Graphics.Implicit.ExtOpenScad (runOpenscad) where 7 | 8 | import Prelude(String, IO, ($), (<$>), pure, either, (.), Applicative, Bool(True), Maybe, maybe) 9 | 10 | import Graphics.Implicit.Definitions (SymbolicObj2, SymbolicObj3) 11 | 12 | import Graphics.Implicit.ExtOpenScad.Definitions (VarLookup, ScadOpts, Message(Message), MessageType(SyntaxError), CompState(CompState, scadVars, oVals), StatementI, runImplicitCadM) 13 | 14 | import Graphics.Implicit.ExtOpenScad.Parser.Statement (parseProgram) 15 | 16 | import Graphics.Implicit.ExtOpenScad.Parser.Util (sourcePosition) 17 | 18 | import Graphics.Implicit.ExtOpenScad.Eval.Statement (runStatementI) 19 | 20 | import Graphics.Implicit.ExtOpenScad.Eval.Constant (addConstants) 21 | 22 | import Graphics.Implicit.ExtOpenScad.Util.OVal (divideObjs) 23 | 24 | import Text.Parsec.Error (errorPos, errorMessages, showErrorMessages, ParseError) 25 | 26 | import System.Directory (getCurrentDirectory) 27 | 28 | import Data.Foldable (traverse_) 29 | 30 | import Data.Text.Lazy (pack) 31 | import System.FilePath (FilePath, takeDirectory) 32 | 33 | -- | Small wrapper of our parser to handle parse errors, etc. 34 | runOpenscad :: ScadOpts -> [String] -> Maybe FilePath -> String -> IO (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message]) 35 | runOpenscad scadOpts constants filepath source = do 36 | (initialObjects, initialMessages) <- addConstants constants True 37 | let 38 | err :: Applicative f => ParseError -> f (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message]) 39 | err e = pure (initialObjects, [], [], mesg e : initialMessages) 40 | run :: [StatementI] -> IO (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message]) 41 | run sts = rearrange <$> do 42 | let sts' = traverse_ runStatementI sts 43 | -- If we are given a filepath, use its directory, relative or absolute. 44 | -- If there is no filepath given, then use the current directory of the process. 45 | path <- maybe getCurrentDirectory (pure . takeDirectory) filepath 46 | let initState = CompState initialObjects [] path 47 | (_, w, s') <- runImplicitCadM scadOpts initState sts' 48 | pure (w, s') 49 | either err run $ parseProgram "" source 50 | where 51 | rearrange :: ([Message], CompState) -> (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message]) 52 | rearrange (messages, s) = 53 | let (obj2s, obj3s, _) = divideObjs $ oVals s 54 | in (scadVars s, obj2s, obj3s, messages) 55 | show' = showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" . errorMessages 56 | mesg e = Message SyntaxError (sourcePosition $ errorPos e) $ pack $ show' e 57 | -------------------------------------------------------------------------------- /Graphics/Implicit/ExtOpenScad/Eval/Constant.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright (C) 2016, Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | module Graphics.Implicit.ExtOpenScad.Eval.Constant (addConstants, runExpr) where 6 | 7 | import Prelude (String, IO, ($), pure, (+), Either, Bool(False), (.), either, (<$>), (<*), (<*>)) 8 | 9 | import Data.Foldable (traverse_, foldlM) 10 | 11 | import Graphics.Implicit.Definitions (Fastℕ) 12 | 13 | import Graphics.Implicit.ExtOpenScad.Definitions ( 14 | Pattern, 15 | Expr, 16 | VarLookup, 17 | Message(Message), 18 | MessageType(SyntaxError), 19 | StateC, 20 | ScadOpts(ScadOpts), 21 | CompState(CompState, scadVars), 22 | SourcePosition(SourcePosition), 23 | OVal(OUndefined), 24 | varUnion, runImplicitCadM 25 | ) 26 | 27 | import Graphics.Implicit.ExtOpenScad.Util.StateC (modifyVarLookup, addMessage) 28 | 29 | import Graphics.Implicit.ExtOpenScad.Parser.Expr (expr0) 30 | 31 | import Graphics.Implicit.ExtOpenScad.Eval.Expr (evalExpr, matchPat, rawRunExpr) 32 | 33 | import Graphics.Implicit.ExtOpenScad.Default (defaultObjects) 34 | 35 | import Control.Monad ((>>=)) 36 | 37 | import Control.Monad.IO.Class (liftIO) 38 | 39 | import System.Directory (getCurrentDirectory) 40 | 41 | import Text.Parsec (SourceName, parse, ParseError) 42 | 43 | import Text.Parsec.Error (errorMessages, showErrorMessages) 44 | 45 | import Data.Text.Lazy (pack) 46 | 47 | import Graphics.Implicit.ExtOpenScad.Parser.Util (patternMatcher) 48 | 49 | import Graphics.Implicit.ExtOpenScad.Parser.Lexer (matchTok) 50 | 51 | -- | Define variables used during the extOpenScad run. 52 | addConstants :: [String] -> Bool -> IO (VarLookup, [Message]) 53 | addConstants constants withCSG = do 54 | path <- getCurrentDirectory 55 | let initState = CompState (defaultObjects withCSG) [] path 56 | (_, messages, s) <- liftIO . 57 | runImplicitCadM opts initState $ execAssignments constants 58 | pure (scadVars s, messages) 59 | where 60 | opts = ScadOpts False False 61 | show' = showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" . errorMessages 62 | execAssignments :: [String] -> StateC Fastℕ 63 | execAssignments = foldlM execAssignment 0 64 | execAssignment :: Fastℕ -> String -> StateC Fastℕ 65 | execAssignment count assignment = do 66 | let pos = SourcePosition count 1 "cmdline_constants" 67 | err = addMessage SyntaxError pos . pack . show' 68 | run (k, e) = evalExpr pos e >>= traverse_ (modifyVarLookup . varUnion) . matchPat k 69 | either err run $ parseAssignment "cmdline_constant" assignment 70 | pure $ count + 1 71 | parseAssignment :: SourceName -> String -> Either ParseError (Pattern, Expr) 72 | parseAssignment = parse $ (,) <$> patternMatcher <* matchTok '=' <*> expr0 73 | 74 | -- | Evaluate an expression. 75 | runExpr :: String -> Bool -> (OVal, [Message]) 76 | runExpr expression withCSG = do 77 | either oUndefined run $ parse expr0 "raw_expression" expression 78 | where 79 | run = rawRunExpr initPos (defaultObjects withCSG) 80 | initPos = SourcePosition 1 1 "raw_expression" 81 | show' = showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" . errorMessages 82 | oUndefined e = (OUndefined, [Message SyntaxError initPos $ pack $ show' e]) 83 | -------------------------------------------------------------------------------- /Graphics/Implicit/ExtOpenScad/Parser/Lexer.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright (C) 2016, Kelvin Cookshaw (kelvin@cookshaw.com) 3 | -- Copyright 2014 2015 2016, Julia Longtin (julial@turinglace.com) 4 | -- Released under the GNU AGPLV3+, see LICENSE 5 | 6 | -- Allow us to use string literals for Text 7 | {-# LANGUAGE OverloadedStrings #-} 8 | 9 | module Graphics.Implicit.ExtOpenScad.Parser.Lexer (whiteSpace, matchTrue, matchFalse, matchFunction, matchInclude, matchUse, matchIf, matchElse, matchModule, matchLet, matchUndef, matchTok, matchColon, matchSemi, matchComma, matchIdentifier, surroundedBy, matchLT, matchLE, matchGT, matchGE, matchEQ, matchNE, matchCAT, matchOR, matchAND, matchEXP, matchEach, lexer) where 10 | 11 | import Prelude (String, Char, Bool(True), (>>), pure, not, (&&), ($)) 12 | 13 | import Data.List (notElem) 14 | 15 | import Data.Char (isSpace) 16 | 17 | import Data.Functor.Identity (Identity) 18 | 19 | import Text.Parsec.String (GenParser) 20 | 21 | import qualified Text.Parsec.Token as P (whiteSpace, reserved, identifier, reservedOp) 22 | 23 | import Text.Parsec.Language (GenLanguageDef, emptyDef) 24 | 25 | import Text.Parsec.Token (GenTokenParser, makeTokenParser, commentStart, commentEnd, commentLine, nestedComments, caseSensitive, colon, semi, comma, identStart, identLetter, reservedNames, reservedOpNames) 26 | 27 | import Text.Parsec (char, between) 28 | 29 | import Text.Parsec.Char (satisfy) 30 | 31 | import Data.Text.Lazy (Text) 32 | 33 | -- The definition of openscad used by parsec. 34 | openScadStyle :: GenLanguageDef String u0 Identity 35 | openScadStyle 36 | = emptyDef 37 | { commentStart = "/*" 38 | , commentEnd = "*/" 39 | , commentLine = "//" 40 | , nestedComments = True 41 | , identStart = satisfy $ \c -> notElem c (",|[]{}()+-*&^%#@!~`'\"\\/;:.,<>?=1234567890" :: String) && not (isSpace c) 42 | , identLetter = satisfy $ \c -> notElem c (",|[]{}()+-*&^%#@!~`'\"\\/;:.,<>?=" :: String) && not (isSpace c) 43 | , reservedNames = ["module", "function", "if", "else", "let", "each", "true", "false", "undef", "include", "use"] 44 | , reservedOpNames= ["<=", ">=", "==", "!=", "&&", "||", "++", "^", "<", ">"] 45 | , caseSensitive = True 46 | } 47 | 48 | lexer :: GenTokenParser String st Identity 49 | lexer = makeTokenParser openScadStyle 50 | 51 | -- | Consume whitespace. 52 | whiteSpace :: GenParser Char st () 53 | whiteSpace = P.whiteSpace lexer 54 | 55 | -- | Match the module keyword. 56 | matchModule :: GenParser Char st () 57 | matchModule = P.reserved lexer "module" 58 | 59 | -- | Match the function keyword. 60 | matchFunction :: GenParser Char st () 61 | matchFunction = P.reserved lexer "function" 62 | 63 | -- | Match the if keyword. 64 | matchIf :: GenParser Char st () 65 | matchIf = P.reserved lexer "if" 66 | 67 | -- | Match the else keyword. 68 | matchElse :: GenParser Char st () 69 | matchElse = P.reserved lexer "else" 70 | 71 | -- | Match the let keyword. 72 | matchLet :: GenParser Char st () 73 | matchLet = P.reserved lexer "let" 74 | 75 | -- | Match the each keyword. 76 | matchEach :: GenParser Char st () 77 | matchEach = P.reserved lexer "each" 78 | 79 | -- | Match boolean true. 80 | matchTrue :: GenParser Char st () 81 | matchTrue = P.reserved lexer "true" 82 | 83 | -- | Match boolean false 84 | matchFalse :: GenParser Char st () 85 | matchFalse = P.reserved lexer "false" 86 | 87 | -- | Match the undef keyword. 88 | matchUndef :: GenParser Char st () 89 | matchUndef = P.reserved lexer "undef" 90 | 91 | -- | Match the include keyword. 92 | matchInclude :: GenParser Char st () 93 | matchInclude = P.reserved lexer "include" 94 | 95 | -- | Match the use keyword. 96 | matchUse :: GenParser Char st () 97 | matchUse = P.reserved lexer "use" 98 | 99 | -- | match a single character token followed by whitespace. 100 | matchTok :: Char -> GenParser Char st Char 101 | matchTok x = do 102 | y <- char x 103 | _ <- whiteSpace 104 | pure y 105 | --matchTok tok = lexeme lexer $ symbol lexer [tok] 106 | 107 | -- | match a colon. 108 | matchColon :: GenParser Char st Text 109 | matchColon = colon lexer >> pure ":" 110 | 111 | -- | match a semicolon. 112 | matchSemi :: GenParser Char st Text 113 | matchSemi = semi lexer >> pure ";" 114 | 115 | -- | match a comma. 116 | matchComma :: GenParser Char st Text 117 | matchComma = comma lexer >> pure "," 118 | 119 | -- | Match operators. 120 | matchLE :: GenParser Char st Text 121 | matchLE = P.reservedOp lexer "<=" >> pure "<=" 122 | matchLT :: GenParser Char st Text 123 | matchLT = P.reservedOp lexer "<" >> pure "<" 124 | matchGE :: GenParser Char st Text 125 | matchGE = P.reservedOp lexer ">=" >> pure ">=" 126 | matchGT :: GenParser Char st Text 127 | matchGT = P.reservedOp lexer ">" >> pure ">" 128 | matchEQ :: GenParser Char st Text 129 | matchEQ = P.reservedOp lexer "==" >> pure "==" 130 | matchNE :: GenParser Char st Text 131 | matchNE = P.reservedOp lexer "!=" >> pure "!=" 132 | matchAND :: GenParser Char st Text 133 | matchAND = P.reservedOp lexer "&&" >> pure "&&" 134 | matchOR :: GenParser Char st Text 135 | matchOR = P.reservedOp lexer "||" >> pure "||" 136 | matchCAT :: GenParser Char st Text 137 | matchCAT = P.reservedOp lexer "++" >> pure "++" 138 | matchEXP :: GenParser Char st Char 139 | matchEXP = P.reservedOp lexer "^" >> pure '^' 140 | 141 | -- | match something between two ends. 142 | surroundedBy :: Char -> GenParser Char st a -> Char -> GenParser Char st a 143 | surroundedBy leftTok middle rightTok = between (matchTok leftTok) (matchTok rightTok) middle 144 | 145 | -- | match an identifier. variable name, function name, module name, etc. 146 | matchIdentifier :: GenParser Char st String 147 | matchIdentifier = P.identifier lexer 148 | -------------------------------------------------------------------------------- /Graphics/Implicit/ExtOpenScad/Parser/Util.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright (C) 2016 Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | -- Allow us to use string literals for Text 6 | {-# LANGUAGE OverloadedStrings #-} 7 | 8 | module Graphics.Implicit.ExtOpenScad.Parser.Util ((*<|>), (?:), tryMany, patternMatcher, sourcePosition, number, variable, boolean, scadString, scadUndefined) where 9 | 10 | import Prelude (String, Char, ($), foldl1, fmap, (.), pure, (*>), Bool(True, False), read, (**), (*), (==), (<>), (<$>), (<$)) 11 | 12 | import Text.Parsec (SourcePos, (<|>), (), try, char, sepBy, noneOf, string, many, digit, many1, optional, choice, option, oneOf, between) 13 | 14 | import Text.Parsec.String (GenParser) 15 | 16 | import qualified Text.Parsec as P (sourceLine, sourceColumn, sourceName) 17 | 18 | import Text.Parsec.Prim (ParsecT) 19 | 20 | import Data.Functor.Identity (Identity) 21 | 22 | import Graphics.Implicit.ExtOpenScad.Definitions (Pattern(Wild, Name, ListP), SourcePosition(SourcePosition), Symbol(Symbol), Expr(LitE, Var), OVal(ONum, OString, OBool, OUndefined)) 23 | 24 | import Graphics.Implicit.Definitions (toFastℕ) 25 | 26 | -- The lexer. 27 | import Graphics.Implicit.ExtOpenScad.Parser.Lexer (matchIdentifier, matchTok, matchUndef, matchTrue, matchFalse, whiteSpace, surroundedBy, matchComma) 28 | 29 | import Data.Functor (($>)) 30 | 31 | import Data.Text.Lazy (pack) 32 | 33 | infixr 1 *<|> 34 | (*<|>) :: GenParser tok u a -> ParsecT [tok] u Identity a -> ParsecT [tok] u Identity a 35 | a *<|> b = try a <|> b 36 | 37 | infixr 2 ?: 38 | (?:) :: String -> ParsecT s u m a -> ParsecT s u m a 39 | l ?: p = p l 40 | 41 | tryMany :: [GenParser tok u a] -> ParsecT [tok] u Identity a 42 | tryMany = foldl1 (<|>) . fmap try 43 | 44 | -- | A pattern parser 45 | patternMatcher :: GenParser Char st Pattern 46 | patternMatcher = "pattern" ?: 47 | (Wild <$ char '_') 48 | <|> ( Name . Symbol . pack <$> matchIdentifier) 49 | <|> ( ListP <$> surroundedBy '[' (patternMatcher `sepBy` matchComma) ']' ) 50 | 51 | -- expression parsers 52 | 53 | -- | Parse a number. 54 | number :: GenParser Char st Expr 55 | number = ("number" ?:) $ do 56 | h <- choice 57 | [ 58 | do 59 | a <- many1 digit 60 | b <- option "" ( ('.':) <$> (char '.' *> many1 digit) ) 61 | pure (a <> b) 62 | , 63 | ("0." <>) <$> (char '.' *> many1 digit) 64 | ] 65 | d <- option "0" 66 | ( 67 | oneOf "eE" *> choice 68 | [ 69 | ('-':) <$> (char '-' *> many1 digit) 70 | , 71 | optional (char '+') *> many1 digit 72 | ] 73 | ) 74 | _ <- whiteSpace 75 | pure . LitE $ ONum $ if d == "0" 76 | then read h 77 | else read h * (10 ** read d) 78 | 79 | -- | Parse a variable reference. 80 | -- NOTE: abused by the parser for function calls. 81 | variable :: GenParser Char st Expr 82 | variable = "variable" ?: 83 | Var . Symbol . pack <$> matchIdentifier 84 | 85 | -- | Parse a true or false value. 86 | boolean :: GenParser Char st Expr 87 | boolean = "boolean" ?: 88 | LitE . OBool <$> (matchTrue $> True <|> matchFalse $> False) 89 | 90 | -- | Parse a quoted string. 91 | -- FIXME: no @\u@ unicode support? 92 | scadString :: GenParser Char st Expr 93 | scadString = "string" ?: LitE . OString . pack <$> 94 | between 95 | (char '"') 96 | (matchTok '"') 97 | (many $ 98 | (string "\\\"" $> '\"') *<|> 99 | (string "\\n" $> '\n') *<|> 100 | (string "\\r" $> '\r') *<|> 101 | (string "\\t" $> '\t') *<|> 102 | (string "\\\\" $> '\\') *<|> 103 | noneOf "\"\n" 104 | ) 105 | 106 | scadUndefined :: GenParser Char st Expr 107 | scadUndefined = "undefined" ?: 108 | LitE OUndefined <$ matchUndef 109 | 110 | sourcePosition :: SourcePos -> SourcePosition 111 | sourcePosition pos = SourcePosition (toFastℕ $ P.sourceLine pos) (toFastℕ $ P.sourceColumn pos) (P.sourceName pos) 112 | -------------------------------------------------------------------------------- /Graphics/Implicit/ExtOpenScad/Util/ArgParser.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright (C) 2016, Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | -- FIXME: why is this required? 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | 8 | -- Allow us to use string literals for Text 9 | {-# LANGUAGE OverloadedStrings #-} 10 | 11 | module Graphics.Implicit.ExtOpenScad.Util.ArgParser (argument, doc, defaultTo, example, test, eulerCharacteristic, argMap) where 12 | 13 | -- imported twice, once qualified. null from Data.Map conflicts with null from Prelude. 14 | import Prelude(String, Maybe(Just, Nothing), ($), (<>), show, return, fmap, snd, filter, (.), fst, foldl1, not, (&&), (<$>), maybe) 15 | import qualified Prelude as P (null) 16 | 17 | import Graphics.Implicit.ExtOpenScad.Definitions (ArgParser(AP, APTest, APBranch, APTerminator, APFail, APExample), OVal (OError), TestInvariant(EulerCharacteristic), Symbol, VarLookup(VarLookup)) 18 | 19 | import Graphics.Implicit.ExtOpenScad.Util.OVal (fromOObj, toOObj, OTypeMirror) 20 | 21 | import Graphics.Implicit.Definitions(ℕ) 22 | 23 | -- imported twice, once qualified. null from Data.Map conflicts with null from Prelude. 24 | import Data.Map (fromList, lookup, delete) 25 | import qualified Data.Map as DM (null) 26 | 27 | import Data.Maybe (isNothing, fromJust, isJust) 28 | 29 | import Data.Text.Lazy (Text, pack, unpack) 30 | 31 | import Control.Arrow (first) 32 | 33 | -- * ArgParser building functions 34 | 35 | -- ** argument and combinators 36 | 37 | -- | Builds an argparser for the type that is expected from it. 38 | -- FIXME: make a version of this that accepts multiple symbol names, so we can have h= and height= 39 | argument :: forall desiredType. (OTypeMirror desiredType) => Symbol -> ArgParser desiredType 40 | argument name = 41 | AP name Nothing "" $ \oObjVal -> do 42 | let 43 | val :: Maybe desiredType 44 | val = fromOObj oObjVal 45 | errmsg :: Text 46 | errmsg = case oObjVal of 47 | OError err -> "error in computing value for argument " <> pack (show name) 48 | <> ": " <> err 49 | _ -> "arg " <> pack (show oObjVal) <> " not compatible with " <> pack (show name) 50 | maybe (APFail errmsg) APTerminator val 51 | {-# INLINABLE argument #-} 52 | 53 | -- | Inline documentation. 54 | doc :: forall a. ArgParser a -> Text -> ArgParser a 55 | doc (AP name defMaybeVal _ next) newDoc = AP name defMaybeVal newDoc next 56 | doc _ _ = APFail "Impossible! doc" 57 | 58 | -- | An inline default value. 59 | defaultTo :: forall a. (OTypeMirror a) => ArgParser a -> a -> ArgParser a 60 | defaultTo (AP name _ doc' next) newDefVal = 61 | AP name (Just $ toOObj newDefVal) doc' next 62 | defaultTo _ _ = APFail "Impossible! defaultTo" 63 | 64 | -- | An inline example. 65 | example :: Text -> ArgParser () 66 | example str = APExample str (return ()) 67 | 68 | -- | Inline test and combinators. 69 | test :: Text -> ArgParser () 70 | test str = APTest str [] (return ()) 71 | 72 | eulerCharacteristic :: ArgParser a -> ℕ -> ArgParser a 73 | eulerCharacteristic (APTest str tests child) χ = 74 | APTest str (EulerCharacteristic χ : tests) child 75 | eulerCharacteristic _ _ = APFail "Impossible! eulerCharacteristic" 76 | 77 | -- * Tools for handeling ArgParsers 78 | 79 | -- | Apply arguments to an ArgParser 80 | argMap :: 81 | [(Maybe Symbol, OVal)] -- ^ arguments 82 | -> ArgParser a -- ^ ArgParser to apply them to 83 | -> (Maybe a, [String]) -- ^ (result, error messages) 84 | argMap args = argMap2 unnamedArgs (VarLookup $ fromList namedArgs) where 85 | unnamedArgs = snd <$> filter (isNothing . fst) args 86 | namedArgs = first fromJust <$> filter (isJust . fst) args 87 | 88 | argMap2 :: [OVal] -> VarLookup -> ArgParser a -> (Maybe a, [String]) 89 | argMap2 unnamedArgs namedArgs (APBranch branches) = 90 | foldl1 merge solutions where 91 | solutions = fmap (argMap2 unnamedArgs namedArgs) branches 92 | merge :: forall a. (Maybe a, [String]) -> (Maybe a, [String]) -> (Maybe a, [String]) 93 | merge a@(Just _, []) _ = a 94 | merge _ b@(Just _, []) = b 95 | merge a@(Just _, _) _ = a 96 | merge (Nothing, _) a = a 97 | 98 | -- FIXME: don't use delete directly here, wrap it in StateC.hs 99 | -- FIXME: generate a warning. 100 | argMap2 unnamedArgs (VarLookup namedArgs) (AP name fallback _ f) = 101 | case lookup name namedArgs of 102 | Just a -> argMap2 103 | unnamedArgs 104 | (VarLookup $ delete name namedArgs) 105 | (f a) 106 | Nothing -> case unnamedArgs of 107 | x:xs -> argMap2 xs (VarLookup namedArgs) (f x) 108 | [] -> case fallback of 109 | Just b -> argMap2 [] (VarLookup namedArgs) (f b) 110 | Nothing -> (Nothing, ["No value and no default for argument " <> show name]) 111 | 112 | -- FIXME: don't use map.null here, wrap it in StateC.hs. 113 | -- FIXME: generate a warning. 114 | argMap2 a (VarLookup b) (APTerminator val) = 115 | (Just val, ["Unused arguments" | not (P.null a && DM.null b)]) 116 | 117 | argMap2 _ _ (APFail err) = (Nothing, [unpack err]) 118 | 119 | argMap2 a b (APExample _ child) = argMap2 a b child 120 | 121 | argMap2 a b (APTest _ _ child) = argMap2 a b child 122 | -------------------------------------------------------------------------------- /Graphics/Implicit/ExtOpenScad/Util/StateC.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright 2016, Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | module Graphics.Implicit.ExtOpenScad.Util.StateC (addMessage, getVarLookup, modifyVarLookup, lookupVar, pushVals, getVals, putVals, withPathShiftedBy, getPath, getRelPath, errorC, warnC, scadOptions) where 6 | 7 | import Prelude(FilePath, Maybe, ($), (<>), pure) 8 | 9 | import Graphics.Implicit.ExtOpenScad.Definitions(VarLookup(VarLookup), OVal, Symbol, SourcePosition, Message(Message), MessageType(Error, Warning), ScadOpts, StateC, CompState(scadVars, oVals, sourceDir)) 10 | 11 | import Data.Map (lookup) 12 | 13 | import Data.Text.Lazy (Text) 14 | 15 | import Control.Monad.State (modify, gets) 16 | 17 | import System.FilePath(()) 18 | import Control.Monad.Writer (tell) 19 | import Control.Monad.Reader.Class (ask) 20 | 21 | getVarLookup :: StateC VarLookup 22 | getVarLookup = gets scadVars 23 | 24 | modifyVarLookup :: (VarLookup -> VarLookup) -> StateC () 25 | modifyVarLookup f = modify $ \c -> c { scadVars = f $ scadVars c } 26 | 27 | -- | Perform a variable lookup 28 | -- FIXME: generate a warning when we look up a variable that is not present. 29 | lookupVar :: Symbol -> StateC (Maybe OVal) 30 | lookupVar name = do 31 | (VarLookup varlookup) <- getVarLookup 32 | pure $ lookup name varlookup 33 | 34 | pushVals :: [OVal] -> StateC () 35 | pushVals vals = modify $ \c -> c { oVals = vals <> oVals c } 36 | 37 | getVals :: StateC [OVal] 38 | getVals = gets oVals 39 | 40 | putVals :: [OVal] -> StateC () 41 | putVals vals = modify $ \c -> c { oVals = vals } 42 | 43 | withPathShiftedBy :: FilePath -> StateC a -> StateC a 44 | withPathShiftedBy pathShift s = do 45 | path <- getPath 46 | modify $ \c -> c { sourceDir = path pathShift } 47 | x <- s 48 | modify $ \c -> c { sourceDir = path } 49 | pure x 50 | 51 | -- | Pure the path stored in the state. 52 | getPath :: StateC FilePath 53 | getPath = gets sourceDir 54 | 55 | getRelPath :: FilePath -> StateC FilePath 56 | getRelPath relPath = do 57 | path <- getPath 58 | pure $ path relPath 59 | 60 | -- Add a single message to the list of messages being returned 61 | addMesg :: Message -> StateC () 62 | addMesg m = tell [m] 63 | 64 | addMessage :: MessageType -> SourcePosition -> Text -> StateC () 65 | addMessage mtype pos text = addMesg $ Message mtype pos text 66 | 67 | errorC :: SourcePosition -> Text -> StateC () 68 | errorC = addMessage Error 69 | {-# INLINABLE errorC #-} 70 | 71 | warnC :: SourcePosition -> Text -> StateC () 72 | warnC = addMessage Warning 73 | {-# INLINABLE warnC #-} 74 | 75 | -- Get the ScadOpts from the Reader in ImplicitCadM 76 | scadOptions :: StateC ScadOpts 77 | scadOptions = ask 78 | -------------------------------------------------------------------------------- /Graphics/Implicit/FastIntUtil.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright 2014-2019, Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | -- Use existing instances for the wrapped types rather than manually manking them 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | 8 | module Graphics.Implicit.FastIntUtil (Fastℕ(Fastℕ), toFastℕ, fromFastℕ) where 9 | 10 | import Prelude (Integral, Num, Eq, Ord, Enum, Real, Show, Read, Int, id) 11 | 12 | class FastN n where 13 | fromFastℕ :: Fastℕ -> n 14 | toFastℕ :: n -> Fastℕ 15 | 16 | instance FastN Int where 17 | fromFastℕ (Fastℕ a) = a 18 | {-# INLINABLE fromFastℕ #-} 19 | toFastℕ = Fastℕ 20 | {-# INLINABLE toFastℕ #-} 21 | 22 | instance FastN Fastℕ where 23 | fromFastℕ = id 24 | {-# INLINABLE fromFastℕ #-} 25 | toFastℕ = id 26 | {-# INLINABLE toFastℕ #-} 27 | 28 | -- System integers, meant to go fast, and have no chance of wrapping 2^31. 29 | newtype Fastℕ = Fastℕ Int 30 | deriving (Show, Read, Eq, Ord, Num, Enum, Integral, Real) 31 | -------------------------------------------------------------------------------- /Graphics/Implicit/IntegralUtil.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright 2014-2019, Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | -- Lift the numeric instances where we can 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | -- Suppress a warning about the derived Integral instance 8 | {-# OPTIONS_GHC -Wno-identities #-} 9 | 10 | module Graphics.Implicit.IntegralUtil (ℕ, toℕ, fromℕ) where 11 | 12 | import Prelude (Integral, Integer, Int, Show, Read, Eq, Ord, Num, Enum, Integral, Real, ($), fromIntegral, (.)) 13 | 14 | -- So we can produce an instance of Fastℕ for ℕ. 15 | import Graphics.Implicit.FastIntUtil (Fastℕ(Fastℕ)) 16 | 17 | -- the N typeclass. only used to define the ℕ type. 18 | class (Integral n) => N n where 19 | fromℕ :: ℕ -> n 20 | toℕ :: n -> ℕ 21 | 22 | instance N Integer where 23 | fromℕ (ℕ a) = a 24 | {-# INLINABLE fromℕ #-} 25 | toℕ = ℕ 26 | {-# INLINABLE toℕ #-} 27 | 28 | instance N Fastℕ where 29 | fromℕ (ℕ a) = Fastℕ $ fromIntegral a 30 | {-# INLINABLE fromℕ #-} 31 | toℕ = ℕ . fromIntegral 32 | {-# INLINABLE toℕ #-} 33 | 34 | instance N Int where 35 | fromℕ (ℕ a) = fromIntegral a 36 | {-# INLINABLE fromℕ #-} 37 | toℕ = ℕ . fromIntegral 38 | {-# INLINABLE toℕ #-} 39 | 40 | -- Arbitrary precision integers. To be used for anything countable, or in ratios. 41 | -- When Read and Show instances exist on a given type they need to satisfy 42 | -- read . show = id 43 | newtype ℕ = ℕ Integer 44 | deriving (Show, Read, Eq, Ord, Num, Enum, Integral, Real) 45 | -------------------------------------------------------------------------------- /Graphics/Implicit/MathUtil.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright (C) 2014 2015 2016, Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE ViewPatterns #-} 7 | 8 | -- A module of math utilities. 9 | module Graphics.Implicit.MathUtil (rmax, rmaximum, rminimum, distFromLineSeg, pack, box3sWithin, reflect, alaV3, packV3, unpackV3, infty) where 10 | 11 | -- Explicitly include what we need from Prelude. 12 | import Prelude (Num, Fractional, Bool, Ordering, (.), (>), (<), (+), ($), (/), otherwise, not, (||), (&&), abs, (-), (*), sin, asin, pi, max, sqrt, min, compare, (<=), fst, snd, (<>), flip, error, (/=)) 13 | 14 | import Graphics.Implicit.Definitions (ℝ, ℝ2, ℝ3, Box2) 15 | 16 | import Data.List (sort, sortBy) 17 | import Linear (Metric, (*^), norm, distance, normalize, dot, V2(V2), V3(V3)) 18 | 19 | -- | The distance a point p is from a line segment (a,b) 20 | distFromLineSeg :: ℝ2 -> (ℝ2, ℝ2) -> ℝ 21 | distFromLineSeg p (a,b) = distance p closest 22 | where 23 | ab = b - a 24 | ap = p - a 25 | d :: ℝ 26 | d = normalize ab `dot` ap 27 | -- the closest point to p on the line segment. 28 | closest :: ℝ2 29 | closest 30 | | d < 0 = a 31 | | d > norm ab = b 32 | | otherwise = a + d *^ normalize ab 33 | 34 | box3sWithin :: ℝ -> (ℝ3, ℝ3) -> (ℝ3, ℝ3) -> Bool 35 | box3sWithin r (V3 ax1 ay1 az1, V3 ax2 ay2 az2) (V3 bx1 by1 bz1, V3 bx2 by2 bz2) = 36 | let 37 | near (a1, a2) (b1, b2) = not $ (a2 + r < b1) || (b2 + r < a1) 38 | in 39 | (ax1,ax2) `near` (bx1, bx2) 40 | && (ay1,ay2) `near` (by1, by2) 41 | && (az1,az2) `near` (bz1, bz2) 42 | 43 | -- | Rounded Maximum 44 | -- Consider max(x,y) = 0, the generated curve 45 | -- has a square-like corner. We replace it with a 46 | -- quarter of a circle 47 | -- 48 | -- NOTE: rmax is not associative! 49 | rmax :: 50 | ℝ -- ^ radius 51 | -> ℝ -- ^ first number to round maximum 52 | -> ℝ -- ^ second number to round maximum 53 | -> ℝ -- ^ resulting number 54 | rmax r x y = if r /= 0 && abs (x-y) < r 55 | then y - r*sin(pi/4-asin((x-y)/r/sqrt 2)) + r 56 | else max x y 57 | 58 | -- | Rounded minimum 59 | -- 60 | -- NOTE: rmin is not associative! 61 | rmin :: 62 | ℝ -- ^ radius 63 | -> ℝ -- ^ first number to round minimum 64 | -> ℝ -- ^ second number to round minimum 65 | -> ℝ -- ^ resulting number 66 | rmin r x y = if r /= 0 && abs (x-y) < r 67 | then y + r*sin(pi/4+asin((x-y)/r/sqrt 2)) - r 68 | else min x y 69 | 70 | -- | Like rmax, but on a list instead of two. 71 | -- Just as maximum is. 72 | -- The implementation is to take the maximum two 73 | -- and rmax those. 74 | rmaximum :: 75 | ℝ -- ^ radius 76 | -> [ℝ] -- ^ numbers to take round maximum 77 | -> ℝ -- ^ resulting number 78 | rmaximum _ [] = 0 79 | rmaximum _ [a] = a 80 | rmaximum r [a,b] = rmax r a b 81 | rmaximum r (sortBy (flip compare) -> (a:b:_:_)) = rmax r a b 82 | rmaximum _ _ = error "impossible." -- (and with dependent types we could prove it!) 83 | 84 | -- | Like rmin but on a list. 85 | rminimum :: 86 | ℝ -- ^ radius 87 | -> [ℝ] -- ^ numbers to take round minimum 88 | -> ℝ -- ^ resulting number 89 | rminimum _ [] = 0 90 | rminimum _ [a] = a 91 | rminimum r [a,b] = rmin r a b 92 | rminimum r (sort -> (a:b:_:_)) = rmin r a b 93 | rminimum _ _ = error "impossible." 94 | 95 | -- | Pack the given objects in a box the given size. 96 | pack :: 97 | Box2 -- ^ The box to pack within 98 | -> ℝ -- ^ The space seperation between items 99 | -> [(Box2, a)] -- ^ Objects with their boxes 100 | -> ([(ℝ2, a)], [(Box2, a)] ) -- ^ Packed objects with their positions, objects that could be packed 101 | pack (dx, dy) sep objs = packSome sortedObjs (dx, dy) 102 | where 103 | compareBoxesByY :: Box2 -> Box2 -> Ordering 104 | compareBoxesByY (V2 _ ay1, V2 _ ay2) (V2 _ by1, V2 _ by2) = 105 | compare (abs $ by2-by1) (abs $ ay2-ay1) 106 | 107 | sortedObjs = sortBy 108 | (\(boxa, _) (boxb, _) -> compareBoxesByY boxa boxb ) 109 | objs 110 | 111 | tmap1 :: (t2 -> t) -> (t2, t1) -> (t, t1) 112 | tmap1 f (a,b) = (f a, b) 113 | tmap2 :: (t2 -> t1) -> (t, t2) -> (t, t1) 114 | tmap2 f (a,b) = (a, f b) 115 | 116 | packSome :: [(Box2,a)] -> Box2 -> ([(ℝ2,a)], [(Box2,a)]) 117 | packSome (presObj@((V2 x1 y1,V2 x2 y2),obj):otherBoxedObjs) box@(V2 bx1 by1, V2 bx2 by2) = 118 | if abs (x2 - x1) <= abs (bx2-bx1) && abs (y2 - y1) <= abs (by2-by1) 119 | then 120 | let 121 | row = tmap1 ((V2 (bx1-x1) (by1-y1), obj):) $ 122 | packSome otherBoxedObjs (V2 (bx1+x2-x1+sep) by1, V2 bx2 (by1 + y2-y1)) 123 | rowAndUp = 124 | if abs (by2-by1) - abs (y2-y1) > sep 125 | then tmap1 (fst row <> ) $ 126 | packSome (snd row) (V2 bx1 (by1 + y2-y1+sep), V2 bx2 by2) 127 | else row 128 | in 129 | rowAndUp 130 | else 131 | tmap2 (presObj:) $ packSome otherBoxedObjs box 132 | packSome [] _ = ([], []) 133 | 134 | -- | Reflect a vector across a hyperplane defined by its normal vector. 135 | -- 136 | -- From https://en.wikipedia.org/wiki/Reflection_(mathematics)#Reflection_through_a_hyperplane_in_n_dimensions 137 | reflect 138 | :: (Num (f a), Fractional a, Metric f) 139 | => f a -- ^ Mirror axis 140 | -> f a -- ^ Vector to transform 141 | -> f a 142 | reflect a v = v - (2 * ((v `dot` a) / (a `dot` a))) *^ a 143 | 144 | -- | Lift a function over 'V3' into a function over 'ℝ3'. 145 | alaV3 :: (V3 a -> V3 a) -> (a, a, a) -> (a, a, a) 146 | alaV3 f = unpackV3 . f . packV3 147 | {-# INLINABLE alaV3 #-} 148 | 149 | packV3 :: (a, a, a) -> V3 a 150 | packV3 (x, y, z) = V3 x y z 151 | {-# INLINABLE packV3 #-} 152 | 153 | unpackV3 :: V3 a -> (a, a, a) 154 | unpackV3 (V3 a a2 a3) = (a, a2, a3) 155 | {-# INLINABLE unpackV3 #-} 156 | 157 | ------------------------------------------------------------------------------ 158 | -- | Haskell's standard library doesn't make floating-point infinity available 159 | -- in any convenient way, so we define it here. 160 | infty :: (Fractional t) => t 161 | infty = 1/0 162 | {-# INLINABLE infty #-} 163 | -------------------------------------------------------------------------------- /Graphics/Implicit/ObjectUtil.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright (C) 2014 2015 2016, Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | -- create a module that just wraps the functions in the ObjectUtil directory. 6 | 7 | module Graphics.Implicit.ObjectUtil(getImplicit3, getImplicit2, getBox3, getBox2) where 8 | 9 | import Graphics.Implicit.ObjectUtil.GetImplicit3 (getImplicit3) 10 | 11 | import Graphics.Implicit.ObjectUtil.GetImplicit2 (getImplicit2) 12 | 13 | import Graphics.Implicit.ObjectUtil.GetBox3 (getBox3) 14 | 15 | import Graphics.Implicit.ObjectUtil.GetBox2 (getBox2) 16 | -------------------------------------------------------------------------------- /Graphics/Implicit/ObjectUtil/GetBoxShared.hs: -------------------------------------------------------------------------------- 1 | -- Copyright 2014 2015 2016, Julia Longtin (julial@turinglace.com) 2 | -- Copyright 2015 2016, Mike MacHenry (mike.machenry@gmail.com) 3 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 4 | -- Released under the GNU AGPLV3+, see LICENSE 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | 10 | module Graphics.Implicit.ObjectUtil.GetBoxShared (VectorStuff(uniformV, elements, corners), intersectBoxes, emptyBox, pointsBox, unionBoxes, outsetBox, getBoxShared) where 11 | 12 | import Prelude (Num, (-), (+), pure, (==), max, min, foldr, ($), fmap, (.), not, filter, foldMap, Fractional, Bool, Eq) 13 | import {-# SOURCE #-} Graphics.Implicit.Primitives 14 | ( Object(getBox) ) 15 | import Graphics.Implicit.Definitions 16 | ( SharedObj(Empty, Full, Complement, UnionR, DifferenceR, IntersectR, Translate, Scale, Mirror, Shell, Outset, EmbedBoxedObj, WithRounding), ComponentWiseMultable((⋯*)), ℝ3, ℝ2, ℝ ) 17 | import Graphics.Implicit.MathUtil (infty, reflect ) 18 | import Linear (Metric, V2(V2), V3(V3)) 19 | import Data.Foldable (Foldable(toList)) 20 | import Control.Applicative (Applicative(liftA2)) 21 | 22 | ------------------------------------------------------------------------------ 23 | -- | Ad-hoc methods we need to share code between 2D and 3D. With the exception 24 | -- of 'corners', these are actually all standard methods of other classes, 25 | -- which we don't have access to due to the choice representation for R2 and 26 | -- R3. 27 | -- 28 | -- This class is unnecessary if we were to implement #283. 29 | class VectorStuff vec where 30 | -- | Equivalent to 'Prelude.pure' 31 | uniformV :: ℝ -> vec 32 | -- | Equivalent to 'Control.Applicative.liftA2' 33 | pointwise :: (ℝ -> ℝ -> ℝ) -> vec -> vec -> vec 34 | -- | Equivalent to 'Data.Foldable.toList' 35 | elements :: vec -> [ℝ] 36 | -- | Given a bounding box, produce the points at each corner. 37 | corners :: (vec, vec) -> [vec] 38 | 39 | instance VectorStuff ℝ2 where 40 | uniformV = pure 41 | corners (p1@(V2 x1 y1), p2@(V2 x2 y2)) = 42 | [ p1 43 | , V2 x1 y2 44 | , V2 x2 y1 45 | , p2 46 | ] 47 | pointwise = liftA2 48 | elements = toList 49 | {-# INLINABLE uniformV #-} 50 | {-# INLINABLE pointwise #-} 51 | {-# INLINABLE elements #-} 52 | {-# INLINABLE corners #-} 53 | 54 | instance VectorStuff ℝ3 where 55 | uniformV = pure 56 | corners (p1@(V3 x1 y1 z1), p2@(V3 x2 y2 z2)) = 57 | [ p1 58 | , V3 x1 y2 z1 59 | , V3 x2 y2 z1 60 | , V3 x2 y1 z1 61 | , V3 x1 y1 z2 62 | , V3 x2 y1 z2 63 | , V3 x1 y2 z2 64 | , p2 65 | ] 66 | pointwise = liftA2 67 | elements = toList 68 | {-# INLINABLE uniformV #-} 69 | {-# INLINABLE pointwise #-} 70 | {-# INLINABLE elements #-} 71 | {-# INLINABLE corners #-} 72 | 73 | ------------------------------------------------------------------------------ 74 | -- | Compute the intersection of dimensionality-polymorphic bounding boxes. 75 | intersectBoxes 76 | :: (VectorStuff a) => [(a, a)] -> (a, a) 77 | intersectBoxes [] = fullBox 78 | intersectBoxes (b : boxes) 79 | = foldr (biapp (pointwise max) (pointwise min)) b boxes 80 | {-# INLINABLE intersectBoxes #-} 81 | 82 | ------------------------------------------------------------------------------ 83 | -- | Apply two functions elementwise across pairs. This is the biapplicative 84 | -- operation specialized to pairs. 85 | biapp 86 | :: (a -> b -> c) 87 | -> (d -> e -> f) 88 | -> (a, d) 89 | -> (b, e) 90 | -> (c, f) 91 | biapp f g (a1, b1) (a2, b2) = (f a1 a2, g b1 b2) 92 | {-# INLINABLE biapp #-} 93 | 94 | -- | An empty box. 95 | emptyBox :: (Applicative f, Num a) => (f a, f a) 96 | emptyBox = (pure 0, pure 0) 97 | {-# INLINABLE emptyBox #-} 98 | 99 | -- | A full box. 100 | fullBox :: (VectorStuff vec) => (vec, vec) 101 | fullBox = (uniformV (-infty), uniformV infty) 102 | {-# INLINABLE fullBox #-} 103 | 104 | -- | Define a box around all of the given points. 105 | pointsBox :: (Applicative f, Num a, VectorStuff (f a)) => [f a] -> (f a, f a) 106 | pointsBox [] = emptyBox 107 | pointsBox (a : as) = (foldr (pointwise min) a as, foldr (pointwise max) a as) 108 | {-# INLINABLE pointsBox #-} 109 | 110 | ------------------------------------------------------------------------------ 111 | -- | Compute the intersection of dimensionality-polymorphic bounding boxes. 112 | unionBoxes :: (VectorStuff (f a), Applicative f, Eq (f a), Num a, Num (f a)) => ℝ -> [(f a, f a)] -> (f a, f a) 113 | unionBoxes r 114 | = outsetBox r 115 | . pointsBox 116 | . foldMap corners 117 | . filter (not . isEmpty) 118 | {-# INLINABLE unionBoxes #-} 119 | 120 | -- | Is a box empty? 121 | isEmpty :: (Eq (f a), Applicative f, Num a, Num (f a)) => (f a, f a) -> Bool 122 | isEmpty (v1, v2) = (v1 - v2) == pure 0 123 | 124 | -- | Increase a boxes size by a rounding value. 125 | outsetBox :: (VectorStuff a, Num a) => ℝ -> (a, a) -> (a, a) 126 | outsetBox r (a, b) = (a - uniformV r, b + uniformV r) 127 | 128 | -- Get a box around the given object. 129 | getBoxShared 130 | :: forall obj f a 131 | . ( Object obj f a, VectorStuff (f a), ComponentWiseMultable (f a), Fractional a, Metric f) 132 | => SharedObj obj f a 133 | -> (f a, f a) 134 | {-# INLINABLE getBoxShared #-} 135 | -- Primitives 136 | getBoxShared Empty = emptyBox 137 | getBoxShared Full = fullBox 138 | -- (Rounded) CSG 139 | getBoxShared (Complement _) = fullBox 140 | getBoxShared (UnionR r symbObjs) = unionBoxes r $ fmap getBox symbObjs 141 | getBoxShared (DifferenceR _ symbObj _) = getBox symbObj 142 | getBoxShared (IntersectR _ symbObjs) = 143 | intersectBoxes $ 144 | fmap getBox symbObjs 145 | -- -- Simple transforms 146 | getBoxShared (Translate v symbObj) = 147 | let (a :: f a, b) = getBox symbObj 148 | in (a + v, b + v) 149 | getBoxShared (Scale s symbObj) = 150 | let 151 | (a :: f a, b) = getBox symbObj 152 | sa = s ⋯* a 153 | sb = s ⋯* b 154 | in pointsBox [sa, sb] 155 | getBoxShared (Mirror v symbObj) = 156 | pointsBox $ fmap (reflect v) $ corners $ getBox symbObj 157 | -- Boundary mods 158 | -- Shell shouldn't be changing bounding boxes 159 | getBoxShared (Shell _ symbObj) = getBox symbObj 160 | getBoxShared (Outset d symbObj) = 161 | outsetBox d $ getBox symbObj 162 | -- Misc 163 | getBoxShared (WithRounding _ obj) = getBox obj 164 | getBoxShared (EmbedBoxedObj (_,box)) = box 165 | 166 | -------------------------------------------------------------------------------- /Graphics/Implicit/ObjectUtil/GetImplicit2.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright (C) 2016, Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | {-# LANGUAGE TypeApplications #-} 6 | {-# LANGUAGE ViewPatterns #-} 7 | 8 | module Graphics.Implicit.ObjectUtil.GetImplicit2 (getImplicit2) where 9 | 10 | import Prelude(cycle, (/=), uncurry, fst, Eq, zip, drop, abs, (-), (/), sqrt, (*), (+), length, fmap, (<=), (&&), (>=), (||), odd, ($), (>), filter, (<), minimum, (.), sin, cos) 11 | 12 | import Graphics.Implicit.Definitions 13 | ( objectRounding, ObjectContext, SymbolicObj2(Square, Circle, Polygon, Rotate2, Slice, Transform2, Shared2), SharedObj (Empty), Obj2, ℝ2, ℝ ) 14 | 15 | import Graphics.Implicit.MathUtil 16 | ( distFromLineSeg, rmaximum ) 17 | 18 | import Data.List (nub) 19 | import Graphics.Implicit.ObjectUtil.GetImplicitShared (getImplicitShared) 20 | import Linear (V2(V2), V3(V3)) 21 | import qualified Linear 22 | 23 | import {-# SOURCE #-} Graphics.Implicit.Primitives (getImplicit) 24 | 25 | ------------------------------------------------------------------------------ 26 | -- | Filter out equal consecutive elements in the list. This function will 27 | -- additionally trim the last element of the list if it's equal to the first. 28 | scanUniqueCircular :: Eq a => [a] -> [a] 29 | scanUniqueCircular 30 | = fmap fst 31 | . filter (uncurry (/=)) 32 | . circularPairs 33 | 34 | ------------------------------------------------------------------------------ 35 | -- | Given @[a, b, c, ... n]@, return the pairs @[(a, b), (b, c), ... (n, a)]@. 36 | circularPairs :: [a] -> [(a,a)] 37 | circularPairs as = zip as $ drop 1 $ cycle as 38 | 39 | getImplicit2 :: ObjectContext -> SymbolicObj2 -> Obj2 40 | -- Primitives 41 | getImplicit2 ctx (Square (V2 dx dy)) = 42 | \(V2 x y) -> rmaximum (objectRounding ctx) [abs (x-dx/2) - dx/2, abs (y-dy/2) - dy/2] 43 | getImplicit2 _ (Circle r) = 44 | \(V2 x y) -> sqrt (x * x + y * y) - r 45 | -- FIXME: stop ignoring rounding for polygons. 46 | getImplicit2 _ (Polygon (scanUniqueCircular -> points@(_:_:_:_))) = 47 | \p -> let 48 | pairs :: [(ℝ2,ℝ2)] 49 | pairs = circularPairs points 50 | relativePairs = fmap (\(a,b) -> (a - p, b - p) ) pairs 51 | crossing_points = 52 | [x2 - y2*(x2-x1)/(y2-y1) | (V2 x1 y1, V2 x2 y2) <- relativePairs, 53 | ( (y2 <= 0) && (y1 >= 0) ) || ( (y2 >= 0) && (y1 <= 0) ) ] 54 | -- FIXME: use partition instead? 55 | seemsInRight = odd . length . filter (>0) $ nub crossing_points 56 | seemsInLeft = odd . length . filter (<0) $ nub crossing_points 57 | isIn = seemsInRight && seemsInLeft 58 | dists :: [ℝ] 59 | dists = fmap (distFromLineSeg p) pairs 60 | in 61 | minimum dists * if isIn then -1 else 1 62 | getImplicit2 ctx (Polygon _) = getImplicitShared @SymbolicObj2 ctx Empty 63 | -- Simple transforms 64 | getImplicit2 ctx (Rotate2 θ symbObj) = 65 | \(V2 x y) -> let 66 | obj = getImplicit2 ctx symbObj 67 | in 68 | obj $ V2 (x*cos θ + y*sin θ) (y*cos θ - x*sin θ) 69 | getImplicit2 _ctx (Slice symObj) = 70 | let 71 | obj = getImplicit symObj 72 | in 73 | \(V2 x y) -> obj (V3 x y 0) 74 | getImplicit2 ctx (Transform2 m symbObj) = 75 | \vin -> 76 | let 77 | obj = getImplicit2 ctx symbObj 78 | augment (V2 x y) = V3 x y 1 79 | normalize (V3 x y w) = V2 (x/w) (y/w) 80 | in 81 | obj (normalize . (Linear.inv33 m Linear.!*) . augment $ vin) 82 | getImplicit2 ctx (Shared2 obj) = getImplicitShared ctx obj 83 | -------------------------------------------------------------------------------- /Graphics/Implicit/ObjectUtil/GetImplicitShared.hs: -------------------------------------------------------------------------------- 1 | -- Copyright 2014 2015 2016, Julia Longtin (julial@turinglace.com) 2 | -- Copyright 2015 2016, Mike MacHenry (mike.machenry@gmail.com) 3 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 4 | -- Released under the GNU AGPLV3+, see LICENSE 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | 10 | module Graphics.Implicit.ObjectUtil.GetImplicitShared (getImplicitShared, normalize) where 11 | 12 | import {-# SOURCE #-} Graphics.Implicit.Primitives (Object(getImplicit')) 13 | 14 | import Prelude (flip, (-), (*), (>), (<), (&&), (/), product, abs, (**), fmap, (.), negate, ($), const) 15 | 16 | import Graphics.Implicit.Definitions 17 | ( objectRounding, ObjectContext, SharedObj(Empty, Full, Complement, UnionR, IntersectR, DifferenceR, Translate, Scale, Mirror, Shell, Outset, EmbedBoxedObj, WithRounding), ComponentWiseMultable((⋯/)), ℝ, minℝ ) 18 | 19 | import Graphics.Implicit.MathUtil (infty, rmax, rmaximum, rminimum, reflect) 20 | 21 | -- Use getImplicit2 for handling extrusion of 2D shapes to 3D. 22 | import Graphics.Implicit.ObjectUtil.GetBoxShared (VectorStuff(elements, uniformV)) 23 | 24 | import Linear (Metric(dot)) 25 | import {-# SOURCE #-} Graphics.Implicit.Primitives (outset) 26 | 27 | ------------------------------------------------------------------------------ 28 | -- | Normalize a dimensionality-polymorphic vector. 29 | normalize 30 | :: forall f 31 | . (VectorStuff (f ℝ), Metric f) 32 | => f ℝ 33 | -> ℝ 34 | normalize v = 35 | let all1s = uniformV @(f ℝ) 1 36 | in abs (product (elements v)) ** (1 / (all1s `dot` all1s)) 37 | 38 | -- Get a function that describes the surface of the object. 39 | getImplicitShared 40 | :: forall obj f 41 | . ( Object obj f ℝ 42 | , VectorStuff (f ℝ) 43 | , ComponentWiseMultable (f ℝ) 44 | , Metric f 45 | ) 46 | => ObjectContext 47 | -> SharedObj obj f ℝ 48 | -> f ℝ 49 | -> ℝ 50 | getImplicitShared _ Empty = const infty 51 | getImplicitShared _ Full = const $ -infty 52 | getImplicitShared ctx (Complement symbObj) = 53 | negate . getImplicit' ctx symbObj 54 | getImplicitShared ctx (UnionR r symbObjs) = \p -> 55 | rminimum r $ fmap (flip (getImplicit' ctx) p) symbObjs 56 | getImplicitShared ctx (IntersectR r symbObjs) = \p -> 57 | rmaximum r $ fmap (flip (getImplicit' ctx) p) symbObjs 58 | getImplicitShared ctx (DifferenceR _ symbObj []) = 59 | getImplicit' ctx symbObj 60 | getImplicitShared ctx (DifferenceR r symbObj symbObjs) = 61 | let headObj = getImplicit' ctx symbObj 62 | in 63 | \p -> do 64 | let 65 | maxTail = rmaximum r 66 | $ fmap (flip (getImplicitShared ctx) p . Complement) symbObjs 67 | if maxTail > -minℝ && maxTail < minℝ 68 | then rmax r (headObj p) minℝ 69 | else rmax r (headObj p) maxTail 70 | 71 | -- Simple transforms 72 | getImplicitShared ctx (Translate v symbObj) = \p -> 73 | getImplicit' ctx symbObj (p - v) 74 | getImplicitShared ctx (Scale s symbObj) = \p -> 75 | normalize s * getImplicit' ctx symbObj (p ⋯/ s) 76 | getImplicitShared ctx (Mirror v symbObj) = 77 | getImplicit' ctx symbObj . reflect v 78 | -- Boundary mods 79 | getImplicitShared ctx (Shell w symbObj) = 80 | -- Get the difference of the original object, and the same 81 | -- object with its boundaries moved towards the center. 82 | getImplicitShared ctx (DifferenceR 0 symbObj [outset (-w) symbObj]) 83 | getImplicitShared ctx (Outset d symbObj) = \p -> 84 | getImplicit' ctx symbObj p - d 85 | -- Misc 86 | getImplicitShared _ (EmbedBoxedObj (obj,_)) = obj 87 | getImplicitShared ctx (WithRounding r obj) = getImplicit' (ctx { objectRounding = r }) obj 88 | -------------------------------------------------------------------------------- /Graphics/Implicit/Primitives.hs-boot: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | 6 | -- due to GHC 8.7.10 (and lesser) warning about Space 7 | {-# OPTIONS_GHC -fno-warn-missing-methods #-} 8 | 9 | module Graphics.Implicit.Primitives (Object(getBox, getImplicit', Space, _Shared), getImplicit, emptySpace, fullSpace,outset) where 10 | 11 | import Graphics.Implicit.Definitions (ObjectContext, SymbolicObj2, SymbolicObj3, SharedObj, ℝ) 12 | import Control.Lens (Prism') 13 | import Data.Kind (Type) 14 | import Prelude (Applicative, Eq, Foldable, Num, Ord) 15 | import Linear (V2, V3) 16 | 17 | -- See the non-source version of "Graphics.Implicit.Primitives" for 18 | -- documentation of this class. 19 | class ( Applicative f 20 | , Eq a 21 | , Eq (f a) 22 | , Foldable f 23 | , Ord a 24 | , Num a 25 | , Num (f a) 26 | ) 27 | => Object obj f a | obj -> f a 28 | where 29 | type Space obj :: Type -> Type 30 | _Shared :: Prism' obj (SharedObj obj f a) 31 | getBox :: obj -> (f a, f a) 32 | getImplicit' :: ObjectContext -> obj -> (f a -> a) 33 | canonicalize :: obj -> obj 34 | implicit :: (f a -> a) -> (f a, f a) -> obj 35 | 36 | getImplicit :: Object obj f a => obj -> (f a -> a) 37 | 38 | instance Object SymbolicObj2 V2 ℝ 39 | instance Object SymbolicObj3 V3 ℝ 40 | 41 | emptySpace, fullSpace :: Object obj f a => obj 42 | outset :: Object obj f a => ℝ -> obj -> obj 43 | -------------------------------------------------------------------------------- /Makefile-OldCabal: -------------------------------------------------------------------------------- 1 | # ImplicitCAD Makefile. Build and test Implicitcad. 2 | 3 | # This is the Makefile for when you are running a version of cabal-install less than version 1.24. 4 | 5 | ## Locations of binaries used when running tests, or generating the images to go along with our README.md. 6 | # The location of stl2ps, from stltools, available from https://github.com/rsmith-nl/stltools/tree/develop 7 | stl2ps=/disk4/faikvm.com/stltools/stltools/stl2ps.py 8 | # The location of convert, from imagemagick 9 | convert=convert 10 | # The location of GHC, used to compile .hs examples. 11 | GHC=ghc 12 | # The location of the created extopenscad binary, for running shell based test cases. 13 | EXTOPENSCAD=dist/build/extopenscad/extopenscad 14 | # The location of the implicitsnap binary, which listens for requests via http. The backend of the website. 15 | IMPLICITSNAP=dist/build/implicitsnap/implicitsnap 16 | # The location of the benchmark binary, for benchmarking some implicitcad internals. 17 | BENCHMARK=dist/build/Benchmark/Benchmark 18 | # The location of the parser benchmark binary, specifically for benchmarking implicitcad's parser. 19 | PARSERBENCH=dist/build/parser-bench/parser-bench 20 | # The location of the created test binary, for running haskell test cases. 21 | TESTSUITE=dist/build/test-implicit/test-implicit 22 | # The location of it's source. 23 | TESTFILES=$(shell find tests/ -name '*.hs') 24 | # The location of the documentation generator. for documenting (some of) the extopenscad language. 25 | DOCGEN=dist/build/docgen/docgen 26 | 27 | ## Options used when calling ImplicitCAD. for testing, and for image generation. 28 | # Enable multiple CPU usage. 29 | # Use the parallel garbage collector. 30 | # spit out some performance statistics. 31 | RTSOPTS=+RTS -N -qg -t 32 | # The resolution to generate objects at. FIXME: what does this mean in human terms? 33 | RESOPTS=-r 50 34 | 35 | SCADOPTS?=-q 36 | 37 | # Uncomment for profiling support. Note that you will need to recompile all of the libraries, as well. 38 | #PROFILING= --enable-profiling 39 | 40 | ## FIXME: escape this right 41 | # Uncomment for valgrind on the examples. 42 | #VALGRIND=valgrind --tool=cachegrind --cachegrind-out-file=$$each.cachegrind.`date +%s` 43 | 44 | LIBFILES=$(shell find Graphics -name '*.hs') 45 | LIBTARGET=dist/build/Graphics/Implicit.o 46 | 47 | EXECTARGETS=$(EXTOPENSCAD) $(IMPLICITSNAP) $(BENCHMARK) $(TESTSUITE) $(PARSERBENCH) $(DOCGEN) 48 | TARGETS=$(EXECTARGETS) $(LIBTARGET) 49 | 50 | # Mark the below fake targets as unreal, so make will not get choked up if a file with one of these names is created. 51 | .PHONY: build install clean distclean nukeclean docs dist examples tests 52 | 53 | # Empty out the default suffix list, to make debugging output cleaner. 54 | .SUFFIXES: 55 | 56 | # Allow for us to (ab)use $$* in dependencies of rules. 57 | .SECONDEXPANSION: 58 | 59 | # Disable make's default builtin rules, to make debugging output cleaner. 60 | MAKEFLAGS += --no-builtin-rules 61 | 62 | # Build implicitcad binaries. 63 | build: $(TARGETS) 64 | 65 | # Install implicitcad. 66 | install: build 67 | cabal install 68 | 69 | # Cleanup from using the rules in this file. 70 | clean: Setup 71 | rm -f Examples/*.stl 72 | rm -f Examples/*.svg 73 | rm -f Examples/*.ps 74 | rm -f Examples/*.png 75 | rm -f Examples/example[0-9][0-9] 76 | rm -f Examples/*.hi 77 | rm -f Examples/*.o 78 | rm -f tests/*.stl 79 | rm -rf docs/parser.md 80 | rm -f $(TARGETS) 81 | rm -rf dist/build/Graphics 82 | rm -f dist/build/libHS* 83 | rm -f Examples/example*.cachegrind.* 84 | 85 | # Clean up before making a release. 86 | distclean: clean Setup 87 | ./Setup clean 88 | rm -f Setup Setup.hi Setup.o 89 | rm -rf dist/ 90 | rm -f `find ./ -name *~` 91 | rm -f `find ./ -name \#*\#` 92 | 93 | # Destroy the current user's cabal/ghc environment. 94 | nukeclean: distclean 95 | rm -rf ~/.cabal/ ~/.ghc/ 96 | 97 | # Generate documentation. 98 | docs: $(DOCGEN) 99 | ./Setup haddock 100 | $(DOCGEN) > docs/escad.md 101 | 102 | # Upload to hackage? 103 | dist: $(TARGETS) 104 | ./Setup sdist 105 | 106 | # Generate examples. 107 | examples: $(EXTOPENSCAD) 108 | cd Examples && for each in `find ./ -name '*scad' -type f | sort`; do { echo $$each ; ../$(EXTOPENSCAD) $(SCADOPTS) $$each $(RTSOPTS); } done 109 | cd Examples && for each in `find ./ -name '*.hs' -type f | sort`; do { filename=$(basename "$$each"); filename="$${filename%.*}"; cd ..; $(GHC) Examples/$$filename.hs -o Examples/$$filename; cd Examples; echo $$filename; $$filename +RTS -t ; } done 110 | 111 | # Generate images from the examples, so we can upload the images to our website. 112 | images: examples 113 | cd Examples && for each in `find ./ -name '*.stl' -type f | sort`; do { filename=$(basename "$$each"); filename="$${filename%.*}"; if [ -e $$filename.transform ] ; then echo ${stl2ps} $$each $$filename.ps `cat $$filename.transform`; else ${stl2ps} $$each $$filename.ps; fi; ${convert} $$filename.ps $$filename.png; } done 114 | 115 | # Hspec parser tests. 116 | tests: $(TESTSUITE) $(TESTFILES) 117 | # cd tests && for each in `find ./ -name '*scad' -type f | sort`; do { ../$(EXTOPENSCAD) $$each ${RESOPTS} ${RTSOPTS}; } done 118 | $(TESTSUITE) 119 | 120 | # The ImplicitCAD library. 121 | $(LIBTARGET): $(LIBFILES) 122 | cabal build implicit 123 | 124 | # The parser test suite, since it's source is stored in a different location than the other binaries we build: 125 | dist/build/test-implicit/test-implicit: $(TESTFILES) Setup dist/setup-config $(LIBTARGET) $(LIBFILES) 126 | cabal build test-implicit 127 | 128 | # Build a binary target with cabal. 129 | dist/build/%: programs/$$(word 2,$$(subst /, ,%)).hs Setup dist/setup-config $(LIBTARGET) $(LIBFILES) 130 | cabal build $(word 2,$(subst /, ,$*)) 131 | 132 | # Prepare to build. 133 | dist/setup-config: Setup implicit.cabal 134 | cabal update 135 | cabal install --only-dependencies --upgrade-dependencies $(PROFILING) 136 | cabal configure --enable-tests --enable-benchmarks $(PROFILING) 137 | 138 | # The setup command, used to perform administrative tasks (haddock, upload to hackage, clean, etc...). 139 | Setup: Setup.*hs 140 | $(GHC) -O2 -Wall --make Setup 141 | 142 | -------------------------------------------------------------------------------- /Release.md: -------------------------------------------------------------------------------- 1 | # Release Processes: 2 | 3 | Purpose of this document: to make sure we follow a consistent pattern, when making releases of ImplicitCAD. 4 | 5 | ## Version Logic: 6 | 1. The first digit is always 0. Maybe we'll change this when we're ready for the masses. ;) 7 | 2. The second digit changes with "major" releases. 8 | * Major releases change: 9 | * the CSG representation (the MD5sum of generated output files) 10 | * the Haskell interface (in a non-additive fashion) 11 | * or the SCAD interface (in a non-additive fashion) 12 | 3. The third digit changes with the "minor" releases. 13 | * Minor releases DO NOT change: 14 | * the CSG representation (the MD5sum of generated output files) 15 | * the Haskell interface (in a non-additive fashion) 16 | * or the SCAD interface (in a non-additive fashion) 17 | * Minor releases may change anything else. 18 | 4. The fourth digit changes with the "trivial" releases. 19 | * Trivial releases change nothing except the documentation. 20 | 21 | ## Tests for a Minor Release 22 | 1. make sure the output of the test-implicit binary is all green. 23 | 2. make sure the output of the docgen executable hasn't changed too greatly since the last release. 24 | * run `make docs` 25 | * examine the difference in the docs/escad.md 26 | 3. make sure the output of the parser-bench binary does not show any unacceptable speed reductions. 27 | 4. make sure the output of the Benchmark binary does not show any unacceptable speed reductions. 28 | 5. make sure the md5sum of the stl files resulting from running 'make examples' have not changed. 29 | 30 | ## Performing a release 31 | 32 | ### Create a Release branch 33 | 1. `git checkout -b release/` 34 | 2. update the Version field in implicit.cabal. 35 | 3. update the Version in the README.md. 36 | 4. change the most recent Version line in CHANGELOG.md from 'next', updating the following fields on that line. 37 | 5. push the branch to github, and file a pull request. 38 | 39 | ### Merge to master 40 | In the github interface, after all of the tests are green, merge to the master branch. 41 | 42 | ### Tagging a release 43 | On your git machine: 44 | ``` 45 | export VERSION= 46 | git checkout master 47 | git tag -a v$VERSION -m "Release $VERSION" 48 | git push origin v$VERSION 49 | ``` 50 | 51 | ### Publishing the release to GitHub 52 | 53 | 1. Open Github. 54 | 2. Click on the 'Releases' link from the code page for the implicitcad repo. 55 | 3. Click on 'Draft a new release' 56 | 4. Select the tag created in the previous step. 57 | 5. Paste the CHANGELOG.md entries from this release into the release description. 58 | 6. Title the release 'Release ' 59 | 7. Click on 'Publish release' 60 | 61 | ### Publishing the release to Hackage 62 | 63 | 1. Use github's 'download zip' to download a zip of the package. 64 | 2. Extract it to a temporary directory 65 | 3. Move the container directory to `implicit-` 66 | 4. Make a tar file from it. make sure to add the --format=ustar option. 67 | * `tar --format=ustar -cvzf implicit-.tar.gz implicit-/` 68 | 5. Upload the package candidate to https://hackage.haskell.org/packages/candidates/upload 69 | 6. Look over the resulting page. 70 | 7. Scroll down to 'edit package information' 71 | 8. click on 'publish candidate' 72 | 9. hit the 'publish package' button. 73 | 74 | ### Update ImplicitCAD.org 75 | 1. Use the output of docgen to update implicitcad.org (FIXME: how?) 76 | 77 | ### Re-Anchor the ChangeLog. 78 | File a new PR for adding a clean '# Version [next](https://github.com/Haskell-Things/ImplicitCAD/compare/v0.4.0.0...master) (202Y-MM-DD)' to the top of the Changelog, with a single empty bullet point. 79 | -------------------------------------------------------------------------------- /Tools.md: -------------------------------------------------------------------------------- 1 | # Purpose of this document: 2 | 3 | List the external tools i've found useful with this codebase. 4 | 5 | # Tools: 6 | 7 | ## Workflow: 8 | 9 | My workflow consists of: 10 | 11 | ### admesh 12 | 13 | ### meshlab 14 | 15 | ## Code Checking 16 | 'weeder' is useful for finding dead code 17 | 'hlint -g' is also useful. -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | ./implicit.cabal 3 | ./implicit-interpreter/implicit-interpreter.cabal 4 | 5 | -- due to interpreter tests 6 | write-ghc-environment-files: always 7 | -------------------------------------------------------------------------------- /cabal.project.local.ci: -------------------------------------------------------------------------------- 1 | flags: +implicitsnap 2 | 3 | package implicit 4 | ghc-options: 5 | -fspecialise-aggressively 6 | -Wunused-packages 7 | -Wno-all-missed-specialisations 8 | -Werror 9 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import { } 2 | , compiler ? null 3 | , withImplicitSnap ? false 4 | }: 5 | let 6 | overlay = import ./overlay.nix pkgs compiler withImplicitSnap; 7 | overrideHaskellPackages = orig: { 8 | buildHaskellPackages = 9 | orig.buildHaskellPackages.override overrideHaskellPackages; 10 | overrides = if orig ? overrides 11 | then pkgs.lib.composeExtensions orig.overrides overlay 12 | else overlay; 13 | }; 14 | 15 | packageSet = 16 | if compiler == null 17 | then pkgs.haskellPackages 18 | else pkgs.haskell.packages.${compiler}; 19 | 20 | haskellPackages = packageSet.override overrideHaskellPackages; 21 | in { 22 | inherit (haskellPackages) 23 | implicit 24 | implicit-interpreter; 25 | 26 | inherit haskellPackages; 27 | inherit pkgs; 28 | } 29 | -------------------------------------------------------------------------------- /docs/hacking.md: -------------------------------------------------------------------------------- 1 | ImplicitCAD Hacking How To 2 | ========================== 3 | 4 | So you want to improve ImplicitCAD. Yay! More help is a good thing. 5 | 6 | As of the time of writing, ImplicitCAD has 3417 lines of code, 896 lines of comments, and 877 blank lines, for a total of 5190 lines spread over 42 files. For a project of ImplicitCAD's scope, that's pretty small, but it's still enough that it can be difficult to find the section we need to change... 7 | 8 | The structure of ImplicitCAD is as follows: 9 | 10 | ``` 11 | Graphics 12 | └── Implicit 13 | ├── Export 14 | │   ├── Render 15 | │   └── Symbolic 16 | ├── ExtOpenScad 17 | │   └── Util 18 | └── ObjectUtil 19 | ``` 20 | 21 | `Graphics.Implicit.Export` is, as you may guess, where all the export stuff is. `Graphics.Implicit.ExtOpenScad` is the programming language interpreter for the ExtOpenScad language, our extention of openscad. Finally, the graphics engine is defined in `Graphics.Implicit` and `Graphics.Implicit.ObjectUtil`. 22 | 23 | The rest of this file will go through different changes you are likely to want to make and how to implement them. 24 | 25 | Language Changes 26 | ---------------- 27 | 28 | Most likely, you want to change one of four things: 29 | 30 | * **Expressions**: Expressions are things like `1+2`, `"abc"`, and `[sin(3.14), pi]`. They are defined in `Graphics.Implicit.ExtOpenScad.Expressions`. (Note that `sin` and `pi` are variables, which are defined elsewhere.) 31 | 32 | * **Statements**: Statements are things like variable assignment, for loops, and if statements. For example `for (a = [1,2,3]) echo (a);`. Statements are defined in `Graphics.Implicit.ExtOpenScad.Statements`. 33 | 34 | ```haskell 35 | computationStatement = ... 36 | ifStatement, 37 | forStatement, 38 | ... 39 | 40 | ... 41 | 42 | forStatement = (do 43 | line <- fmap sourceLine getPosition 44 | -- a for loop is of the form: 45 | -- for ( vsymb = vexpr ) loopStatements 46 | -- eg. for ( a = [1,2,3] ) {echo(a); echo "lol";} 47 | -- eg. for ( [a,b] = [[1,2]] ) {echo(a+b); echo "lol";} 48 | string "for" 49 | many space 50 | char '(' 51 | many space 52 | pattern <- patternMatcher 53 | many space 54 | char '=' 55 | vexpr <- expression 0 56 | char ')' 57 | many space 58 | loopStatements <- suite 59 | ... 60 | ``` 61 | 62 | 63 | * **Default Variables**: Like `sin`, `pi`, `sqrt`. These are all defined in ` Graphics.Implicit.ExtOpenScad.Default`. We can just use `toOObj` to convert Haskell values into `OpenscadObj`s and use them as default variable settings. (Small caveat: inputs to `toOObj` can't be polymorphic, so we use a type signature to force it to a certain type.) 64 | 65 | ```haskell 66 | defaultFunctions = map (\(a,b) -> (a, toOObj ( b :: ℝ -> ℝ))) 67 | [ 68 | ("sin", sin), 69 | ("cos", cos), 70 | ("tan", tan), 71 | ... 72 | ] 73 | ``` 74 | 75 | * **Default Modules**: Like `sphere` and `linear_extrude`. These are all defined in `Graphics.Implicit.ExtOpenScad.Primitives`. 76 | 77 | ```haskell 78 | primitives = [ sphere, cube, square, cylinder, ... ] 79 | 80 | ... 81 | 82 | -- **Exmaple of implementing a module** 83 | -- sphere is a module without a suite named sphere, 84 | -- this means that the parser will look for this like 85 | -- sphere(args...); 86 | sphere = moduleWithoutSuite "sphere" $ do 87 | example "sphere(3);" 88 | example "sphere(r=5);" 89 | -- What are the arguments? 90 | -- The radius, r, which is a (real) number. 91 | -- Because we don't provide a default, this ends right 92 | -- here if it doesn't get a suitable argument! 93 | r :: ℝ <- argument "r" 94 | `doc` "radius of the sphere" 95 | -- So what does this module do? 96 | -- It adds a 3D object, a sphere of radius r, 97 | -- using the sphere implementation in Prim 98 | -- (Graphics.Implicit.Primitives) 99 | addObj3 $ Prim.sphere r 100 | 101 | ``` 102 | 103 | Output Formats 104 | -------------- 105 | 106 | Formats are defined in files like `Graphics.Implicit.Export.TriangleMeshFormats` (as is the case with STLs), `Graphics.Implicit.Export.PolylineMeshFormats` (as is the case with SVGs). 107 | 108 | Then, in `Graphics.Implicit.Export`: 109 | 110 | ```haskell 111 | writeSVG res = writeObject res PolylineFormats.svg 112 | writeSTL res = writeObject res TriangleMeshFormats.stl 113 | ``` 114 | 115 | Rendering Algorithms 116 | -------------------- 117 | 118 | These are defined in `Graphics.Implicit.Export.Render` and children. `Graphics.Implicit.Export.Render` begins with an outline of how rendering is done: 119 | 120 | ```haskell 121 | -- Here's the plan for rendering a cube (the 2D case is trivial): 122 | 123 | -- (1) We calculate midpoints using interpolate. 124 | -- This guarentees that our mesh will line up everywhere. 125 | -- (Contrast with calculating them in getSegs) 126 | 127 | import Graphics.Implicit.Export.Render.Interpolate (interpolate) 128 | 129 | ... 130 | ``` 131 | 132 | If you are interested on working on this part of the code, read it. The children are also well documented. 133 | 134 | Graphics Primitives 135 | ------------------- 136 | 137 | The most complicated part of ImplicitCAD is the actual graphics engine. Before working on it, please familiarize yourself with the theory as described in [Chris' blog post](http://christopherolah.wordpress.com/2011/11/06/manipulation-of-implicit-functions-with-an-eye-on-cad/) (though changes have occured since then). 138 | 139 | The simples way to implement a new primitive is using `implicit`, a contructor that takes an implicit function and boudning box, producing an object. For example, we could have originally defined `sphere` as: 140 | 141 | ```haskell 142 | sphere :: ℝ -> SymbolicObj3 143 | sphere r = implicit ( 144 | \(x,y,z) -> sqrt (x^2+y^2+z^2) - r, 145 | ((-r, -r, -r), (r, r, r)) 146 | ) 147 | ``` 148 | 149 | and put it in `Graphics.Implicit.Primitives`. However, to allow more powerful optimizations, meta-inspection, and other goodies, frequently used objects should be put in the `SymbolicObj` definitions in `Graphics.Implicit.Definitions`. For example, `sphere`: 150 | 151 | ```haskell 152 | data SymbolicObj3 = 153 | CubeR ℝ ℝ3 ℝ3 154 | | Sphere ℝ 155 | ... 156 | ``` 157 | 158 | Then one needs to make the relevant entries in `Graphics.Implicit.ObjectUtil.*`. 159 | 160 | `Graphics.Implicit.ObjectUtil.Box3`: 161 | 162 | ```haskell 163 | getBox3 (Sphere r ) = ((-r, -r, -r), (r,r,r)) 164 | ``` 165 | 166 | `Graphics.Implicit.ObjectUtil.GetImplicit3`: 167 | 168 | ```haskell 169 | getImplicit3 (Sphere r ) = 170 | \(x,y,z) -> sqrt (x^2 + y^2 + z^2) - r 171 | ``` 172 | 173 | 174 | -------------------------------------------------------------------------------- /implicit-interpreter/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Version [0.1.0.0](https://github.com/HaskellThings/ImplicitCAD/compare/interpreter-0.1.0.0...interpreter-0.1.0.0) (2024-MM-DD) 2 | 3 | * Initial release 4 | 5 | --- 6 | 7 | `implicit-interpreter` uses [PVP Versioning][1]. 8 | 9 | [1]: https://pvp.haskell.org 10 | 11 | -------------------------------------------------------------------------------- /implicit-interpreter/README.md: -------------------------------------------------------------------------------- 1 | # implicit-interpreter 2 | 3 | Interpret implicit objects using [Hint](https://hackage.haskell.org/package/hint). 4 | -------------------------------------------------------------------------------- /implicit-interpreter/implicit-interpreter.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: implicit-interpreter 3 | version: 0.1.0.0 4 | synopsis: ImplicitCAD Haskell intepreter 5 | description: Interpret implicit objects using Hint 6 | homepage: https://github.com/HaskellThings/ImplicitCAD 7 | License: AGPL-3.0-or-later 8 | license-file: LICENSE 9 | author: Sorki 10 | maintainer: srk@48.io 11 | copyright: 2024 Sorki 12 | category: Graphics 13 | build-type: Simple 14 | 15 | extra-source-files: 16 | LICENSE 17 | README.md 18 | 19 | extra-doc-files: 20 | CHANGELOG.md 21 | 22 | library 23 | ghc-options: -Wall -Wunused-packages 24 | hs-source-dirs: src 25 | exposed-modules: Graphics.Implicit.Interpreter 26 | build-depends: base >= 4.7 && < 5 27 | , filepath 28 | , hint 29 | , transformers 30 | , temporary 31 | , exceptions 32 | , text 33 | default-language: Haskell2010 34 | 35 | test-suite implicit-interpreter-tests 36 | type: exitcode-stdio-1.0 37 | hs-source-dirs: test 38 | main-is: Spec.hs 39 | build-depends: base >= 4.7 && < 5 40 | , implicit 41 | , implicit-interpreter 42 | , hspec 43 | , text 44 | default-language: Haskell2010 45 | 46 | source-repository head 47 | type: git 48 | location: https://github.com/HaskellThings/ImplicitCAD 49 | -------------------------------------------------------------------------------- /implicit-interpreter/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | module Main (main) where 6 | 7 | import Data.Text (Text) 8 | import Data.Typeable (Typeable) 9 | import Graphics.Implicit (SymbolicObj3, sphere) 10 | import Graphics.Implicit.Canon (EqObj((=^=))) 11 | import Graphics.Implicit.Interpreter 12 | import Test.Hspec 13 | ( Spec 14 | , describe 15 | , expectationFailure 16 | , hspec 17 | , it 18 | , shouldBe 19 | , shouldSatisfy 20 | ) 21 | 22 | import qualified Data.Either 23 | import qualified Data.Text 24 | 25 | spec :: Spec 26 | spec = do 27 | describe "interpretText" $ do 28 | it "interprets plain sphere" $ do 29 | interpretsFine 30 | "sphere 3" 31 | (sphere 3) 32 | 1 33 | 34 | it "interprets sphere module" $ do 35 | interpretsFine 36 | sphereMod 37 | (sphere 3) 38 | 2 39 | 40 | it "refuses unsafe" $ do 41 | res <- 42 | interpretText 43 | @SymbolicObj3 44 | ("unsafePerformIO $ cube") 45 | res `shouldSatisfy` Data.Either.isLeft 46 | 47 | interpretsFine 48 | :: ( EqObj a 49 | , Show a 50 | , Typeable a 51 | ) 52 | => Text 53 | -> a 54 | -> Double 55 | -> IO () 56 | interpretsFine input object resolution = 57 | interpretText 58 | input 59 | >>= \case 60 | Left e -> 61 | expectationFailure 62 | $ "Interpreter failed with " 63 | <> show e 64 | Right (res, obj) -> do 65 | res `shouldBe` resolution 66 | obj `shouldSatisfy` (=^= object) 67 | 68 | sphereMod :: Text 69 | sphereMod = 70 | Data.Text.unlines 71 | [ "module Obj (obj) where" 72 | , "import Graphics.Implicit" 73 | , "obj = sphere 3" 74 | , "res = 2" 75 | ] 76 | 77 | main :: IO () 78 | main = hspec spec 79 | -------------------------------------------------------------------------------- /overlay.nix: -------------------------------------------------------------------------------- 1 | pkgs: compiler: withImplicitSnap: hself: hsuper: 2 | let 3 | lib = pkgs.lib; 4 | haskellLib = pkgs.haskell.lib; 5 | src = pkgs.nix-gitignore.gitignoreSource [ ] ./.; 6 | in 7 | { 8 | implicit = 9 | lib.pipe 10 | ( 11 | if withImplicitSnap 12 | then hself.callCabal2nixWithOptions "implicit" src "-fimplicitsnap" {} 13 | else hself.callCabal2nix "implicit" src {} 14 | ) 15 | [ 16 | haskellLib.compose.buildFromSdist 17 | ]; 18 | implicit-interpreter = 19 | lib.pipe 20 | (hself.callCabal2nix "implicit-interpreter" "${src}/implicit-interpreter" {}) 21 | [ 22 | haskellLib.compose.buildFromSdist 23 | ]; 24 | } 25 | -------------------------------------------------------------------------------- /programs/Benchmark.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright (C) 2014 2015 2016, Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | -- Our benchmarking suite. 6 | 7 | -- Let's be explicit about where things come from :) 8 | 9 | import Prelude (pure, ($), (*), (/), String, IO, cos, pi, fmap, zip3, Either(Left, Right), fromIntegral, (<>), (<$>)) 10 | 11 | -- Use criterion for benchmarking. see 12 | import Criterion.Main (Benchmark, bgroup, bench, nf, nfAppIO, defaultMain) 13 | 14 | -- The parts of ImplicitCAD we know how to benchmark. 15 | import Graphics.Implicit (union, circle, sphere, SymbolicObj2, SymbolicObj3, ExtrudeMScale(C1), writeDXF2, writeSVG, writePNG2, writeSTL, writeBinSTL, unionR, translate, difference, extrudeM, rect3, withRounding) 16 | -- The default object context and variables defining distance and counting in our world. 17 | import Graphics.Implicit.Definitions (defaultObjectContext, ℝ, Fastℕ) 18 | import Graphics.Implicit.Export.SymbolicObj2 (symbolicGetContour) 19 | import Graphics.Implicit.Export.SymbolicObj3 (symbolicGetMesh) 20 | 21 | -- Vectors. 22 | import Linear(V2(V2), V3(V3)) 23 | 24 | -- Haskell representations of objects to benchmark. 25 | 26 | -- FIXME: move each of these objects into seperate compilable files. 27 | 28 | -- | What we extrude in the example on the website. 29 | obj2d_1 :: SymbolicObj2 30 | obj2d_1 = 31 | unionR 8 32 | [ circle 10 33 | , translate (V2 22 0) $ circle 10 34 | , translate (V2 0 22) $ circle 10 35 | , translate (V2 (-22) 0) $ circle 10 36 | , translate (V2 0 (-22)) $ circle 10 37 | ] 38 | 39 | -- | An extruded version of obj2d_1, should be identical to the website's example, and example5.escad. 40 | object1 :: SymbolicObj3 41 | object1 = extrudeM (Right twist) (C1 1) (Left (V2 0 0)) obj2d_1 (Left 40) 42 | where 43 | twist :: ℝ -> ℝ 44 | twist h = 35*cos(h*2*pi/60) 45 | 46 | -- | another 3D object, for benchmarking. 47 | object2 :: SymbolicObj3 48 | object2 = squarePipe (10,10,10) 1 100 49 | where 50 | squarePipe :: (ℝ,ℝ,ℝ) -> ℝ -> ℝ -> SymbolicObj3 51 | squarePipe (x,y,z) diameter precision = 52 | union 53 | ((\(a, b, c)-> translate (V3 a b c) 54 | $ rect3 (pure 0) (pure diameter) 55 | ) 56 | <$> 57 | zip3 (fmap (\n->(fromIntegral n/precision)*x) [0..100::Fastℕ]) 58 | (fmap (\n->(fromIntegral n/precision)*y) [0..100::Fastℕ]) 59 | (fmap (\n->(fromIntegral n/precision)*z) [0..100::Fastℕ])) 60 | 61 | -- | A third 3d object to benchmark. 62 | object3 :: SymbolicObj3 63 | object3 = 64 | withRounding 1 $ difference (rect3 (pure (-1)) (pure 1)) [ rect3 (pure 0) (pure 2)] 65 | 66 | -- | Example 13 - the rounded union of a cube and a sphere. 67 | object4 :: SymbolicObj3 68 | object4 = union [ 69 | rect3 (pure 0) (pure 20), 70 | translate (pure 20) (sphere 15) ] 71 | 72 | -- | Benchmark a 2D object. 73 | obj2Benchmarks :: String -> String -> SymbolicObj2 -> Benchmark 74 | obj2Benchmarks name filename obj = 75 | bgroup name 76 | [ 77 | bench "SVG write" $ nfAppIO (writeSVG 1 $ filename <> ".svg") obj, 78 | bench "PNG write" $ nfAppIO (writePNG2 1 $ filename <> ".png") obj, 79 | bench "DXF write" $ nfAppIO (writeDXF2 1 $ filename <> ".dxf") obj, 80 | bench "Get contour" $ nf (symbolicGetContour 1 defaultObjectContext) obj 81 | ] 82 | 83 | -- | Benchmark a 3D object. 84 | obj3Benchmarks :: String -> String -> SymbolicObj3 -> Benchmark 85 | obj3Benchmarks name filename obj = 86 | bgroup name 87 | [ 88 | -- bench "PNG write" $ writePNG3 1 "benchmark.png" obj 89 | bench "STLTEXT write" $ nfAppIO (writeSTL 1 $ filename <> ".stl.text") obj, 90 | bench "STL write" $ nfAppIO (writeBinSTL 1 $ filename <> ".stl") obj, 91 | bench "Get mesh" $ nf (symbolicGetMesh 1) obj 92 | ] 93 | 94 | -- | Benchmark all of our objects. 95 | benchmarks :: [Benchmark] 96 | benchmarks = 97 | [ obj3Benchmarks "Object 1" "example5" object1 98 | , obj3Benchmarks "Object 2" "object2" object2 99 | , obj3Benchmarks "Object 3" "object3" object3 100 | , obj3Benchmarks "Object 4" "object4" object4 101 | , obj2Benchmarks "Object 2d 1" "example18" obj2d_1 102 | ] 103 | 104 | -- | Our entrypoint. Runs all benchmarks. 105 | main :: IO () 106 | main = defaultMain benchmarks 107 | 108 | -------------------------------------------------------------------------------- /programs/parser-bench.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright (C) 2016, Kelvin Cookshaw (kelvin@cookshaw.com) 3 | -- Copyright 2014-2019, Julia Longtin (julial@turinglace.com) 4 | -- Released under the GNU AGPLV3+, see LICENSE 5 | 6 | import Prelude (IO, String, Int, Either(Left, Right), return, show, ($), otherwise, (==), (-), (<>), mod, concat, error) 7 | import Criterion.Main (Benchmark, bgroup, defaultMain, bench, env, whnf) 8 | import Graphics.Implicit.ExtOpenScad.Definitions (Expr, StatementI) 9 | import Graphics.Implicit.ExtOpenScad.Parser.Expr (expr0) 10 | import Graphics.Implicit.ExtOpenScad.Parser.Statement (parseProgram) 11 | import Text.ParserCombinators.Parsec (parse) 12 | import Text.Printf (printf) 13 | 14 | lineComment :: Int -> String 15 | lineComment width = "//" <> ['x' | _ <- [1..width]] <> "\n" 16 | 17 | lineComments :: Int -> String 18 | lineComments n = concat [lineComment 80 | _ <- [1..n]] 19 | 20 | blockComment :: Int -> Int -> String 21 | blockComment lineCount width = 22 | "/*" <> concat [['x' | _ <- [1..width]] <> "\n" | _ <- [1..lineCount]] <> "*/" 23 | 24 | blockComments :: Int -> Int -> String 25 | blockComments lineCount n = concat [blockComment lineCount 40 | _ <- [1..n]] 26 | 27 | throwAway :: Int -> String 28 | throwAway n = concat ["%cube (10);*cube (10);" | _ <- [1..n]] 29 | 30 | include :: Int -> String 31 | include n = concat ["include ;" | _ <- [1..n]] 32 | 33 | use :: Int -> String 34 | use n = concat ["use ;" | _ <- [1..n]] 35 | 36 | assignments :: Int -> String 37 | assignments n = concat ["x = (foo + bar);\n" | _ <- [1..n]] 38 | 39 | functionDeclarations :: Int -> String 40 | functionDeclarations n = concat ["function functionname(arg, arg2) = sin(arg*arg2);" | _ <- [1..n]] 41 | 42 | echos :: Int -> String 43 | echos n = concat ["echo(" <> show x <> ");" | x <- [1..n]] 44 | 45 | ifs :: Int -> String 46 | ifs n = concat ["if (true) {cube (10);} else {cube (20);}" | _ <- [1..n]] 47 | 48 | fors :: Int -> String 49 | fors n = concat ["for (i=[0:1:10]) {cube (i);}" | _ <- [1..n]] 50 | 51 | moduleCalls :: Int -> String 52 | moduleCalls n = concat ["moduleno" <> show x <> " (" <> show x <> ");" | x <- [1..n]] 53 | 54 | moduleDeclarations :: Int -> String 55 | moduleDeclarations n = concat ["module modulename(arg, arg2=10) { cube(arg2); }" | _ <- [1..n]] 56 | 57 | ternary :: Int -> String 58 | ternary n = concat ["true?1:" | _ <- [1..n]] <> "2" 59 | 60 | lets :: Int -> String 61 | lets n = concat ["let (a=1) " | _ <- [1..n]] <> " a" 62 | 63 | intList :: Int -> String 64 | intList n = "[" <> concat [show i <> "," | i <- [1..n]] <> "0]" 65 | 66 | intParList :: Int -> String 67 | intParList n = "(" <> concat [show i <> "," | i <- [1..n]] <> "0)" 68 | 69 | intPosNegList :: Int -> String 70 | intPosNegList n = "[" <> concat [posOrNeg i <> show i <> "," | i <- [1..n]] <> "0]" 71 | where 72 | posOrNeg :: Int -> String 73 | posOrNeg x = if x `mod` 2 == 1 74 | then "+" 75 | else "-" 76 | 77 | parExpr :: Int -> String 78 | parExpr n = concat ["(a+" <> show i <> "+" | i <- [0..n]] <> "0)" <> concat ["+" <> show i <> ")" | i <- [1..n]] 79 | 80 | genList :: Int -> String 81 | genList n = concat ["[1:1:" <> show i <> "] ++ " | i <- [1..n]] <> "0" 82 | 83 | stringList :: Int -> String 84 | stringList n = "[" <> concat ["\"" <> show i <> "\", " | i <- [1..n]] <> " \"something\"]" 85 | 86 | boolList :: Int -> String 87 | boolList n = "[" <> concat [trueOrFalse i <> "," | i <- [1..n]] <> "false]" 88 | where 89 | trueOrFalse :: Int -> String 90 | trueOrFalse x = if x `mod` 2 == 1 91 | then "true" 92 | else "false" 93 | 94 | undefinedList :: Int -> String 95 | undefinedList n = "[" <> concat ["undef, " | _ <- [1..n]] <> "undef]" 96 | 97 | deepArithmetic :: Int -> String 98 | deepArithmetic n 99 | | n == 0 = "1" 100 | | otherwise = printf "%s + %s * (%s - %s)" d d d d 101 | where 102 | d = deepArithmetic (n - 1) 103 | 104 | parseExpr :: String -> Expr 105 | parseExpr s = case parse expr0 "src" s of 106 | Left err -> error (show err) 107 | Right e -> e 108 | 109 | parseStatements :: String -> [StatementI] 110 | parseStatements s = case parseProgram "noname" s of 111 | Left err -> error (show err) 112 | Right e -> e 113 | 114 | run :: String -> (String -> a) -> String -> Benchmark 115 | run name func input = 116 | env (return input) $ \s -> 117 | bench name $ whnf func s 118 | 119 | main :: IO () 120 | main = 121 | defaultMain 122 | [ bgroup "lexer" [ 123 | bgroup "comments" 124 | [ run "line" parseStatements (lineComments 5000) 125 | , run "block" parseStatements (blockComments 10 500) 126 | ] 127 | ] 128 | , bgroup "statement" [ 129 | run "throwAway" parseStatements (throwAway 500) 130 | , bgroup "includes" 131 | [ run "include" parseStatements (include 5000) 132 | , run "use" parseStatements (use 5000) 133 | ] 134 | , run "assignments" parseStatements (assignments 50) 135 | , run "function declarations" parseStatements (functionDeclarations 100) 136 | , run "echos" parseStatements (echos 1000) 137 | , run "ifs" parseStatements (ifs 250) 138 | , run "fors" parseStatements (fors 50) 139 | , run "module calls" parseStatements (moduleCalls 500) 140 | , run "module declarations" parseStatements (moduleDeclarations 500) 141 | ] 142 | , bgroup "expression" [ 143 | run "ternary operators" parseExpr (ternary 500) 144 | , run "let statements" parseExpr (lets 3) 145 | , run "int list" parseExpr (intList 100) 146 | , run "parenthesized int list" parseExpr (intParList 100) 147 | , run "parenthesized expression" parseExpr (parExpr 2) 148 | , run "generated list" parseExpr (genList 50) 149 | , run "list of positive or negative integers" parseExpr (intPosNegList 100) 150 | , run "string list" parseExpr (stringList 100) 151 | , run "bool list" parseExpr (boolList 100) 152 | , run "undefined list" parseExpr (undefinedList 100) 153 | , run "deep arithmetic" parseExpr (deepArithmetic 3) 154 | ] 155 | ] 156 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | attrs@{...}: 2 | let 3 | inherit (import ./. attrs) pkgs haskellPackages; 4 | hlib = pkgs.haskell.lib; 5 | 6 | packages = [ 7 | "implicit" 8 | "implicit-interpreter" 9 | ]; 10 | extract-external-inputs = p: 11 | builtins.filter 12 | (dep: !(builtins.elem dep packages)) 13 | (map 14 | (x: x.pname) 15 | (hlib.getHaskellBuildInputs haskellPackages.${p})); 16 | external-inputs = 17 | map 18 | (x: haskellPackages.${x}) 19 | (builtins.concatLists 20 | (map 21 | extract-external-inputs 22 | packages)); 23 | metaPackage = 24 | haskellPackages.mkDerivation 25 | { pname = "implicit-shell"; 26 | version = "0.0.0.0"; 27 | libraryHaskellDepends = external-inputs; 28 | license = pkgs.stdenv.lib.licenses.asl20;}; 29 | 30 | package-envs = 31 | builtins.listToAttrs 32 | (map 33 | (p: 34 | { name = p; 35 | value = haskellPackages.${p}.env;}) 36 | packages); 37 | 38 | in 39 | 40 | metaPackage.env // package-envs 41 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: https://github.com/commercialhaskell/stack/blob/master/doc/yaml_configuration.md 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | 5 | resolver: lts-16.25 6 | 7 | # Local packages, usually specified by relative directory name 8 | packages: 9 | - '.' 10 | 11 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 12 | extra-deps: 13 | - storable-endian-0.2.6@sha256:cae7aac2bfe6037660b2cf294891867e69bcd74e739a3b3ea759e9ad99d6c889,801 14 | - quickspec-2.1.5@sha256:1d1cc020fa9075cb5fafd4056fe1d930d5763b954fa8200e57ce6aba057544b2,3557 15 | - twee-lib-2.2@sha256:9fe9327505d8f450a94f2fc9eea74b292901b7992d520aa1dd4f0410fbe0e594,2112 16 | 17 | # Override default flag values for local packages and extra-deps 18 | flags: {} 19 | 20 | # Control whether we use the GHC we find on the path 21 | # system-ghc: true 22 | 23 | # Require a specific version of stack, using version ranges 24 | # require-stack-version: -any # Default 25 | # require-stack-version: >= 0.1.4.0 26 | 27 | # Override the architecture used by stack, especially useful on Windows 28 | # arch: i386 29 | # arch: x86_64 30 | 31 | # Extra directories used by stack for building 32 | # extra-include-dirs: [/path/to/dir] 33 | # extra-lib-dirs: [/path/to/dir] 34 | -------------------------------------------------------------------------------- /tests/ExecSpec/Expr.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright (C) 2014-2017, Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | module ExecSpec.Expr (exprExec) where 6 | 7 | -- Be explicit about what we import. 8 | import Prelude (($), (==), length, null, Bool (False), (<=), (&&), (<>), show) 9 | 10 | -- Hspec, for writing specs. 11 | import Test.Hspec (describe, Spec, it, shouldSatisfy, expectationFailure) 12 | 13 | -- The type used for variables, in ImplicitCAD. 14 | import Graphics.Implicit.Definitions (ℝ) 15 | 16 | -- Our utility library, for making these tests easier to read. 17 | import ExecSpec.Util ((-->), num, list, vect) 18 | 19 | import Graphics.Implicit.ExtOpenScad.Eval.Constant (runExpr) 20 | import Graphics.Implicit.ExtOpenScad.Definitions (OVal(OIO, OList, ONum, OUndefined)) 21 | 22 | -- Default all numbers in this file to being of the type ImplicitCAD uses for values. 23 | default (ℝ) 24 | 25 | exprExec :: Spec 26 | exprExec = do 27 | describe "arithmetic" $ do 28 | it "performs simple addition" $ 29 | "1+1" --> num 2 30 | it "performs multiple additions" $ 31 | "1+1+1" --> num 3 32 | it "performs sum on numbers" $ 33 | "sum(1,1)" --> num 2 34 | it "performs sum on list" $ 35 | "sum([1,2,3])" --> num 6 36 | it "performs vector additions" $ 37 | "[1, 2, 3] + [3, 4, 5]" --> vect [4, 6, 8] 38 | it "performs nested vector additions" $ 39 | "[1, [2, 3]] + [3, [4, 5]]" --> list [num 4, vect [6, 8]] 40 | it "performs vector substraction" $ 41 | "[1, 2, 3] - [1, 1, 1]" --> vect [0, 1, 2] 42 | it "performs number and list/vector addition" $ 43 | "2 + [1, 2]" --> vect [3, 4] 44 | it "performs number and list/vector multiplication" $ 45 | "2 * [3, 4, 5]" --> vect [6, 8, 10] 46 | it "performs matrix multiplication" $ do 47 | -- number - matrix, covered above but included for completness 48 | "4 * [[3, 4, -1], [0, 9, 5]]" --> list [vect [12, 16, -4], vect [0, 36, 20]] 49 | -- matrix - vector 50 | "[[1, -1, 2], [0, -3, 1]] * [2, 1, 0]" --> vect [1, -3] 51 | -- vector - matrix 52 | "[2, 1] * [[1, -1, 2], [0, -3, 1]]" --> vect [2, -5, 5] 53 | --matrix - matrix 54 | "[[12, 8, 4], [3, 17, 14], [9, 8, 10]] * [[5, 19, 3], [6, 15, 9], [7, 8, 16]]" --> list [vect [136, 380, 172], vect [215, 424, 386], vect [163, 371, 259]] 55 | describe "rands" $ do 56 | it "generates random numbers" $ do 57 | case runExpr "rands(1,2,1)" False of 58 | (OIO m, _) -> do 59 | OList l <- m 60 | shouldSatisfy l $ \l' -> length l' == 1 61 | _ -> expectationFailure "Not an OIO" 62 | case runExpr "rands(1,2,10)" False of 63 | (OIO m, _) -> do 64 | OList l <- m 65 | shouldSatisfy l $ \l' -> length l' == 10 66 | _ -> expectationFailure "Not an OIO" 67 | case runExpr "rands(1,2,0)" False of 68 | (OIO m, _) -> do 69 | OList l <- m 70 | shouldSatisfy l $ \l' -> null l' 71 | _ -> expectationFailure "Not an OIO" 72 | case runExpr "rands(1,1,1)" False of 73 | (OIO m, _) -> do 74 | OList l <- m 75 | shouldSatisfy l $ \l' -> 76 | length l' == 1 && 77 | l' == [num 1] 78 | _ -> expectationFailure "Not an OIO" 79 | case runExpr "rands(1,2,1)[0]" False of 80 | (OIO m, _) -> do 81 | ONum n <- m 82 | shouldSatisfy n $ \n' -> 1 <= n' && n' <= 2 83 | o -> expectationFailure $ "Not an OIO: " <> show o 84 | case runExpr "rands(1,2,2)[0+1]" False of 85 | (OIO m, _) -> do 86 | ONum n <- m 87 | shouldSatisfy n $ \n' -> 1 <= n' && n' <= 2 88 | o -> expectationFailure $ "Not an OIO: " <> show o 89 | describe "lookup" $ do 90 | it "Gets a value from a table" $ do 91 | "lookup(1, [[0, 0], [1, 1], [2, 2]])" --> num 1 92 | it "Interpolates values from a table" $ do 93 | "lookup(1, [[0, 0], [2, 2]])" --> num 1 94 | "lookup(7, [[0, 0], [5, 50], [10, 100], [11, 0]])" --> num 70 95 | "lookup(10.5, [[0, 0], [5, 50], [10, 100], [11, 0]])" --> num 50 96 | it "Gets an upper extreme from a table" $ do 97 | "lookup(10, [[0, 0], [1, 1], [2, 2]])" --> num 2 98 | it "Gets an lower extreme from a table" $ do 99 | "lookup(0, [[1, 1], [2, 2]])" --> num 1 100 | it "Gets an nothing from a table" $ do 101 | "lookup(0, [])" --> OUndefined 102 | it "Handles embedded statements" $ do 103 | "lookup(0+1, [[0*2, 0], [1+1, 4/2]])" --> num 1 104 | describe "let bindings" $ do 105 | it "Evaluates let bindings" $ do 106 | -- basic let binding 107 | "let (a = 1) [a, 1]" --> vect [1, 1] 108 | -- Directly nested lets 109 | "let (a = 1) let (b = a) [a, b]" --> vect [1, 1] 110 | "let (a = 1) let (b = a) let (c = b) [a, b, c]" --> vect [1, 1, 1] 111 | "let (a = 1) let (b = a) let (c = a) [a, b, c]" --> vect [1, 1, 1] 112 | "let (a = 1) let (b = a) let (c = b + 1) [a, b, c]" --> vect [1, 1, 2] 113 | "let (a = 1) let (b = a) let (c = a + 1) [a, b, c]" --> vect [1, 1, 2] 114 | "let (a = 1) let (b = a+1) let (c = b+1) [a, b, c]" --> vect [1, 2, 3] 115 | "let (a = 1) let (a = a+1) [a]" --> vect [2] 116 | -- Indirect nesting 117 | "let (a = 1) [a, let (b = a) b]" --> vect [1, 1] 118 | -- Let name overloading 119 | "let (a = 1) let (b = a + 1) let (a = b) [a, a]" --> vect [2, 2] 120 | -- Scoped name overloading 121 | "let (a = 1) let (b = a + 1) [a, let (a = b) a]" --> vect [1, 2] 122 | describe "operator precedence" $ do 123 | -- https://github.com/Haskell-Things/ImplicitCAD/issues/428 124 | it "Evaluates exponents correctly" $ do 125 | "2*3^2" --> num 18 126 | "-2^2" --> num 4 127 | "-(2^2)" --> num (-4) 128 | -------------------------------------------------------------------------------- /tests/ExecSpec/Util.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright 2014 2015 2016, Julia Longtin (julial@turinglace.com) 3 | -- Copyright 2015 2016, Mike MacHenry (mike.machenry@gmail.com) 4 | -- Released under the GNU AGPLV3+, see LICENSE 5 | 6 | -- Utilities 7 | module ExecSpec.Util 8 | ( (-->) 9 | , num 10 | , list 11 | , vect 12 | , io 13 | ) where 14 | 15 | -- be explicit about where we get things from. 16 | import Prelude (String, Bool(False), map, (.), IO) 17 | 18 | -- The datatype of positions in our world. 19 | import Graphics.Implicit.Definitions (ℝ) 20 | 21 | -- Expressions, symbols, and values in the OpenScad language. 22 | import Graphics.Implicit.ExtOpenScad.Definitions (OVal(ONum, OList, OIO)) 23 | 24 | import Graphics.Implicit.ExtOpenScad.Eval.Constant (runExpr) 25 | 26 | import Test.Hspec (Expectation, shouldBe) 27 | 28 | -- An operator for expressions for "the left side should evaluate to the right side." 29 | infixr 1 --> 30 | (-->) :: String -> OVal -> Expectation 31 | (-->) source value = 32 | runExpr source False `shouldBe` (value, []) 33 | 34 | -- Types 35 | 36 | num :: ℝ -> OVal 37 | num = ONum 38 | 39 | list :: [OVal] -> OVal 40 | list = OList 41 | 42 | vect :: [ℝ] -> OVal 43 | vect = list . map num 44 | 45 | io :: IO OVal -> OVal 46 | io = OIO 47 | -------------------------------------------------------------------------------- /tests/GoldenSpec/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | 4 | module GoldenSpec.Util (golden, goldenAllFormats, goldenFormat, goldenFormat2) where 5 | 6 | import Control.Monad (forM_, unless) 7 | import Control.Monad.IO.Class (liftIO) 8 | import Graphics.Implicit (SymbolicObj2, SymbolicObj3) 9 | import Graphics.Implicit.Export (export2, export3) 10 | import Graphics.Implicit.Export.OutputFormat (OutputFormat (ASCIISTL), formats3D, formatExtension) 11 | import Prelude (IO, FilePath, Bool (True, False), String, Double, pure, (==), (>>=), (<>), ($), show) 12 | import System.Directory (getTemporaryDirectory, doesFileExist, removeFile) 13 | import System.IO (hClose, openTempFile) 14 | import Test.Hspec (describe, it, SpecWith) 15 | import Test.HUnit (assertFailure) 16 | import Data.ByteString (readFile, writeFile) 17 | 18 | -- | Construct a golden test for rendering the given 'SymbolicObj3' at the 19 | -- specified resolution in ASCIISTL format. 20 | golden :: String -> Double -> SymbolicObj3 -> SpecWith () 21 | golden = goldenFormat ASCIISTL 22 | 23 | -- | Construct a golden test for rendering the given 'SymbolicObj3' at the 24 | -- specified resolution in all 3D formats. 25 | goldenAllFormats :: String -> Double -> SymbolicObj3 -> SpecWith () 26 | goldenAllFormats name resolution sym = do 27 | describe ("golden " <> name) 28 | $ forM_ formats3D 29 | $ \fmt -> goldenFormat fmt name resolution sym 30 | 31 | -- | Construct a golden test for rendering the given 'SymbolicObj2|3' at the 32 | -- specified resolution. On the first run of this test, it will render the 33 | -- object and cache the results. Subsequent test runs will compare their result 34 | -- to the cached one. This is valuable for ensuring mesh generation doesn't 35 | -- break across commits. 36 | -- 37 | -- The objects are cached under @tests/golden/@, with the given name. Deleting 38 | -- this file is sufficient to update the test if changes in the mesh generation 39 | -- are intended. 40 | goldenFormat' 41 | :: ( OutputFormat 42 | -> Double 43 | -> FilePath 44 | -> a 45 | -> IO () 46 | ) 47 | -> OutputFormat 48 | -> String 49 | -> Double 50 | -> a 51 | -> SpecWith () 52 | goldenFormat' exportFn fmt name resolution sym = it (name <> " (golden, format: " <> show fmt <> ")") $ do 53 | (okay, goldenFp, tempFp) <- liftIO $ do 54 | tempFp <- getTemporaryFilePath "golden" 55 | -- Output the rendered mesh 56 | exportFn fmt resolution tempFp sym 57 | !res <- readFile tempFp 58 | let goldenFp = "./tests/golden/" <> name <> "." <> formatExtension fmt 59 | -- Check if the cached results already exist. 60 | doesFileExist goldenFp >>= \case 61 | True -> pure () 62 | -- If not, save the mesh we just created in the cache. 63 | False -> writeFile goldenFp res 64 | !cached <- readFile goldenFp 65 | -- Finally, ceck if the two meshes are equal. 66 | if res == cached 67 | then do 68 | removeFile tempFp 69 | pure (True, goldenFp, tempFp) 70 | else 71 | pure (False, goldenFp, tempFp) 72 | 73 | unless okay 74 | $ assertFailure 75 | $ "Object doesn't match its golden preimage," 76 | <> " temporary file preserved at " 77 | <> tempFp 78 | <> " compare with original at " 79 | <> goldenFp 80 | 81 | -- | Test for @SymbolicObj3@ 82 | goldenFormat 83 | :: OutputFormat 84 | -> String 85 | -> Double 86 | -> SymbolicObj3 87 | -> SpecWith () 88 | goldenFormat = goldenFormat' export3 89 | 90 | -- | Test for @SymbolicObj2@ 91 | goldenFormat2 92 | :: OutputFormat 93 | -> String 94 | -> Double 95 | -> SymbolicObj2 96 | -> SpecWith () 97 | goldenFormat2 = goldenFormat' export2 98 | 99 | ------------------------------------------------------------------------------ 100 | -- | Get a temporary filepath with the desired extension. On unix systems, this 101 | -- is a file under @/tmp@. Useful for tests that need to write files. 102 | getTemporaryFilePath 103 | :: String -- ^ File extension 104 | -> IO FilePath 105 | getTemporaryFilePath ext = do 106 | tempdir <- getTemporaryDirectory 107 | -- The only means available to us for getting a temporary filename also opens 108 | -- its file handle. Because the 'writeSTL' function opens the file handle 109 | -- itself, we must first close our handle. 110 | (fp, h) <- openTempFile tempdir "implicit-golden" 111 | hClose h 112 | pure $ fp <> "." <> ext 113 | -------------------------------------------------------------------------------- /tests/Graphics/Implicit/Test/Utils.hs: -------------------------------------------------------------------------------- 1 | module Graphics.Implicit.Test.Utils (randomGroups) where 2 | 3 | import Prelude (drop, (<*>), (<$>), take, length, pure) 4 | import Test.QuickCheck ( choose, Gen ) 5 | 6 | {-# ANN randomGroups "HLint: ignore Redundant <$>" #-} 7 | randomGroups :: [a] -> Gen [[a]] 8 | randomGroups [] = pure [] 9 | randomGroups as = do 10 | n <- choose (1, length as) 11 | (:) <$> pure (take n as) 12 | <*> randomGroups (drop n as) 13 | 14 | -------------------------------------------------------------------------------- /tests/Main.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright (C) 2018, Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | -- be explicit about what we import. 6 | import Prelude (($), IO) 7 | 8 | -- our testing engine. 9 | import Test.Hspec(hspec, describe) 10 | 11 | -- the parser test for statements. 12 | import ParserSpec.Statement(statementSpec) 13 | 14 | -- the parser test for expressions. 15 | import ParserSpec.Expr(exprSpec) 16 | 17 | -- the execution test for expressions. 18 | import ExecSpec.Expr(exprExec) 19 | 20 | -- the execution test for warnings. 21 | import MessageSpec.Message(programExec) 22 | 23 | import PropertySpec (propSpec) 24 | 25 | import qualified GoldenSpec.Spec as Golden 26 | import qualified ImplicitSpec as Implicit 27 | import qualified RewriteSpec as Rewrite 28 | import qualified TesselationSpec as Tesselation 29 | 30 | main :: IO () 31 | main = hspec $ do 32 | -- run the golden tests to ensure we haven't broken mesh generation 33 | describe "golden tests" Golden.spec 34 | 35 | describe "extopenscad tests" $ do 36 | -- run tests against the expression parsing engine. 37 | describe "expression parsing" exprSpec 38 | -- and now, against the statement parsing engine. 39 | describe "statements parsing" statementSpec 40 | -- run tests against the expression execution engine. single statements. 41 | describe "expression execution" exprExec 42 | -- run tests against the evaluation engine, checking for messages. 43 | describe "program execution" programExec 44 | 45 | -- Generate data to be evaluated, and ensure the properties hold. 46 | describe "property tests" propSpec 47 | 48 | Implicit.spec 49 | Tesselation.spec 50 | Rewrite.spec 51 | 52 | -------------------------------------------------------------------------------- /tests/MessageSpec/Message.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright (C) 2014-2017, Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | -- Allow us to use string literals for Text 6 | {-# LANGUAGE OverloadedStrings #-} 7 | 8 | module MessageSpec.Message (programExec) where 9 | 10 | -- Be explicit about what we import. 11 | import Prelude (($)) 12 | 13 | -- Hspec, for writing specs. 14 | import Test.Hspec (describe, Spec, it) 15 | 16 | -- The types used for variables, in ImplicitCAD. 17 | import Graphics.Implicit.Definitions (Fastℕ, ℝ) 18 | 19 | import Graphics.Implicit.ExtOpenScad.Definitions (MessageType(TextOut), SourcePosition(SourcePosition)) 20 | 21 | -- Our utility library, for making these tests easier to read. 22 | import MessageSpec.Util ((-->), oneMessage) 23 | 24 | -- Default all numbers in this file to being of the type ImplicitCAD uses for values. 25 | default (Fastℕ, ℝ) 26 | 27 | programExec :: Spec 28 | programExec = 29 | describe "arithmatic" $ do 30 | it "echoes simple addition" $ 31 | "echo(1+1);" --> oneMessage TextOut (SourcePosition 1 1 []) "2.0" 32 | it "calls a no argument function" $ 33 | "module a(){echo(1);}a();" --> oneMessage TextOut (SourcePosition 1 12 []) "1.0" 34 | it "calls a single argument function" $ 35 | "module a(b){echo(b);}a(1);" --> oneMessage TextOut (SourcePosition 1 13 []) "1.0" 36 | it "calls a function with a named and an unnamed argument" $ 37 | "module a(b,c){echo(b+c);}a(b=1,1);" --> oneMessage TextOut (SourcePosition 1 15 []) "2.0" 38 | -- it "warns about a missing argument" $ 39 | -- "module a(b){echo(b);}a();" --> oneMessage TextOut (SourcePosition 1 13 []) "1.0" 40 | it "handles let bindings in functions" $ 41 | "function foo(a,b,c) = let(output=b) [output,b]; echo(foo(1,2,3));" --> oneMessage TextOut (SourcePosition 1 49 []) "[2.0,2.0]" 42 | -------------------------------------------------------------------------------- /tests/MessageSpec/Util.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright 2014 2015 2016, Julia Longtin (julial@turinglace.com) 3 | -- Copyright 2015 2016, Mike MacHenry (mike.machenry@gmail.com) 4 | -- Released under the GNU AGPLV3+, see LICENSE 5 | 6 | -- Utilities 7 | module MessageSpec.Util 8 | ( (-->) 9 | , oneMessage 10 | ) where 11 | 12 | -- be explicit about where we get things from. 13 | import Prelude (String, Bool(False), IO, return, Maybe (Nothing)) 14 | 15 | -- Expressions, symbols, and values in the OpenScad language. 16 | import Graphics.Implicit.ExtOpenScad.Definitions (ScadOpts(ScadOpts), MessageType, Message(Message), SourcePosition) 17 | 18 | import Graphics.Implicit.ExtOpenScad (runOpenscad) 19 | 20 | import Test.Hspec (Expectation, shouldReturn) 21 | 22 | import Data.Text.Lazy (Text) 23 | 24 | -- | decide what options to send to the scad engine. 25 | generateScadOpts :: ScadOpts 26 | generateScadOpts = ScadOpts compat_flag import_flag 27 | where 28 | compat_flag = False -- Do not try to be extra compatible with openscad. 29 | import_flag = False -- Do not honor include or use statements. 30 | 31 | -- An operator for expressions for "the left side should evaluate to the right side." 32 | infixr 1 --> 33 | (-->) :: String -> [Message] -> Expectation 34 | (-->) source value = 35 | getOpenscadMessages scadOptions [] source `shouldReturn` value 36 | where 37 | scadOptions = generateScadOpts 38 | 39 | -- | An even smaller wrapper which runs a program, and only returns the generated messages. for the test suite. 40 | getOpenscadMessages :: ScadOpts -> [String] -> String -> IO [Message] 41 | getOpenscadMessages scadOpts constants source = do 42 | (_, _, _, messages) <- runOpenscad scadOpts constants Nothing source 43 | return messages 44 | 45 | oneMessage :: MessageType -> SourcePosition -> Text -> [Message] 46 | oneMessage msgType pos text = [Message msgType pos text] 47 | -------------------------------------------------------------------------------- /tests/NOTES: -------------------------------------------------------------------------------- 1 | https://github.com/nmz787/microfluidic-cad: GPLV2 or greater 2 | -------------------------------------------------------------------------------- /tests/ParserSpec/Statement.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright (C) 2014-2017, Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | -- Allow us to use shorter forms of Var and Name. 6 | {-# LANGUAGE PatternSynonyms #-} 7 | 8 | -- Allow us to use string literals for Text 9 | {-# LANGUAGE OverloadedStrings #-} 10 | 11 | -- | Statement related hspec tests. 12 | module ParserSpec.Statement (statementSpec) where 13 | 14 | import Prelude (String, Maybe(Just, Nothing), Bool(True), ($)) 15 | 16 | import Test.Hspec (Spec, Expectation, shouldBe, it, describe) 17 | 18 | import Data.Text.Lazy (Text) 19 | 20 | import ParserSpec.Util (bool, num, minus, plus, mult, index) 21 | 22 | import Graphics.Implicit.ExtOpenScad.Definitions (StatementI(StatementI), Symbol(Symbol), Expr(ListE, LamE, (:$)), Statement(NewModule, ModuleCall, If, (:=)), Pattern(ListP), SourcePosition(SourcePosition)) 23 | 24 | import qualified Graphics.Implicit.ExtOpenScad.Definitions as GIED (Expr(Var), Pattern(Name)) 25 | 26 | -- Parse an ExtOpenScad program. 27 | import Graphics.Implicit.ExtOpenScad.Parser.Statement (parseProgram) 28 | 29 | import Graphics.Implicit.Definitions (Fastℕ) 30 | 31 | import Data.Either (Either(Right)) 32 | 33 | -- Let us use the old syntax when defining Vars and Names. 34 | pattern Var :: Text -> Expr 35 | pattern Var s = GIED.Var (Symbol s) 36 | pattern Name :: Text -> Pattern 37 | pattern Name n = GIED.Name (Symbol n) 38 | 39 | -- | an expectation that a string is equivalent to a statement. 40 | (-->) :: String -> [StatementI] -> Expectation 41 | (-->) source stmts = 42 | parseProgram "noname" source `shouldBe` Right stmts 43 | infixr 1 --> 44 | 45 | -- | A single statement. 46 | single :: Statement StatementI -> [StatementI] 47 | single st = [StatementI (SourcePosition 1 1 "noname") st] 48 | 49 | -- | A function call. 50 | call :: Text -> Fastℕ -> [(Maybe Symbol, Expr)] -> [StatementI] -> StatementI 51 | call name column args stmts = StatementI (SourcePosition 1 column "noname") (ModuleCall (Symbol name) args stmts) 52 | 53 | -- | Test assignments. 54 | assignmentSpec :: Spec 55 | assignmentSpec = do 56 | it "handles assignment" $ 57 | "y = -5 ; " --> single ( Name "y" := num (-5)) 58 | it "handles pattern matching" $ 59 | "[ x , y ] = [ 1 , 2 ] ; " --> single (ListP [Name "x", Name "y"] := ListE [num 1, num 2]) 60 | it "handles the function keyword" $ 61 | "function foo ( x , y ) = x * y ; " --> single fooFunction 62 | it "handles function with let expression" $ 63 | "function withlet ( b ) = let ( c = 5 ) b + c ; " --> 64 | single (Name "withlet" := LamE [Name "b"] (LamE [Name "c"] (plus [Var "b", Var "c"]) :$ [num 5])) 65 | -- https://github.com/Haskell-Things/ImplicitCAD/issues/431 66 | it "handles function with let expression" $ 67 | "function foo(a,b,c) = let(output=b) [output,b];" --> 68 | single (Name "foo" := LamE [Name "a", Name "b", Name "c"] (LamE [Name "output"] (ListE [Var "output", Var "b"]) :$ [Var "b"])) 69 | it "handles nested indexing" $ 70 | "x = [ y [ 0 ] - z * 2 ] ; " --> 71 | single ( Name "x" := ListE [minus [index [Var "y", num 0], 72 | mult [Var "z", num 2]]]) 73 | where 74 | fooFunction :: Statement st 75 | fooFunction = Name "foo" := LamE [Name "x", Name "y"] 76 | (mult [Var "x", Var "y"]) 77 | 78 | -- Test a simple if block. 79 | ifSpec :: Spec 80 | ifSpec = do 81 | it "parses" $ 82 | "if ( true ) { a ( ) ; }" --> 83 | single ( If (bool True) [call "a" 15 [] []] []) 84 | it "parses with else clause" $ 85 | "if ( true ) { a ( ) ; } else {b();}" --> 86 | single ( If (bool True) [call "a" 15 [] []] [call "b" 31 [] []]) 87 | 88 | -- Our entry point. Test all of the statements. 89 | statementSpec :: Spec 90 | statementSpec = do 91 | describe "empty file" $ 92 | it "returns an empty list" $ "" --> [] 93 | describe "assignment" assignmentSpec 94 | describe "if" ifSpec 95 | describe "line comment" $ 96 | it "parses as empty" $ "// foish bar \n " --> [] 97 | describe "multiline comment" $ 98 | it "parses as empty" $ "/* foish bar\n */ " --> [] 99 | describe "module call" $ 100 | it "parses" $ "foo ( ) ; " --> single (ModuleCall (Symbol "foo") [] []) 101 | describe "disabled module call" $ 102 | it "parses as empty" $ "% foo ( ) ; " --> [] 103 | describe "difference of two cylinders" $ 104 | it "parses correctly" $ 105 | "difference ( ) { cylinder ( r = 5 , h = 20 ) ;cylinder(r=2,h=20); } " 106 | --> single ( 107 | ModuleCall (Symbol "difference") [] [ 108 | call "cylinder" 18 [(Just (Symbol "r"), num 5.0), 109 | (Just (Symbol "h"), num 20.0)] 110 | [], 111 | call "cylinder" 47 [(Just (Symbol "r"), num 2.0), 112 | (Just (Symbol "h"), num 20.0)] 113 | []]) 114 | describe "module definition" $ do 115 | it "parses correctly" $ 116 | "module foo_bar ( ) { }" --> single (NewModule (Symbol "foo_bar") [] []) 117 | it "accepts argument" $ 118 | "module foo_bar ( x ) { }" --> single (NewModule (Symbol "foo_bar") [(Symbol "x", Nothing)] []) 119 | it "accepts argument with default" $ 120 | "module foo_bar ( x = 1) { }" --> single (NewModule (Symbol "foo_bar") [(Symbol "x", Just $ num 1)] []) 121 | it "accepts split lines" $ do 122 | "module foo\n(\nbar\n)\n{}" --> single (NewModule (Symbol "foo") [(Symbol "bar", Nothing)] []) 123 | describe "identifiers" $ do 124 | it "accepts unicode" $ 125 | "module 💩 () { }" --> single (NewModule (Symbol "💩") [] []) -------------------------------------------------------------------------------- /tests/ParserSpec/Util.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright 2014 2015 2016, Julia Longtin (julial@turinglace.com) 3 | -- Copyright 2015 2016, Mike MacHenry (mike.machenry@gmail.com) 4 | -- Released under the GNU AGPLV3+, see LICENSE 5 | 6 | -- Allow us to use string literals for Text 7 | {-# LANGUAGE OverloadedStrings #-} 8 | 9 | -- Utilities 10 | module ParserSpec.Util 11 | ( (-->) 12 | , num 13 | , bool 14 | , stringLiteral 15 | , undefined 16 | , fapp 17 | , plus 18 | , minus 19 | , mult 20 | , modulo 21 | , power 22 | , divide 23 | , not 24 | , and 25 | , or 26 | , gt 27 | , lt 28 | , negate 29 | , ternary 30 | , append 31 | , index 32 | , lambda 33 | , parseWithLeftOver 34 | ) where 35 | 36 | -- be explicit about where we get things from. 37 | import Prelude (Bool, String, Either, (<), ($), (.), (<*), otherwise) 38 | 39 | -- The datatype of positions in our world. 40 | import Graphics.Implicit.Definitions (ℝ) 41 | 42 | -- Expressions, symbols, and values in the OpenScad language. 43 | import Graphics.Implicit.ExtOpenScad.Definitions (Expr(LitE, (:$), Var, ListE, LamE), Symbol(Symbol), OVal(ONum, OBool, OString, OUndefined), Pattern) 44 | 45 | import Text.Parsec (ParseError, parse, manyTill, anyChar, eof) 46 | 47 | import Text.Parsec.String (Parser) 48 | 49 | import Control.Applicative ((<$>), (<*>)) 50 | 51 | import Test.Hspec (Expectation, shouldBe) 52 | 53 | import Data.Either (Either(Right)) 54 | 55 | import Data.Text.Lazy (Text) 56 | 57 | -- The expression parser entry point. 58 | import Graphics.Implicit.ExtOpenScad.Parser.Expr (expr0) 59 | 60 | -- An operator for expressions for "the left side should parse to the right side." 61 | infixr 1 --> 62 | (-->) :: String -> Expr -> Expectation 63 | (-->) source expr = 64 | parse (expr0 <* eof) "" source `shouldBe` Right expr 65 | 66 | -- Types 67 | 68 | num :: ℝ -> Expr 69 | num x 70 | -- FIXME: the parser should handle negative number literals 71 | -- directly, we abstract that deficiency away here 72 | | x < 0 = oapp "negate" [LitE $ ONum (-x)] 73 | | otherwise = LitE $ ONum x 74 | 75 | bool :: Bool -> Expr 76 | bool = LitE . OBool 77 | 78 | stringLiteral :: Text -> Expr 79 | stringLiteral = LitE . OString 80 | 81 | undefined :: Expr 82 | undefined = LitE OUndefined 83 | 84 | -- Operators 85 | 86 | plus,minus,mult,modulo,power,divide,negate,and,or,not,gt,lt,ternary,append,index :: [Expr] -> Expr 87 | minus = oapp "-" 88 | modulo = oapp "%" 89 | power = oapp "^" 90 | mult = oapp "*" 91 | divide = oapp "/" 92 | and = oapp "&&" 93 | or = oapp "||" 94 | not = oapp "!" 95 | gt = oapp ">" 96 | lt = oapp "<" 97 | ternary = oapp "?" 98 | negate = oapp "negate" 99 | index = oapp "index" 100 | append = oapp "++" 101 | plus = oapp "+" 102 | 103 | -- | We need two different kinds of application functions, one for operators, and one for functions. See also: 'fapp'. 104 | oapp :: Text -> [Expr] -> Expr 105 | oapp name args = Var (Symbol name) :$ args 106 | 107 | -- | See 'oapp'. 108 | fapp :: Text -> [Expr] -> Expr 109 | fapp name args = Var (Symbol name) :$ [ListE args] 110 | 111 | lambda :: [Pattern] -> Expr -> [Expr] -> Expr 112 | lambda params expr args = LamE params expr :$ args 113 | 114 | parseWithLeftOver :: Parser a -> String -> Either ParseError (a, String) 115 | parseWithLeftOver p = parse ((,) <$> p <*> leftOver) "" 116 | where 117 | leftOver :: Parser String 118 | leftOver = manyTill anyChar eof 119 | -------------------------------------------------------------------------------- /tests/PropertySpec.hs: -------------------------------------------------------------------------------- 1 | module PropertySpec 2 | ( propSpec 3 | ) where 4 | 5 | import Test.Hspec (Spec) 6 | import PropertySpec.Exec (additionSpec, subtractionSpec, multiplicationSpec, divisionSpec) 7 | 8 | propSpec :: Spec 9 | propSpec = do 10 | additionSpec 11 | subtractionSpec 12 | multiplicationSpec 13 | divisionSpec 14 | -------------------------------------------------------------------------------- /tests/PropertySpec/Exec.hs: -------------------------------------------------------------------------------- 1 | module PropertySpec.Exec 2 | ( additionSpec 3 | , subtractionSpec 4 | , multiplicationSpec 5 | , divisionSpec 6 | )where 7 | 8 | import Data.Foldable (fold, foldl1) 9 | import Data.List.NonEmpty (intersperse) 10 | import ExecSpec.Util (num) 11 | import Graphics.Implicit.ExtOpenScad.Definitions (OVal (ONum)) 12 | import Graphics.Implicit.ExtOpenScad.Eval.Constant (runExpr) 13 | import HaskellWorks.Hspec.Hedgehog (requireProperty) 14 | import Hedgehog (diff, forAll) 15 | import qualified Hedgehog.Gen as Gen 16 | import qualified Hedgehog.Range as Range 17 | import Prelude (Bool (False), Floating, String, Double, Show, 18 | Eq, Ord, fail, show, 19 | ($), (&&), (+), 20 | (.), (<$>), (<=), (*), (/), 21 | (<>), (>=), (-)) 22 | import Test.Hspec (Spec, it) 23 | 24 | approx :: (Floating a, Ord a) => a -> a -> a -> Bool 25 | approx z a b = a + z >= b && a <= b + z 26 | 27 | data Op = Add | Sub | Mul | Div 28 | deriving Eq 29 | 30 | instance Show Op where 31 | show Add = "+" 32 | show Sub = "-" 33 | show Mul = "*" 34 | show Div = "/" 35 | 36 | opName :: Op -> String 37 | opName Add = "addition" 38 | opName Sub = "subttraction" 39 | opName Mul = "multiplication" 40 | opName Div = "division" 41 | 42 | fromOp :: Op -> Double -> Double -> Double 43 | fromOp Add = (+) 44 | fromOp Sub = (-) 45 | fromOp Mul = (*) 46 | fromOp Div = (/) 47 | 48 | mathsSpec :: Op -> Spec 49 | mathsSpec o = 50 | it (opName o) . requireProperty $ do 51 | -- up to 100 values, between 1 and 1000 52 | l <- forAll . Gen.nonEmpty (Range.linear 1 100) . Gen.double $ Range.linearFrac 1 1000 53 | let e = fold . intersperse (show o) $ show <$> l 54 | n = foldl1 (fromOp o) l 55 | case (runExpr e False, num n) of 56 | ((ONum a, []), ONum b) -> diff a (approx 0.000001) b -- Some value to supress floating point inaccuracies 57 | (a, _) -> fail $ "Unexpected result value " <> show a 58 | 59 | additionSpec :: Spec 60 | additionSpec = mathsSpec Add 61 | 62 | subtractionSpec :: Spec 63 | subtractionSpec = mathsSpec Sub 64 | 65 | multiplicationSpec :: Spec 66 | multiplicationSpec = mathsSpec Mul 67 | 68 | divisionSpec :: Spec 69 | divisionSpec = mathsSpec Div 70 | -------------------------------------------------------------------------------- /tests/RewriteSpec.hs: -------------------------------------------------------------------------------- 1 | -- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca) 2 | -- Copyright (C) 2014-2017, Julia Longtin (julial@turinglace.com) 3 | -- Released under the GNU AGPLV3+, see LICENSE 4 | 5 | {-# LANGUAGE PatternSynonyms #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | 8 | module RewriteSpec (spec) where 9 | 10 | import Prelude 11 | ( Bool(True) 12 | , Double 13 | , Eq((==)) 14 | , Show 15 | , id 16 | , pure 17 | , ($) 18 | , (.) 19 | ) 20 | 21 | import qualified Test.Hspec 22 | import Test.Hspec 23 | ( Expectation 24 | , Spec 25 | , describe 26 | , it 27 | ) 28 | 29 | import Linear 30 | ( V2(V2) 31 | , V3(V3) 32 | ) 33 | 34 | import Graphics.Implicit.Canon 35 | ( EqObj((=^=)) 36 | , canonicalize2 37 | , canonicalize3 38 | , fmapObj2 39 | , fmapObj3 40 | , fmapSharedObj 41 | , rewriteUntilIrreducible 42 | ) 43 | 44 | import Graphics.Implicit.Definitions 45 | ( SharedObj(Translate) 46 | , SymbolicObj2(Square) 47 | , SymbolicObj3(Cube) 48 | ) 49 | 50 | import Graphics.Implicit.Primitives 51 | ( Object 52 | , circle 53 | , cube 54 | , emptySpace 55 | , extrude 56 | , fullSpace 57 | , implicit 58 | , pattern Shared 59 | , rotate 60 | , rotate3 61 | , scale 62 | , sphere 63 | , square 64 | , translate 65 | ) 66 | 67 | newtype WrapEq a = WrapEq a 68 | deriving Show 69 | 70 | instance (EqObj a) => Eq (WrapEq a) where 71 | WrapEq a == WrapEq b = a =^= b 72 | 73 | -- | shouldBe wrapper so we compare using EqObj 74 | shouldBe :: (Show a, EqObj a) => a -> a -> Expectation 75 | shouldBe a b = WrapEq a `Test.Hspec.shouldBe` WrapEq b 76 | 77 | -- | Rewrite translations to scale 78 | testRewShared :: Object obj f a => obj -> obj 79 | testRewShared (Shared (Translate v o)) = scale v o 80 | testRewShared x = x 81 | 82 | sharedSample :: SymbolicObj2 83 | sharedSample = translate 1 emptySpace 84 | 85 | sharedExpected :: SymbolicObj2 86 | sharedExpected = scale 1 fullSpace 87 | 88 | -- | Rewrite squares to circles 89 | testRew2 :: SymbolicObj2 -> SymbolicObj2 90 | testRew2 (Square (V2 x _)) = circle x 91 | testRew2 x = x 92 | 93 | sym2Sample :: SymbolicObj2 94 | sym2Sample = 95 | translate 1 96 | . rotate 3 97 | $ square True 1 98 | 99 | sym2Expected :: SymbolicObj2 100 | sym2Expected = 101 | scale 1 102 | . rotate 3.0 103 | . scale (-0.5) 104 | $ circle 1 105 | 106 | -- | Rewrite cubes to spheres 107 | testRew3 :: SymbolicObj3 -> SymbolicObj3 108 | testRew3 (Cube (V3 x _ _)) = sphere x 109 | testRew3 x = x 110 | 111 | sym3Sample :: SymbolicObj3 112 | sym3Sample = 113 | translate 1 114 | . rotate3 0 115 | $ cube True 10 116 | 117 | sym3Expected :: SymbolicObj3 118 | sym3Expected = 119 | scale 1 120 | . rotate3 0 121 | . scale (-5) 122 | $ sphere 10 123 | 124 | sym32Sample :: SymbolicObj3 125 | sym32Sample = 126 | translate 1 127 | . rotate3 0 128 | $ extrude 2 sym2Sample 129 | 130 | sym32Expected :: SymbolicObj3 131 | sym32Expected = 132 | scale 1 133 | . rotate3 0 134 | $ extrude 2 sym2Expected 135 | 136 | spec :: Spec 137 | spec = 138 | describe "fmap for objects" $ do 139 | describe "fmapSharedObj" $ do 140 | it "preserves identity" $ 141 | fmapSharedObj id id sharedSample `shouldBe` sharedSample 142 | 143 | it "maps over tree" $ 144 | fmapSharedObj (pure fullSpace) testRewShared sharedSample `shouldBe` sharedExpected 145 | 146 | describe "fmapObj2" $ do 147 | it "preserves identity" $ 148 | fmapObj2 id id id sym2Sample `shouldBe` sym2Sample 149 | 150 | it "testRew2 id testRewShared" $ 151 | fmapObj2 testRew2 id testRewShared sym2Sample `shouldBe` sym2Expected 152 | 153 | describe "fmapObj3" $ do 154 | it "identity" $ 155 | fmapObj3 id id id sym3Sample `shouldBe` sym3Sample 156 | 157 | it "testRew3 id testRewShared" $ 158 | fmapObj3 testRew3 id testRewShared sym3Sample `shouldBe` sym3Expected 159 | 160 | it "testRew3 testRew2 testRewShared" $ 161 | fmapObj3 testRew3 testRew2 testRewShared sym32Sample `shouldBe` sym32Expected 162 | 163 | describe "rewriteUntilIrreducible" $ do 164 | describe "terminates" $ do 165 | it "simple" $ 166 | rewriteUntilIrreducible id sym32Sample `shouldBe` sym32Sample 167 | 168 | it "handles implicit" $ 169 | rewriteUntilIrreducible 170 | id 171 | (implicit @SymbolicObj2 @V2 @Double (\(V2 x _) -> x) (1, 1)) 172 | `shouldBe` implicit (\(V2 x _) -> x) (1, 1) 173 | 174 | describe "canonicalize2" $ do 175 | let c2 = canonicalize2 176 | 177 | it "eliminates identities" $ 178 | c2 (translate 0 $ rotate 0 $ circle 1) `shouldBe` circle 1 179 | 180 | it "eliminates identities after merging" $ 181 | c2 (translate 1 $ scale 0 $ translate (-1) $ circle 1) `shouldBe` circle 1 182 | 183 | describe "canonicalize3" $ do 184 | let c3 = canonicalize3 185 | 186 | it "eliminates identities" $ 187 | c3 (translate 0 $ scale 0 $ sphere 1) `shouldBe` sphere 1 188 | 189 | it "eliminates identities after merging" $ 190 | c3 (translate 1 $ scale 0 $ translate (-1) $ sphere 1) `shouldBe` sphere 1 191 | 192 | it "handles 2D as well" $ 193 | c3 (translate 1 194 | $ scale 0 195 | $ translate (-1) 196 | $ extrude 1 197 | $ translate 1 198 | $ scale 0 199 | $ translate (-1) 200 | $ circle 1 201 | ) `shouldBe` extrude 1 (circle 1) 202 | -------------------------------------------------------------------------------- /tests/TesselationSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ImplicitPrelude #-} 2 | {-# LANGUAGE TupleSections #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | module TesselationSpec (spec) where 6 | 7 | import Prelude (Int, Maybe(Just), Show, Eq, Enum, (-), otherwise, (<), ($), pure, length, (.), head, fmap, drop, repeat, take, zip, uncurry, (!!), (=<<), mappend, zipWith, unzip, replicate, (<$>), enumFrom) 8 | import Test.Hspec 9 | (describe, shouldBe, shouldContain, Spec, Expectation ) 10 | import Test.QuickCheck (Gen, Positive(), arbitrary, choose, getPositive, shuffle) 11 | import Data.Foldable ( for_ ) 12 | import Test.Hspec.QuickCheck (prop) 13 | import Data.List (sort, group) 14 | import Data.Traversable ( for ) 15 | import Graphics.Implicit.Export.Render.GetLoops (getLoops) 16 | import Graphics.Implicit.Test.Utils (randomGroups) 17 | import Graphics.Implicit.Test.Instances () 18 | import Control.Monad (join) 19 | import Control.Lens (Ixed(ix), (&), (.~) ) 20 | 21 | spec :: Spec 22 | spec = do 23 | describe "getLoops" $ do 24 | prop "stability" $ do 25 | n <- choose (2, 20) 26 | (_, segs) <- genManyLoops @Int 0 n 27 | -- Shuffle the loops amongst themselves (but dont intermingle their segments) 28 | shuffled_segs <- shuffle segs 29 | pure $ do 30 | Just loops <- pure $ getLoops $ join shuffled_segs 31 | -- The discovered loops should be in the same order that we generated 32 | -- them in 33 | for_ (zip loops shuffled_segs) $ \(loop, seg) -> 34 | head loop `shouldBe` head seg 35 | 36 | prop "loops a loop" $ do 37 | (v, segs) <- genLoop @Int 0 38 | pure $ do 39 | Just [loop] <- pure $ getLoops segs 40 | proveLoop v loop 41 | 42 | prop "loops many loops" $ do 43 | -- Pick a number of loops to aim for 44 | n <- choose (2, 20) 45 | (vs, segs) <- genManyLoops @Int 0 n 46 | 47 | -- Shuffle the segments of all the loops together 48 | shuffled_segs <- shuffle $ join segs 49 | pure $ do 50 | Just loops <- pure $ getLoops shuffled_segs 51 | -- Make sure we have the right length 52 | length loops `shouldBe` n 53 | -- Ensure that we can 'proveLoop' on each loop 54 | for_ (zip vs $ sort loops) $ uncurry proveLoop 55 | 56 | prop "inserting in the middle is ok" $ do 57 | (_, segs) <- genLoop @Int 0 58 | let n = length segs 59 | -- Pick a random segment 60 | seg_idx <- choose (0, n - 1) 61 | -- Insert a random element into it 62 | seg' <- insertMiddle (segs !! seg_idx) =<< arbitrary 63 | let segs' = segs & ix seg_idx .~ seg' 64 | 65 | pure $ do 66 | -- We should be able to get the loops of the original and inserted segments. 67 | Just [loop] <- pure $ getLoops segs 68 | Just [loop'] <- pure $ getLoops segs' 69 | -- Really we're just testing to make sure the above pattern match doesn't 70 | -- 'fail', but let's make sure they have the same number of segments too. 71 | length loop `shouldBe` length loop' 72 | 73 | ------------------------------------------------------------------------------ 74 | -- | Show that the given loop exists somewhere in the discovered loops. 75 | -- Correctly deals with the case where the two loops start at different places. 76 | proveLoop :: (Show a, Eq a) => [a] -> [[a]] -> Expectation 77 | proveLoop v loops = 78 | join (replicate 2 v) `shouldContain` unloop loops 79 | 80 | ------------------------------------------------------------------------------ 81 | -- | Generate a loop and random segments that should produce it. The defining 82 | -- equation of this generator is tested by "getLoops > loops a loop". 83 | genLoop 84 | :: Enum a 85 | => a 86 | -> Gen ([a], [[a]]) -- ^ @(loop, segments)@ 87 | genLoop start = do 88 | n <- getPositive <$> arbitrary @(Positive Int) 89 | let v = take n $ enumFrom start 90 | bits <- randomGroups v 91 | let segs = loopify bits 92 | shuffled_segs <- shuffle segs 93 | pure (v, shuffled_segs) 94 | 95 | ------------------------------------------------------------------------------ 96 | -- | Like 'genLoop', but produces several loops, tagged with an index number. 97 | -- For best results, you should call @shuffle . join@ on the resulting segments 98 | -- before calling @getLoops@ on it, to ensure the segments are intermingled 99 | -- between the loops. 100 | genManyLoops 101 | :: Enum a 102 | => a 103 | -> Int -- ^ Number of loops to generate 104 | -> Gen ([[(Int, a)]], [[[(Int, a)]]]) -- ^ @(loop, segments)@ 105 | genManyLoops start n = do 106 | fmap unzip $ for [0 .. n - 1] $ \idx -> do 107 | -- Generate a loop for each 108 | (v, segs) <- genLoop start 109 | -- and tag it with the index 110 | pure (fmap (idx,) v, fmap (fmap (idx,)) segs) 111 | 112 | ------------------------------------------------------------------------------ 113 | -- | Given a list of lists, insert elements into the 'head' and 'last' of each 114 | -- sub-list so that the 'last' of one list is the 'head' of the next. 115 | loopify :: [[a]] -> [[a]] 116 | loopify as = zipWith (\a -> mappend a . take 1) as $ drop 1 $ join $ repeat as 117 | 118 | ------------------------------------------------------------------------------ 119 | -- | Remove sequential elements in a list. Additionally, this function removes 120 | -- the 'head' of the list, because conceptully it is also the 'last'. 121 | unloop :: Eq a => [[a]] -> [a] 122 | unloop = drop 1 . fmap head . group . join 123 | 124 | ------------------------------------------------------------------------------ 125 | -- | Insert an element into the middle (not 'head' or 'last') of a list. 126 | insertMiddle :: [a] -> a -> Gen [a] 127 | insertMiddle [] _ = pure [] 128 | insertMiddle [a] _ = pure [a] 129 | insertMiddle as a = do 130 | let n = length as 131 | i <- choose (1, n - 1) 132 | pure $ insertAt i a as 133 | 134 | ------------------------------------------------------------------------------ 135 | -- | Helper function to insert an element into a list at a given position. 136 | -- 137 | -- Stolen from https://hackage.haskell.org/package/ilist-0.4.0.1/docs/Data-List-Index.html#v:insertAt 138 | insertAt :: Int -> a -> [a] -> [a] 139 | insertAt i a ls 140 | | i < 0 = ls 141 | | otherwise = go i ls 142 | where 143 | go 0 xs = a : xs 144 | go n (x:xs) = x : go (n-1) xs 145 | go _ [] = [] 146 | 147 | -------------------------------------------------------------------------------- /tests/golden/boxCylinder.scad: -------------------------------------------------------------------------------- 1 | union() { 2 | cube([5.0e0, 5.0e0, 5.0e0]); 3 | translate([2.5e0, 2.5e0, 5.0e0]) cylinder(r1 = 2.0e0, r2 = 1.0e0, 3.0e0); 4 | } -------------------------------------------------------------------------------- /tests/golden/boxCylinder.stl: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Haskell-Things/ImplicitCAD/8827fb0a2553db0e70a8bf7495f9413007d6d8cb/tests/golden/boxCylinder.stl -------------------------------------------------------------------------------- /tests/golden/pretty-printing.scad: -------------------------------------------------------------------------------- 1 | union() { 2 | sphere(r = 1.5e1); 3 | cube([1.0e1, 1.5e1, 2.0e1]); 4 | translate([0.0e0, 0.0e0, 2.5e1]) union() { 5 | cylinder(r1 = 0.0e0, r2 = 2.0e1, 2.0e1); 6 | cube([1.0e1, 1.0e1, 1.0e1]); 7 | } 8 | linear_extrude(height = 7.0e0) translate([2.0e1, 0.0e0]) difference() { 9 | circle([1.0e1]); 10 | circle([1.0e1]); 11 | } 12 | } -------------------------------------------------------------------------------- /tests/golden/pretty-printing.stl: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Haskell-Things/ImplicitCAD/8827fb0a2553db0e70a8bf7495f9413007d6d8cb/tests/golden/pretty-printing.stl -------------------------------------------------------------------------------- /tests/golden/troublesome-polygon-under-rotation.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Haskell-Things/ImplicitCAD/8827fb0a2553db0e70a8bf7495f9413007d6d8cb/tests/golden/troublesome-polygon-under-rotation.png -------------------------------------------------------------------------------- /tests/golden/troublesome-polygon.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Haskell-Things/ImplicitCAD/8827fb0a2553db0e70a8bf7495f9413007d6d8cb/tests/golden/troublesome-polygon.png -------------------------------------------------------------------------------- /tests/imports/child.scad: -------------------------------------------------------------------------------- 1 | include ; -------------------------------------------------------------------------------- /tests/imports/config.scad: -------------------------------------------------------------------------------- 1 | foo=1; 2 | bar=2; 3 | baz=3; -------------------------------------------------------------------------------- /tests/imports/neighbour.scad: -------------------------------------------------------------------------------- 1 | include <./config.scad>; 2 | 3 | cube(foo,bar,baz); -------------------------------------------------------------------------------- /tests/imports/relative/deep/grandparent.scad: -------------------------------------------------------------------------------- 1 | include <../parent.scad>; -------------------------------------------------------------------------------- /tests/imports/relative/parent.scad: -------------------------------------------------------------------------------- 1 | include <../config.scad>; 2 | 3 | cube(foo,bar,baz); --------------------------------------------------------------------------------