{- ORMOLU_DISABLE -}
-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)
-- Copyright (C) 2016, Julia Longtin (julial@turinglace.com)
-- Released under the GNU AGPLV3+, see LICENSE

{-# LANGUAGE OverloadedStrings #-}

module Graphics.Implicit.Export.PolylineFormats (svg, hacklabLaserGCode, dxf2) where

import Prelude((.), ($), (-), (+), (/), minimum, maximum, unzip, show, unwords, fmap, snd, compare, min, max, length, foldl, mempty, (<>), (<$>))

import Graphics.Implicit.Definitions (Polyline(Polyline), ℝ, ℝ2)

import Graphics.Implicit.Export.TextBuilderUtils (Text, Builder, toLazyText, bf, buildInt, buildTruncFloat)

import Text.Blaze.Svg.Renderer.Text (renderSvg)
import Text.Blaze.Svg11 ((!),docTypeSvg,g,polyline,toValue,Svg)
import Text.Blaze.Internal (stringValue)
import qualified Text.Blaze.Svg11.Attributes as A (version, width, height, viewbox, points, stroke, strokeWidth, fill)

import Data.List (sortBy, foldl')

import Data.Foldable (fold, foldMap, traverse_)
import Linear ( V2(V2) )

default (ℝ)

-- FIXME: magic numbers.
svg :: [Polyline] -> Text
svg :: [Polyline] -> Text
svg [Polyline]
plines = Svg -> Text
renderSvg forall b c a. (b -> c) -> (a -> b) -> a -> c
. Svg -> Svg
svg11 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Polyline] -> Svg
svg' forall a b. (a -> b) -> a -> b
$ [Polyline]
plines
    where
      strokeWidth :: ℝ
      strokeWidth :: ℝ
strokeWidth = ℝ
1
      (ℝ
xmin, ℝ
xmax, ℝ
ymin, ℝ
ymax) = (ℝ
xmin' forall a. Num a => a -> a -> a
- ℝ
margin, ℝ
xmax' forall a. Num a => a -> a -> a
+ ℝ
margin, ℝ
ymin' forall a. Num a => a -> a -> a
- ℝ
margin, ℝ
ymax' forall a. Num a => a -> a -> a
+ ℝ
margin)
           where margin :: ℝ
margin = ℝ
strokeWidth forall a. Fractional a => a -> a -> a
/ ℝ
2
                 ((ℝ
xmin', ℝ
xmax'), (ℝ
ymin', ℝ
ymax')) = ([ℝ] -> (ℝ, ℝ)
maxMinList [ℝ]
xs,[ℝ] -> (ℝ, ℝ)
maxMinList [ℝ]
ys)
                 xs, ys :: [ℝ]
                 ([ℝ]
xs,[ℝ]
ys) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a. V2 a -> (a, a)
unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Polyline -> [V2 ℝ]
pair [Polyline]
plines
                 pair :: Polyline -> [V2 ℝ]
pair (Polyline [V2 ℝ]
a) = [V2 ℝ]
a
                 maxMinList :: [ℝ] -> (ℝ,ℝ)
                 maxMinList :: [ℝ] -> (ℝ, ℝ)
maxMinList (ℝ
x:[ℝ]
others) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\(ℝ
l,ℝ
h) ℝ
y -> (forall a. Ord a => a -> a -> a
min ℝ
l ℝ
y, forall a. Ord a => a -> a -> a
max ℝ
h ℝ
y)) (ℝ
x,ℝ
x) [ℝ]
others
                 maxMinList [] = (ℝ
0,ℝ
0)
      svg11 :: Svg -> Svg
svg11 = Svg -> Svg
docTypeSvg forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.version AttributeValue
"1.1"
                         forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.width  (String -> AttributeValue
stringValue forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (ℝ
xmaxforall a. Num a => a -> a -> a
-ℝ
xmin) forall a. Semigroup a => a -> a -> a
<> String
"mm")
                         forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.height (String -> AttributeValue
stringValue forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (ℝ
ymaxforall a. Num a => a -> a -> a
-ℝ
ymin) forall a. Semigroup a => a -> a -> a
<> String
"mm")
                         forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.viewbox (String -> AttributeValue
stringValue forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ℝ
0,ℝ
0,ℝ
xmaxforall a. Num a => a -> a -> a
-ℝ
xmin,ℝ
ymaxforall a. Num a => a -> a -> a
-ℝ
ymin])

      -- The reason this isn't totally straightforwards is that svg has different coordinate system
      -- and we need to compute the requisite translation.
      svg' :: [Polyline] -> Svg
      svg' :: [Polyline] -> Svg
