diff --git a/Approx.hs b/Approx.hs new file mode 100644 --- /dev/null +++ b/Approx.hs @@ -0,0 +1,83 @@ +module Approx ( bezier2biarc + ) where + +import qualified CubicBezier as B +import qualified BiArc as BA +import qualified Line as L + +import Linear +import Data.Complex + +import Types + +bezier2biarc :: B.CubicBezier + -> Double + -> Double + -> [BA.BiArc] +bezier2biarc mbezier samplingStep tolerance + = 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 -> [BA.BiArc] + approxOne bezier + | maxDistance > tolerance + = let (b1, b2) = B.bezierSplitAt bezier maxDistanceAt + in approxOne b1 ++ approxOne b2 + | otherwise + = [biarc] + where + -- V: Intersection point of tangent lines + t1 = L.fromPoints (B._p1 bezier) (B._c1 bezier) + t2 = L.fromPoints (B._p2 bezier) (B._c2 bezier) + 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 - B._c1 bezier) (B._p2 bezier) (B._p2 bezier - B._c2 bezier) g + + -- calculate the error + nrPointsToCheck = (BA.arcLength biarc) / samplingStep + parameterStep = 1 / nrPointsToCheck + + (maxDistance, maxDistanceAt) = maxDistance' 0 0 0 + + 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 + diff --git a/BiArc.hs b/BiArc.hs new file mode 100644 --- /dev/null +++ b/BiArc.hs @@ -0,0 +1,81 @@ +module BiArc ( BiArc (..) + , create + , pointAt + , arcLength + ) 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) + diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for juicy-gcode + +## 0.1.0.0 -- 2016-10-30 + +* First version. Mostly feature complete, but not well tested. diff --git a/CircularArc.hs b/CircularArc.hs new file mode 100644 --- /dev/null +++ b/CircularArc.hs @@ -0,0 +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) + diff --git a/CubiCBezier.hs b/CubiCBezier.hs new file mode 100644 --- /dev/null +++ b/CubiCBezier.hs @@ -0,0 +1,60 @@ +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 diff --git a/GCode.hs b/GCode.hs new file mode 100644 --- /dev/null +++ b/GCode.hs @@ -0,0 +1,46 @@ +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 Z10\nG0 X0 Y0\nM3\nG4 P2000.000000" "G0 Z10\nM5\nM2" "G01 Z0 F10.00" "G00 Z10" + +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 / dd) * 2.54 * 10 + + 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 + | (mm i) < 1 || (mm i) < 1 + = printf "G01 X%.4f Y%.4f" (mm x) (mm y) + | otherwise + = printf "%s X%.4f Y%.4f I%.4f J%.4f" cmd (mm x) (mm y) (mm i) (mm j) + + toString' [] _ _ = [] diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, dlacko + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of dlacko nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Line.hs b/Line.hs new file mode 100644 --- /dev/null +++ b/Line.hs @@ -0,0 +1,63 @@ +module Line ( Line (..) + , throughPoint + , fromPoints + , createPerpendicularAt + , slope + , intersection + ) where + +import Linear +import Control.Lens + +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 unique it actually return +/-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 + diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,71 @@ +import qualified Graphics.Svg as SVG + +import Data.Text +import qualified Data.Configurator as C + +import Data.Monoid + +import Options.Applicative + +import Render +import GCode + +data Options = Options { _svgfile :: String + , _cfgfile :: Maybe String + , _outfile :: Maybe String + , _dpi :: Int + } + +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 72 + <> short 'd' + <> metavar "DPI" + <> help "Density of the SVG file (default is 72 DPI)" )) + +runWithOptions :: Options -> IO () +runWithOptions (Options svgFile mbCfg mbOut dpi) = + do + mbDoc <- SVG.loadSvgFile svgFile + flavor <- maybe (return defaultFlavor) readFlavor mbCfg + case mbDoc of + (Just doc) -> writer (toString flavor dpi $ renderDoc dpi 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) + +main :: IO () +main = execParser opts >>= runWithOptions + where + opts = info (helper <*> options) + ( fullDesc + <> progDesc "Convert SVGFILE to G-Code" + <> header "juicy-gcode - The SVG to G-Code converter" ) + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,84 @@ +## Synopsis + +Haskell SVG to G-code converter. It aims to support almost all of the SVG features. The flavor of the generated G-Code can be configured providing a configuration file. + +## Installation and usage + +* Install the latest [Haskell Platform](https://www.haskell.org/platform/) if you do not have it yet +* `$ git clone https://github.com/domoszlai/juicy-gcode.git` +* `$ cabal install juicy-gcode/juicy-gcode.cabal` +* `$ juicy-gcode --help` + +``` +juicy-gcode - The SVG to G-Code converter + +Usage: juicy-gcode.exe SVGFILE [-f|--flavor CONFIGFILE] [-o|--output OUTPUTFILE] + [-d|--dpi DPI] + Convert SVGFILE to G-Code + +Available options: + -h,--help Show this help text + SVGFILE The SVG file to be converted + -f,--flavor CONFIGFILE Configuration of G-Code flavor + -o,--output OUTPUTFILE The output G-Code file (default is standard output) + -d,--dpi DPI Density of the SVG file (default is 72 DPI) +``` + +## Configuration + +The default G-Code flavor configuration file is the following: + +``` +gcode +{ + begin = "G17;G90;G0 Z10;G0 X0 Y0;M3;G4 P2000.000000" + end = "G0 Z10;M5;M2" + toolon = "G00 Z10" + tooloff = "G01 Z0 F10.00" +} +``` + +A new configuration file can be set by the `--flavor` or `-f` command line option. + +Another configurable property is the resolution of the SVG image in DPI (dot per inch). It can be given by the `--dpi` or `-d` command line option. Default value is 72 DPI. + +## Limitations + +Missing features: +* text (easy with e.g. [FontyFruity](https://hackage.haskell.org/package/FontyFruity), maybe once, you can convert text to curves easily anyway) +* filling (moderately difficult) +* clipping (probably not easy, maybe once) +* images (not planned) + +## Implementation + +SVG images are built using the following shapes (all of these are subject of an arbitrary affine transformation): + + * lines + * circles + * ellipses + * elliptic arcs with optional x axis rotation + * quadratic and cubic bezier curves + + + +In contrast G-Code implements only + + + + * lines + * non-elliptical arcs + + +That means that only lines, circles and some arcs (non-elliptic ones without rotation) can be transleted to G-Code directly. If transformations are also counted, then +only lines can be translated to G-Code directly as circles are not invariant under affine transformations. Because of this, the converter is implemented in two stages. + +### Stage 1 + +All the SVG drawing operations are translated to a list of MoveTo, LineTo and CubicBezierTo operations as these are invariant under affine transformations. +Arcs, circles and ellipses can be easily approximated with bezier curves with a small error. + +### Stage 2 + +Cubic bezier curves are approximated with [Biarcs](https://en.wikipedia.org/wiki/Biarc) using the algorithm described in [[1](http://www.itc.ktu.lt/index.php/ITC/article/view/11812)] and explained [here](http://dlacko.blogspot.nl/2016/10/approximating-bezier-curves-by-biarcs.html). + diff --git a/Render.hs b/Render.hs new file mode 100644 --- /dev/null +++ b/Render.hs @@ -0,0 +1,246 @@ +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 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) + +renderDoc :: Int -> SVG.Document -> [GCodeOp] +renderDoc dpi doc = stage2 $ renderTrees identityMatrix (SVG._elements doc) + where + -- 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 = concat (map biarc2garc biarcs) ++ convert ds (fromPoint p2) + where + biarcs = bezier2biarc (B.CubicBezier cp (fromPoint c1) (fromPoint c2) (fromPoint p2)) 5 1 + biarc2garc biarc = [arc2garc (BA._a1 biarc), arc2garc (BA._a2 biarc)] + 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._linePoint1 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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/SvgArcSegment.hs b/SvgArcSegment.hs new file mode 100644 --- /dev/null +++ b/SvgArcSegment.hs @@ -0,0 +1,123 @@ +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 == y0 + = [] + | 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) + +{- +-- ported from: http://www.java2s.com/Code/Java/2D-Graphics-GUI/AgeometricpathconstructedfromstraightlinesquadraticandcubicBeziercurvesandellipticalarc.htm +-- works without angle and with circle segments only +convertArc :: Double -> Double -> Double -> Bool -> Bool -> Double -> Double -> Arc +convertArc x0 y0 radius largeArcFlag sweepFlag x y = Arc (x0,y0) (x,y) (cx,cy) dir + where + x1 = (x0 - x) / 2.0 + y1 = (y0 - y) / 2.0 + + pr' = radius * radius + px1 = x1 * x1 + py1 = y1 * y1 + + radiiCheck = px1 / pr' + py1 / pr' + + r = if' (radiiCheck > 1) (sqrt radiiCheck * abs radius) (abs radius) + pr = r * r + + sign = if' (largeArcFlag == sweepFlag) (-1) 1 + sq' = ((pr * pr) - (pr * py1) - (pr * px1)) / ((pr * py1) + (pr * px1)) + coef = sign * sqrt (max 0.0 sq') + cx1 = coef * y1 + cy1 = coef * (-x1) + + sx2 = (x0 + x) / 2.0 + sy2 = (y0 + y) / 2.0 + cx = sx2 + cx1 + cy = sy2 + cy1 + + ux = (x1 - cx1) / r + uy = (y1 - cy1) / r + vx = (-x1 - cx1) / r + vy = (-y1 - cy1) / r + + -- compute direction. True -> Clockwise + dir' = ux * vy - uy * vx >= 0 + dir = if' (not sweepFlag && dir') + False + (if' (sweepFlag && not dir') True dir') +-} + diff --git a/Transformation.hs b/Transformation.hs new file mode 100644 --- /dev/null +++ b/Transformation.hs @@ -0,0 +1,51 @@ +module Transformation ( TransformationMatrix + , identityMatrix + , transformPoint + , transformDrawOp + , applyTransformations + ) where + +import qualified Graphics.Svg as SVG +import Data.Matrix as M +import Types + +type TransformationMatrix = Matrix Double + +identityMatrix :: TransformationMatrix +identityMatrix = identity 3 + +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/Types.hs b/Types.hs new file mode 100644 --- /dev/null +++ b/Types.hs @@ -0,0 +1,28 @@ +module Types ( Point + , DArcDir + , DrawOp (..) + , GCodeOp (..) + , if' + ) where + +-- type Command = String +type Point = (Double,Double) -- A point in the plane, absolute coordinates + +data DArcDir = CC | CCW deriving Show + +-- 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 + deriving Show + +-- just to make it available everywhere +if' :: Bool -> t -> t -> t +if' True t _ = t +if' False _ f = f diff --git a/juicy-gcode.cabal b/juicy-gcode.cabal new file mode 100644 --- /dev/null +++ b/juicy-gcode.cabal @@ -0,0 +1,31 @@ +name: juicy-gcode +version: 0.1.0.0 +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 almost all of the SVG features. It currently supports all of the shapes except images (not planned) and text (maybe once as you it can be converted to curves easily anyway). The flavor of the generated G-Code can be configured providing a configuration file. + +extra-source-files: ChangeLog.md, README.md +cabal-version: >=1.10 +executable juicy-gcode + main-is: Main.hs + + other-modules: Approx BiArc CircularArc CubiCBezier GCode Line Render SvgArcSegment Transformation Types + + build-depends: base >=4.9 && <4.10, svg-tree >=0.5 && <0.6, matrix >=0.3 && <0.4,text >=1.2 && <1.3, configurator >=0.3 && <0.4, optparse-applicative >=0.13 && <0.14, linear >=1.20 && <1.21, lens >=4.14 && <4.15 + + GHC-Options: -Wall + default-language: Haskell2010 + +Source-repository head + Type: git + Location: https://github.com/domoszlai/juicy-gcode +