juicy-gcode 0.1.0.3 → 0.1.0.4
raw patch · 27 files changed
+933/−919 lines, 27 filesdep ~basedep ~lensdep ~matrixsetup-changed
Dependency ranges changed: base, lens, matrix, text
Files
- Approx.hs +0/−83
- BiArc.hs +0/−81
- ChangeLog.md +4/−0
- CircularArc.hs +0/−29
- CubicBezier.hs +0/−60
- GCode.hs +0/−47
- LICENSE +17/−26
- Line.hs +0/−63
- Main.hs +0/−71
- README.md +13/−2
- Render.hs +0/−246
- Setup.hs +2/−2
- SvgArcSegment.hs +0/−123
- Transformation.hs +0/−51
- Types.hs +0/−28
- juicy-gcode.cabal +15/−7
- src/Approx.hs +83/−0
- src/BiArc.hs +81/−0
- src/CircularArc.hs +29/−0
- src/CubicBezier.hs +60/−0
- src/GCode.hs +47/−0
- src/Line.hs +63/−0
- src/Main.hs +71/−0
- src/Render.hs +246/−0
- src/SvgArcSegment.hs +123/−0
- src/Transformation.hs +51/−0
- src/Types.hs +28/−0
− Approx.hs
@@ -1,83 +0,0 @@-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 -
− BiArc.hs
@@ -1,81 +0,0 @@-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) -
ChangeLog.md view
@@ -1,5 +1,9 @@ # Revision history for juicy-gcode +## 0.1.0.4 -- 2017-12-30 + +* Update LICENSE + ## 0.1.0.3 -- 2017-03-19 * Fix typo in cabal file
− CircularArc.hs
@@ -1,29 +0,0 @@-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) -
− CubicBezier.hs
@@ -1,60 +0,0 @@-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
− GCode.hs
@@ -1,47 +0,0 @@-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 - -- avoid tiny arcs - | (mm $ abs i) < 1 && (mm $ abs j) < 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' [] _ _ = []
LICENSE view
@@ -1,30 +1,21 @@-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: +The MIT License - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. +Copyright (c) 2010-2017 Google, Inc., dlacko - * 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. +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: - * 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. +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. -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. +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.
− Line.hs
@@ -1,63 +0,0 @@-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 -
− Main.hs
@@ -1,71 +0,0 @@-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" ) -
README.md view
@@ -1,12 +1,23 @@+Juicy-gcode: A Haskell SVG to GCode converter +================================== + +[](https://hackage.haskell.org/package/juicy-gcode) +[](http://travis-ci.org/domoszlai/juicy-gcode) + + ## Synopsis Haskell 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. ## Installation and usage -* Install the latest [Haskell Platform](https://www.haskell.org/platform/) if you do not have it yet +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` -* `$ cabal install juicy-gcode/juicy-gcode.cabal` +* `$ stack build` +* `$ stack install` * `$ juicy-gcode --help` ```
− Render.hs
@@ -1,246 +0,0 @@-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 - - -
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
− SvgArcSegment.hs
@@ -1,123 +0,0 @@-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') --} -
− Transformation.hs
@@ -1,51 +0,0 @@-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 -
− Types.hs
@@ -1,28 +0,0 @@-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
juicy-gcode.cabal view
@@ -1,5 +1,5 @@ name: juicy-gcode -version: 0.1.0.3 +version: 0.1.0.4 license: BSD3 license-file: LICENSE author: dlacko @@ -16,16 +16,24 @@ extra-source-files: ChangeLog.md, README.md cabal-version: >=1.10 executable juicy-gcode - main-is: Main.hs + hs-source-dirs: src + main-is: Main.hs - other-modules: Approx BiArc CircularArc CubicBezier GCode Line Render SvgArcSegment Transformation Types + other-modules: Approx BiArc CircularArc CubicBezier GCode Line Render SvgArcSegment Transformation Types - build-depends: base >=4.8 && <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 + build-depends: + base >=4.8 && <5, + lens >=4.15.4 && <4.16, + linear >=1.20 && <1.21, + optparse-applicative >=0.13 && <0.14, + configurator >=0.3 && <0.4, + text >=1.2.2 && <1.3, + matrix >=0.3.5 && <0.4, + svg-tree >=0.5 && <0.6 - GHC-Options: -Wall - default-language: Haskell2010 + GHC-Options: -Wall + default-language: Haskell2010 Source-repository head Type: git Location: https://github.com/domoszlai/juicy-gcode -
+ src/Approx.hs view
@@ -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 +
+ src/BiArc.hs view
@@ -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) +
+ src/CircularArc.hs view
@@ -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) +
+ src/CubicBezier.hs view
@@ -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
+ src/GCode.hs view
@@ -0,0 +1,47 @@+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 + -- avoid tiny arcs + | (mm $ abs i) < 1 && (mm $ abs j) < 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' [] _ _ = []
+ src/Line.hs view
@@ -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 +
+ src/Main.hs view
@@ -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" ) +
+ src/Render.hs view
@@ -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 + + +
+ src/SvgArcSegment.hs view
@@ -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') +-} +
+ src/Transformation.hs view
@@ -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 +
+ src/Types.hs view
@@ -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