diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,60 +1,64 @@ -# Revision history for juicy-gcode - -## 0.2.0.1 -- 2020-08-24 - -- Breaking change: change default DPI to 96 instead of 72 -- Breaking change: the option to mirror the Y axis is removed (it is always mirrored now for correct result) -- Add --version flag - -## 0.1.0.10 -- 2020-08-19 - -- Improve algorithmic stability at small details -- Fix issue with SVG Line element - -## 0.1.0.9 -- 2020-05-27 - -- Add option to generate bezier curves instead of arcs - -## 0.1.0.8 -- 2020-05-19 - -- Fix unhandled bezier edge cases resulting NaNs in GCode - -## 0.1.0.7 -- 2020-05-15 - -- Add support for the viewBox attribute - -## 0.1.0.6 -- 2020-05-11 - -- Add option to mirror Y axis - -## 0.1.0.5.2 -- 2020-04-11 - -- Update dependencies - -## 0.1.0.5.1 -- 2018-08-08 - -- Update documentation - -## 0.1.0.5 -- 2018-08-08 - -- Simplify special bezier curves to lines - -## 0.1.0.4 -- 2017-12-30 - -- Update LICENSE - -## 0.1.0.3 -- 2017-03-19 - -- Fix typo in cabal file - -## 0.1.0.2 -- 2017-03-18 - -- Fix generating arcs with negative I or J - -## 0.1.0.1 -- 2016-10-31 - -- Minor changes to the package description and README. - -## 0.1.0.0 -- 2016-10-30 - -- First version. Mostly feature complete, but not well tested. +# Revision history for juicy-gcode + +## 0.2.0.2 -- 2022-10-31 + +- Fix a problem triggered by non-quadratic inflexion point equations + +## 0.2.0.1 -- 2020-08-24 + +- Breaking change: change default DPI to 96 instead of 72 +- Breaking change: the option to mirror the Y axis is removed (it is always mirrored now for correct result) +- Add --version flag + +## 0.1.0.10 -- 2020-08-19 + +- Improve algorithmic stability at small details +- Fix issue with SVG Line element + +## 0.1.0.9 -- 2020-05-27 + +- Add option to generate bezier curves instead of arcs + +## 0.1.0.8 -- 2020-05-19 + +- Fix unhandled bezier edge cases resulting NaNs in GCode + +## 0.1.0.7 -- 2020-05-15 + +- Add support for the viewBox attribute + +## 0.1.0.6 -- 2020-05-11 + +- Add option to mirror Y axis + +## 0.1.0.5.2 -- 2020-04-11 + +- Update dependencies + +## 0.1.0.5.1 -- 2018-08-08 + +- Update documentation + +## 0.1.0.5 -- 2018-08-08 + +- Simplify special bezier curves to lines + +## 0.1.0.4 -- 2017-12-30 + +- Update LICENSE + +## 0.1.0.3 -- 2017-03-19 + +- Fix typo in cabal file + +## 0.1.0.2 -- 2017-03-18 + +- Fix generating arcs with negative I or J + +## 0.1.0.1 -- 2016-10-31 + +- Minor changes to the package description and README. + +## 0.1.0.0 -- 2016-10-30 + +- First version. Mostly feature complete, but not well tested. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,21 +1,21 @@ -The MIT License - -Copyright (c) 2010-2017 Google, Inc., dlacko - -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in -all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +The MIT License + +Copyright (c) 2010-2017 Google, Inc., dlacko + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,107 +1,106 @@ -# Juicy-gcode: A lightweight SVG to GCode converter for maximal curve fitting - -[![Hackage](https://img.shields.io/hackage/v/juicy-gcode.svg)](https://hackage.haskell.org/package/juicy-gcode) -[![Travis](https://travis-ci.org/domoszlai/juicy-gcode.svg?branch=master)](http://travis-ci.org/domoszlai/juicy-gcode) -![Appveyor](https://ci.appveyor.com/api/projects/status/github/domoszlai/juicy-gcode?branch=master&svg=true) - -## Overview - -Juicy-gcode is a configurable SVG to G-code converter that approximates bezier curves with [biarcs](http://dlacko.org/blog/2016/10/19/approximating-bezier-curves-by-biarcs/) for maximal curve fitting. - -## Installation - -The easiest way is to download one of the pre-built binaries from the [releases page](https://github.com/domoszlai/juicy-gcode/releases). -Alternatively, you can build from source code as follows: - -- Install [Stack](https://docs.haskellstack.org/en/stable/install_and_upgrade/) if you do not have it yet -- `$ git clone https://github.com/domoszlai/juicy-gcode.git` -- `$ stack build` -- `$ stack install` -- `$ juicy-gcode --help` - -## Usage - -> :warning: **Breaking change**: Since version 0.2.0.1, default DPI is changed to 96 and the option to mirror the Y axis is removed (it is always mirrored now for correct result) - -The easier way to use juicy-gcode is to simply provide an SVG file name. The generated GCode will be written to standard output. - -``` -$ juicy-gcode SVGFILE -``` - -Alternativly, you can provide an output file name as well. - -``` -$ juicy-gcode SVGFILE -o OUTPUT -``` - -Sometimes you want to overwrite some default settings. These are the - -* *--dpi* (default 96 DPI) [the resolution of the SVG file](https://developer.mozilla.org/en-US/docs/Web/CSS/resolution) that is used to determine the size of the SVG when it does not contain explicit units -* *--resolution* (default is 0.1 mm) the resolution of the generated GCode. Paths smaller than this are replaced by line segments instead of further approximated by biarcs - -``` -$ juicy-gcode SVGFILE --dpi 72 --resolution 0.01 -``` - -Some firmwares (e.g. [Marlin](https://marlinfw.org/docs/gcode/G005.html)) can handle bezier curves directly. In this case -you can command juicy-gcode not to approximate bezier-curves but emit them unchanged. - -``` -$ juicy-gcode SVGFILE --generate-bezier -``` - -## Configuration - -The generated GCode is highly dependent on the actual device it will be executed by. In juicy-gcode these settings are called -GCode *flavor* and consists of the following: - -- Begin GCode routine (commands that are executed *before* the actual print job) -- End GCode routine (commands that are executed *after* the actual print job) -- Tool on (commands to switch the tool on, e.g. lower pen) -- Tool off (commands to switch the tool off e.g. lift pen) - -These settings can be provided by a configuration file. The default settings -are made for being able to test the generated GCode in an emulator e.g. with [LaserWeb](https://laserweb.yurl.ch/) -or [my hanging plotter simulator](https://github.com/domoszlai/hanging-plotter-simulator). - -``` -gcode -{ - begin = "G17;G90;G0 Z1;G0 X0 Y0" - end = "G0 Z1" - toolon = "G00 Z1" - tooloff = "G01 Z0 F10.00" -} -``` - -In the case you want to overwrite it, copy this favor to a text file and modify it according to your need. Then use juicy-gcode as follows: - -``` -$ juicy-gcode SVGFILE -f FLAVORFILE -``` - -## Future development - -Juicy-gcode was originally developed as a testbed for my hanging plotter project, but over the years -it reached maturity and became a really usuable tool. My main idea for further development is to turn it -into a tool that can drive CNCs in 2.5 dimensions (e.g. carving, engraving) with just one colored SVG file. - -To be able to test and enjoy that software, I need a proper CNC. Please consider donating a small amount for that purpose, -or donate an actual CNC if you have a spare one for whatever reason. - -**[Donate for a CNC](https://www.paypal.com/cgi-bin/webscr?cmd=_s-xclick&hosted_button_id=UGFZYDQSTF58L&source=https://github.com/domoszlai/juicy-gcode/)** - -Collected so far: 102.47€ -Target: >= 209€ - -Thank you so much for all people supporting the development! - -## Limitations - -SVG features that are not supported: - -- texts -- filling -- clipping -- images +# Juicy-gcode: A lightweight SVG to GCode converter for maximal curve fitting + +[![Hackage](https://img.shields.io/hackage/v/juicy-gcode.svg)](https://hackage.haskell.org/package/juicy-gcode) +[![Appveyor](https://ci.appveyor.com/api/projects/status/github/domoszlai/juicy-gcode?branch=master&svg=true)](https://ci.appveyor.com/project/domoszlai/juicy-gcode) + +## Overview + +Juicy-gcode is a configurable SVG to G-code converter that approximates bezier curves with [biarcs](http://dlacko.org/blog/2016/10/19/approximating-bezier-curves-by-biarcs/) for maximal curve fitting. + +## Installation + +The easiest way is to download one of the pre-built binaries from the [releases page](https://github.com/domoszlai/juicy-gcode/releases). +Alternatively, you can build from source code as follows: + +- Install [Stack](https://docs.haskellstack.org/en/stable/install_and_upgrade/) if you do not have it yet +- `$ git clone https://github.com/domoszlai/juicy-gcode.git` +- `$ stack build` +- `$ stack install` +- `$ juicy-gcode --help` + +## Usage + +> :warning: **Breaking change**: Since version 0.2.0.1, default DPI is changed to 96 and the option to mirror the Y axis is removed (it is always mirrored now for correct result) + +The easier way to use juicy-gcode is to simply provide an SVG file name. The generated GCode will be written to standard output. + +``` +$ juicy-gcode SVGFILE +``` + +Alternativly, you can provide an output file name as well. + +``` +$ juicy-gcode SVGFILE -o OUTPUT +``` + +Sometimes you want to overwrite some default settings. These are the + +* *--dpi* (default 96 DPI) [the resolution of the SVG file](https://developer.mozilla.org/en-US/docs/Web/CSS/resolution) that is used to determine the size of the SVG when it does not contain explicit units +* *--resolution* (default is 0.1 mm) the resolution of the generated GCode. Paths smaller than this are replaced by line segments instead of further approximated by biarcs + +``` +$ juicy-gcode SVGFILE --dpi 72 --resolution 0.01 +``` + +Some firmwares (e.g. [Marlin](https://marlinfw.org/docs/gcode/G005.html)) can handle bezier curves directly. In this case +you can command juicy-gcode not to approximate bezier-curves but emit them unchanged. + +``` +$ juicy-gcode SVGFILE --generate-bezier +``` + +## Configuration + +The generated GCode is highly dependent on the actual device it will be executed by. In juicy-gcode these settings are called +GCode *flavor* and consists of the following: + +- Begin GCode routine (commands that are executed *before* the actual print job) +- End GCode routine (commands that are executed *after* the actual print job) +- Tool on (commands to switch the tool on, e.g. lower pen) +- Tool off (commands to switch the tool off e.g. lift pen) + +These settings can be provided by a configuration file. The default settings +are made for being able to test the generated GCode in an emulator e.g. with [LaserWeb](https://laserweb.yurl.ch/) +or [my hanging plotter simulator](https://github.com/domoszlai/hanging-plotter-simulator). + +``` +gcode +{ + begin = "G17;G90;G0 Z1;G0 X0 Y0" + end = "G0 Z1" + toolon = "G00 Z1" + tooloff = "G01 Z0 F10.00" +} +``` + +In the case you want to overwrite it, copy this favor to a text file and modify it according to your need. Then use juicy-gcode as follows: + +``` +$ juicy-gcode SVGFILE -f FLAVORFILE +``` + +## Future development + +Juicy-gcode was originally developed as a testbed for my hanging plotter project, but over the years +it reached maturity and became a really usuable tool. My main idea for further development is to turn it +into a tool that can drive CNCs in 2.5 dimensions (e.g. carving, engraving) with just one colored SVG file. + +To be able to test and enjoy that software, I need a proper CNC. Please consider donating a small amount for that purpose, +or donate an actual CNC if you have a spare one for whatever reason. + +**[Donate for a CNC](https://www.paypal.com/cgi-bin/webscr?cmd=_s-xclick&hosted_button_id=UGFZYDQSTF58L&source=https://github.com/domoszlai/juicy-gcode/)** + +Collected so far: 229.47€ +Target: >= 209€ + +Thank you so much for all people supporting the development! + +## Limitations + +SVG features that are not supported: + +- texts +- filling +- clipping +- images diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/juicy-gcode.cabal b/juicy-gcode.cabal --- a/juicy-gcode.cabal +++ b/juicy-gcode.cabal @@ -1,40 +1,40 @@ -name: juicy-gcode -version: 0.2.0.1 -license: BSD3 -license-file: LICENSE -author: dlacko -maintainer: dlacko@gmail.com -stability: experimental -synopsis: SVG to G-Code converter -category: Graphics -homepage: https://github.com/domoszlai/juicy-gcode -bug-reports: https://github.com/domoszlai/juicy-gcode/issues -build-type: Simple -description: - SVG to G-code converter that aims to support most SVG features. The flavor of the generated G-Code can be influenced providing a configuration file. - -extra-source-files: ChangeLog.md, README.md -cabal-version: >=1.10 -executable juicy-gcode - hs-source-dirs: src - main-is: Main.hs - - other-modules: Approx BiArc CircularArc CubicBezier GCode Line Render SvgArcSegment Transformation Types SVGExt Paths_juicy_gcode - - build-depends: - base >=4.8 && <5, - lens >=4.15.4 && <4.20, - linear >=1.20 && <1.22, - optparse-applicative >=0.13 && <0.20, - configurator >=0.3 && <0.4, - text >=1.2.2 && <1.3, - matrix >=0.3.5 && <0.4, - svg-tree >=0.6 && <0.7, - gitrev >=1.3.0 && <1.4 - - GHC-Options: -Wall - default-language: Haskell2010 - -Source-repository head - Type: git - Location: https://github.com/domoszlai/juicy-gcode +name: juicy-gcode +version: 0.2.0.2 +license: BSD3 +license-file: LICENSE +author: dlacko +maintainer: dlacko@gmail.com +stability: experimental +synopsis: SVG to G-Code converter +category: Graphics +homepage: https://github.com/domoszlai/juicy-gcode +bug-reports: https://github.com/domoszlai/juicy-gcode/issues +build-type: Simple +description: + SVG to G-code converter that aims to support most SVG features. The flavor of the generated G-Code can be influenced providing a configuration file. + +extra-source-files: ChangeLog.md, README.md +cabal-version: >=1.10 +executable juicy-gcode + hs-source-dirs: src + main-is: Main.hs + + other-modules: Approx BiArc CircularArc CubicBezier GCode Line Render SvgArcSegment Transformation Types SVGExt Paths_juicy_gcode + + build-depends: + base >=4.8 && <5, + lens >=4.15.4 && <4.20, + linear >=1.20 && <1.22, + optparse-applicative >=0.13 && <0.20, + configurator >=0.3 && <0.4, + text >=1.2.2 && <1.3, + matrix >=0.3.5 && <0.4, + svg-tree >=0.6 && <0.7, + gitrev >=1.3.0 && <1.4 + + GHC-Options: -Wall + default-language: Haskell2010 + +Source-repository head + Type: git + Location: https://github.com/domoszlai/juicy-gcode diff --git a/src/Approx.hs b/src/Approx.hs --- a/src/Approx.hs +++ b/src/Approx.hs @@ -1,122 +1,115 @@ -module Approx ( bezier2biarc - ) where - -import qualified CubicBezier as B -import qualified BiArc as BA -import qualified Line as L - -import Data.Bool (bool) -import Linear -import Data.Complex - -import Types - --- Approximate a bezier curve with biarcs (Left) and line segments (Right) -bezier2biarc :: B.CubicBezier - -> Double - -> [Either BA.BiArc (V2 Double)] -bezier2biarc mbezier resolution - -- Edge case: all points on the same line -> it is a line - | (L.isOnLine (L.fromPoints (B._p2 mbezier) (B._p1 mbezier)) (B._c1 mbezier)) && - (L.isOnLine (L.fromPoints (B._p2 mbezier) (B._p1 mbezier)) (B._c2 mbezier)) - = [Right (B._p2 mbezier)] - -- Edge case: p1 == c1, don't split - | (B._p1 mbezier) == (B._c1 mbezier) - = approxOne mbezier - -- Edge case: p2 == c2, don't split - | (B._p2 mbezier) == (B._c2 mbezier) - = approxOne mbezier - -- Split by the inflexion points (if any) - | otherwise - = byInflection (B.realInflectionPoint i1) (B.realInflectionPoint i2) - where - (i1, i2) = B.inflectionPoints mbezier - - order a b | b < a = (b, a) - | otherwise = (a, b) - - byInflection True False = approxOne b1 ++ approxOne b2 - where - (b1, b2) = B.bezierSplitAt mbezier (realPart i1) - - byInflection False True = approxOne b1 ++ approxOne b2 - where - (b1, b2) = B.bezierSplitAt mbezier (realPart i2) - - byInflection True True = approxOne b1 ++ approxOne b2 ++ approxOne b3 - where - (it1, it2') = order (realPart i1) (realPart i2) - - -- Make the first split and save the first new curve. The second one has to be splitted again - -- at the recalculated t2 (it is on a new curve) - it2 = (1 - it1) * it2' - - (b1, toSplit) = B.bezierSplitAt mbezier it1 - (b2, b3) = B.bezierSplitAt toSplit it2 - - byInflection False False = approxOne mbezier - - -- TODO: make it tail recursive - approxOne :: B.CubicBezier -> [Either BA.BiArc (V2 Double)] - approxOne bezier - -- Approximate bezier length. if smaller than resolution, do not approximate - | (distance (B._p1 bezier) (B._c1 bezier)) + - (distance (B._c1 bezier) (B._c2 bezier)) + - (distance (B._c2 bezier) (B._p2 bezier)) < resolution - = [Right (B._p2 bezier)] - -- Edge case: start- and endpoints are the same - | (B._p1 bezier) == (B._p2 bezier) - = splitAndRecur 0.5 - -- Edge case: control lines are parallel - | (L._m t1) == (L._m t2) || (isNaN (L._m t1) && isNaN (L._m t2)) - = splitAndRecur 0.5 - -- Approximation is not close enough yet, refine - | BA.isStable biarc && maxDistance > resolution - = splitAndRecur maxDistanceAt - -- Desired case: approximation is stable and close enough - | BA.isStable biarc - = [Left biarc] - -- Unstable approximation: split the bezier into half, basically switching to - -- linear approximation mode - | otherwise - = splitAndRecur 0.5 - - where - -- Edge case: P1==C1 or P2==C2 - -- there is no derivative at P1 or P2, use the other control point - c1 = bool (B._c1 bezier) (B._c2 bezier) ((B._p1 bezier) == (B._c1 bezier)) - c2 = bool (B._c2 bezier) (B._c1 bezier) ((B._p2 bezier) == (B._c2 bezier)) - - -- V: Intersection point of tangent lines - t1 = L.fromPoints (B._p1 bezier) c1 - t2 = L.fromPoints (B._p2 bezier) c2 - v = L.intersection t1 t2 - - -- G: incenter point of the triangle (P1, V, P2) - dP2V = distance (B._p2 bezier) v - dP1V = distance (B._p1 bezier) v - dP1P2 = distance (B._p1 bezier) (B._p2 bezier) - g = (dP2V *^ B._p1 bezier + dP1V *^ B._p2 bezier + dP1P2 *^ v) ^/ (dP2V + dP1V + dP1P2) - - -- Calculate the BiArc - biarc = BA.create (B._p1 bezier) (B._p1 bezier - c1) (B._p2 bezier) (B._p2 bezier - c2) g - - -- Calculate the error - -- TODO: we only calculate the distance at 8 points (first and last skipped as - -- they should be precise), seems a resonable approximation as for now - parameterStep = 1 / 10 - - (maxDistance, maxDistanceAt) = maxDistance' 0 0 parameterStep - - maxDistance' m mt t - | t < 1 - = if' (d > m) (maxDistance' d t nt) (maxDistance' m mt nt) - | otherwise - = (m, mt) - where - d = distance (BA.pointAt biarc t) (B.pointAt bezier t) - nt = t + parameterStep - - splitAndRecur t = let (b1, b2) = B.bezierSplitAt bezier t - in approxOne b1 ++ approxOne b2 - +module Approx ( bezier2biarc + ) where + +import qualified CubicBezier as B +import qualified BiArc as BA +import qualified Line as L + +import Data.Bool (bool) +import Linear + +import Types + +-- Approximate a bezier curve with biarcs (Left) and line segments (Right) +bezier2biarc :: B.CubicBezier + -> Double + -> [Either BA.BiArc (V2 Double)] +bezier2biarc mbezier resolution + -- Edge case: all points on the same line -> it is a line + | (L.isOnLine (L.fromPoints (B._p2 mbezier) (B._p1 mbezier)) (B._c1 mbezier)) && + (L.isOnLine (L.fromPoints (B._p2 mbezier) (B._p1 mbezier)) (B._c2 mbezier)) + = [Right (B._p2 mbezier)] + -- Edge case: p1 == c1, don't split + | (B._p1 mbezier) == (B._c1 mbezier) + = approxOne mbezier + -- Edge case: p2 == c2, don't split + | (B._p2 mbezier) == (B._c2 mbezier) + = approxOne mbezier + -- Split by the inflexion points (if any) + | otherwise + = byInflection (B.inflectionPoints mbezier) + where + order a b | b < a = (b, a) + | otherwise = (a, b) + + byInflection [t] = approxOne b1 ++ approxOne b2 + where + (b1, b2) = B.bezierSplitAt mbezier t + + byInflection [t1, t2] = approxOne b1 ++ approxOne b2 ++ approxOne b3 + where + (it1, it2') = order t1 t2 + + -- Make the first split and save the first new curve. The second one has to be splitted again + -- at the recalculated t2 (it is on a new curve) + it2 = (1 - it1) * it2' + + (b1, toSplit) = B.bezierSplitAt mbezier it1 + (b2, b3) = B.bezierSplitAt toSplit it2 + + byInflection _ = approxOne mbezier + + -- TODO: make it tail recursive + approxOne :: B.CubicBezier -> [Either BA.BiArc (V2 Double)] + approxOne bezier + -- Approximate bezier length. if smaller than resolution, do not approximate + | (distance (B._p1 bezier) (B._c1 bezier)) + + (distance (B._c1 bezier) (B._c2 bezier)) + + (distance (B._c2 bezier) (B._p2 bezier)) < resolution + = [Right (B._p2 bezier)] + -- Edge case: start- and endpoints are the same + | (B._p1 bezier) == (B._p2 bezier) + = splitAndRecur 0.5 + -- Edge case: control lines are parallel + | (L._m t1) == (L._m t2) || (isNaN (L._m t1) && isNaN (L._m t2)) + = splitAndRecur 0.5 + -- Approximation is not close enough yet, refine + | BA.isStable biarc && maxDistance > resolution + = splitAndRecur maxDistanceAt + -- Desired case: approximation is stable and close enough + | BA.isStable biarc + = [Left biarc] + -- Unstable approximation: split the bezier into half, basically switching to + -- linear approximation mode + | otherwise + = splitAndRecur 0.5 + + where + -- Edge case: P1==C1 or P2==C2 + -- there is no derivative at P1 or P2, use the other control point + c1 = bool (B._c1 bezier) (B._c2 bezier) ((B._p1 bezier) == (B._c1 bezier)) + c2 = bool (B._c2 bezier) (B._c1 bezier) ((B._p2 bezier) == (B._c2 bezier)) + + -- V: Intersection point of tangent lines + t1 = L.fromPoints (B._p1 bezier) c1 + t2 = L.fromPoints (B._p2 bezier) c2 + v = L.intersection t1 t2 + + -- G: incenter point of the triangle (P1, V, P2) + dP2V = distance (B._p2 bezier) v + dP1V = distance (B._p1 bezier) v + dP1P2 = distance (B._p1 bezier) (B._p2 bezier) + g = (dP2V *^ B._p1 bezier + dP1V *^ B._p2 bezier + dP1P2 *^ v) ^/ (dP2V + dP1V + dP1P2) + + -- Calculate the BiArc + biarc = BA.create (B._p1 bezier) (B._p1 bezier - c1) (B._p2 bezier) (B._p2 bezier - c2) g + + -- Calculate the error + -- TODO: we only calculate the distance at 8 points (first and last skipped as + -- they should be precise), seems a resonable approximation as for now + parameterStep = 1 / 10 + + (maxDistance, maxDistanceAt) = maxDistance' 0 0 parameterStep + + maxDistance' m mt t + | t < 1 + = if' (d > m) (maxDistance' d t nt) (maxDistance' m mt nt) + | otherwise + = (m, mt) + where + d = distance (BA.pointAt biarc t) (B.pointAt bezier t) + nt = t + parameterStep + + splitAndRecur t = let (b1, b2) = B.bezierSplitAt bezier t + in approxOne b1 ++ approxOne b2 + diff --git a/src/BiArc.hs b/src/BiArc.hs --- a/src/BiArc.hs +++ b/src/BiArc.hs @@ -1,90 +1,90 @@ -module BiArc ( BiArc (..) - , create - , pointAt - , arcLength - , isStable - ) where - -import qualified CircularArc as CA -import qualified Line as L - -import Linear hiding (angle) -import Control.Lens - -data BiArc = BiArc { _a1 :: CA.CircularArc - , _a2 :: CA.CircularArc - } deriving Show - -create :: V2 Double -- Start point - -> V2 Double -- Tangent vector at start point - -> V2 Double -- End point - -> V2 Double -- Tangent vector at end point - -> V2 Double -- Transition point (connection point of the arcs) - -> BiArc -create p1 t1 p2 t2 t - = BiArc (CA.CircularArc c1 r1 startAngle1 sweepAngle1 p1 t) (CA.CircularArc c2 r2 startAngle2 sweepAngle2 t p2) - where - -- Calculate the orientation - osum = (t ^. _x - p1 ^. _x) * (t ^. _y + p1 ^. _y) - + (p2 ^. _x - t ^. _x) * (p2 ^. _y + t ^. _y) - + (p1 ^. _x - p2 ^. _x) * (p1 ^. _y + p2 ^. _y) - cw = osum < 0 - - -- Calculate perpendicular lines to the tangent at P1 and P2 - tl1 = L.createPerpendicularAt p1 (p1 + t1) - tl2 = L.createPerpendicularAt p2 (p2 + t2) - - -- Calculate the perpendicular bisector of P1T and P2T - p1t2 = (p1 + t) ^/ 2 - pb_p1t = L.createPerpendicularAt p1t2 t - - p2t2 = (p2 + t) ^/ 2 - pb_p2t = L.createPerpendicularAt p2t2 t - - -- The origo of the circles are at the intersection points - c1 = L.intersection tl1 pb_p1t - c2 = L.intersection tl2 pb_p2t - - -- Calculate the radii - r1 = distance c1 p1 - r2 = distance c2 p2 - - -- Calculate start and sweep angles - startVector1 = p1 - c1; - endVector1 = t - c1; - startAngle1 = atan2 (startVector1 ^. _y) (startVector1 ^. _x) - sweepAngle1' = (atan2 (endVector1 ^. _y) (endVector1 ^. _x)) - startAngle1 - - startVector2 = t - c2 - endVector2 = p2 - c2 - startAngle2 = atan2 (startVector2 ^. _y) (startVector2 ^. _x) - sweepAngle2' = (atan2 (endVector2 ^. _y) (endVector2 ^. _x)) - startAngle2 - - -- Adjust angles according to the orientation of the curve - sweepAngle1 = adjustSweepAngle cw sweepAngle1' - sweepAngle2 = adjustSweepAngle cw sweepAngle2' - -adjustSweepAngle :: Bool -> Double -> Double -adjustSweepAngle True angle | angle < 0 = 2 * pi + angle -adjustSweepAngle False angle | angle > 0 = angle - 2 * pi -adjustSweepAngle _ angle = angle - -pointAt :: BiArc -> Double -> V2 Double -pointAt arc t - | t <= s - = CA.pointAt (_a1 arc) (t / s) - | otherwise - = CA.pointAt (_a2 arc) ((t - s) / (1 - s)) - where - s = CA.arcLength (_a1 arc) / (arcLength arc) - -arcLength :: BiArc -> Double -arcLength arc = CA.arcLength (_a1 arc) + CA.arcLength (_a2 arc) - --- Heuristics for unstable biarc: the radius of at least one of the arcs --- is too big or too small -isStable :: BiArc -> Bool -isStable biarc - = not (CA._r (_a1 biarc) > 99999 || CA._r (_a1 biarc) < 0.001 || - CA._r (_a2 biarc) > 99999 || CA._r (_a2 biarc) < 0.001) - +module BiArc ( BiArc (..) + , create + , pointAt + , arcLength + , isStable + ) where + +import qualified CircularArc as CA +import qualified Line as L + +import Linear hiding (angle) +import Control.Lens + +data BiArc = BiArc { _a1 :: CA.CircularArc + , _a2 :: CA.CircularArc + } deriving Show + +create :: V2 Double -- Start point + -> V2 Double -- Tangent vector at start point + -> V2 Double -- End point + -> V2 Double -- Tangent vector at end point + -> V2 Double -- Transition point (connection point of the arcs) + -> BiArc +create p1 t1 p2 t2 t + = BiArc (CA.CircularArc c1 r1 startAngle1 sweepAngle1 p1 t) (CA.CircularArc c2 r2 startAngle2 sweepAngle2 t p2) + where + -- Calculate the orientation + osum = (t ^. _x - p1 ^. _x) * (t ^. _y + p1 ^. _y) + + (p2 ^. _x - t ^. _x) * (p2 ^. _y + t ^. _y) + + (p1 ^. _x - p2 ^. _x) * (p1 ^. _y + p2 ^. _y) + cw = osum < 0 + + -- Calculate perpendicular lines to the tangent at P1 and P2 + tl1 = L.createPerpendicularAt p1 (p1 + t1) + tl2 = L.createPerpendicularAt p2 (p2 + t2) + + -- Calculate the perpendicular bisector of P1T and P2T + p1t2 = (p1 + t) ^/ 2 + pb_p1t = L.createPerpendicularAt p1t2 t + + p2t2 = (p2 + t) ^/ 2 + pb_p2t = L.createPerpendicularAt p2t2 t + + -- The origo of the circles are at the intersection points + c1 = L.intersection tl1 pb_p1t + c2 = L.intersection tl2 pb_p2t + + -- Calculate the radii + r1 = distance c1 p1 + r2 = distance c2 p2 + + -- Calculate start and sweep angles + startVector1 = p1 - c1; + endVector1 = t - c1; + startAngle1 = atan2 (startVector1 ^. _y) (startVector1 ^. _x) + sweepAngle1' = (atan2 (endVector1 ^. _y) (endVector1 ^. _x)) - startAngle1 + + startVector2 = t - c2 + endVector2 = p2 - c2 + startAngle2 = atan2 (startVector2 ^. _y) (startVector2 ^. _x) + sweepAngle2' = (atan2 (endVector2 ^. _y) (endVector2 ^. _x)) - startAngle2 + + -- Adjust angles according to the orientation of the curve + sweepAngle1 = adjustSweepAngle cw sweepAngle1' + sweepAngle2 = adjustSweepAngle cw sweepAngle2' + +adjustSweepAngle :: Bool -> Double -> Double +adjustSweepAngle True angle | angle < 0 = 2 * pi + angle +adjustSweepAngle False angle | angle > 0 = angle - 2 * pi +adjustSweepAngle _ angle = angle + +pointAt :: BiArc -> Double -> V2 Double +pointAt arc t + | t <= s + = CA.pointAt (_a1 arc) (t / s) + | otherwise + = CA.pointAt (_a2 arc) ((t - s) / (1 - s)) + where + s = CA.arcLength (_a1 arc) / (arcLength arc) + +arcLength :: BiArc -> Double +arcLength arc = CA.arcLength (_a1 arc) + CA.arcLength (_a2 arc) + +-- Heuristics for unstable biarc: the radius of at least one of the arcs +-- is too big or too small +isStable :: BiArc -> Bool +isStable biarc + = not (CA._r (_a1 biarc) > 99999 || CA._r (_a1 biarc) < 0.001 || + CA._r (_a2 biarc) > 99999 || CA._r (_a2 biarc) < 0.001) + diff --git a/src/CircularArc.hs b/src/CircularArc.hs --- a/src/CircularArc.hs +++ b/src/CircularArc.hs @@ -1,29 +1,29 @@ -module CircularArc ( CircularArc (..) - , isClockwise - , pointAt - , arcLength - ) where - -import Linear -import Control.Lens - -data CircularArc = CircularArc { _c :: V2 Double - , _r :: Double - , _startAngle :: Double - , _sweepAngle :: Double - , _p1 :: V2 Double - , _p2 :: V2 Double - } deriving Show - -isClockwise :: CircularArc -> Bool -isClockwise arc = _sweepAngle arc > 0 - -pointAt :: CircularArc -> Double -> V2 Double -pointAt arc t = V2 x y - where - x = _c arc ^. _x + _r arc * cos (_startAngle arc + t * _sweepAngle arc) - y = _c arc ^. _y + _r arc * sin (_startAngle arc + t * _sweepAngle arc) - -arcLength :: CircularArc -> Double -arcLength arc = _r arc * abs(_sweepAngle arc) +module CircularArc ( CircularArc (..) + , isClockwise + , pointAt + , arcLength + ) where + +import Linear +import Control.Lens + +data CircularArc = CircularArc { _c :: V2 Double + , _r :: Double + , _startAngle :: Double + , _sweepAngle :: Double + , _p1 :: V2 Double + , _p2 :: V2 Double + } deriving Show + +isClockwise :: CircularArc -> Bool +isClockwise arc = _sweepAngle arc > 0 + +pointAt :: CircularArc -> Double -> V2 Double +pointAt arc t = V2 x y + where + x = _c arc ^. _x + _r arc * cos (_startAngle arc + t * _sweepAngle arc) + y = _c arc ^. _y + _r arc * sin (_startAngle arc + t * _sweepAngle arc) + +arcLength :: CircularArc -> Double +arcLength arc = _r arc * abs(_sweepAngle arc) diff --git a/src/CubicBezier.hs b/src/CubicBezier.hs --- a/src/CubicBezier.hs +++ b/src/CubicBezier.hs @@ -1,60 +1,68 @@ -module CubicBezier ( CubicBezier (..) - , pointAt - , bezierSplitAt - , isClockwise - , inflectionPoints - , realInflectionPoint - ) where - -import Linear -import Control.Lens -import Data.Complex - -data CubicBezier = CubicBezier { _p1 :: V2 Double - , _c1 :: V2 Double - , _c2 :: V2 Double - , _p2 :: V2 Double - } deriving Show - -pointAt :: CubicBezier -> Double -> V2 Double -pointAt bezier t = ((1 - t) ** 3) *^ _p1 bezier + - ((1 - t) ** 2) * 3 * t *^ _c1 bezier + - (t ** 2) * (1 - t) * 3 *^ _c2 bezier + - (t ** 3) *^ _p2 bezier - -bezierSplitAt :: CubicBezier -> Double -> (CubicBezier, CubicBezier) -bezierSplitAt bezier t = (CubicBezier (_p1 bezier) p0 p01 dp, CubicBezier dp p12 p2 (_p2 bezier)) - where - p0 = _p1 bezier + t *^ (_c1 bezier - _p1 bezier) - p1 = _c1 bezier + t *^ (_c2 bezier - _c1 bezier) - p2 = _c2 bezier + t *^ (_p2 bezier - _c2 bezier) - - p01 = p0 + t *^ (p1 - p0) - p12 = p1 + t *^ (p2 - p1) - - dp = p01 + t *^ (p12 - p01) - -isClockwise :: CubicBezier -> Bool -isClockwise bezier = s < 0 - where - s = (_c1 bezier ^. _x - _p1 bezier ^. _x) * (_c1 bezier ^. _y + _p1 bezier ^. _y) - + (_c2 bezier ^. _x - _c1 bezier ^. _x) * (_c2 bezier ^. _y + _c1 bezier ^. _y) - + (_p2 bezier ^. _x - _c2 bezier ^. _x) * (_p2 bezier ^. _y + _c2 bezier ^. _y) - + (_p1 bezier ^. _x - _p2 bezier ^. _x) * (_p1 bezier ^. _y + _p2 bezier ^. _y) - -inflectionPoints :: CubicBezier -> (Complex Double, Complex Double) -inflectionPoints bezier = (t1, t2) - where - pa = _c1 bezier - _p1 bezier - pb = _c2 bezier - _c1 bezier - pa - pc = _p2 bezier - _c2 bezier - pa - 2 *^ pb - - a = (pb ^. _x * pc ^. _y - pb ^. _y * pc ^. _x) :+ 0 - b = (pa ^. _x * pc ^. _y - pa ^. _y * pc ^. _x) :+ 0 - c = (pa ^. _x * pb ^. _y - pa ^. _y * pb ^. _x) :+ 0 - - t1 = (-b + sqrt (b * b - 4 * a * c)) / (2 * a) - t2 = (-b - sqrt (b * b - 4 * a * c)) / (2 * a) - -realInflectionPoint :: Complex Double -> Bool -realInflectionPoint c = imagPart c == 0 && realPart c > 0 && realPart c < 1 +module CubicBezier ( CubicBezier (..) + , pointAt + , bezierSplitAt + , isClockwise + , inflectionPoints + ) where + +import Linear +import Control.Lens +import Data.Complex + +data CubicBezier = CubicBezier { _p1 :: V2 Double + , _c1 :: V2 Double + , _c2 :: V2 Double + , _p2 :: V2 Double + } deriving Show + +pointAt :: CubicBezier -> Double -> V2 Double +pointAt bezier t = ((1 - t) ** 3) *^ _p1 bezier + + ((1 - t) ** 2) * 3 * t *^ _c1 bezier + + (t ** 2) * (1 - t) * 3 *^ _c2 bezier + + (t ** 3) *^ _p2 bezier + +bezierSplitAt :: CubicBezier -> Double -> (CubicBezier, CubicBezier) +bezierSplitAt bezier t = (CubicBezier (_p1 bezier) p0 p01 dp, CubicBezier dp p12 p2 (_p2 bezier)) + where + p0 = _p1 bezier + t *^ (_c1 bezier - _p1 bezier) + p1 = _c1 bezier + t *^ (_c2 bezier - _c1 bezier) + p2 = _c2 bezier + t *^ (_p2 bezier - _c2 bezier) + + p01 = p0 + t *^ (p1 - p0) + p12 = p1 + t *^ (p2 - p1) + + dp = p01 + t *^ (p12 - p01) + +isClockwise :: CubicBezier -> Bool +isClockwise bezier = s < 0 + where + s = (_c1 bezier ^. _x - _p1 bezier ^. _x) * (_c1 bezier ^. _y + _p1 bezier ^. _y) + + (_c2 bezier ^. _x - _c1 bezier ^. _x) * (_c2 bezier ^. _y + _c1 bezier ^. _y) + + (_p2 bezier ^. _x - _c2 bezier ^. _x) * (_p2 bezier ^. _y + _c2 bezier ^. _y) + + (_p1 bezier ^. _x - _p2 bezier ^. _x) * (_p1 bezier ^. _y + _p2 bezier ^. _y) + +inflectionPoints :: CubicBezier -> [Double] +inflectionPoints bezier + | a /= 0 = realInflectionPoints [t1, t2] + | otherwise = realInflectionPoints [t] + where + pa = _c1 bezier - _p1 bezier + pb = _c2 bezier - _c1 bezier - pa + pc = _p2 bezier - _c2 bezier - pa - 2 *^ pb + + a = (pb ^. _x * pc ^. _y - pb ^. _y * pc ^. _x) :+ 0 + b = (pa ^. _x * pc ^. _y - pa ^. _y * pc ^. _x) :+ 0 + c = (pa ^. _x * pb ^. _y - pa ^. _y * pb ^. _x) :+ 0 + + -- linear case + t = -c / b + + -- quadratic case + t1 = (-b + sqrt (b * b - 4 * a * c)) / (2 * a) + t2 = (-b - sqrt (b * b - 4 * a * c)) / (2 * a) + +realInflectionPoints :: [Complex Double] -> [Double] +realInflectionPoints = map realPart . filter isInflectionPoint + +isInflectionPoint :: Complex Double -> Bool +isInflectionPoint c = imagPart c == 0 && realPart c > 0 && realPart c < 1 diff --git a/src/GCode.hs b/src/GCode.hs --- a/src/GCode.hs +++ b/src/GCode.hs @@ -1,57 +1,63 @@ -module GCode ( GCodeFlavor(..) - , defaultFlavor - , toString - ) where - -import Data.List -import Text.Printf - -import Types - -data GCodeFlavor = GCodeFlavor { _begin :: String - , _end :: String - , _toolon :: String - , _tooloff :: String - } - -defaultFlavor :: GCodeFlavor -defaultFlavor = GCodeFlavor "G17\nG90\nG0 Z1\nG0 X0 Y0\n" "G0 Z1" "G01 Z0 F10.00" "G00 Z1" - -toString :: GCodeFlavor -> Int -> [GCodeOp] -> String -toString (GCodeFlavor begin end on off) dpi gops = begin ++ "\n" ++ intercalate "\n" (toString' gops (0,0) True) ++ "\n" ++ end - where - dd :: Double - dd = fromIntegral dpi - - mm :: Double -> Double - mm px = (px * 2.54 * 10) / dd - - toString' (GMoveTo p@(x,y) : gs) _ False - = printf "G00 X%.4f Y%.4f" (mm x) (mm y) : toString' gs p False - toString' (GMoveTo p@(x,y) : gs) _ True - = off : printf "G00 X%.4f Y%.4f" (mm x) (mm y) : toString' gs p False - toString' gs cp False - = on : toString' gs cp True - toString' (GLineTo p@(x,y) : gs) _ True - = printf "G01 X%.4f Y%.4f" (mm x) (mm y) : toString' gs p True - toString' (GArcTo (ox,oy) p@(x,y) cw : gs) (cx,cy) True - = arcStr : toString' gs p True - where - i = ox - cx - j = oy - cy - - cmd = if' cw "G03" "G02" - - arcStr = printf "%s X%.4f Y%.4f I%.4f J%.4f" cmd (mm x) (mm y) (mm i) (mm j) - toString' (GBezierTo (c1x,c1y) (c2x,c2y) p2@(p2x,p2y) : gs) (p1x,p1y) True - = bStr : toString' gs p2 True - where - i = c1x - p1x - j = c1y - p1y - p = c2x - p2x - q = c2y - p2y - - bStr = printf "G05 I%.4f J%.4f P%.4f Q%.4f X%.4f Y%.4f" - (mm i) (mm j) (mm p) (mm q) (mm p2x) (mm p2y) - - toString' [] _ _ = [] +module GCode ( GCodeFlavor(..) + , defaultFlavor + , toString + ) where + +import Data.List +import Text.Printf + +import Types + +data GCodeFlavor = GCodeFlavor { _begin :: String + , _end :: String + , _toolon :: String + , _tooloff :: String + } + +defaultFlavor :: GCodeFlavor +defaultFlavor = GCodeFlavor "G17\nG90\nG0 Z1\nG0 X0 Y0" "G0 Z1" "G01 Z0 F10.00" "G00 Z1" + +toString :: GCodeFlavor -> Int -> [GCodeOp] -> String +toString (GCodeFlavor begin end on off) dpi gops + = begin ++ + "\n" ++ + intercalate "\n" (toString' gops (0,0) True) ++ + "\n" ++ + end ++ + "\n" + where + dd :: Double + dd = fromIntegral dpi + + mm :: Double -> Double + mm px = (px * 2.54 * 10) / dd + + toString' (GMoveTo p@(x,y) : gs) _ False + = printf "G00 X%.4f Y%.4f" (mm x) (mm y) : toString' gs p False + toString' (GMoveTo p@(x,y) : gs) _ True + = off : printf "G00 X%.4f Y%.4f" (mm x) (mm y) : toString' gs p False + toString' gs cp False + = on : toString' gs cp True + toString' (GLineTo p@(x,y) : gs) _ True + = printf "G01 X%.4f Y%.4f" (mm x) (mm y) : toString' gs p True + toString' (GArcTo (ox,oy) p@(x,y) cw : gs) (cx,cy) True + = arcStr : toString' gs p True + where + i = ox - cx + j = oy - cy + + cmd = if' cw "G03" "G02" + + arcStr = printf "%s X%.4f Y%.4f I%.4f J%.4f" cmd (mm x) (mm y) (mm i) (mm j) + toString' (GBezierTo (c1x,c1y) (c2x,c2y) p2@(p2x,p2y) : gs) (p1x,p1y) True + = bStr : toString' gs p2 True + where + i = c1x - p1x + j = c1y - p1y + p = c2x - p2x + q = c2y - p2y + + bStr = printf "G05 I%.4f J%.4f P%.4f Q%.4f X%.4f Y%.4f" + (mm i) (mm j) (mm p) (mm q) (mm p2x) (mm p2y) + + toString' [] _ _ = [] diff --git a/src/Line.hs b/src/Line.hs --- a/src/Line.hs +++ b/src/Line.hs @@ -1,73 +1,73 @@ -module Line ( Line (..) - , throughPoint - , fromPoints - , createPerpendicularAt - , slope - , intersection - , isOnLine - ) where - -import Linear -import Control.Lens - --- TODO: letting _p to be NaN is actually a really bad idea -data Line = Line { _m :: Double - , _p :: V2 Double - } deriving Show - -throughPoint :: V2 Double -> Double -> Line -throughPoint p m = Line m p - -fromPoints :: V2 Double -> V2 Double -> Line -fromPoints p1 p2 = throughPoint p1 (slope p1 p2) - --- Creates a a line which is perpendicular to the line defined by P and P1 and goes through P -createPerpendicularAt :: V2 Double -> V2 Double -> Line -createPerpendicularAt p p1 - | m == 0 - = throughPoint p nan - | isNaN m - = throughPoint p 0 - | otherwise - = throughPoint p (-1 / m) - where - m = slope p p1 - -slope :: V2 Double -> V2 Double -> Double -slope p1 p2 - | p2 ^. _x == p1 ^. _x - = nan - | otherwise - = (p2 ^. _y - p1 ^. _y) / (p2 ^. _x - p1 ^. _x) - -nan :: Double -nan = 0/0 - --- If the solution is not found it actually returns +/-infinity -intersection :: Line -> Line -> V2 Double -intersection line1 line2 - | isNaN (_m line1) - = verticalIntersection line1 line2 - | isNaN (_m line2) - = verticalIntersection line2 line1 - | otherwise - = V2 x y - where - x = (_m line1 * _p line1 ^. _x - _m line2 * _p line2 ^. _x - _p line1 ^. _y + _p line2 ^. _y) / (_m line1 - _m line2) - y = _m line1 * x - _m line1 * _p line1 ^. _x + _p line1 ^. _y - --- First line is vertical -verticalIntersection :: Line -> Line -> V2 Double -verticalIntersection vline line = V2 x y - where - x = _p vline ^. _x - y = _m line * (x - _p line ^. _x) + _p line ^. _y - -isOnLine :: Line -> V2 Double -> Bool -isOnLine l p2 - | isNaN (_m l) - = p1 ^. _x == p2 ^. _x - | otherwise - = (p2 ^. _x - p1 ^. _x) * (_m l) == (p2 ^. _y - p1 ^. _y) - where +module Line ( Line (..) + , throughPoint + , fromPoints + , createPerpendicularAt + , slope + , intersection + , isOnLine + ) where + +import Linear +import Control.Lens + +-- TODO: letting _p to be NaN is actually a really bad idea +data Line = Line { _m :: Double + , _p :: V2 Double + } deriving Show + +throughPoint :: V2 Double -> Double -> Line +throughPoint p m = Line m p + +fromPoints :: V2 Double -> V2 Double -> Line +fromPoints p1 p2 = throughPoint p1 (slope p1 p2) + +-- Creates a a line which is perpendicular to the line defined by P and P1 and goes through P +createPerpendicularAt :: V2 Double -> V2 Double -> Line +createPerpendicularAt p p1 + | m == 0 + = throughPoint p nan + | isNaN m + = throughPoint p 0 + | otherwise + = throughPoint p (-1 / m) + where + m = slope p p1 + +slope :: V2 Double -> V2 Double -> Double +slope p1 p2 + | p2 ^. _x == p1 ^. _x + = nan + | otherwise + = (p2 ^. _y - p1 ^. _y) / (p2 ^. _x - p1 ^. _x) + +nan :: Double +nan = 0/0 + +-- If the solution is not found it actually returns +/-infinity +intersection :: Line -> Line -> V2 Double +intersection line1 line2 + | isNaN (_m line1) + = verticalIntersection line1 line2 + | isNaN (_m line2) + = verticalIntersection line2 line1 + | otherwise + = V2 x y + where + x = (_m line1 * _p line1 ^. _x - _m line2 * _p line2 ^. _x - _p line1 ^. _y + _p line2 ^. _y) / (_m line1 - _m line2) + y = _m line1 * x - _m line1 * _p line1 ^. _x + _p line1 ^. _y + +-- First line is vertical +verticalIntersection :: Line -> Line -> V2 Double +verticalIntersection vline line = V2 x y + where + x = _p vline ^. _x + y = _m line * (x - _p line ^. _x) + _p line ^. _y + +isOnLine :: Line -> V2 Double -> Bool +isOnLine l p2 + | isNaN (_m l) + = p1 ^. _x == p2 ^. _x + | otherwise + = (p2 ^. _x - p1 ^. _x) * (_m l) == (p2 ^. _y - p1 ^. _y) + where p1 = _p l diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,92 +1,90 @@ -{-# LANGUAGE TemplateHaskell #-} - -import qualified Graphics.Svg as SVG - -import Options.Applicative -import Paths_juicy_gcode (version) -import Data.Version (showVersion) -import Development.GitRev (gitHash) - -import Data.Text (Text, pack, unpack, replace) -import qualified Data.Configurator as C - -import Data.Monoid - -import Render -import GCode - -data Options = Options { _svgfile :: String - , _cfgfile :: Maybe String - , _outfile :: Maybe String - , _dpi :: Int - , _resolution :: Double - , _generateBezier :: Bool - } - -options :: Parser Options -options = Options - <$> argument str - ( metavar "SVGFILE" - <> help "The SVG file to be converted" ) - <*> (optional $ strOption - ( long "flavor" - <> short 'f' - <> metavar "CONFIGFILE" - <> help "Configuration of G-Code flavor" )) - <*> (optional $ strOption - ( long "output" - <> short 'o' - <> metavar "OUTPUTFILE" - <> help "The output G-Code file (default is standard output)" )) - <*> (option auto - ( long "dpi" - <> value 96 - <> short 'd' - <> metavar "DPI" - <> help "Used to determine the size of the SVG when it does not contain any units; dot per inch (default is 96)" )) - <*> (option auto - ( long "resolution" - <> value 0.1 - <> short 'r' - <> metavar "RESOLUTION" - <> help "Shorter paths are replaced by line segments; mm (default is 0.1)" )) - <*> (switch - ( long "generate-bezier" - <> short 'b' - <> help "Generate bezier curves (G5) instead of arcs (G2,G3)" )) - -runWithOptions :: Options -> IO () -runWithOptions (Options svgFile mbCfg mbOut dpi resolution generateBezier) = - do - mbDoc <- SVG.loadSvgFile svgFile - flavor <- maybe (return defaultFlavor) readFlavor mbCfg - case mbDoc of - (Just doc) -> writer (toString flavor dpi $ renderDoc generateBezier dpi resolution doc) - Nothing -> putStrLn "juicy-gcode: error during opening the SVG file" - where - writer = maybe putStrLn (\fn -> writeFile fn) mbOut - -toLines :: Text -> String -toLines t = unpack $ replace (pack ";") (pack "\n") t - -readFlavor :: FilePath -> IO GCodeFlavor -readFlavor cfgFile = do - cfg <- C.load [C.Required cfgFile] - begin <- C.require cfg (pack "gcode.begin") - end <- C.require cfg (pack "gcode.end") - toolon <- C.require cfg (pack "gcode.toolon") - tooloff <- C.require cfg (pack "gcode.tooloff") - return $ GCodeFlavor (toLines begin) (toLines end) (toLines toolon) (toLines tooloff) - -versionOption :: Parser (a -> a) -versionOption = infoOption - (concat ["juicy-gcode ", showVersion version, ", git revision ", $(gitHash)]) - (long "version" <> short 'v' <> help "Show version") - -main :: IO () -main = execParser opts >>= runWithOptions - where - opts = info (helper <*> versionOption <*> options) - ( fullDesc - <> progDesc "Convert SVGFILE to G-Code" +{-# LANGUAGE TemplateHaskell #-} + +import qualified Graphics.Svg as SVG + +import Options.Applicative +import Paths_juicy_gcode (version) +import Data.Version (showVersion) +import Development.GitRev (gitHash) + +import Data.Text (Text, pack, unpack, replace) +import qualified Data.Configurator as C + +import Render +import GCode + +data Options = Options { _svgfile :: String + , _cfgfile :: Maybe String + , _outfile :: Maybe String + , _dpi :: Int + , _resolution :: Double + , _generateBezier :: Bool + } + +options :: Parser Options +options = Options + <$> argument str + ( metavar "SVGFILE" + <> help "The SVG file to be converted" ) + <*> (optional $ strOption + ( long "flavor" + <> short 'f' + <> metavar "CONFIGFILE" + <> help "Configuration of G-Code flavor" )) + <*> (optional $ strOption + ( long "output" + <> short 'o' + <> metavar "OUTPUTFILE" + <> help "The output G-Code file (default is standard output)" )) + <*> (option auto + ( long "dpi" + <> value 96 + <> short 'd' + <> metavar "DPI" + <> help "Used to determine the size of the SVG when it does not contain any units; dot per inch (default is 96)" )) + <*> (option auto + ( long "resolution" + <> value 0.1 + <> short 'r' + <> metavar "RESOLUTION" + <> help "Shorter paths are replaced by line segments; mm (default is 0.1)" )) + <*> (switch + ( long "generate-bezier" + <> short 'b' + <> help "Generate bezier curves (G5) instead of arcs (G2,G3)" )) + +runWithOptions :: Options -> IO () +runWithOptions (Options svgFile mbCfg mbOut dpi resolution generateBezier) = + do + mbDoc <- SVG.loadSvgFile svgFile + flavor <- maybe (return defaultFlavor) readFlavor mbCfg + case mbDoc of + (Just doc) -> writer (toString flavor dpi $ renderDoc generateBezier dpi resolution doc) + Nothing -> putStrLn "juicy-gcode: error during opening the SVG file" + where + writer = maybe putStr (\fn -> writeFile fn) mbOut + +toLines :: Text -> String +toLines t = unpack $ replace (pack ";") (pack "\n") t + +readFlavor :: FilePath -> IO GCodeFlavor +readFlavor cfgFile = do + cfg <- C.load [C.Required cfgFile] + begin <- C.require cfg (pack "gcode.begin") + end <- C.require cfg (pack "gcode.end") + toolon <- C.require cfg (pack "gcode.toolon") + tooloff <- C.require cfg (pack "gcode.tooloff") + return $ GCodeFlavor (toLines begin) (toLines end) (toLines toolon) (toLines tooloff) + +versionOption :: Parser (a -> a) +versionOption = infoOption + (concat ["juicy-gcode ", showVersion version, ", git revision ", $(gitHash)]) + (long "version" <> short 'v' <> help "Show version") + +main :: IO () +main = execParser opts >>= runWithOptions + where + opts = info (helper <*> versionOption <*> options) + ( fullDesc + <> progDesc "Convert SVGFILE to G-Code" <> header "juicy-gcode - The SVG to G-Code converter" ) diff --git a/src/Render.hs b/src/Render.hs --- a/src/Render.hs +++ b/src/Render.hs @@ -1,266 +1,266 @@ -module Render ( renderDoc - ) where - -import qualified Graphics.Svg as SVG -import qualified Graphics.Svg.CssTypes as CSS -import qualified Linear - -import Types -import Transformation -import SvgArcSegment -import Approx -import SVGExt - -import qualified CircularArc as CA -import qualified BiArc as BA -import qualified CubicBezier as B - -mapTuple :: (a -> b) -> (a, a) -> (b, b) -mapTuple f (a1, a2) = (f a1, f a2) - -fromSvgPoint :: Int -> SVG.Point -> Point -fromSvgPoint dpi (x,y) = (fromSvgNumber dpi x, fromSvgNumber dpi y) - -fromRPoint :: SVG.RPoint -> Point -fromRPoint (Linear.V2 x y) = (x, y) - -toPoint :: Linear.V2 Double -> Point -toPoint (Linear.V2 x y) = (x, y) - -fromPoint :: Point -> Linear.V2 Double -fromPoint (x, y) = (Linear.V2 x y) - --- TODO: em, percentage -fromSvgNumber :: Int -> SVG.Number -> Double -fromSvgNumber dpi num = fromNumber' (CSS.toUserUnit dpi num) - where - fromNumber' (SVG.Num n) = n - fromNumber' _ = error "TODO: unhandled em or percentage" - --- current point + control point -> mirrored control point -mirrorControlPoint :: Point -> Point -> Point -mirrorControlPoint (cx, cy) (cpx, cpy) = (cx + cx - cpx, cy + cy - cpy) - --- convert a quadratic bezier to a cubic one -bezierQ2C :: Point -> Point -> Point -> DrawOp -bezierQ2C (qp0x, qp0y) (qp1x, qp1y) (qp2x, qp2y) - = DBezierTo (qp0x + 2.0 / 3.0 * (qp1x - qp0x), qp0y + 2.0 / 3.0 * (qp1y - qp0y)) - (qp2x + 2.0 / 3.0 * (qp1x - qp2x), qp2y + 2.0 / 3.0 * (qp1y - qp2y)) - (qp2x, qp2y) - -toAbsolute :: (Double, Double) -> SVG.Origin -> (Double, Double) -> (Double, Double) -toAbsolute _ SVG.OriginAbsolute p = p -toAbsolute (cx,cy) SVG.OriginRelative (dx,dy) = (cx+dx, cy+dy) - -docTransform :: Int -> SVG.Document -> TransformationMatrix -docTransform dpi doc = multiply mirrorTransform (viewBoxTransform $ SVG._viewBox doc) - where - viewBoxTransform (Just (vbx,vby,vbw,vbh)) - = multiply (scaleTransform (w/vbw) (h/vbh)) (translateTransform (-vbx) (-vby)) - viewBoxTransform Nothing - = identityTransform - - mirrorTransform = mirrorYTransform w h - - (w, h) = (documentSize dpi doc) - -renderDoc :: Bool -> Int -> Double -> SVG.Document -> [GCodeOp] -renderDoc generateBezier dpi resolution doc - = stage2 $ renderTrees (docTransform dpi doc) (SVG._elements doc) - where - pxresolution = (fromIntegral dpi) / 2.45 / 10 * resolution - - -- TODO: make it tail recursive - stage2 :: [DrawOp] -> [GCodeOp] - stage2 dops = convert dops (Linear.V2 0 0) - where - convert [] _ = [] - convert (DMoveTo p:ds) _ = GMoveTo p : convert ds (fromPoint p) - convert (DLineTo p:ds) _ = GLineTo p : convert ds (fromPoint p) - convert (DBezierTo c1 c2 p2:ds) cp - | generateBezier - = [GBezierTo c1 c2 p2] ++ convert ds (fromPoint p2) - | otherwise - = concatMap biarc2garc biarcs ++ convert ds (fromPoint p2) - where - biarcs = bezier2biarc (B.CubicBezier cp (fromPoint c1) (fromPoint c2) (fromPoint p2)) pxresolution - biarc2garc (Left biarc) - = [arc2garc (BA._a1 biarc), arc2garc (BA._a2 biarc)] - biarc2garc (Right (Linear.V2 x y)) - = [GLineTo (x,y)] - arc2garc arc = GArcTo (toPoint (CA._c arc)) (toPoint (CA._p2 arc)) (CA.isClockwise arc) - - renderPathCommands :: Point -> Point -> Maybe Point -> [SVG.PathCommand] -> [DrawOp] - renderPathCommands _ currentp _ (SVG.MoveTo origin (p:ps):ds) - = DMoveTo ap : renderPathCommands ap ap Nothing (cont ps) - where - ap = toAbsolute currentp origin (fromRPoint p) - - cont [] = ds - cont ps' = SVG.LineTo origin ps' : ds - - renderPathCommands firstp currentp _ (SVG.LineTo origin (p:ps):ds) - = DLineTo ap : renderPathCommands firstp ap Nothing (cont ps) - where - ap = toAbsolute currentp origin (fromRPoint p) - - cont [] = ds - cont ps' = SVG.LineTo origin ps' : ds - - renderPathCommands firstp (_, cy) _ (SVG.HorizontalTo SVG.OriginAbsolute (px:pxs):ds) - = DLineTo ap : renderPathCommands firstp ap Nothing (cont pxs) - where - ap = (px,cy) - - cont [] = ds - cont pxs' = SVG.HorizontalTo SVG.OriginAbsolute pxs' : ds - - renderPathCommands firstp (cx, cy) _ (SVG.HorizontalTo SVG.OriginRelative (dx:dxs):ds) - = DLineTo ap : renderPathCommands firstp ap Nothing (cont dxs) - where - ap = (cx+dx,cy) - - cont [] = ds - cont dxs' = SVG.HorizontalTo SVG.OriginRelative dxs' : ds - - renderPathCommands firstp (cx, _) _ (SVG.VerticalTo SVG.OriginAbsolute (py:pys):ds) - = DLineTo ap : renderPathCommands firstp ap Nothing (cont pys) - where - ap = (cx,py) - - cont [] = ds - cont pys' = SVG.VerticalTo SVG.OriginAbsolute pys' : ds - - renderPathCommands firstp (cx, cy) _ (SVG.VerticalTo SVG.OriginRelative (dy:dys):ds) - = DLineTo ap : renderPathCommands firstp ap Nothing (cont dys) - where - ap = (cx,cy+dy) - - cont [] = ds - cont dys' = SVG.VerticalTo SVG.OriginRelative dys' : ds - - renderPathCommands firstp currentp _ (SVG.CurveTo origin ((c1,c2,p):ps):ds) - = DBezierTo ac1 ac2 ap : renderPathCommands firstp ap (Just ac2) (cont ps) - where - ap = toAbsolute currentp origin (fromRPoint p) - ac1 = toAbsolute currentp origin (fromRPoint c1) - ac2 = toAbsolute currentp origin (fromRPoint c2) - - cont [] = ds - cont ps' = SVG.CurveTo origin ps' : ds - - renderPathCommands firstp currentp mbControlp (SVG.SmoothCurveTo origin ((c2,p):ps):ds) - = DBezierTo ac1 ac2 ap : renderPathCommands firstp ap (Just ac2) (cont ps) - where - ap = toAbsolute currentp origin (fromRPoint p) - ac1 = maybe ac2 (mirrorControlPoint currentp) mbControlp - ac2 = toAbsolute currentp origin (fromRPoint c2) - - cont [] = ds - cont ps' = SVG.SmoothCurveTo origin ps' : ds - - renderPathCommands firstp currentp _ (SVG.QuadraticBezier origin ((c1,p):ps):ds) - = cbezier : renderPathCommands firstp ap (Just ac1) (cont ps) - where - ap = toAbsolute currentp origin (fromRPoint p) - ac1 = toAbsolute currentp origin (fromRPoint c1) - - cbezier = bezierQ2C currentp ac1 ap - - cont [] = ds - cont ps' = SVG.QuadraticBezier origin ps' : ds - - renderPathCommands firstp currentp mbControlp (SVG.SmoothQuadraticBezierCurveTo origin (p:ps):ds) - = cbezier : renderPathCommands firstp ap (Just ac1) (cont ps) - where - ap = toAbsolute currentp origin (fromRPoint p) - ac1 = maybe currentp (mirrorControlPoint currentp) mbControlp - - cbezier = bezierQ2C currentp ac1 ap - - cont [] = ds - cont ps' = SVG.SmoothQuadraticBezierCurveTo origin ps' : ds - - renderPathCommands firstp currentp _ (SVG.EllipticalArc origin ((rx,ry,rot,largeArcFlag,sweepFlag,p):ps):ds) - = convertSvgArc currentp rx ry rot largeArcFlag sweepFlag ap ++ renderPathCommands firstp ap Nothing (cont ps) - where - ap = toAbsolute currentp origin (fromRPoint p) - - cont [] = ds - cont ps' = SVG.EllipticalArc origin ps' : ds - - renderPathCommands firstp@(fx,fy) (cx,cy) mbControlp (SVG.EndPath:ds) - | fx /= cx || fy /= cy - = DLineTo firstp : renderPathCommands firstp firstp mbControlp ds - | otherwise - = renderPathCommands firstp firstp mbControlp ds - - renderPathCommands _ _ _ _ = [] - - renderTree :: TransformationMatrix -> SVG.Tree -> [DrawOp] - renderTree m (SVG.GroupTree g) = renderTrees (applyTransformations m (SVG._transform (SVG._groupDrawAttributes g))) (SVG._groupChildren g) - renderTree m (SVG.PathTree p) = map (transformDrawOp tr) $ renderPathCommands (0,0) (0,0) Nothing (SVG._pathDefinition p) - where - tr = applyTransformations m (SVG._transform (SVG._pathDrawAttributes p)) - - renderTree m (SVG.RectangleTree r) - | rx == 0.0 && ry == 0.0 - = map (transformDrawOp tr) [DMoveTo (x,y), DLineTo (x+w,y), DLineTo (x+w,y+h), DLineTo (x,y+h), DLineTo (x,y)] - | otherwise - = map (transformDrawOp tr) - ([DMoveTo (x,y+ry)] ++ convertSvgArc (x,y+ry) rx ry 0 False True (x+rx, y) ++ - [DLineTo (x+w-rx,y)] ++ convertSvgArc (x+w-rx,y) rx ry 0 False True (x+w, y+ry) ++ - [DLineTo (x+w,y+h-ry)] ++ convertSvgArc (x+w,y+h-ry) rx ry 0 False True (x+w-rx, y+h) ++ - [DLineTo (x+rx,y+h)] ++ convertSvgArc (x+rx, y+h) rx ry 0 False True (x, y+h-ry) ++ - [DLineTo (x,y+ry)]) - where - (x,y) = fromSvgPoint dpi (SVG._rectUpperLeftCorner r) - w = fromSvgNumber dpi (SVG._rectWidth r) - h = fromSvgNumber dpi (SVG._rectHeight r) - (rx, ry) = mapTuple (fromSvgNumber dpi) (SVG._rectCornerRadius r) - tr = applyTransformations m (SVG._transform (SVG._rectDrawAttributes r)) - - renderTree m (SVG.LineTree l) = [DMoveTo p1, DLineTo p2] - where - p1 = transformPoint tr (fromSvgPoint dpi (SVG._linePoint1 l)) - p2 = transformPoint tr (fromSvgPoint dpi (SVG._linePoint2 l)) - tr = applyTransformations m (SVG._transform (SVG._lineDrawAttributes l)) - - renderTree m (SVG.PolyLineTree l) = map (transformDrawOp tr) (DMoveTo p0:map DLineTo ps) - where - (p0:ps) = map (\(Linear.V2 x y) -> (x,y)) (SVG._polyLinePoints l) - tr = applyTransformations m (SVG._transform (SVG._polyLineDrawAttributes l)) - - renderTree m (SVG.PolygonTree l) = map (transformDrawOp tr) (DMoveTo p0:map DLineTo (ps ++ [p0])) - where - (p0:ps) = map (\(Linear.V2 x y) -> (x,y)) (SVG._polygonPoints l) - tr = applyTransformations m (SVG._transform (SVG._polygonDrawAttributes l)) - - renderTree m (SVG.EllipseTree e) = map (transformDrawOp tr) (DMoveTo (cx-rx,cy) : bs1++bs2++bs3++bs4) - where - bs1 = convertSvgArc (cx-rx, cy) rx ry 0 False True (cx, cy-ry) - bs2 = convertSvgArc (cx, cy-ry) rx ry 0 False True (cx+rx, cy) - bs3 = convertSvgArc (cx+rx, cy) rx ry 0 False True (cx, cy+ry) - bs4 = convertSvgArc (cx, cy+ry) rx ry 0 False True (cx-rx, cy) - - (cx,cy) = fromSvgPoint dpi (SVG._ellipseCenter e) - rx = fromSvgNumber dpi (SVG._ellipseXRadius e) - ry = fromSvgNumber dpi (SVG._ellipseYRadius e) - tr = applyTransformations m (SVG._transform (SVG._ellipseDrawAttributes e)) - - renderTree m (SVG.CircleTree c) = map (transformDrawOp tr) (DMoveTo (cx-r,cy) : bs1++bs2++bs3++bs4) - where - bs1 = convertSvgArc (cx-r, cy) r r 0 False True (cx, cy-r) - bs2 = convertSvgArc (cx, cy-r) r r 0 False True (cx+r, cy) - bs3 = convertSvgArc (cx+r, cy) r r 0 False True (cx, cy+r) - bs4 = convertSvgArc (cx, cy+r) r r 0 False True (cx-r, cy) - - (cx,cy) = fromSvgPoint dpi (SVG._circleCenter c) - r = fromSvgNumber dpi (SVG._circleRadius c) - tr = applyTransformations m (SVG._transform (SVG._circleDrawAttributes c)) - - {- The rest: None, UseTree, SymbolTree, TextTree, ImageTree -} - renderTree _ _ = [] - - renderTrees :: TransformationMatrix -> [SVG.Tree] -> [DrawOp] - renderTrees m es = concat $ map (renderTree m) es +module Render ( renderDoc + ) where + +import qualified Graphics.Svg as SVG +import qualified Graphics.Svg.CssTypes as CSS +import qualified Linear + +import Types +import Transformation +import SvgArcSegment +import Approx +import SVGExt + +import qualified CircularArc as CA +import qualified BiArc as BA +import qualified CubicBezier as B + +mapTuple :: (a -> b) -> (a, a) -> (b, b) +mapTuple f (a1, a2) = (f a1, f a2) + +fromSvgPoint :: Int -> SVG.Point -> Point +fromSvgPoint dpi (x,y) = (fromSvgNumber dpi x, fromSvgNumber dpi y) + +fromRPoint :: SVG.RPoint -> Point +fromRPoint (Linear.V2 x y) = (x, y) + +toPoint :: Linear.V2 Double -> Point +toPoint (Linear.V2 x y) = (x, y) + +fromPoint :: Point -> Linear.V2 Double +fromPoint (x, y) = (Linear.V2 x y) + +-- TODO: em, percentage +fromSvgNumber :: Int -> SVG.Number -> Double +fromSvgNumber dpi num = fromNumber' (CSS.toUserUnit dpi num) + where + fromNumber' (SVG.Num n) = n + fromNumber' _ = error "TODO: unhandled em or percentage" + +-- current point + control point -> mirrored control point +mirrorControlPoint :: Point -> Point -> Point +mirrorControlPoint (cx, cy) (cpx, cpy) = (cx + cx - cpx, cy + cy - cpy) + +-- convert a quadratic bezier to a cubic one +bezierQ2C :: Point -> Point -> Point -> DrawOp +bezierQ2C (qp0x, qp0y) (qp1x, qp1y) (qp2x, qp2y) + = DBezierTo (qp0x + 2.0 / 3.0 * (qp1x - qp0x), qp0y + 2.0 / 3.0 * (qp1y - qp0y)) + (qp2x + 2.0 / 3.0 * (qp1x - qp2x), qp2y + 2.0 / 3.0 * (qp1y - qp2y)) + (qp2x, qp2y) + +toAbsolute :: (Double, Double) -> SVG.Origin -> (Double, Double) -> (Double, Double) +toAbsolute _ SVG.OriginAbsolute p = p +toAbsolute (cx,cy) SVG.OriginRelative (dx,dy) = (cx+dx, cy+dy) + +docTransform :: Int -> SVG.Document -> TransformationMatrix +docTransform dpi doc = multiply mirrorTransform (viewBoxTransform $ SVG._viewBox doc) + where + viewBoxTransform (Just (vbx,vby,vbw,vbh)) + = multiply (scaleTransform (w/vbw) (h/vbh)) (translateTransform (-vbx) (-vby)) + viewBoxTransform Nothing + = identityTransform + + mirrorTransform = mirrorYTransform w h + + (w, h) = (documentSize dpi doc) + +renderDoc :: Bool -> Int -> Double -> SVG.Document -> [GCodeOp] +renderDoc generateBezier dpi resolution doc + = stage2 $ renderTrees (docTransform dpi doc) (SVG._elements doc) + where + pxresolution = (fromIntegral dpi) / 2.45 / 10 * resolution + + -- TODO: make it tail recursive + stage2 :: [DrawOp] -> [GCodeOp] + stage2 dops = convert dops (Linear.V2 0 0) + where + convert [] _ = [] + convert (DMoveTo p:ds) _ = GMoveTo p : convert ds (fromPoint p) + convert (DLineTo p:ds) _ = GLineTo p : convert ds (fromPoint p) + convert (DBezierTo c1 c2 p2:ds) cp + | generateBezier + = [GBezierTo c1 c2 p2] ++ convert ds (fromPoint p2) + | otherwise + = concatMap biarc2garc biarcs ++ convert ds (fromPoint p2) + where + biarcs = bezier2biarc (B.CubicBezier cp (fromPoint c1) (fromPoint c2) (fromPoint p2)) pxresolution + biarc2garc (Left biarc) + = [arc2garc (BA._a1 biarc), arc2garc (BA._a2 biarc)] + biarc2garc (Right (Linear.V2 x y)) + = [GLineTo (x,y)] + arc2garc arc = GArcTo (toPoint (CA._c arc)) (toPoint (CA._p2 arc)) (CA.isClockwise arc) + + renderPathCommands :: Point -> Point -> Maybe Point -> [SVG.PathCommand] -> [DrawOp] + renderPathCommands _ currentp _ (SVG.MoveTo origin (p:ps):ds) + = DMoveTo ap : renderPathCommands ap ap Nothing (cont ps) + where + ap = toAbsolute currentp origin (fromRPoint p) + + cont [] = ds + cont ps' = SVG.LineTo origin ps' : ds + + renderPathCommands firstp currentp _ (SVG.LineTo origin (p:ps):ds) + = DLineTo ap : renderPathCommands firstp ap Nothing (cont ps) + where + ap = toAbsolute currentp origin (fromRPoint p) + + cont [] = ds + cont ps' = SVG.LineTo origin ps' : ds + + renderPathCommands firstp (_, cy) _ (SVG.HorizontalTo SVG.OriginAbsolute (px:pxs):ds) + = DLineTo ap : renderPathCommands firstp ap Nothing (cont pxs) + where + ap = (px,cy) + + cont [] = ds + cont pxs' = SVG.HorizontalTo SVG.OriginAbsolute pxs' : ds + + renderPathCommands firstp (cx, cy) _ (SVG.HorizontalTo SVG.OriginRelative (dx:dxs):ds) + = DLineTo ap : renderPathCommands firstp ap Nothing (cont dxs) + where + ap = (cx+dx,cy) + + cont [] = ds + cont dxs' = SVG.HorizontalTo SVG.OriginRelative dxs' : ds + + renderPathCommands firstp (cx, _) _ (SVG.VerticalTo SVG.OriginAbsolute (py:pys):ds) + = DLineTo ap : renderPathCommands firstp ap Nothing (cont pys) + where + ap = (cx,py) + + cont [] = ds + cont pys' = SVG.VerticalTo SVG.OriginAbsolute pys' : ds + + renderPathCommands firstp (cx, cy) _ (SVG.VerticalTo SVG.OriginRelative (dy:dys):ds) + = DLineTo ap : renderPathCommands firstp ap Nothing (cont dys) + where + ap = (cx,cy+dy) + + cont [] = ds + cont dys' = SVG.VerticalTo SVG.OriginRelative dys' : ds + + renderPathCommands firstp currentp _ (SVG.CurveTo origin ((c1,c2,p):ps):ds) + = DBezierTo ac1 ac2 ap : renderPathCommands firstp ap (Just ac2) (cont ps) + where + ap = toAbsolute currentp origin (fromRPoint p) + ac1 = toAbsolute currentp origin (fromRPoint c1) + ac2 = toAbsolute currentp origin (fromRPoint c2) + + cont [] = ds + cont ps' = SVG.CurveTo origin ps' : ds + + renderPathCommands firstp currentp mbControlp (SVG.SmoothCurveTo origin ((c2,p):ps):ds) + = DBezierTo ac1 ac2 ap : renderPathCommands firstp ap (Just ac2) (cont ps) + where + ap = toAbsolute currentp origin (fromRPoint p) + ac1 = maybe ac2 (mirrorControlPoint currentp) mbControlp + ac2 = toAbsolute currentp origin (fromRPoint c2) + + cont [] = ds + cont ps' = SVG.SmoothCurveTo origin ps' : ds + + renderPathCommands firstp currentp _ (SVG.QuadraticBezier origin ((c1,p):ps):ds) + = cbezier : renderPathCommands firstp ap (Just ac1) (cont ps) + where + ap = toAbsolute currentp origin (fromRPoint p) + ac1 = toAbsolute currentp origin (fromRPoint c1) + + cbezier = bezierQ2C currentp ac1 ap + + cont [] = ds + cont ps' = SVG.QuadraticBezier origin ps' : ds + + renderPathCommands firstp currentp mbControlp (SVG.SmoothQuadraticBezierCurveTo origin (p:ps):ds) + = cbezier : renderPathCommands firstp ap (Just ac1) (cont ps) + where + ap = toAbsolute currentp origin (fromRPoint p) + ac1 = maybe currentp (mirrorControlPoint currentp) mbControlp + + cbezier = bezierQ2C currentp ac1 ap + + cont [] = ds + cont ps' = SVG.SmoothQuadraticBezierCurveTo origin ps' : ds + + renderPathCommands firstp currentp _ (SVG.EllipticalArc origin ((rx,ry,rot,largeArcFlag,sweepFlag,p):ps):ds) + = convertSvgArc currentp rx ry rot largeArcFlag sweepFlag ap ++ renderPathCommands firstp ap Nothing (cont ps) + where + ap = toAbsolute currentp origin (fromRPoint p) + + cont [] = ds + cont ps' = SVG.EllipticalArc origin ps' : ds + + renderPathCommands firstp@(fx,fy) (cx,cy) mbControlp (SVG.EndPath:ds) + | fx /= cx || fy /= cy + = DLineTo firstp : renderPathCommands firstp firstp mbControlp ds + | otherwise + = renderPathCommands firstp firstp mbControlp ds + + renderPathCommands _ _ _ _ = [] + + renderTree :: TransformationMatrix -> SVG.Tree -> [DrawOp] + renderTree m (SVG.GroupTree g) = renderTrees (applyTransformations m (SVG._transform (SVG._groupDrawAttributes g))) (SVG._groupChildren g) + renderTree m (SVG.PathTree p) = map (transformDrawOp tr) $ renderPathCommands (0,0) (0,0) Nothing (SVG._pathDefinition p) + where + tr = applyTransformations m (SVG._transform (SVG._pathDrawAttributes p)) + + renderTree m (SVG.RectangleTree r) + | rx == 0.0 && ry == 0.0 + = map (transformDrawOp tr) [DMoveTo (x,y), DLineTo (x+w,y), DLineTo (x+w,y+h), DLineTo (x,y+h), DLineTo (x,y)] + | otherwise + = map (transformDrawOp tr) + ([DMoveTo (x,y+ry)] ++ convertSvgArc (x,y+ry) rx ry 0 False True (x+rx, y) ++ + [DLineTo (x+w-rx,y)] ++ convertSvgArc (x+w-rx,y) rx ry 0 False True (x+w, y+ry) ++ + [DLineTo (x+w,y+h-ry)] ++ convertSvgArc (x+w,y+h-ry) rx ry 0 False True (x+w-rx, y+h) ++ + [DLineTo (x+rx,y+h)] ++ convertSvgArc (x+rx, y+h) rx ry 0 False True (x, y+h-ry) ++ + [DLineTo (x,y+ry)]) + where + (x,y) = fromSvgPoint dpi (SVG._rectUpperLeftCorner r) + w = fromSvgNumber dpi (SVG._rectWidth r) + h = fromSvgNumber dpi (SVG._rectHeight r) + (rx, ry) = mapTuple (fromSvgNumber dpi) (SVG._rectCornerRadius r) + tr = applyTransformations m (SVG._transform (SVG._rectDrawAttributes r)) + + renderTree m (SVG.LineTree l) = [DMoveTo p1, DLineTo p2] + where + p1 = transformPoint tr (fromSvgPoint dpi (SVG._linePoint1 l)) + p2 = transformPoint tr (fromSvgPoint dpi (SVG._linePoint2 l)) + tr = applyTransformations m (SVG._transform (SVG._lineDrawAttributes l)) + + renderTree m (SVG.PolyLineTree l) = map (transformDrawOp tr) (DMoveTo p0:map DLineTo ps) + where + (p0:ps) = map (\(Linear.V2 x y) -> (x,y)) (SVG._polyLinePoints l) + tr = applyTransformations m (SVG._transform (SVG._polyLineDrawAttributes l)) + + renderTree m (SVG.PolygonTree l) = map (transformDrawOp tr) (DMoveTo p0:map DLineTo (ps ++ [p0])) + where + (p0:ps) = map (\(Linear.V2 x y) -> (x,y)) (SVG._polygonPoints l) + tr = applyTransformations m (SVG._transform (SVG._polygonDrawAttributes l)) + + renderTree m (SVG.EllipseTree e) = map (transformDrawOp tr) (DMoveTo (cx-rx,cy) : bs1++bs2++bs3++bs4) + where + bs1 = convertSvgArc (cx-rx, cy) rx ry 0 False True (cx, cy-ry) + bs2 = convertSvgArc (cx, cy-ry) rx ry 0 False True (cx+rx, cy) + bs3 = convertSvgArc (cx+rx, cy) rx ry 0 False True (cx, cy+ry) + bs4 = convertSvgArc (cx, cy+ry) rx ry 0 False True (cx-rx, cy) + + (cx,cy) = fromSvgPoint dpi (SVG._ellipseCenter e) + rx = fromSvgNumber dpi (SVG._ellipseXRadius e) + ry = fromSvgNumber dpi (SVG._ellipseYRadius e) + tr = applyTransformations m (SVG._transform (SVG._ellipseDrawAttributes e)) + + renderTree m (SVG.CircleTree c) = map (transformDrawOp tr) (DMoveTo (cx-r,cy) : bs1++bs2++bs3++bs4) + where + bs1 = convertSvgArc (cx-r, cy) r r 0 False True (cx, cy-r) + bs2 = convertSvgArc (cx, cy-r) r r 0 False True (cx+r, cy) + bs3 = convertSvgArc (cx+r, cy) r r 0 False True (cx, cy+r) + bs4 = convertSvgArc (cx, cy+r) r r 0 False True (cx-r, cy) + + (cx,cy) = fromSvgPoint dpi (SVG._circleCenter c) + r = fromSvgNumber dpi (SVG._circleRadius c) + tr = applyTransformations m (SVG._transform (SVG._circleDrawAttributes c)) + + {- The rest: None, UseTree, SymbolTree, TextTree, ImageTree -} + renderTree _ _ = [] + + renderTrees :: TransformationMatrix -> [SVG.Tree] -> [DrawOp] + renderTrees m es = concat $ map (renderTree m) es diff --git a/src/SVGExt.hs b/src/SVGExt.hs --- a/src/SVGExt.hs +++ b/src/SVGExt.hs @@ -1,30 +1,30 @@ -module SVGExt ( documentSize - ) where - -import qualified Graphics.Svg as SVG - --- it is a replacement of SVG.documentSize as that returns (Int,Int) causing a serious --- precision loss in the final gcode -documentSize :: Int -> SVG.Document -> (Double, Double) -documentSize _ SVG.Document { SVG._viewBox = Just (x1, y1, x2, y2) - , SVG._width = Just (SVG.Percent pw) - , SVG._height = Just (SVG.Percent ph) - } = - (dx * pw, dy * ph) - where - dx = abs $ x2 - x1 - dy = abs $ y2 - y1 - -documentSize _ SVG.Document { SVG._width = Just (SVG.Num w) - , SVG._height = Just (SVG.Num h) } = (w, h) - -documentSize dpi doc@(SVG.Document { SVG._width = Just w - , SVG._height = Just h }) = - documentSize dpi $ doc - { SVG._width = Just $ SVG.toUserUnit dpi w - , SVG._height = Just $ SVG.toUserUnit dpi h } - -documentSize _ SVG.Document { SVG._viewBox = Just (x1, y1, x2, y2) } = - (abs $ x2 - x1, abs $ y2 - y1) - -documentSize _ _ = (1, 1) +module SVGExt ( documentSize + ) where + +import qualified Graphics.Svg as SVG + +-- it is a replacement of SVG.documentSize as that returns (Int,Int) causing a serious +-- precision loss in the final gcode +documentSize :: Int -> SVG.Document -> (Double, Double) +documentSize _ SVG.Document { SVG._viewBox = Just (x1, y1, x2, y2) + , SVG._width = Just (SVG.Percent pw) + , SVG._height = Just (SVG.Percent ph) + } = + (dx * pw, dy * ph) + where + dx = abs $ x2 - x1 + dy = abs $ y2 - y1 + +documentSize _ SVG.Document { SVG._width = Just (SVG.Num w) + , SVG._height = Just (SVG.Num h) } = (w, h) + +documentSize dpi doc@(SVG.Document { SVG._width = Just w + , SVG._height = Just h }) = + documentSize dpi $ doc + { SVG._width = Just $ SVG.toUserUnit dpi w + , SVG._height = Just $ SVG.toUserUnit dpi h } + +documentSize _ SVG.Document { SVG._viewBox = Just (x1, y1, x2, y2) } = + (abs $ x2 - x1, abs $ y2 - y1) + +documentSize _ _ = (1, 1) diff --git a/src/SvgArcSegment.hs b/src/SvgArcSegment.hs --- a/src/SvgArcSegment.hs +++ b/src/SvgArcSegment.hs @@ -1,83 +1,83 @@ -module SvgArcSegment ( - convertSvgArc - ) where - -import Types - -radiansPerDegree :: Double -radiansPerDegree = pi / 180.0 - -calculateVectorAngle :: Double -> Double -> Double -> Double -> Double -calculateVectorAngle ux uy vx vy - | tb >= ta - = tb - ta - | otherwise - = pi * 2 - (ta - tb) - where - ta = atan2 uy ux - tb = atan2 vy vx - --- ported from: https://github.com/vvvv/SVG/blob/master/Source/Paths/SvgArcSegment.cs -convertSvgArc :: Point -> Double -> Double -> Double -> Bool -> Bool -> Point -> [DrawOp] -convertSvgArc (x0,y0) radiusX radiusY angle largeArcFlag sweepFlag (x,y) - | x0 == x && y0 == y - = [] - | radiusX == 0.0 && radiusY == 0.0 - = [DLineTo (x,y)] - | otherwise - = calcSegments x0 y0 theta1' segments' - where - sinPhi = sin (angle * radiansPerDegree) - cosPhi = cos (angle * radiansPerDegree) - - x1dash = cosPhi * (x0 - x) / 2.0 + sinPhi * (y0 - y) / 2.0 - y1dash = -sinPhi * (x0 - x) / 2.0 + cosPhi * (y0 - y) / 2.0 - - numerator = radiusX * radiusX * radiusY * radiusY - radiusX * radiusX * y1dash * y1dash - radiusY * radiusY * x1dash * x1dash - - s = sqrt(1.0 - numerator / (radiusX * radiusX * radiusY * radiusY)) - rx = if' (numerator < 0.0) (radiusX * s) radiusX - ry = if' (numerator < 0.0) (radiusY * s) radiusY - root = if' (numerator < 0.0) - (0.0) - ((if' ((largeArcFlag && sweepFlag) || (not largeArcFlag && not sweepFlag)) (-1.0) 1.0) * - sqrt(numerator / (radiusX * radiusX * y1dash * y1dash + radiusY * radiusY * x1dash * x1dash))) - - cxdash = root * rx * y1dash / ry - cydash = -root * ry * x1dash / rx - - cx = cosPhi * cxdash - sinPhi * cydash + (x0 + x) / 2.0 - cy = sinPhi * cxdash + cosPhi * cydash + (y0 + y) / 2.0 - - theta1' = calculateVectorAngle 1.0 0.0 ((x1dash - cxdash) / rx) ((y1dash - cydash) / ry) - dtheta' = calculateVectorAngle ((x1dash - cxdash) / rx) ((y1dash - cydash) / ry) ((-x1dash - cxdash) / rx) ((-y1dash - cydash) / ry) - dtheta = if' (not sweepFlag && dtheta' > 0) - (dtheta' - 2 * pi) - (if' (sweepFlag && dtheta' < 0) (dtheta' + 2 * pi) dtheta') - - segments' = ceiling (abs (dtheta / (pi / 2.0))) - delta = dtheta / fromInteger segments' - t = 8.0 / 3.0 * sin(delta / 4.0) * sin(delta / 4.0) / sin(delta / 2.0) - - calcSegments startX startY theta1 segments - | segments == 0 - = [] - | otherwise - = (DBezierTo (startX + dx1, startY + dy1) (endpointX + dxe, endpointY + dye) (endpointX, endpointY) : calcSegments endpointX endpointY theta2 (segments - 1)) - where - cosTheta1 = cos theta1 - sinTheta1 = sin theta1 - theta2 = theta1 + delta - cosTheta2 = cos theta2 - sinTheta2 = sin theta2 - - endpointX = cosPhi * rx * cosTheta2 - sinPhi * ry * sinTheta2 + cx - endpointY = sinPhi * rx * cosTheta2 + cosPhi * ry * sinTheta2 + cy - - dx1 = t * (-cosPhi * rx * sinTheta1 - sinPhi * ry * cosTheta1) - dy1 = t * (-sinPhi * rx * sinTheta1 + cosPhi * ry * cosTheta1) - - dxe = t * (cosPhi * rx * sinTheta2 + sinPhi * ry * cosTheta2) - dye = t * (sinPhi * rx * sinTheta2 - cosPhi * ry * cosTheta2) - +module SvgArcSegment ( + convertSvgArc + ) where + +import Types + +radiansPerDegree :: Double +radiansPerDegree = pi / 180.0 + +calculateVectorAngle :: Double -> Double -> Double -> Double -> Double +calculateVectorAngle ux uy vx vy + | tb >= ta + = tb - ta + | otherwise + = pi * 2 - (ta - tb) + where + ta = atan2 uy ux + tb = atan2 vy vx + +-- ported from: https://github.com/vvvv/SVG/blob/master/Source/Paths/SvgArcSegment.cs +convertSvgArc :: Point -> Double -> Double -> Double -> Bool -> Bool -> Point -> [DrawOp] +convertSvgArc (x0,y0) radiusX radiusY angle largeArcFlag sweepFlag (x,y) + | x0 == x && y0 == y + = [] + | radiusX == 0.0 && radiusY == 0.0 + = [DLineTo (x,y)] + | otherwise + = calcSegments x0 y0 theta1' segments' + where + sinPhi = sin (angle * radiansPerDegree) + cosPhi = cos (angle * radiansPerDegree) + + x1dash = cosPhi * (x0 - x) / 2.0 + sinPhi * (y0 - y) / 2.0 + y1dash = -sinPhi * (x0 - x) / 2.0 + cosPhi * (y0 - y) / 2.0 + + numerator = radiusX * radiusX * radiusY * radiusY - radiusX * radiusX * y1dash * y1dash - radiusY * radiusY * x1dash * x1dash + + s = sqrt(1.0 - numerator / (radiusX * radiusX * radiusY * radiusY)) + rx = if' (numerator < 0.0) (radiusX * s) radiusX + ry = if' (numerator < 0.0) (radiusY * s) radiusY + root = if' (numerator < 0.0) + (0.0) + ((if' ((largeArcFlag && sweepFlag) || (not largeArcFlag && not sweepFlag)) (-1.0) 1.0) * + sqrt(numerator / (radiusX * radiusX * y1dash * y1dash + radiusY * radiusY * x1dash * x1dash))) + + cxdash = root * rx * y1dash / ry + cydash = -root * ry * x1dash / rx + + cx = cosPhi * cxdash - sinPhi * cydash + (x0 + x) / 2.0 + cy = sinPhi * cxdash + cosPhi * cydash + (y0 + y) / 2.0 + + theta1' = calculateVectorAngle 1.0 0.0 ((x1dash - cxdash) / rx) ((y1dash - cydash) / ry) + dtheta' = calculateVectorAngle ((x1dash - cxdash) / rx) ((y1dash - cydash) / ry) ((-x1dash - cxdash) / rx) ((-y1dash - cydash) / ry) + dtheta = if' (not sweepFlag && dtheta' > 0) + (dtheta' - 2 * pi) + (if' (sweepFlag && dtheta' < 0) (dtheta' + 2 * pi) dtheta') + + segments' = ceiling (abs (dtheta / (pi / 2.0))) + delta = dtheta / fromInteger segments' + t = 8.0 / 3.0 * sin(delta / 4.0) * sin(delta / 4.0) / sin(delta / 2.0) + + calcSegments startX startY theta1 segments + | segments == 0 + = [] + | otherwise + = (DBezierTo (startX + dx1, startY + dy1) (endpointX + dxe, endpointY + dye) (endpointX, endpointY) : calcSegments endpointX endpointY theta2 (segments - 1)) + where + cosTheta1 = cos theta1 + sinTheta1 = sin theta1 + theta2 = theta1 + delta + cosTheta2 = cos theta2 + sinTheta2 = sin theta2 + + endpointX = cosPhi * rx * cosTheta2 - sinPhi * ry * sinTheta2 + cx + endpointY = sinPhi * rx * cosTheta2 + cosPhi * ry * sinTheta2 + cy + + dx1 = t * (-cosPhi * rx * sinTheta1 - sinPhi * ry * cosTheta1) + dy1 = t * (-sinPhi * rx * sinTheta1 + cosPhi * ry * cosTheta1) + + dxe = t * (cosPhi * rx * sinTheta2 + sinPhi * ry * cosTheta2) + dye = t * (sinPhi * rx * sinTheta2 - cosPhi * ry * cosTheta2) + diff --git a/src/Transformation.hs b/src/Transformation.hs --- a/src/Transformation.hs +++ b/src/Transformation.hs @@ -1,66 +1,66 @@ -module Transformation ( TransformationMatrix - , identityTransform - , mirrorYTransform - , translateTransform - , scaleTransform - , transformPoint - , transformDrawOp - , applyTransformations - , multiply - ) where - -import qualified Graphics.Svg as SVG -import Data.Matrix as M -import Types - -type TransformationMatrix = Matrix Double - -identityTransform :: TransformationMatrix -identityTransform = identity 3 - -mirrorYTransform :: Double -> Double -> TransformationMatrix -mirrorYTransform _ h = fromElements [1, 0, 0, -1, 0, h] - -translateTransform :: Double -> Double -> TransformationMatrix -translateTransform x y = fromElements [1, 0, 0, 1, x, y] - -scaleTransform :: Double -> Double -> TransformationMatrix -scaleTransform sx sy = fromElements [sx, 0, 0, sy, 0, 0] - -multiply :: TransformationMatrix -> TransformationMatrix -> TransformationMatrix -multiply a b = multStd a b - -fromElements :: [Double] -> TransformationMatrix -fromElements [a,b,c,d,e,f] = fromList 3 3 [a,c,e,b,d,f,0,0,1] -fromElements _ = error "Malformed transformation matrix" - -transformPoint :: TransformationMatrix -> Point -> Point -transformPoint m (x,y) = (a * x + c * y + e, b * x + d * y + f) - where - (a:c:e:b:d:f:_) = M.toList m - -transformDrawOp :: TransformationMatrix -> DrawOp -> DrawOp -transformDrawOp m (DMoveTo p) = DMoveTo (transformPoint m p) -transformDrawOp m (DLineTo p) = DLineTo (transformPoint m p) -transformDrawOp m (DBezierTo c1 c2 p2) = DBezierTo (transformPoint m c1) (transformPoint m c2) (transformPoint m p2) - -applyTransformations :: TransformationMatrix -> Maybe [SVG.Transformation] -> TransformationMatrix -applyTransformations m Nothing = m -applyTransformations m (Just ts) = foldl applyTransformation m ts - -radiansPerDegree :: Double -radiansPerDegree = pi / 180.0 - --- https://developer.mozilla.org/en/docs/Web/SVG/Attribute/transform -applyTransformation :: Matrix Double -> SVG.Transformation -> Matrix Double -applyTransformation m (SVG.TransformMatrix a b c d e f) = multStd m (fromElements [a,b,c,d,e,f]) -applyTransformation m (SVG.Translate x y) = multStd m (fromElements [1,0,0,1,x,y]) -applyTransformation m (SVG.Scale sx mbSy) = multStd m (fromElements [sx,0,0,maybe sx id mbSy,0,0]) -applyTransformation m (SVG.Rotate a Nothing) - = multStd m (fromElements [cos(r),sin(r),-sin(r),cos(r),0,0]) - where - r = a * radiansPerDegree -applyTransformation m (SVG.Rotate a (Just (x, y))) = applyTransformations m (Just [SVG.Translate x y , SVG.Rotate a Nothing , SVG.Translate (-x) (-y)]) -applyTransformation m (SVG.SkewX a) = multStd m (fromElements [1,0,tan(a*radiansPerDegree),1,0,0]) -applyTransformation m (SVG.SkewY a) = multStd m (fromElements [1,tan(a*radiansPerDegree),0,1,0,0]) -applyTransformation m (SVG.TransformUnknown) = m +module Transformation ( TransformationMatrix + , identityTransform + , mirrorYTransform + , translateTransform + , scaleTransform + , transformPoint + , transformDrawOp + , applyTransformations + , multiply + ) where + +import qualified Graphics.Svg as SVG +import Data.Matrix as M +import Types + +type TransformationMatrix = Matrix Double + +identityTransform :: TransformationMatrix +identityTransform = identity 3 + +mirrorYTransform :: Double -> Double -> TransformationMatrix +mirrorYTransform _ h = fromElements [1, 0, 0, -1, 0, h] + +translateTransform :: Double -> Double -> TransformationMatrix +translateTransform x y = fromElements [1, 0, 0, 1, x, y] + +scaleTransform :: Double -> Double -> TransformationMatrix +scaleTransform sx sy = fromElements [sx, 0, 0, sy, 0, 0] + +multiply :: TransformationMatrix -> TransformationMatrix -> TransformationMatrix +multiply a b = multStd a b + +fromElements :: [Double] -> TransformationMatrix +fromElements [a,b,c,d,e,f] = fromList 3 3 [a,c,e,b,d,f,0,0,1] +fromElements _ = error "Malformed transformation matrix" + +transformPoint :: TransformationMatrix -> Point -> Point +transformPoint m (x,y) = (a * x + c * y + e, b * x + d * y + f) + where + (a:c:e:b:d:f:_) = M.toList m + +transformDrawOp :: TransformationMatrix -> DrawOp -> DrawOp +transformDrawOp m (DMoveTo p) = DMoveTo (transformPoint m p) +transformDrawOp m (DLineTo p) = DLineTo (transformPoint m p) +transformDrawOp m (DBezierTo c1 c2 p2) = DBezierTo (transformPoint m c1) (transformPoint m c2) (transformPoint m p2) + +applyTransformations :: TransformationMatrix -> Maybe [SVG.Transformation] -> TransformationMatrix +applyTransformations m Nothing = m +applyTransformations m (Just ts) = foldl applyTransformation m ts + +radiansPerDegree :: Double +radiansPerDegree = pi / 180.0 + +-- https://developer.mozilla.org/en/docs/Web/SVG/Attribute/transform +applyTransformation :: Matrix Double -> SVG.Transformation -> Matrix Double +applyTransformation m (SVG.TransformMatrix a b c d e f) = multStd m (fromElements [a,b,c,d,e,f]) +applyTransformation m (SVG.Translate x y) = multStd m (fromElements [1,0,0,1,x,y]) +applyTransformation m (SVG.Scale sx mbSy) = multStd m (fromElements [sx,0,0,maybe sx id mbSy,0,0]) +applyTransformation m (SVG.Rotate a Nothing) + = multStd m (fromElements [cos(r),sin(r),-sin(r),cos(r),0,0]) + where + r = a * radiansPerDegree +applyTransformation m (SVG.Rotate a (Just (x, y))) = applyTransformations m (Just [SVG.Translate x y , SVG.Rotate a Nothing , SVG.Translate (-x) (-y)]) +applyTransformation m (SVG.SkewX a) = multStd m (fromElements [1,0,tan(a*radiansPerDegree),1,0,0]) +applyTransformation m (SVG.SkewY a) = multStd m (fromElements [1,tan(a*radiansPerDegree),0,1,0,0]) +applyTransformation m (SVG.TransformUnknown) = m diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -1,25 +1,25 @@ -module Types ( Point - , DrawOp (..) - , GCodeOp (..) - , if' - ) where - -type Point = (Double, Double) -- A point in the plane, absolute coordinates - --- all of them are invariant under affine transformation -data DrawOp = DMoveTo Point - | DLineTo Point -- End point - | DBezierTo Point Point Point -- Control point1, control point2, end point - deriving Show - --- this is basically what GCode can do -data GCodeOp = GMoveTo Point - | GLineTo Point -- End point - | GArcTo Point Point Bool -- Center point, end point, clockwise - | GBezierTo Point Point Point -- First and second control points, end point - deriving Show - --- just to make it available everywhere -if' :: Bool -> t -> t -> t -if' True t _ = t -if' False _ f = f +module Types ( Point + , DrawOp (..) + , GCodeOp (..) + , if' + ) where + +type Point = (Double, Double) -- A point in the plane, absolute coordinates + +-- all of them are invariant under affine transformation +data DrawOp = DMoveTo Point + | DLineTo Point -- End point + | DBezierTo Point Point Point -- Control point1, control point2, end point + deriving Show + +-- this is basically what GCode can do +data GCodeOp = GMoveTo Point + | GLineTo Point -- End point + | GArcTo Point Point Bool -- Center point, end point, clockwise + | GBezierTo Point Point Point -- First and second control points, end point + deriving Show + +-- just to make it available everywhere +if' :: Bool -> t -> t -> t +if' True t _ = t +if' False _ f = f