svg' [] = forall a. Monoid a => a
mempty
      -- When we have a known point, we can compute said transformation:
      svg' [Polyline]
polylines = Svg -> Svg
thinBlueGroup forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Polyline -> Svg
poly [Polyline]
polylines

      poly :: Polyline -> Svg
poly (Polyline [V2 ℝ]
line) = Svg
polyline forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.points AttributeValue
pointList
          where pointList :: AttributeValue
pointList = forall a. ToValue a => a -> AttributeValue
toValue forall a b. (a -> b) -> a -> b
$ Builder -> Text
toLazyText forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [ℝ -> Builder
bf (ℝ
xforall a. Num a => a -> a -> a
-ℝ
xmin) forall a. Semigroup a => a -> a -> a
<> Builder
"," forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
bf (ℝ
ymax forall a. Num a => a -> a -> a
- ℝ
y) forall a. Semigroup a => a -> a -> a
<> Builder
" " | (V2 ℝ
x ℝ
y) <- [V2 ℝ]
line]

      -- Instead of setting styles on every polyline, we wrap the lines in a group element and set the styles on it:
      thinBlueGroup :: Svg -> Svg
thinBlueGroup = Svg -> Svg
g forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.stroke AttributeValue
"rgb(0,0,255)" forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.strokeWidth (String -> AttributeValue
stringValue forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show ℝ
strokeWidth) forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.fill AttributeValue
"none" -- obj

-- | DXF2 export in 2D. conforming to AutoCAD R12/13.
dxf2 :: [Polyline] -> Text
dxf2 :: [Polyline] -> Text
dxf2 [Polyline]
plines = Builder -> Text
toLazyText forall a b. (a -> b) -> a -> b
$ Builder
dxf2Header forall a. Semigroup a => a -> a -> a
<> Builder
dxf2Tables forall a. Semigroup a => a -> a -> a
<> Builder
dxf2Blocks forall a. Semigroup a => a -> a -> a
<> Builder
dxf2Entities
     where
      dxf2Header :: Builder
      dxf2Header :: Builder
dxf2Header =
        Builder
"  0\n" forall a. Semigroup a => a -> a -> a
<> Builder
"SECTION\n" forall a. Semigroup a => a -> a -> a
<>
        Builder
"  2\n" forall a. Semigroup a => a -> a -> a
<> Builder
"HEADER\n" forall a. Semigroup a => a -> a -> a
<>
        Builder
"  9\n" forall a. Semigroup a => a -> a -> a
<> Builder
"$ACADVER\n" forall a. Semigroup a => a -> a -> a
<>
        Builder
"  1\n" forall a. Semigroup a => a -> a -> a
<> Builder
"AC1009\n" forall a. Semigroup a => a -> a -> a
<>
        Builder
"  9\n" forall a. Semigroup a => a -> a -> a
<> Builder
"$LIMMIN\n" forall a. Semigroup a => a -> a -> a
<>
        Builder
" 10\n" forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
buildTruncFloat ℝ
dxfxmin forall a. Semigroup a => a -> a -> a
<> Builder
"\n" forall a. Semigroup a => a -> a -> a
<>
        Builder
" 20\n" forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
buildTruncFloat ℝ
dxfymin forall a. Semigroup a => a -> a -> a
<> Builder
"\n" forall a. Semigroup a => a -> a -> a
<>
        Builder
