{- 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 = Markup -> Text
renderSvg (Markup -> Text) -> ([Polyline] -> Markup) -> [Polyline] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Markup -> Markup
svg11 (Markup -> Markup)
-> ([Polyline] -> Markup) -> [Polyline] -> Markup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Polyline] -> Markup
svg' ([Polyline] -> Text) -> [Polyline] -> Text
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
$ V2 ℝ -> (ℝ, ℝ)
forall a. V2 a -> (a, a)
unpack (V2 ℝ -> (ℝ, ℝ)) -> [V2 ℝ] -> [(ℝ, ℝ)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Polyline -> [V2 ℝ]) -> [Polyline] -> [V2 ℝ]
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 :: Markup -> Markup
svg11 = Markup -> Markup
docTypeSvg (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.version AttributeValue
"1.1"
                         (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.width  (String -> AttributeValue
stringValue (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ ℝ -> String
forall a. Show a => a -> String
show (ℝ
xmaxℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
-ℝ
xmin) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"mm")
                         (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.height (String -> AttributeValue
stringValue (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ ℝ -> String
forall a. Show a => a -> String
show (ℝ
ymaxℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
-ℝ
ymin) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"mm")
                         (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.viewbox (String -> AttributeValue
stringValue (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ℝ -> String
forall a. Show a => a -> String
show (ℝ -> String) -> [ℝ] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ℝ
0,ℝ
0,ℝ
xmaxℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
-ℝ
xmin,ℝ
ymaxℝ -> ℝ -> ℝ
forall 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] -> Markup
svg' [] = Markup
forall a. Monoid a => a
mempty
      -- When we have a known point, we can compute said transformation:
      svg' [Polyline]
polylines = Markup -> Markup
thinBlueGroup (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ (Polyline -> Markup) -> [Polyline] -> Markup
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Polyline -> Markup
poly [Polyline]
polylines

      poly :: Polyline -> Markup
poly (Polyline [V2 ℝ]
line) = Markup
polyline Markup -> Attribute -> Markup
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.points AttributeValue
pointList
          where pointList :: AttributeValue
pointList = Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (Text -> AttributeValue) -> Text -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Builder -> Text
toLazyText (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [ℝ -> Builder
bf (ℝ
xℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
-ℝ
xmin) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"," Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
bf (ℝ
ymax ℝ -> ℝ -> ℝ
forall a. Num a => a -> a -> a
- ℝ
y) Builder -> Builder -> Builder
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 :: Markup -> Markup
thinBlueGroup = Markup -> Markup
g (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.stroke AttributeValue
"rgb(0,0,255)" (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.strokeWidth (String -> AttributeValue
stringValue (String -> AttributeValue) -> String -> AttributeValue
forall a b. (a -> b) -> a -> b
$ ℝ -> String
forall a. Show a => a -> String
show ℝ
strokeWidth) (Markup -> Markup) -> Attribute -> Markup -> Markup
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 (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ Builder
dxf2Header Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
dxf2Tables Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
dxf2Blocks Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
dxf2Entities
     where
      dxf2Header :: Builder
      dxf2Header :: Builder
dxf2Header =
        Builder
"  0\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"SECTION\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
"  2\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"HEADER\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
"  9\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"$ACADVER\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
"  1\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"AC1009\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
"  9\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"$LIMMIN\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
" 10\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
buildTruncFloat ℝ
dxfxmin Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
" 20\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
buildTruncFloat ℝ
dxfymin Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
"  9\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"$LIMMAX\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
" 10\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
buildTruncFloat ℝ
dxfxmax Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
" 20\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
buildTruncFloat ℝ
dxfymax Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
"  9\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"$LUPREC\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
" 70\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"4\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
"  0\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"ENDSEC\n"
      dxf2Tables :: Builder
      dxf2Tables :: Builder
dxf2Tables =
        Builder
"  0\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"SECTION\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
"  2\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"TABLES\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
"  0\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"ENDSEC\n"
      dxf2Blocks :: Builder
      dxf2Blocks :: Builder
dxf2Blocks =
        Builder
"  0\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"SECTION\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
"  2\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"BLOCKS\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
"  0\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"ENDSEC\n"
      dxf2Entities :: Builder
      dxf2Entities :: Builder
dxf2Entities =
        Builder
"  0\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"SECTION\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
"  2\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"ENTITIES\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        (Polyline -> Builder) -> [Polyline] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Polyline -> Builder
buildPolyline ([Polyline] -> [Polyline]
orderPolylines [Polyline]
plines) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
"  0\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"ENDSEC\n"
      buildPolyline :: Polyline -> Builder
      buildPolyline :: Polyline -> Builder
buildPolyline (Polyline [V2 ℝ]
singlePolyline) =
        Builder
"  0\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"POLYLINE\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
"  8\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"0\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
"  6\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"CONTINUOUS\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
" 66\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"1\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
" 62\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
buildInt ([V2 ℝ] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [V2 ℝ]
singlePolyline) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
" 10\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"0.0\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
" 20\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"0.0\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
" 30\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"0.0000\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        (V2 ℝ -> Builder) -> [V2 ℝ] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap V2 ℝ -> Builder
buildVertex [V2 ℝ]
singlePolyline Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
"  0\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"SEQEND\n"
      buildVertex :: ℝ2 -> Builder
      buildVertex :: V2 ℝ -> Builder
buildVertex (V2 ℝ
x1 ℝ
y1) =
        Builder
"  0\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>Builder
"VERTEX\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
"  8\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>Builder
"0\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
"  10\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
buildTruncFloat ℝ
x1 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
"  20\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
buildTruncFloat ℝ
y1 Builder -> Builder -> Builder
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
$ V2 ℝ -> (ℝ, ℝ)
forall a. V2 a -> (a, a)
unpack (V2 ℝ -> (ℝ, ℝ)) -> [V2 ℝ] -> [(ℝ, ℝ)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Polyline -> [V2 ℝ]) -> [Polyline] -> [V2 ℝ]
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 =
  ((ℝ, Polyline) -> Polyline) -> [(ℝ, Polyline)] -> [Polyline]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ℝ, Polyline) -> Polyline
forall a b. (a, b) -> b
snd ([(ℝ, Polyline)] -> [Polyline])
-> ([Polyline] -> [(ℝ, Polyline)]) -> [Polyline] -> [Polyline]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ℝ, Polyline) -> (ℝ, Polyline) -> Ordering)
-> [(ℝ, Polyline)] -> [(ℝ, Polyline)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\(ℝ
a,Polyline
_) (ℝ
b, Polyline
_) -> ℝ -> ℝ -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ℝ
a ℝ
b) ([(ℝ, Polyline)] -> [(ℝ, Polyline)])
-> ([Polyline] -> [(ℝ, Polyline)]) -> [Polyline] -> [(ℝ, Polyline)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Polyline -> (ℝ, Polyline)) -> [Polyline] -> [(ℝ, Polyline)]
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
$ V2 ℝ -> (ℝ, ℝ)
forall a. V2 a -> (a, a)
unpack (V2 ℝ -> (ℝ, ℝ)) -> [V2 ℝ] -> [(ℝ, ℝ)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Polyline -> [V2 ℝ]) -> [Polyline] -> [V2 ℝ]
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) = (V2 ℝ -> ℝ -> V2 ℝ) -> V2 ℝ -> [ℝ] -> V2 ℝ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\(V2 ℝ
l ℝ
h) ℝ
y -> ℝ -> ℝ -> V2 ℝ
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)) (ℝ -> ℝ -> V2 ℝ
forall a. a -> a -> V2 a
V2 ℝ
x ℝ
x) [ℝ]
others
            maxMinList [] = ℝ -> ℝ -> V2 ℝ
forall a. a -> a -> V2 a
V2 ℝ
0 ℝ
0

unpack :: V2 a -> (a, a)
unpack :: 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 (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ Builder
gcodeHeader Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Polyline -> Builder) -> [Polyline] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Polyline -> Builder
interpretPolyline ([Polyline] -> [Polyline]
orderPolylines [Polyline]
polylines) Builder -> Builder -> Builder
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"
                    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"M63 P0 (laser off)\n"
                    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"G0 Z0.002 (laser off)\n"
                    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"G21 (units=mm)\n"
                    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"F400 (set feedrate)\n"
                    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"M3 S1 (enable laser)\n\n"
      gcodeFooter :: Builder
      gcodeFooter :: Builder
gcodeFooter = Builder
"M5 (disable laser)\n"
                    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"G00 X0.0 Y0.0 (move to 0)\n"
                    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"M2 (end)"
      gcodeXY :: ℝ2 -> Builder
      gcodeXY :: V2 ℝ -> Builder
gcodeXY (V2 ℝ
x ℝ
y) = Builder
"X" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
buildTruncFloat ℝ
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" Y" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ℝ -> Builder
buildTruncFloat ℝ
y
      interpretPolyline :: Polyline -> Builder
      interpretPolyline :: Polyline -> Builder
interpretPolyline (Polyline (V2 ℝ
start:[V2 ℝ]
others)) =
        Builder
"G00 " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> V2 ℝ -> Builder
gcodeXY V2 ℝ
start
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\nM62 P0 (laser on)\n"
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Builder] -> Builder
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [ Builder
"G01 " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> V2 ℝ -> Builder
gcodeXY V2 ℝ
point Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\n" | V2 ℝ
point <- [V2 ℝ]
others]
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"M63 P0 (laser off)\n\n"
      interpretPolyline (Polyline []) = Builder
forall a. Monoid a => a
mempty