"  9\n" forall a. Semigroup a => a -> a -> a
<> Builder
"$LIMMAX\n" forall a. Semigroup a => a -> a -> a
<>
        Builder
" 10\n" forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
buildTruncFloat ℝ
dxfxmax forall a. Semigroup a => a -> a -> a
<> Builder
"\n" forall a. Semigroup a => a -> a -> a
<>
        Builder
" 20\n" forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
buildTruncFloat ℝ
dxfymax forall a. Semigroup a => a -> a -> a
<> Builder
"\n" forall a. Semigroup a => a -> a -> a
<>
        Builder
"  9\n" forall a. Semigroup a => a -> a -> a
<> Builder
"$LUPREC\n" forall a. Semigroup a => a -> a -> a
<>
        Builder
" 70\n" forall a. Semigroup a => a -> a -> a
<> Builder
"4\n" forall a. Semigroup a => a -> a -> a
<>
        Builder
"  0\n" forall a. Semigroup a => a -> a -> a
<> Builder
"ENDSEC\n"
      dxf2Tables :: Builder
      dxf2Tables :: Builder
dxf2Tables =
        Builder
"  0\n" forall a. Semigroup a => a -> a -> a
<> Builder
"SECTION\n" forall a. Semigroup a => a -> a -> a
<>
        Builder
"  2\n" forall a. Semigroup a => a -> a -> a
<> Builder
"TABLES\n" forall a. Semigroup a => a -> a -> a
<>
        Builder
"  0\n" forall a. Semigroup a => a -> a -> a
<> Builder
"ENDSEC\n"
      dxf2Blocks :: Builder
      dxf2Blocks :: Builder
dxf2Blocks =
        Builder
"  0\n" forall a. Semigroup a => a -> a -> a
<> Builder
"SECTION\n" forall a. Semigroup a => a -> a -> a
<>
        Builder
"  2\n" forall a. Semigroup a => a -> a -> a
<> Builder
"BLOCKS\n" forall a. Semigroup a => a -> a -> a
<>
        Builder
"  0\n" forall a. Semigroup a => a -> a -> a
<> Builder
"ENDSEC\n"
      dxf2Entities :: Builder
      dxf2Entities :: Builder
dxf2Entities =
        Builder
"  0\n" forall a. Semigroup a => a -> a -> a
<> Builder
"SECTION\n" forall a. Semigroup a => a -> a -> a
<>
        Builder
"  2\n" forall a. Semigroup a => a -> a -> a
<> Builder
"ENTITIES\n" forall a. Semigroup a => a -> a -> a
<>
        forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Polyline -> Builder
buildPolyline ([Polyline] -> [Polyline]
orderPolylines [Polyline]
plines) forall a. Semigroup a => a -> a -> a
<>
        Builder
"  0\n" forall a. Semigroup a => a -> a -> a
<> Builder
"ENDSEC\n"
      buildPolyline :: Polyline -> Builder
      buildPolyline :: Polyline -> Builder
buildPolyline (Polyline [V2 ℝ]
singlePolyline) =
        Builder
"  0\n" forall a. Semigroup a => a -> a -> a
<> Builder
"POLYLINE\n" forall a. Semigroup a => a -> a -> a
<>
        Builder
"  8\n" forall a. Semigroup a => a -> a -> a
<> Builder
"0\n" forall a. Semigroup a => a -> a -> a
<>
        Builder
"  6\n" forall a. Semigroup a => a -> a -> a
<> Builder
"CONTINUOUS\n" forall a. Semigroup a => a -> a -> a
<>
        Builder
" 66\n" forall a. Semigroup a => a -> a -> a
<> Builder
"1\n" forall a. Semigroup a => a -> a -> a
<>
        Builder
" 62\n" forall a. Semigroup a => a -> a -> a
<> Int -> Builder
buildInt (forall (t :: * -> *) a. Foldable t => t a -> Int
length [V2 ℝ]
singlePolyline) forall a. Semigroup a => a -> a -> a
<> Builder
"\n" forall a. Semigroup a => a -> a -> a
<>
        Builder
" 10\n" forall a. Semigroup a => a -> a -> a
<> Builder
"0.0\n" forall a. Semigroup a => a -> a -> a
<>
        Builder
" 20\n" forall a. Semigroup a => a -> a -> a
<> Builder
"0.0\n" forall a. Semigroup a => a -> a -> a
<>
        Builder
" 30\n" forall a. Semigroup a => a -> a -> a
<> Builder
"0.0000\n" forall a. Semigroup a => a -> a -> a
<>
        forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap V2 ℝ -> Builder
buildVertex [V2 ℝ]
singlePolyline forall a. Semigroup a => a -> a -> a
<>
        Builder
"  0\n" forall a. Semigroup a => a -> a -> a
<> Builder
"SEQEND\n"
      buildVertex :: ℝ2 -> Builder
      buildVertex :: V2 ℝ -> Builder
buildVertex (V2 ℝ
x1 ℝ
y1) =
        Builder
"  0\n" forall a. Semigroup a => a -> a -> a
<>Builder
"VERTEX\n" forall a. Semigroup a => a -> a -> a
<>
        Builder
"  8\n" forall a. Semigroup a => a -> a -> a
<>Builder
"0\n" forall a. Semigroup a => a -> a -> a
<>
        Builder
"  10\n" forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
buildTruncFloat ℝ
x1 forall a. Semigroup a => a -> a -> a
<> Builder
"\n" forall a. Semigroup a => a -> a -> a
<>
        Builder
"  20\n" forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
buildTruncFloat ℝ
y1 forall a. Semigroup a => a -> a -> a
<> Builder
"\n"
      (ℝ
dxfxmin, ℝ
dxfxmax, ℝ
dxfymin, ℝ
dxfymax) = (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [ℝ]
xs, forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [ℝ]
xs, forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [ℝ]
ys, forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [ℝ]
ys)
      ([ℝ]
xs, [ℝ]
ys) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a. V2 a -> (a, a)
unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Polyline -> [V2 ℝ]
pair [Polyline]
plines
      pair :: Polyline -> [ℝ2]
      pair :: Polyline -> [V2 ℝ]
pair (Polyline [V2 ℝ]
x) = [V2 ℝ]
x

orderPolylines :: [Polyline] -> [Polyline]
orderPolylines :: [Polyline] -> [Polyline]
orderPolylines =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\(ℝ
a,Polyline
_) (ℝ
b, Polyline
_) -> forall a. Ord a => a -> a -> Ordering
compare ℝ
a ℝ
b) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Polyline
x -> (Polyline -> ℝ
polylineRadius Polyline
x, Polyline
x))
  where
    polylineRadius :: Polyline -> ℝ
    polylineRadius :: Polyline -> ℝ
polylineRadius Polyline
polyline' = forall a. Ord a => a -> a -> a
max (ℝ
xmax' forall a. Num a => a -> a -> a
- ℝ
xmin') (ℝ
ymax' forall a. Num a => a -> a -> a
- ℝ
ymin')
      where
        (V2 ℝ
xmin'  ℝ
xmax', V2 ℝ
ymin' ℝ
ymax') = [Polyline] -> (V2 ℝ, V2 ℝ)
polylineRadius' [Polyline
polyline']
        polylineRadius' :: [Polyline] -> (ℝ2, ℝ2)
        polylineRadius' :: [Polyline] -> (V2 ℝ, V2 ℝ)
polylineRadius' [Polyline]
lines = ([ℝ] -> V2 ℝ
maxMinList [ℝ]
xs,[ℝ] -> V2 ℝ
maxMinList [ℝ]
ys)
          where
            ([ℝ]
xs,[ℝ]
ys) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a. V2 a -> (a, a)
unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Polyline -> [V2 ℝ]
pair [Polyline]
lines
            pair :: Polyline -> [V2 ℝ]
pair (Polyline [V2 ℝ]
a) = [V2 ℝ]
a
            maxMinList :: [ℝ] -> ℝ2
            maxMinList :: [ℝ] -> V2 ℝ
maxMinList (ℝ
x:[ℝ]
others) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\(V2 ℝ
l ℝ
h) ℝ
y -> forall a. a -> a -> V2 a
V2 (forall a. Ord a => a -> a -> a
min ℝ
l ℝ
y) (forall a. Ord a => a -> a -> a
max ℝ
h ℝ
y)) (forall a. a -> a -> V2 a
V2 ℝ
x ℝ
x) [ℝ]
others
            maxMinList [] = forall a. a -> a -> V2 a
V2 ℝ
0 ℝ
0

unpack :: V2 a -> (a, a)
unpack :: forall a. V2 a -> (a, a)
unpack (V2 a
x a
y) = (a
x, a
y)

-- | Gcode generation for the laser cutter in HackLab. Complies with https://ws680.nist.gov/publication/get_pdf.cfm?pub_id=823374
--   FIXME: parameters would be nice.
hacklabLaserGCode :: [Polyline] -> Text
hacklabLaserGCode :: [Polyline] -> Text
hacklabLaserGCode [Polyline]
polylines = Builder -> Text
toLazyText forall a b. (a -> b) -> a -> b
$ Builder
gcodeHeader forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Polyline -> Builder
interpretPolyline ([Polyline] -> [Polyline]
orderPolylines [Polyline]
polylines) forall a. Semigroup a => a -> a -> a
<> Builder
gcodeFooter
    where
      gcodeHeader :: Builder
      gcodeHeader :: Builder
gcodeHeader = Builder
"(generated by ImplicitCAD, based of hacklab wiki example)\n"
                    forall a. Semigroup a => a -> a -> a
<> Builder
"M63 P0 (laser off)\n"
                    forall a. Semigroup a => a -> a -> a
<> Builder
"G0 Z0.002 (laser off)\n"
                    forall a. Semigroup a => a -> a -> a
<> Builder
"G21 (units=mm)\n"
                    forall a. Semigroup a => a -> a -> a
<> Builder
"F400 (set feedrate)\n"
                    forall a. Semigroup a => a -> a -> a
<> Builder
"M3 S1 (enable laser)\n\n"
      gcodeFooter :: Builder
      gcodeFooter :: Builder
gcodeFooter = Builder
"M5 (disable laser)\n"
                    forall a. Semigroup a => a -> a -> a
<> Builder
"G00 X0.0 Y0.0 (move to 0)\n"
                    forall a. Semigroup a => a -> a -> a
<> Builder
"M2 (end)"
      gcodeXY :: ℝ2 -> Builder
      gcodeXY :: V2 ℝ -> Builder
gcodeXY (V2 ℝ
x ℝ
y) = Builder
"X" forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
buildTruncFloat ℝ
x forall a. Semigroup a => a -> a -> a
<> Builder
" Y" forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
buildTruncFloat ℝ
y
      interpretPolyline :: Polyline -> Builder
      interpretPolyline :: Polyline -> Builder
interpretPolyline (Polyline (V2 ℝ
start:[V2 ℝ]
others)) =
        Builder
"G00 " forall a. Semigroup a => a -> a -> a
<> V2 ℝ -> Builder
gcodeXY V2 ℝ
start
        forall a. Semigroup a => a -> a -> a
<> Builder
"\nM62 P0 (laser on)\n"
        forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [ Builder
"G01 " forall a. Semigroup a => a -> a -> a
<> V2 ℝ -> Builder
gcodeXY V2 ℝ
point forall a. Semigroup a => a -> a -> a
<> Builder
"\n" | V2 ℝ
point <- [V2 ℝ]
others]
        forall a. Semigroup a => a -> a -> a
<> Builder
"M63 P0 (laser off)\n\n"
      interpretPolyline (Polyline []) = forall a. Monoid a => a
mempty