{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}

-- | Functions to generate GCode, suitable for being run on a penplotter.
--
-- <<docs/haddock/Draw/Plotting/example.svg>>
--
-- === __(image code)__
-- >>> :{
-- D.haddockRender "Draw/Plotting/example.svg" 300 200 $ \_ -> do
--     let haskellLogo' = transform mirrorYCoords haskellLogo
--         geometry = transform (transformBoundingBox haskellLogo' (shrinkBoundingBox 10 [zero, Vec2 300 200]) def) haskellLogo'
--         plotSettings = def { _canvasBoundingBox = Just (boundingBox [zero, Vec2 300 200]) }
--         plotResult = runPlot def $ do
--             for_ geometry $ \logoPart -> plot logoPart
--     _plotPreview plotResult
-- :}
-- Generated file: size 10KB, crc32: 0x1e175925
module Draw.Plotting (
    -- * 'Plot' type
      Plot()
    , runPlot
    , GCode()
    , writeGCodeFile
    , renderPreview
    , RunPlotResult(..)
    , PlottingSettings(..)
    , FinishMove(..)

    -- ** Raw GCode handling
    , TinkeringInternals(..)
    , PlottingWriterLog(..)
    , PlottingState(..)
    , renderGCode

    -- * 'Plotting' shapes
    , Plotting(..)

    -- * Plotting primitives
    , repositionTo
    , lineTo
    , clockwiseArcAroundTo
    , counterclockwiseArcAroundTo
    , previewCanvas
    , pause
    , PauseMode(..)
    , withFeedrate
    , withDrawingHeight
    , drawingDistance

    -- ** File structure
    , block
    , comment

    -- * Raw G-Code
    , penDown
    , penUp
    , gCode

    -- * Utilities
    , minimizePenHovering
    , minimizePenHoveringBy
    , MinimizePenHoveringSettings(..)
    , module Data.Default.Class
) where



import           Control.Monad.RWS        hiding (modify)
import           Data.Default.Class
import           Data.DList               (DList)
import qualified Data.DList               as DL
import           Data.Foldable
import           Data.Maybe
import qualified Data.Set                 as S
import           Data.Text.Lazy           (Text)
import qualified Data.Text.Lazy.IO        as TL
import           Data.Vector              (Vector)
import qualified Data.Vector              as V
import           Formatting               hiding (center)
import qualified Graphics.Rendering.Cairo as C hiding (x, y)

import qualified Draw                as D
import           Draw.Plotting.GCode
import           Geometry.Bezier
import           Geometry.Core
import           Geometry.Shapes



-- | 'Plot' represents penplotting directives, and is manipulated using functions
-- such as 'plot' and 'gCode'.
newtype Plot a = Plot (RWS PlottingSettings PlottingWriterLog PlottingState a)
    deriving ((forall a b. (a -> b) -> Plot a -> Plot b)
-> (forall a b. a -> Plot b -> Plot a) -> Functor Plot
forall a b. a -> Plot b -> Plot a
forall a b. (a -> b) -> Plot a -> Plot b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Plot a -> Plot b
fmap :: forall a b. (a -> b) -> Plot a -> Plot b
$c<$ :: forall a b. a -> Plot b -> Plot a
<$ :: forall a b. a -> Plot b -> Plot a
Functor, Functor Plot
Functor Plot
-> (forall a. a -> Plot a)
-> (forall a b. Plot (a -> b) -> Plot a -> Plot b)
-> (forall a b c. (a -> b -> c) -> Plot a -> Plot b -> Plot c)
-> (forall a b. Plot a -> Plot b -> Plot b)
-> (forall a b. Plot a -> Plot b -> Plot a)
-> Applicative Plot
forall a. a -> Plot a
forall a b. Plot a -> Plot b -> Plot a
forall a b. Plot a -> Plot b -> Plot b
forall a b. Plot (a -> b) -> Plot a -> Plot b
forall a b c. (a -> b -> c) -> Plot a -> Plot b -> Plot c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Plot a
pure :: forall a. a -> Plot a
$c<*> :: forall a b. Plot (a -> b) -> Plot a -> Plot b
<*> :: forall a b. Plot (a -> b) -> Plot a -> Plot b
$cliftA2 :: forall a b c. (a -> b -> c) -> Plot a -> Plot b -> Plot c
liftA2 :: forall a b c. (a -> b -> c) -> Plot a -> Plot b -> Plot c
$c*> :: forall a b. Plot a -> Plot b -> Plot b
*> :: forall a b. Plot a -> Plot b -> Plot b
$c<* :: forall a b. Plot a -> Plot b -> Plot a
<* :: forall a b. Plot a -> Plot b -> Plot a
Applicative, Applicative Plot
Applicative Plot
-> (forall a b. Plot a -> (a -> Plot b) -> Plot b)
-> (forall a b. Plot a -> Plot b -> Plot b)
-> (forall a. a -> Plot a)
-> Monad Plot
forall a. a -> Plot a
forall a b. Plot a -> Plot b -> Plot b
forall a b. Plot a -> (a -> Plot b) -> Plot b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. Plot a -> (a -> Plot b) -> Plot b
>>= :: forall a b. Plot a -> (a -> Plot b) -> Plot b
$c>> :: forall a b. Plot a -> Plot b -> Plot b
>> :: forall a b. Plot a -> Plot b -> Plot b
$creturn :: forall a. a -> Plot a
return :: forall a. a -> Plot a
Monad, MonadReader PlottingSettings, MonadState PlottingState)

data PlottingWriterLog = PlottingWriterLog
    { PlottingWriterLog -> DList GCode
_plottedGCode :: DList GCode
    , PlottingWriterLog -> Double
_penTravelDistance :: !Double
    , PlottingWriterLog -> Int
_elementsDrawn :: !Int
    , PlottingWriterLog -> Render ()
_plottingCairoPreview :: C.Render ()
    }

instance Semigroup PlottingWriterLog where
    PlottingWriterLog DList GCode
code1 Double
travel1 Int
numDrawn1 Render ()
render1 <> :: PlottingWriterLog -> PlottingWriterLog -> PlottingWriterLog
<> PlottingWriterLog DList GCode
code2 Double
travel2 Int
numDrawn2 Render ()
render2
      = DList GCode -> Double -> Int -> Render () -> PlottingWriterLog
PlottingWriterLog (DList GCode
code1 DList GCode -> DList GCode -> DList GCode
forall a. Semigroup a => a -> a -> a
<> DList GCode
code2) (Double
travel1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
travel2) (Int
numDrawn1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
numDrawn2) (Render ()
render1 Render () -> Render () -> Render ()
forall a b. Render a -> Render b -> Render b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Render ()
render2)

instance Monoid PlottingWriterLog where
    mempty :: PlottingWriterLog
mempty = DList GCode -> Double -> Int -> Render () -> PlottingWriterLog
PlottingWriterLog DList GCode
forall a. Monoid a => a
mempty Double
0 Int
0 (() -> Render ()
forall a. a -> Render a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

{-# WARNING modify "Use modify'. There’s no reason to lazily update the state." #-}
modify, _don'tReportModifyAsUnused :: a
modify :: forall a. a
modify = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Use modify'. There’s no reason to lazily update the state."
_don'tReportModifyAsUnused :: forall a. a
_don'tReportModifyAsUnused = a
forall a. a
modify

data PlottingState = PlottingState
    { PlottingState -> PenState
_penState :: !PenState
    , PlottingState -> Vec2
_penXY :: !Vec2
    , PlottingState -> Double
_drawingDistance :: !Double
    , PlottingState -> BoundingBox
_drawnBoundingBox :: !BoundingBox
    } deriving (PlottingState -> PlottingState -> Bool
(PlottingState -> PlottingState -> Bool)
-> (PlottingState -> PlottingState -> Bool) -> Eq PlottingState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PlottingState -> PlottingState -> Bool
== :: PlottingState -> PlottingState -> Bool
$c/= :: PlottingState -> PlottingState -> Bool
/= :: PlottingState -> PlottingState -> Bool
Eq, Eq PlottingState
Eq PlottingState
-> (PlottingState -> PlottingState -> Ordering)
-> (PlottingState -> PlottingState -> Bool)
-> (PlottingState -> PlottingState -> Bool)
-> (PlottingState -> PlottingState -> Bool)
-> (PlottingState -> PlottingState -> Bool)
-> (PlottingState -> PlottingState -> PlottingState)
-> (PlottingState -> PlottingState -> PlottingState)
-> Ord PlottingState
PlottingState -> PlottingState -> Bool
PlottingState -> PlottingState -> Ordering
PlottingState -> PlottingState -> PlottingState
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: PlottingState -> PlottingState -> Ordering
compare :: PlottingState -> PlottingState -> Ordering
$c< :: PlottingState -> PlottingState -> Bool
< :: PlottingState -> PlottingState -> Bool
$c<= :: PlottingState -> PlottingState -> Bool
<= :: PlottingState -> PlottingState -> Bool
$c> :: PlottingState -> PlottingState -> Bool
> :: PlottingState -> PlottingState -> Bool
$c>= :: PlottingState -> PlottingState -> Bool
>= :: PlottingState -> PlottingState -> Bool
$cmax :: PlottingState -> PlottingState -> PlottingState
max :: PlottingState -> PlottingState -> PlottingState
$cmin :: PlottingState -> PlottingState -> PlottingState
min :: PlottingState -> PlottingState -> PlottingState
Ord, Int -> PlottingState -> ShowS
[PlottingState] -> ShowS
PlottingState -> [Char]
(Int -> PlottingState -> ShowS)
-> (PlottingState -> [Char])
-> ([PlottingState] -> ShowS)
-> Show PlottingState
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PlottingState -> ShowS
showsPrec :: Int -> PlottingState -> ShowS
$cshow :: PlottingState -> [Char]
show :: PlottingState -> [Char]
$cshowList :: [PlottingState] -> ShowS
showList :: [PlottingState] -> ShowS
Show)

data PenState = PenDown | PenUp deriving (PenState -> PenState -> Bool
(PenState -> PenState -> Bool)
-> (PenState -> PenState -> Bool) -> Eq PenState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PenState -> PenState -> Bool
== :: PenState -> PenState -> Bool
$c/= :: PenState -> PenState -> Bool
/= :: PenState -> PenState -> Bool
Eq, Eq PenState
Eq PenState
-> (PenState -> PenState -> Ordering)
-> (PenState -> PenState -> Bool)
-> (PenState -> PenState -> Bool)
-> (PenState -> PenState -> Bool)
-> (PenState -> PenState -> Bool)
-> (PenState -> PenState -> PenState)
-> (PenState -> PenState -> PenState)
-> Ord PenState
PenState -> PenState -> Bool
PenState -> PenState -> Ordering
PenState -> PenState -> PenState
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: PenState -> PenState -> Ordering
compare :: PenState -> PenState -> Ordering
$c< :: PenState -> PenState -> Bool
< :: PenState -> PenState -> Bool
$c<= :: PenState -> PenState -> Bool
<= :: PenState -> PenState -> Bool
$c> :: PenState -> PenState -> Bool
> :: PenState -> PenState -> Bool
$c>= :: PenState -> PenState -> Bool
>= :: PenState -> PenState -> Bool
$cmax :: PenState -> PenState -> PenState
max :: PenState -> PenState -> PenState
$cmin :: PenState -> PenState -> PenState
min :: PenState -> PenState -> PenState
Ord, Int -> PenState -> ShowS
[PenState] -> ShowS
PenState -> [Char]
(Int -> PenState -> ShowS)
-> (PenState -> [Char]) -> ([PenState] -> ShowS) -> Show PenState
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PenState -> ShowS
showsPrec :: Int -> PenState -> ShowS
$cshow :: PenState -> [Char]
show :: PenState -> [Char]
$cshowList :: [PenState] -> ShowS
showList :: [PenState] -> ShowS
Show)

data PlottingSettings = PlottingSettings
    { PlottingSettings -> Double
_feedrate :: Double
    -- ^ Initial feedrate. Can be modified locally with 'withFeedrate'. ('def'ault: 1000)

    , PlottingSettings -> Double
_zTravelHeight :: Double
    -- ^ During travel motion, keep the pen at this height (in absolute
    -- coordinates). ('def'ault: 1)

    , PlottingSettings -> Double
_zDrawingHeight :: Double
    -- ^ When drawing, keep the pen at this height (in absolute coordinates).
    -- ('def'ault: -1)

    , PlottingSettings -> Maybe Double
_zLoweringFeedrate :: Maybe Double
    -- ^ Use this feedrate for lowering the pen. On fast machines, lowering it
    -- at max speed might lead to unwanted vibrations. 'Nothing' means as fast
    -- as possible. ('def'ault: 'Nothing')

    , PlottingSettings -> Maybe FinishMove
_finishMove :: Maybe FinishMove
    -- ^ Do a final move after the drawing has ended. ('def'ault: 'Nothing')

    , PlottingSettings -> Bool
_previewDrawnShapesBoundingBox :: Bool
    -- ^ At the beginning of the plot, trace the bounding box of all the GCode
    -- before actually drawing? Useful as a final check. ('def'ault: 'True')

    , PlottingSettings -> Maybe BoundingBox
_canvasBoundingBox :: Maybe BoundingBox
    -- ^ The canvas we’re painting on. Useful to check whether the pen leaves
    -- the drawing area. ('def'ault: 'Nothing')
    --
    -- <<docs/haddock/Draw/Plotting/leaving_the_canvas.svg>>
    --
    -- === __(image code)__
    -- >>> paper = boundingBox [zero, Vec2 300 200]
    -- >>> haskellLogo' = transform mirrorYCoords haskellLogo
    -- >>> geometry = transform (rotateAround (boundingBoxCenter paper) (deg 40) <> transformBoundingBox haskellLogo' (shrinkBoundingBox 10 paper) def) haskellLogo'
    -- >>> plotSettings = def { _canvasBoundingBox = Just paper }
    -- >>> plotResult = runPlot plotSettings (for_ geometry plot)
    -- >>> renderPreview "docs/haddock/Draw/Plotting/leaving_the_canvas.svg" 1 plotResult

    , PlottingSettings -> Double
_previewPenWidth :: Double
    -- ^ Use this line width in the preview. To get a realistic preview, match
    -- this value with the actual stroke width of your pen. ('def'ault: 1)

    , PlottingSettings -> Color Double
_previewPenColor :: D.Color Double
    -- ^ Use this color for drawings in the preview. To get a realistic preview,
    -- match this value with the actual color of your pen.
    -- ('def'ault: @'mma' 1@)

    , PlottingSettings -> Maybe (Color Double)
_previewPenTravelColor :: Maybe (D.Color Double)
    -- ^ Use this color for indicating pen travel in the preview. 'Nothing'
    -- will disable pen travel preview. ('def'ault: @'Just' ('mma' 0)@)

    , PlottingSettings -> Bool
_previewDecorate :: Bool
    -- ^ Show additional decoration in the preview, like origin and bounding box.
    -- ('def'ault: 'True')
    } deriving (PlottingSettings -> PlottingSettings -> Bool
(PlottingSettings -> PlottingSettings -> Bool)
-> (PlottingSettings -> PlottingSettings -> Bool)
-> Eq PlottingSettings
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PlottingSettings -> PlottingSettings -> Bool
== :: PlottingSettings -> PlottingSettings -> Bool
$c/= :: PlottingSettings -> PlottingSettings -> Bool
/= :: PlottingSettings -> PlottingSettings -> Bool
Eq, Int -> PlottingSettings -> ShowS
[PlottingSettings] -> ShowS
PlottingSettings -> [Char]
(Int -> PlottingSettings -> ShowS)
-> (PlottingSettings -> [Char])
-> ([PlottingSettings] -> ShowS)
-> Show PlottingSettings
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PlottingSettings -> ShowS
showsPrec :: Int -> PlottingSettings -> ShowS
$cshow :: PlottingSettings -> [Char]
show :: PlottingSettings -> [Char]
$cshowList :: [PlottingSettings] -> ShowS
showList :: [PlottingSettings] -> ShowS
Show)

-- | Command to issue after all drawing is finished
data FinishMove
    = FinishWithG28  -- ^ G28: go to predefined position
    | FinishWithG30  -- ^ G30: go to predefined position
    | FinishTopRight -- ^ Move to the top right of the union of drawn and canvas 'BoundingBox'.
    deriving (FinishMove -> FinishMove -> Bool
(FinishMove -> FinishMove -> Bool)
-> (FinishMove -> FinishMove -> Bool) -> Eq FinishMove
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FinishMove -> FinishMove -> Bool
== :: FinishMove -> FinishMove -> Bool
$c/= :: FinishMove -> FinishMove -> Bool
/= :: FinishMove -> FinishMove -> Bool
Eq, Eq FinishMove
Eq FinishMove
-> (FinishMove -> FinishMove -> Ordering)
-> (FinishMove -> FinishMove -> Bool)
-> (FinishMove -> FinishMove -> Bool)
-> (FinishMove -> FinishMove -> Bool)
-> (FinishMove -> FinishMove -> Bool)
-> (FinishMove -> FinishMove -> FinishMove)
-> (FinishMove -> FinishMove -> FinishMove)
-> Ord FinishMove
FinishMove -> FinishMove -> Bool
FinishMove -> FinishMove -> Ordering
FinishMove -> FinishMove -> FinishMove
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: FinishMove -> FinishMove -> Ordering
compare :: FinishMove -> FinishMove -> Ordering
$c< :: FinishMove -> FinishMove -> Bool
< :: FinishMove -> FinishMove -> Bool
$c<= :: FinishMove -> FinishMove -> Bool
<= :: FinishMove -> FinishMove -> Bool
$c> :: FinishMove -> FinishMove -> Bool
> :: FinishMove -> FinishMove -> Bool
$c>= :: FinishMove -> FinishMove -> Bool
>= :: FinishMove -> FinishMove -> Bool
$cmax :: FinishMove -> FinishMove -> FinishMove
max :: FinishMove -> FinishMove -> FinishMove
$cmin :: FinishMove -> FinishMove -> FinishMove
min :: FinishMove -> FinishMove -> FinishMove
Ord, Int -> FinishMove -> ShowS
[FinishMove] -> ShowS
FinishMove -> [Char]
(Int -> FinishMove -> ShowS)
-> (FinishMove -> [Char])
-> ([FinishMove] -> ShowS)
-> Show FinishMove
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FinishMove -> ShowS
showsPrec :: Int -> FinishMove -> ShowS
$cshow :: FinishMove -> [Char]
show :: FinishMove -> [Char]
$cshowList :: [FinishMove] -> ShowS
showList :: [FinishMove] -> ShowS
Show)

instance Default PlottingSettings where
    def :: PlottingSettings
def = PlottingSettings
        { _feedrate :: Double
_feedrate = Double
1000
        , _zTravelHeight :: Double
_zTravelHeight = Double
1
        , _zDrawingHeight :: Double
_zDrawingHeight = -Double
1
        , _zLoweringFeedrate :: Maybe Double
_zLoweringFeedrate = Maybe Double
forall a. Maybe a
Nothing
        , _finishMove :: Maybe FinishMove
_finishMove = Maybe FinishMove
forall a. Maybe a
Nothing
        , _previewDrawnShapesBoundingBox :: Bool
_previewDrawnShapesBoundingBox = Bool
True
        , _canvasBoundingBox :: Maybe BoundingBox
_canvasBoundingBox = Maybe BoundingBox
forall a. Maybe a
Nothing
        , _previewPenWidth :: Double
_previewPenWidth = Double
1
        , _previewPenColor :: Color Double
_previewPenColor = Int -> Color Double
D.mma Int
0
        , _previewPenTravelColor :: Maybe (Color Double)
_previewPenTravelColor = Color Double -> Maybe (Color Double)
forall a. a -> Maybe a
Just (Int -> Color Double
D.mma Int
1)
        , _previewDecorate :: Bool
_previewDecorate = Bool
True
        }

-- | Add raw GCode to the output.
gCode :: [GCode] -> Plot ()
gCode :: [GCode] -> Plot ()
gCode [GCode]
instructions = [GCode] -> (GCode -> Plot ()) -> Plot ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [GCode]
instructions ((GCode -> Plot ()) -> Plot ()) -> (GCode -> Plot ()) -> Plot ()
forall a b. (a -> b) -> a -> b
$ \GCode
instruction -> do
    RWST PlottingSettings PlottingWriterLog PlottingState Identity ()
-> Plot ()
forall a.
RWS PlottingSettings PlottingWriterLog PlottingState a -> Plot a
Plot (PlottingWriterLog
-> RWST
     PlottingSettings PlottingWriterLog PlottingState Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell PlottingWriterLog
forall a. Monoid a => a
mempty{_plottedGCode :: DList GCode
_plottedGCode = GCode -> DList GCode
forall a. a -> DList a
DL.singleton GCode
instruction})
    GCode -> Plot ()
recordDrawingDistance GCode
instruction
    GCode -> Plot ()
recordCairoPreview GCode
instruction
    GCode -> Plot ()
recordBoundingBox GCode
instruction
    GCode -> Plot ()
recordPenXY GCode
instruction -- NB: this is last because the other recorders depend on the pen position!

setPenXY :: Vec2 -> Plot ()
setPenXY :: Vec2 -> Plot ()
setPenXY Vec2
pos = (PlottingState -> PlottingState) -> Plot ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\PlottingState
s -> PlottingState
s { _penXY :: Vec2
_penXY = Vec2
pos })

recordPenXY :: GCode -> Plot ()
recordPenXY :: GCode -> Plot ()
recordPenXY GCode
instruction = do
    Vec2 Double
x0 Double
y0 <- (PlottingState -> Vec2) -> Plot Vec2
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PlottingState -> Vec2
_penXY
    case GCode
instruction of
        G00_LinearRapidMove Maybe Double
x Maybe Double
y Maybe Double
_         -> Vec2 -> Plot ()
setPenXY (Double -> Double -> Vec2
Vec2 (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
x0 Maybe Double
x) (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
y0 Maybe Double
y))
        G01_LinearFeedrateMove Maybe Double
_ Maybe Double
x Maybe Double
y Maybe Double
_    -> Vec2 -> Plot ()
setPenXY (Double -> Double -> Vec2
Vec2 (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
x0 Maybe Double
x) (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
y0 Maybe Double
y))
        G02_ArcClockwise Maybe Double
_ Double
_ Double
_ Double
x Double
y        -> Vec2 -> Plot ()
setPenXY (Double -> Double -> Vec2
Vec2 Double
x Double
y)
        G03_ArcCounterClockwise Maybe Double
_ Double
_ Double
_ Double
x Double
y -> Vec2 -> Plot ()
setPenXY (Double -> Double -> Vec2
Vec2 Double
x Double
y)
        GCode
_otherwise -> () -> Plot ()
forall a. a -> Plot a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

tellCairo :: C.Render () -> Plot ()
tellCairo :: Render () -> Plot ()
tellCairo Render ()
c = RWST PlottingSettings PlottingWriterLog PlottingState Identity ()
-> Plot ()
forall a.
RWS PlottingSettings PlottingWriterLog PlottingState a -> Plot a
Plot (PlottingWriterLog
-> RWST
     PlottingSettings PlottingWriterLog PlottingState Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell PlottingWriterLog
forall a. Monoid a => a
mempty{_plottingCairoPreview :: Render ()
_plottingCairoPreview = Render () -> Render ()
forall a. Render a -> Render a
D.cairoScope Render ()
c})

recordCairoPreview :: GCode -> Plot ()
recordCairoPreview :: GCode -> Plot ()
recordCairoPreview GCode
instruction = do
    start :: Vec2
start@(Vec2 Double
currentX Double
currentY) <- (PlottingState -> Vec2) -> Plot Vec2
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PlottingState -> Vec2
_penXY
    PenState
penState <- (PlottingState -> PenState) -> Plot PenState
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PlottingState -> PenState
_penState
    PlottingSettings
settings <- Plot PlottingSettings
forall r (m :: * -> *). MonadReader r m => m r
ask
    Bool -> Plot () -> Plot ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
currentX) Bool -> Bool -> Bool
&& Bool -> Bool
not (Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
currentY) Bool -> Bool -> Bool
&& (PenState
penState PenState -> PenState -> Bool
forall a. Eq a => a -> a -> Bool
== PenState
PenDown Bool -> Bool -> Bool
|| Maybe (Color Double) -> Bool
forall a. Maybe a -> Bool
isJust (PlottingSettings -> Maybe (Color Double)
_previewPenTravelColor PlottingSettings
settings))) (Plot () -> Plot ()) -> Plot () -> Plot ()
forall a b. (a -> b) -> a -> b
$ do
        let paintStyle :: Render ()
paintStyle = case PenState
penState of
                PenState
PenUp -> Color Double -> Render ()
forall color. CairoColor color => color -> Render ()
D.setColor (Maybe (Color Double) -> Color Double
forall a. HasCallStack => Maybe a -> a
fromJust (PlottingSettings -> Maybe (Color Double)
_previewPenTravelColor PlottingSettings
settings))
                PenState
PenDown -> Color Double -> Render ()
forall color. CairoColor color => color -> Render ()
D.setColor (PlottingSettings -> Color Double
_previewPenColor PlottingSettings
settings)
            fastStyle :: Render ()
fastStyle = Double -> Render ()
C.setLineWidth (PlottingSettings -> Double
_previewPenWidth PlottingSettings
settings) Render () -> Render () -> Render ()
forall a b. Render a -> Render b -> Render b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Double] -> Double -> Render ()
C.setDash [Double
1,Double
1] Double
0
            feedrateStyle :: Render ()
feedrateStyle = Double -> Render ()
C.setLineWidth (PlottingSettings -> Double
_previewPenWidth PlottingSettings
settings)
        case GCode
instruction of
            G00_LinearRapidMove Maybe Double
x Maybe Double
y Maybe Double
_ -> Render () -> Plot ()
tellCairo (Render () -> Plot ()) -> Render () -> Plot ()
forall a b. (a -> b) -> a -> b
$ do
                Render ()
fastStyle
                Render ()
paintStyle
                let end :: Vec2
end = Double -> Double -> Vec2
Vec2 (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
currentX Maybe Double
x) (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
currentY Maybe Double
y)
                Line -> Render ()
forall a. Sketch a => a -> Render ()
D.sketch (Vec2 -> Vec2 -> Line
Line Vec2
start Vec2
end)
                Render ()
C.stroke
            G01_LinearFeedrateMove Maybe Double
_ Maybe Double
x Maybe Double
y Maybe Double
_ -> Render () -> Plot ()
tellCairo (Render () -> Plot ()) -> Render () -> Plot ()
forall a b. (a -> b) -> a -> b
$ do
                Render ()
feedrateStyle
                Render ()
paintStyle
                let end :: Vec2
end = Double -> Double -> Vec2
Vec2 (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
currentX Maybe Double
x) (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
currentY Maybe Double
y)
                Line -> Render ()
forall a. Sketch a => a -> Render ()
D.sketch (Vec2 -> Vec2 -> Line
Line Vec2
start Vec2
end)
                Render ()
C.stroke
            G02_ArcClockwise Maybe Double
_ Double
i Double
j Double
x Double
y -> Render () -> Plot ()
tellCairo (Render () -> Plot ()) -> Render () -> Plot ()
forall a b. (a -> b) -> a -> b
$ do
                Render ()
feedrateStyle
                Render ()
paintStyle
                let radius :: Double
radius = Vec2 -> Double
norm Vec2
centerOffset
                    centerOffset :: Vec2
centerOffset = Double -> Double -> Vec2
Vec2 Double
i Double
j
                    center :: Vec2
center@(Vec2 Double
centerX Double
centerY) = Vec2
start Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Vec2
centerOffset
                    end :: Vec2
end = Double -> Double -> Vec2
Vec2 Double
x Double
y
                    startAngle :: Angle
startAngle = Line -> Angle
angleOfLine (Vec2 -> Vec2 -> Line
Line Vec2
center Vec2
start)
                    endAngle :: Angle
endAngle = Line -> Angle
angleOfLine (Vec2 -> Vec2 -> Line
Line Vec2
center Vec2
end)
                Vec2 -> Render ()
D.moveToVec Vec2
start
                Double -> Double -> Double -> Double -> Double -> Render ()
C.arcNegative Double
centerX Double
centerY Double
radius (Angle -> Double
getRad Angle
startAngle) (Angle -> Double
getRad Angle
endAngle)
                Render ()
C.stroke
            G03_ArcCounterClockwise Maybe Double
_ Double
i Double
j Double
x Double
y -> Render () -> Plot ()
tellCairo (Render () -> Plot ()) -> Render () -> Plot ()
forall a b. (a -> b) -> a -> b
$ do
                Render ()
feedrateStyle
                Render ()
paintStyle
                let radius :: Double
radius = Vec2 -> Double
norm Vec2
centerOffset
                    centerOffset :: Vec2
centerOffset = Double -> Double -> Vec2
Vec2 Double
i Double
j
                    center :: Vec2
center@(Vec2 Double
centerX Double
centerY) = Vec2
start Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Vec2
centerOffset
                    end :: Vec2
end = Double -> Double -> Vec2
Vec2 Double
x Double
y
                    startAngle :: Angle
startAngle = Line -> Angle
angleOfLine (Vec2 -> Vec2 -> Line
Line Vec2
center Vec2
start)
                    endAngle :: Angle
endAngle = Line -> Angle
angleOfLine (Vec2 -> Vec2 -> Line
Line Vec2
center Vec2
end)
                Vec2 -> Render ()
D.moveToVec Vec2
start
                Double -> Double -> Double -> Double -> Double -> Render ()
C.arc Double
centerX Double
centerY Double
radius (Angle -> Double
getRad Angle
startAngle) (Angle -> Double
getRad Angle
endAngle)
                Render ()
C.stroke
            GCode
_otherwise -> () -> Plot ()
forall a. a -> Plot a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

recordDrawingDistance :: GCode -> Plot ()
recordDrawingDistance :: GCode -> Plot ()
recordDrawingDistance GCode
instruction = do
    PenState
penState <- (PlottingState -> PenState) -> Plot PenState
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PlottingState -> PenState
_penState
    penXY :: Vec2
penXY@(Vec2 Double
x0 Double
y0) <- (PlottingState -> Vec2) -> Plot Vec2
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PlottingState -> Vec2
_penXY
    let distanceTravelled :: Maybe Double
distanceTravelled = case GCode
instruction of
            G00_LinearRapidMove Maybe Double
x Maybe Double
y Maybe Double
_      -> Double -> Maybe Double
forall a. a -> Maybe a
Just (Vec2 -> Double
norm (Vec2
penXY Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Double -> Double -> Vec2
Vec2 (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
x0 Maybe Double
x) (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
y0 Maybe Double
y)))
            G01_LinearFeedrateMove Maybe Double
_ Maybe Double
x Maybe Double
y Maybe Double
_ -> Double -> Maybe Double
forall a. a -> Maybe a
Just (Vec2 -> Double
norm (Vec2
penXY Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Double -> Double -> Vec2
Vec2 (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
x0 Maybe Double
x) (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
y0 Maybe Double
y)))
            G02_ArcClockwise Maybe Double
_ Double
i Double
j Double
x Double
y -> do
                let r :: Double
r = Vec2 -> Double
norm (Double -> Double -> Vec2
Vec2 Double
i Double
j)
                    center :: Vec2
center = Vec2
penXY Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Double -> Double -> Vec2
Vec2 Double
i Double
j
                    angle :: Angle
angle = Line -> Line -> Angle
angleBetween (Vec2 -> Vec2 -> Line
Line Vec2
center (Double -> Double -> Vec2
Vec2 Double
x Double
y)) (Vec2 -> Vec2 -> Line
Line Vec2
center Vec2
penXY)
                Double -> Maybe Double
forall a. a -> Maybe a
Just (Double
r Double -> Double -> Double
forall a. Num a => a -> a -> a
* Angle -> Double
getRad (Angle -> Angle -> Angle
normalizeAngle (Double -> Angle
deg Double
0) Angle
angle))
            G03_ArcCounterClockwise Maybe Double
_ Double
i Double
j Double
x Double
y -> do
                let r :: Double
r = Vec2 -> Double
norm (Double -> Double -> Vec2
Vec2 Double
i Double
j)
                    center :: Vec2
center = Vec2
penXY Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Double -> Double -> Vec2
Vec2 Double
i Double
j
                    angle :: Angle
angle = Line -> Line -> Angle
angleBetween (Vec2 -> Vec2 -> Line
Line Vec2
center Vec2
penXY) (Vec2 -> Vec2 -> Line
Line Vec2
center (Double -> Double -> Vec2
Vec2 Double
x Double
y))
                Double -> Maybe Double
forall a. a -> Maybe a
Just (Double
r Double -> Double -> Double
forall a. Num a => a -> a -> a
* Angle -> Double
getRad (Angle -> Angle -> Angle
normalizeAngle (Double -> Angle
deg Double
0) Angle
angle))
            GCode
_otherwise -> Maybe Double
forall a. Maybe a
Nothing

    case Maybe Double
distanceTravelled of
        Maybe Double
Nothing -> () -> Plot ()
forall a. a -> Plot a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just Double
d -> case PenState
penState of
            PenState
PenDown -> Double -> Plot ()
addDrawingDistance Double
d
            PenState
PenUp | Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
d -> () -> Plot ()
forall a. a -> Plot a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- Pen starts at (∞,∞) so we hack around recording it here
            PenState
PenUp -> Double -> Plot ()
addTravelDistance Double
d

recordBB :: HasBoundingBox object => object -> Plot ()
recordBB :: forall object. HasBoundingBox object => object -> Plot ()
recordBB object
object = (PlottingState -> PlottingState) -> Plot ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\PlottingState
s -> PlottingState
s { _drawnBoundingBox :: BoundingBox
_drawnBoundingBox = PlottingState -> BoundingBox
_drawnBoundingBox PlottingState
s BoundingBox -> BoundingBox -> BoundingBox
forall a. Semigroup a => a -> a -> a
<> object -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox object
object })

recordBoundingBox :: GCode -> Plot ()
recordBoundingBox :: GCode -> Plot ()
recordBoundingBox GCode
instruction = do
    current :: Vec2
current@(Vec2 Double
xCurrent Double
yCurrent) <- (PlottingState -> Vec2) -> Plot Vec2
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PlottingState -> Vec2
_penXY
    case GCode
instruction of
        G00_LinearRapidMove Maybe Double
x Maybe Double
y Maybe Double
_         -> Vec2 -> Plot ()
forall object. HasBoundingBox object => object -> Plot ()
recordBB (Double -> Double -> Vec2
Vec2 (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
xCurrent Maybe Double
x) (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
yCurrent Maybe Double
y))
        G01_LinearFeedrateMove Maybe Double
_ Maybe Double
x Maybe Double
y Maybe Double
_    -> Vec2 -> Plot ()
forall object. HasBoundingBox object => object -> Plot ()
recordBB (Double -> Double -> Vec2
Vec2 (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
xCurrent Maybe Double
x) (Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
yCurrent Maybe Double
y))
        G02_ArcClockwise Maybe Double
_ Double
i Double
j Double
x Double
y        -> Arc -> Plot ()
forall object. HasBoundingBox object => object -> Plot ()
recordBB (ArcDirection -> Vec2 -> Vec2 -> Vec2 -> Arc
Arc        ArcDirection
Clockwise Vec2
current (Vec2
current Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Double -> Double -> Vec2
Vec2 Double
i Double
j) (Double -> Double -> Vec2
Vec2 Double
x Double
y))
        G03_ArcCounterClockwise Maybe Double
_ Double
i Double
j Double
x Double
y -> Arc -> Plot ()
forall object. HasBoundingBox object => object -> Plot ()
recordBB (ArcDirection -> Vec2 -> Vec2 -> Vec2 -> Arc
Arc ArcDirection
CounterClockwise Vec2
current (Vec2
current Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Double -> Double -> Vec2
Vec2 Double
i Double
j) (Double -> Double -> Vec2
Vec2 Double
x Double
y))
        GCode
_otherwise -> () -> Plot ()
forall a. a -> Plot a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

addDrawingDistance :: Double -> Plot ()
addDrawingDistance :: Double -> Plot ()
addDrawingDistance Double
d = (PlottingState -> PlottingState) -> Plot ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\PlottingState
s -> PlottingState
s { _drawingDistance :: Double
_drawingDistance = PlottingState -> Double
_drawingDistance PlottingState
s Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
d })

addTravelDistance :: Double -> Plot ()
addTravelDistance :: Double -> Plot ()
addTravelDistance Double
d = RWST PlottingSettings PlottingWriterLog PlottingState Identity ()
-> Plot ()
forall a.
RWS PlottingSettings PlottingWriterLog PlottingState a -> Plot a
Plot (PlottingWriterLog
-> RWST
     PlottingSettings PlottingWriterLog PlottingState Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell PlottingWriterLog
forall a. Monoid a => a
mempty{_penTravelDistance :: Double
_penTravelDistance = Double
d})

-- | CwArc a c b = Clockwise arc from a to b with center at c.
data Arc = Arc ArcDirection Vec2 Vec2 Vec2 deriving (Arc -> Arc -> Bool
(Arc -> Arc -> Bool) -> (Arc -> Arc -> Bool) -> Eq Arc
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Arc -> Arc -> Bool
== :: Arc -> Arc -> Bool
$c/= :: Arc -> Arc -> Bool
/= :: Arc -> Arc -> Bool
Eq, Eq Arc
Eq Arc
-> (Arc -> Arc -> Ordering)
-> (Arc -> Arc -> Bool)
-> (Arc -> Arc -> Bool)
-> (Arc -> Arc -> Bool)
-> (Arc -> Arc -> Bool)
-> (Arc -> Arc -> Arc)
-> (Arc -> Arc -> Arc)
-> Ord Arc
Arc -> Arc -> Bool
Arc -> Arc -> Ordering
Arc -> Arc -> Arc
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Arc -> Arc -> Ordering
compare :: Arc -> Arc -> Ordering
$c< :: Arc -> Arc -> Bool
< :: Arc -> Arc -> Bool
$c<= :: Arc -> Arc -> Bool
<= :: Arc -> Arc -> Bool
$c> :: Arc -> Arc -> Bool
> :: Arc -> Arc -> Bool
$c>= :: Arc -> Arc -> Bool
>= :: Arc -> Arc -> Bool
$cmax :: Arc -> Arc -> Arc
max :: Arc -> Arc -> Arc
$cmin :: Arc -> Arc -> Arc
min :: Arc -> Arc -> Arc
Ord, Int -> Arc -> ShowS
[Arc] -> ShowS
Arc -> [Char]
(Int -> Arc -> ShowS)
-> (Arc -> [Char]) -> ([Arc] -> ShowS) -> Show Arc
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Arc -> ShowS
showsPrec :: Int -> Arc -> ShowS
$cshow :: Arc -> [Char]
show :: Arc -> [Char]
$cshowList :: [Arc] -> ShowS
showList :: [Arc] -> ShowS
Show)

data ArcDirection = Clockwise | CounterClockwise deriving (ArcDirection -> ArcDirection -> Bool
(ArcDirection -> ArcDirection -> Bool)
-> (ArcDirection -> ArcDirection -> Bool) -> Eq ArcDirection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ArcDirection -> ArcDirection -> Bool
== :: ArcDirection -> ArcDirection -> Bool
$c/= :: ArcDirection -> ArcDirection -> Bool
/= :: ArcDirection -> ArcDirection -> Bool
Eq, Eq ArcDirection
Eq ArcDirection
-> (ArcDirection -> ArcDirection -> Ordering)
-> (ArcDirection -> ArcDirection -> Bool)
-> (ArcDirection -> ArcDirection -> Bool)
-> (ArcDirection -> ArcDirection -> Bool)
-> (ArcDirection -> ArcDirection -> Bool)
-> (ArcDirection -> ArcDirection -> ArcDirection)
-> (ArcDirection -> ArcDirection -> ArcDirection)
-> Ord ArcDirection
ArcDirection -> ArcDirection -> Bool
ArcDirection -> ArcDirection -> Ordering
ArcDirection -> ArcDirection -> ArcDirection
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ArcDirection -> ArcDirection -> Ordering
compare :: ArcDirection -> ArcDirection -> Ordering
$c< :: ArcDirection -> ArcDirection -> Bool
< :: ArcDirection -> ArcDirection -> Bool
$c<= :: ArcDirection -> ArcDirection -> Bool
<= :: ArcDirection -> ArcDirection -> Bool
$c> :: ArcDirection -> ArcDirection -> Bool
> :: ArcDirection -> ArcDirection -> Bool
$c>= :: ArcDirection -> ArcDirection -> Bool
>= :: ArcDirection -> ArcDirection -> Bool
$cmax :: ArcDirection -> ArcDirection -> ArcDirection
max :: ArcDirection -> ArcDirection -> ArcDirection
$cmin :: ArcDirection -> ArcDirection -> ArcDirection
min :: ArcDirection -> ArcDirection -> ArcDirection
Ord, Int -> ArcDirection -> ShowS
[ArcDirection] -> ShowS
ArcDirection -> [Char]
(Int -> ArcDirection -> ShowS)
-> (ArcDirection -> [Char])
-> ([ArcDirection] -> ShowS)
-> Show ArcDirection
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ArcDirection -> ShowS
showsPrec :: Int -> ArcDirection -> ShowS
$cshow :: ArcDirection -> [Char]
show :: ArcDirection -> [Char]
$cshowList :: [ArcDirection] -> ShowS
showList :: [ArcDirection] -> ShowS
Show)

instance HasBoundingBox Arc where
    boundingBox :: Arc -> BoundingBox
boundingBox arc :: Arc
arc@(Arc ArcDirection
_ Vec2
start Vec2
_ Vec2
end) =
        (Vec2, Vec2, BoundingBox) -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox (Vec2
start, Vec2
end, Arc -> BoundingBox
quadrantTransitionBB Arc
arc)

quadrantTransitionBB :: Arc -> BoundingBox
quadrantTransitionBB :: Arc -> BoundingBox
quadrantTransitionBB (Arc ArcDirection
arcDirection Vec2
start Vec2
center Vec2
end) = case ArcDirection
arcDirection of
    ArcDirection
Clockwise        -> [Vec2] -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox (     Quadrant -> Quadrant -> [Vec2]
go Quadrant
startQuadrant Quadrant
endQuadrant)
    ArcDirection
CounterClockwise -> [Vec2] -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox ((Quadrant -> Quadrant -> [Vec2]) -> Quadrant -> Quadrant -> [Vec2]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Quadrant -> Quadrant -> [Vec2]
go Quadrant
startQuadrant Quadrant
endQuadrant)
  where
    radius :: Double
radius = Vec2 -> Double
norm (Vec2
start Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
center)
    startQuadrant :: Quadrant
startQuadrant = Vec2 -> Vec2 -> Quadrant
whichQuadrant Vec2
center Vec2
start
    endQuadrant :: Quadrant
endQuadrant = Vec2 -> Vec2 -> Quadrant
whichQuadrant Vec2
center Vec2
end

    rightP :: Vec2
rightP  = Vec2
center Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Double -> Double -> Vec2
Vec2 Double
radius Double
0
    leftP :: Vec2
leftP   = Vec2
center Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Double -> Double -> Vec2
Vec2 Double
radius Double
0
    topP :: Vec2
topP    = Vec2
center Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Double -> Double -> Vec2
Vec2 Double
0 Double
radius
    bottomP :: Vec2
bottomP = Vec2
center Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Double -> Double -> Vec2
Vec2 Double
0 Double
radius
    allP :: [Vec2]
allP = [Vec2
bottomP, Vec2
leftP, Vec2
topP, Vec2
rightP]

    arcIsWrapping :: Bool
arcIsWrapping =
        Quadrant
startQuadrant Quadrant -> Quadrant -> Bool
forall a. Eq a => a -> a -> Bool
== Quadrant
endQuadrant
        Bool -> Bool -> Bool
&& case ArcDirection
arcDirection of
            ArcDirection
Clockwise        -> Vec2 -> Vec2 -> Double
cross (Line -> Vec2
vectorOf (Vec2 -> Vec2 -> Line
Line Vec2
center Vec2
start)) (Line -> Vec2
vectorOf (Vec2 -> Vec2 -> Line
Line Vec2
center Vec2
end)) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0
            ArcDirection
CounterClockwise -> Vec2 -> Vec2 -> Double
cross (Line -> Vec2
vectorOf (Vec2 -> Vec2 -> Line
Line Vec2
center Vec2
start)) (Line -> Vec2
vectorOf (Vec2 -> Vec2 -> Line
Line Vec2
center Vec2
end)) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0

    go :: Quadrant -> Quadrant -> [Vec2]
go Quadrant
QuadrantBR Quadrant
QuadrantBR | Bool
arcIsWrapping = [Vec2]
allP
    go Quadrant
QuadrantBR Quadrant
QuadrantBR = []
    go Quadrant
QuadrantBR Quadrant
QuadrantBL = [Vec2
bottomP]
    go Quadrant
QuadrantBR Quadrant
QuadrantTL = [Vec2
bottomP, Vec2
leftP]
    go Quadrant
QuadrantBR Quadrant
QuadrantTR = [Vec2
bottomP, Vec2
leftP, Vec2
topP]

    go Quadrant
QuadrantBL Quadrant
QuadrantBR = [Vec2
leftP, Vec2
topP, Vec2
rightP]
    go Quadrant
QuadrantBL Quadrant
QuadrantBL | Bool
arcIsWrapping = [Vec2]
allP
    go Quadrant
QuadrantBL Quadrant
QuadrantBL = []
    go Quadrant
QuadrantBL Quadrant
QuadrantTL = [Vec2
leftP]
    go Quadrant
QuadrantBL Quadrant
QuadrantTR = [Vec2
leftP, Vec2
topP]

    go Quadrant
QuadrantTL Quadrant
QuadrantBR = [Vec2
topP, Vec2
rightP]
    go Quadrant
QuadrantTL Quadrant
QuadrantBL = [Vec2
topP, Vec2
rightP, Vec2
bottomP]
    go Quadrant
QuadrantTL Quadrant
QuadrantTL | Bool
arcIsWrapping = [Vec2]
allP
    go Quadrant
QuadrantTL Quadrant
QuadrantTL = []
    go Quadrant
QuadrantTL Quadrant
QuadrantTR = [Vec2
topP]

    go Quadrant
QuadrantTR Quadrant
QuadrantBR = [Vec2
rightP]
    go Quadrant
QuadrantTR Quadrant
QuadrantBL = [Vec2
rightP, Vec2
bottomP]
    go Quadrant
QuadrantTR Quadrant
QuadrantTL = [Vec2
rightP, Vec2
bottomP, Vec2
leftP]
    go Quadrant
QuadrantTR Quadrant
QuadrantTR | Bool
arcIsWrapping = [Vec2]
allP
    go Quadrant
QuadrantTR Quadrant
QuadrantTR = []

data Quadrant = QuadrantBR | QuadrantBL | QuadrantTL | QuadrantTR deriving (Quadrant -> Quadrant -> Bool
(Quadrant -> Quadrant -> Bool)
-> (Quadrant -> Quadrant -> Bool) -> Eq Quadrant
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Quadrant -> Quadrant -> Bool
== :: Quadrant -> Quadrant -> Bool
$c/= :: Quadrant -> Quadrant -> Bool
/= :: Quadrant -> Quadrant -> Bool
Eq, Eq Quadrant
Eq Quadrant
-> (Quadrant -> Quadrant -> Ordering)
-> (Quadrant -> Quadrant -> Bool)
-> (Quadrant -> Quadrant -> Bool)
-> (Quadrant -> Quadrant -> Bool)
-> (Quadrant -> Quadrant -> Bool)
-> (Quadrant -> Quadrant -> Quadrant)
-> (Quadrant -> Quadrant -> Quadrant)
-> Ord Quadrant
Quadrant -> Quadrant -> Bool
Quadrant -> Quadrant -> Ordering
Quadrant -> Quadrant -> Quadrant
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Quadrant -> Quadrant -> Ordering
compare :: Quadrant -> Quadrant -> Ordering
$c< :: Quadrant -> Quadrant -> Bool
< :: Quadrant -> Quadrant -> Bool
$c<= :: Quadrant -> Quadrant -> Bool
<= :: Quadrant -> Quadrant -> Bool
$c> :: Quadrant -> Quadrant -> Bool
> :: Quadrant -> Quadrant -> Bool
$c>= :: Quadrant -> Quadrant -> Bool
>= :: Quadrant -> Quadrant -> Bool
$cmax :: Quadrant -> Quadrant -> Quadrant
max :: Quadrant -> Quadrant -> Quadrant
$cmin :: Quadrant -> Quadrant -> Quadrant
min :: Quadrant -> Quadrant -> Quadrant
Ord, Int -> Quadrant -> ShowS
[Quadrant] -> ShowS
Quadrant -> [Char]
(Int -> Quadrant -> ShowS)
-> (Quadrant -> [Char]) -> ([Quadrant] -> ShowS) -> Show Quadrant
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Quadrant -> ShowS
showsPrec :: Int -> Quadrant -> ShowS
$cshow :: Quadrant -> [Char]
show :: Quadrant -> [Char]
$cshowList :: [Quadrant] -> ShowS
showList :: [Quadrant] -> ShowS
Show)

-- | Quadrants are in math coordinates (y pointing upwards!)
whichQuadrant
    :: Vec2 -- ^ Center
    -> Vec2 -- ^ Which quadrant is this point in?
    -> Quadrant
whichQuadrant :: Vec2 -> Vec2 -> Quadrant
whichQuadrant Vec2
center Vec2
point
    | Double
dx Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0 Bool -> Bool -> Bool
&& Double
dy Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0 = Quadrant
QuadrantTR
    | Double
dx Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<  Double
0 Bool -> Bool -> Bool
&& Double
dy Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0 = Quadrant
QuadrantTL
    | Double
dx Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<  Double
0 Bool -> Bool -> Bool
&& Double
dy Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<  Double
0 = Quadrant
QuadrantBL
    | Bool
otherwise          = Quadrant
QuadrantBR
  where
    Vec2 Double
dx Double
dy = Vec2
point Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
center

-- | Trace the plotting area to preview the extents of the plot, and wait for
-- confirmation. Useful at the start of a plot.
previewCanvas :: Plot ()
previewCanvas :: Plot ()
previewCanvas = Text -> Plot () -> Plot ()
forall a. Text -> Plot a -> Plot a
commented Text
"Preview bounding box" (Plot () -> Plot ()) -> Plot () -> Plot ()
forall a b. (a -> b) -> a -> b
$ do
    (PlottingSettings -> Maybe BoundingBox) -> Plot (Maybe BoundingBox)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PlottingSettings -> Maybe BoundingBox
_canvasBoundingBox Plot (Maybe BoundingBox)
-> (Maybe BoundingBox -> Plot ()) -> Plot ()
forall a b. Plot a -> (a -> Plot b) -> Plot b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just BoundingBox
bb -> BoundingBox -> Plot ()
forall a. Plotting a => a -> Plot ()
plot BoundingBox
bb Plot () -> Plot () -> Plot ()
forall a b. Plot a -> Plot b -> Plot b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PauseMode -> Plot ()
pause PauseMode
PauseUserConfirm
        Maybe BoundingBox
Nothing -> () -> Plot ()
forall a. a -> Plot a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Quick move for repositioning (without drawing).
repositionTo :: Vec2 -> Plot ()
repositionTo :: Vec2 -> Plot ()
repositionTo target :: Vec2
target@(Vec2 Double
x Double
y) = do
    Vec2
currentXY <- (PlottingState -> Vec2) -> Plot Vec2
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PlottingState -> Vec2
_penXY
    Bool -> Plot () -> Plot ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Vec2
currentXY Vec2 -> Vec2 -> Bool
forall a. Eq a => a -> a -> Bool
/= Vec2
target) (Plot () -> Plot ()) -> Plot () -> Plot ()
forall a b. (a -> b) -> a -> b
$ do
        Plot ()
penUp
        [GCode] -> Plot ()
gCode [ Maybe Double -> Maybe Double -> Maybe Double -> GCode
G00_LinearRapidMove (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
x) (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
y) Maybe Double
forall a. Maybe a
Nothing ]

-- | Draw a line from the current position to a target.
lineTo :: Vec2 -> Plot ()
lineTo :: Vec2 -> Plot ()
lineTo target :: Vec2
target@(Vec2 Double
x Double
y) = do
    Vec2
currentXY <- (PlottingState -> Vec2) -> Plot Vec2
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PlottingState -> Vec2
_penXY
    Double
feedrate <- (PlottingSettings -> Double) -> Plot Double
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PlottingSettings -> Double
_feedrate
    Bool -> Plot () -> Plot ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Vec2
currentXY Vec2 -> Vec2 -> Bool
forall a. Eq a => a -> a -> Bool
/= Vec2
target) (Plot () -> Plot ()) -> Plot () -> Plot ()
forall a b. (a -> b) -> a -> b
$ do
        Plot ()
penDown
        [GCode] -> Plot ()
gCode [ Maybe Double
-> Maybe Double -> Maybe Double -> Maybe Double -> GCode
G01_LinearFeedrateMove (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
feedrate) (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
x) (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
y) Maybe Double
forall a. Maybe a
Nothing ]

-- | Arc interpolation, clockwise
clockwiseArcAroundTo
    :: Vec2 -- ^ Center location
    -> Vec2 -- ^ End position
    -> Plot ()
clockwiseArcAroundTo :: Vec2 -> Vec2 -> Plot ()
clockwiseArcAroundTo Vec2
center (Vec2 Double
x Double
y) = do
    Vec2
start <- (PlottingState -> Vec2) -> Plot Vec2
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PlottingState -> Vec2
_penXY
    let Vec2 Double
centerXRel Double
centerYRel = Line -> Vec2
vectorOf (Vec2 -> Vec2 -> Line
Line Vec2
start Vec2
center)
    Double
feedrate <- (PlottingSettings -> Double) -> Plot Double
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PlottingSettings -> Double
_feedrate
    Plot ()
penDown
    [GCode] -> Plot ()
gCode [ Maybe Double -> Double -> Double -> Double -> Double -> GCode
G02_ArcClockwise (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
feedrate) Double
centerXRel Double
centerYRel Double
x Double
y ]

-- | Arc interpolation, counterclockwise
counterclockwiseArcAroundTo
    :: Vec2 -- ^ Center location
    -> Vec2 -- ^ End position
    -> Plot ()
counterclockwiseArcAroundTo :: Vec2 -> Vec2 -> Plot ()
counterclockwiseArcAroundTo Vec2
center (Vec2 Double
x Double
y) = do
    Vec2
start <- (PlottingState -> Vec2) -> Plot Vec2
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PlottingState -> Vec2
_penXY
    let Vec2 Double
centerXRel Double
centerYRel = Line -> Vec2
vectorOf (Vec2 -> Vec2 -> Line
Line Vec2
start Vec2
center)
    Double
feedrate <- (PlottingSettings -> Double) -> Plot Double
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PlottingSettings -> Double
_feedrate
    Plot ()
penDown
    [GCode] -> Plot ()
gCode [ Maybe Double -> Double -> Double -> Double -> Double -> GCode
G03_ArcCounterClockwise (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
feedrate) Double
centerXRel Double
centerYRel Double
x Double
y ]

-- | If the pen is up, lower it to drawing height. Do nothing if it is already
-- lowered.
penDown :: Plot ()
penDown :: Plot ()
penDown = (PlottingState -> PenState) -> Plot PenState
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PlottingState -> PenState
_penState Plot PenState -> (PenState -> Plot ()) -> Plot ()
forall a b. Plot a -> (a -> Plot b) -> Plot b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    PenState
PenDown -> () -> Plot ()
forall a. a -> Plot a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    PenState
PenUp -> do
        Double
zDrawing <- (PlottingSettings -> Double) -> Plot Double
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PlottingSettings -> Double
_zDrawingHeight
        Maybe Double
zFeedrate <- (PlottingSettings -> Maybe Double) -> Plot (Maybe Double)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PlottingSettings -> Maybe Double
_zLoweringFeedrate
        case Maybe Double
zFeedrate of
            Maybe Double
Nothing -> [GCode] -> Plot ()
gCode [ Maybe Double -> Maybe Double -> Maybe Double -> GCode
G00_LinearRapidMove Maybe Double
forall a. Maybe a
Nothing Maybe Double
forall a. Maybe a
Nothing (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
zDrawing) ]
            Just Double
fr -> [GCode] -> Plot ()
gCode [ Maybe Double
-> Maybe Double -> Maybe Double -> Maybe Double -> GCode
G01_LinearFeedrateMove (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
fr) Maybe Double
forall a. Maybe a
Nothing Maybe Double
forall a. Maybe a
Nothing (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
zDrawing) ]
        RWST PlottingSettings PlottingWriterLog PlottingState Identity ()
-> Plot ()
forall a.
RWS PlottingSettings PlottingWriterLog PlottingState a -> Plot a
Plot (PlottingWriterLog
-> RWST
     PlottingSettings PlottingWriterLog PlottingState Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell PlottingWriterLog
forall a. Monoid a => a
mempty{_elementsDrawn :: Int
_elementsDrawn = Int
1})
        (PlottingState -> PlottingState) -> Plot ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\PlottingState
s -> PlottingState
s { _penState :: PenState
_penState = PenState
PenDown })

-- | If the pen is down, lift it to travel height. Do nothing if it is already
-- lifted.
penUp :: Plot ()
penUp :: Plot ()
penUp = (PlottingState -> PenState) -> Plot PenState
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PlottingState -> PenState
_penState Plot PenState -> (PenState -> Plot ()) -> Plot ()
forall a b. Plot a -> (a -> Plot b) -> Plot b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    PenState
PenUp -> () -> Plot ()
forall a. a -> Plot a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    PenState
PenDown -> do
        Double
zTravel <- (PlottingSettings -> Double) -> Plot Double
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PlottingSettings -> Double
_zTravelHeight
        [GCode] -> Plot ()
gCode [ Maybe Double -> Maybe Double -> Maybe Double -> GCode
G00_LinearRapidMove Maybe Double
forall a. Maybe a
Nothing Maybe Double
forall a. Maybe a
Nothing (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
zTravel) ]
        (PlottingState -> PlottingState) -> Plot ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\PlottingState
s -> PlottingState
s { _penState :: PenState
_penState = PenState
PenUp })

-- | Locally change the feedrate
withFeedrate :: Double -> Plot a -> Plot a
withFeedrate :: forall a. Double -> Plot a -> Plot a
withFeedrate Double
f = (PlottingSettings -> PlottingSettings) -> Plot a -> Plot a
forall a.
(PlottingSettings -> PlottingSettings) -> Plot a -> Plot a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\PlottingSettings
settings -> PlottingSettings
settings { _feedrate :: Double
_feedrate = Double
f })

-- | Locally adapt the z drawing height (e.g. for changing pen pressure)
withDrawingHeight :: Double -> Plot a -> Plot a
withDrawingHeight :: forall a. Double -> Plot a -> Plot a
withDrawingHeight Double
z = (PlottingSettings -> PlottingSettings) -> Plot a -> Plot a
forall a.
(PlottingSettings -> PlottingSettings) -> Plot a -> Plot a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\PlottingSettings
settings -> PlottingSettings
settings { _zDrawingHeight :: Double
_zDrawingHeight = Double
z })

-- | Group the commands generated by the arguments in a block. This is purely
-- cosmetical for the generated GCode.
block :: Plot a -> Plot a
block :: forall a. Plot a -> Plot a
block (Plot RWS PlottingSettings PlottingWriterLog PlottingState a
content) = RWS PlottingSettings PlottingWriterLog PlottingState a -> Plot a
forall a.
RWS PlottingSettings PlottingWriterLog PlottingState a -> Plot a
Plot (((a, PlottingState, PlottingWriterLog)
 -> (a, PlottingState, PlottingWriterLog))
-> RWS PlottingSettings PlottingWriterLog PlottingState a
-> RWS PlottingSettings PlottingWriterLog PlottingState a
forall a s w b w' r.
((a, s, w) -> (b, s, w')) -> RWS r w s a -> RWS r w' s b
mapRWS (\(a
a, PlottingState
s, PlottingWriterLog
writerLog) -> (a
a, PlottingState
s, PlottingWriterLog
writerLog{_plottedGCode :: DList GCode
_plottedGCode = GCode -> DList GCode
forall a. a -> DList a
DL.singleton ([GCode] -> GCode
GBlock (DList GCode -> [GCode]
forall a. DList a -> [a]
DL.toList (PlottingWriterLog -> DList GCode
_plottedGCode PlottingWriterLog
writerLog)))})) RWS PlottingSettings PlottingWriterLog PlottingState a
content)

-- | Add a GCode comment.
comment :: Text -> Plot ()
comment :: Text -> Plot ()
comment Text
txt = [GCode] -> Plot ()
gCode [ Text -> GCode
GComment Text
txt ]

-- | Having a block with a comment ontop of it is a common pattern, so here’s a helper for that.
commented :: Text -> Plot a -> Plot a
commented :: forall a. Text -> Plot a -> Plot a
commented Text
caption Plot a
content = do
    Text -> Plot ()
comment Text
caption
    Plot a -> Plot a
forall a. Plot a -> Plot a
block Plot a
content

-- | Pause the plot for later resumption at the current state.
pause :: PauseMode -> Plot ()
pause :: PauseMode -> Plot ()
pause PauseMode
PauseUserConfirm = [GCode] -> Plot ()
gCode [ GCode
M0_Pause ]
pause (PauseSeconds Double
seconds) = [GCode] -> Plot ()
gCode [ Double -> GCode
G04_Dwell_ms (Double
secondsDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
1000) ]

data PauseMode
    = PauseUserConfirm -- ^ Wait until user confirmation, e.g. in a web UI or with a button. (M0/Pause)
    | PauseSeconds Double -- ^ Wait for a certain time (G4/Dwell)
    deriving (PauseMode -> PauseMode -> Bool
(PauseMode -> PauseMode -> Bool)
-> (PauseMode -> PauseMode -> Bool) -> Eq PauseMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PauseMode -> PauseMode -> Bool
== :: PauseMode -> PauseMode -> Bool
$c/= :: PauseMode -> PauseMode -> Bool
/= :: PauseMode -> PauseMode -> Bool
Eq, Eq PauseMode
Eq PauseMode
-> (PauseMode -> PauseMode -> Ordering)
-> (PauseMode -> PauseMode -> Bool)
-> (PauseMode -> PauseMode -> Bool)
-> (PauseMode -> PauseMode -> Bool)
-> (PauseMode -> PauseMode -> Bool)
-> (PauseMode -> PauseMode -> PauseMode)
-> (PauseMode -> PauseMode -> PauseMode)
-> Ord PauseMode
PauseMode -> PauseMode -> Bool
PauseMode -> PauseMode -> Ordering
PauseMode -> PauseMode -> PauseMode
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: PauseMode -> PauseMode -> Ordering
compare :: PauseMode -> PauseMode -> Ordering
$c< :: PauseMode -> PauseMode -> Bool
< :: PauseMode -> PauseMode -> Bool
$c<= :: PauseMode -> PauseMode -> Bool
<= :: PauseMode -> PauseMode -> Bool
$c> :: PauseMode -> PauseMode -> Bool
> :: PauseMode -> PauseMode -> Bool
$c>= :: PauseMode -> PauseMode -> Bool
>= :: PauseMode -> PauseMode -> Bool
$cmax :: PauseMode -> PauseMode -> PauseMode
max :: PauseMode -> PauseMode -> PauseMode
$cmin :: PauseMode -> PauseMode -> PauseMode
min :: PauseMode -> PauseMode -> PauseMode
Ord, Int -> PauseMode -> ShowS
[PauseMode] -> ShowS
PauseMode -> [Char]
(Int -> PauseMode -> ShowS)
-> (PauseMode -> [Char])
-> ([PauseMode] -> ShowS)
-> Show PauseMode
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PauseMode -> ShowS
showsPrec :: Int -> PauseMode -> ShowS
$cshow :: PauseMode -> [Char]
show :: PauseMode -> [Char]
$cshowList :: [PauseMode] -> ShowS
showList :: [PauseMode] -> ShowS
Show)

-- | Distance drawn so far.
--
-- One use case is adding a pause when a pencil needs sharpening again.
drawingDistance :: Plot Double
drawingDistance :: Plot Double
drawingDistance = (PlottingState -> Double) -> Plot Double
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PlottingState -> Double
_drawingDistance

addHeaderFooter :: PlottingSettings -> PlottingWriterLog -> PlottingState -> DList GCode
addHeaderFooter :: PlottingSettings
-> PlottingWriterLog -> PlottingState -> DList GCode
addHeaderFooter PlottingSettings
settings PlottingWriterLog
writerLog PlottingState
finalState = [DList GCode] -> DList GCode
forall a. Monoid a => [a] -> a
mconcat [DList GCode
header, DList GCode
body, DList GCode
footer]
  where
    body :: DList GCode
body = PlottingWriterLog -> DList GCode
_plottedGCode PlottingWriterLog
writerLog

    boundingBoxCheck :: GCode
boundingBoxCheck = case (PlottingSettings -> Bool
_previewDrawnShapesBoundingBox PlottingSettings
settings, PlottingState -> BoundingBox
_drawnBoundingBox PlottingState
finalState) of
        (Bool
False, BoundingBox
_) -> [GCode] -> GCode
GBlock []
        (Bool
True, BoundingBox (Vec2 Double
xMin Double
yMin) (Vec2 Double
xMax Double
yMax)) -> [GCode] -> GCode
GBlock
            [ Text -> GCode
GComment Text
"Trace bounding box"
            , Text -> GCode
GComment (Format Text (Double -> Double -> Text) -> Double -> Double -> Text
forall a. Format Text a -> a
format (Format (Double -> Double -> Text) (Double -> Double -> Text)
"x = [" Format (Double -> Double -> Text) (Double -> Double -> Text)
-> Format Text (Double -> Double -> Text)
-> Format Text (Double -> Double -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Int -> Format (Double -> Text) (Double -> Double -> Text)
forall a r. Real a => Int -> Format r (a -> r)
fixed Int
3 Format (Double -> Text) (Double -> Double -> Text)
-> Format Text (Double -> Text)
-> Format Text (Double -> Double -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (Double -> Text) (Double -> Text)
".." Format (Double -> Text) (Double -> Text)
-> Format Text (Double -> Text) -> Format Text (Double -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Int -> Format Text (Double -> Text)
forall a r. Real a => Int -> Format r (a -> r)
fixed Int
3 Format Text (Double -> Text)
-> Format Text Text -> Format Text (Double -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Text Text
"]") Double
xMin Double
xMax)
            , Text -> GCode
GComment (Format Text (Double -> Double -> Text) -> Double -> Double -> Text
forall a. Format Text a -> a
format (Format (Double -> Double -> Text) (Double -> Double -> Text)
"y = [" Format (Double -> Double -> Text) (Double -> Double -> Text)
-> Format Text (Double -> Double -> Text)
-> Format Text (Double -> Double -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Int -> Format (Double -> Text) (Double -> Double -> Text)
forall a r. Real a => Int -> Format r (a -> r)
fixed Int
3 Format (Double -> Text) (Double -> Double -> Text)
-> Format Text (Double -> Text)
-> Format Text (Double -> Double -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format (Double -> Text) (Double -> Text)
".." Format (Double -> Text) (Double -> Text)
-> Format Text (Double -> Text) -> Format Text (Double -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Int -> Format Text (Double -> Text)
forall a r. Real a => Int -> Format r (a -> r)
fixed Int
3 Format Text (Double -> Text)
-> Format Text Text -> Format Text (Double -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Text Text
"]") Double
yMin Double
yMax)
            , [GCode] -> GCode
GBlock
                [ Maybe Double -> Maybe Double -> Maybe Double -> GCode
G00_LinearRapidMove (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
xMin) (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
yMin) Maybe Double
forall a. Maybe a
Nothing
                , Maybe Double -> Maybe Double -> Maybe Double -> GCode
G00_LinearRapidMove Maybe Double
forall a. Maybe a
Nothing Maybe Double
forall a. Maybe a
Nothing (Double -> Maybe Double
forall a. a -> Maybe a
Just (PlottingSettings -> Double
_zTravelHeight PlottingSettings
settings))
                , GCode
G93_Feedrate_TravelInFractionOfMinute
                , Double -> GCode
G04_Dwell_ms Double
0.5
                -- 60/n ==> n seconds to move
                , Maybe Double
-> Maybe Double -> Maybe Double -> Maybe Double -> GCode
G01_LinearFeedrateMove (Double -> Maybe Double
forall a. a -> Maybe a
Just (Double
60Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
3)) (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
xMax) (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
yMin) Maybe Double
forall a. Maybe a
Nothing
                , Double -> GCode
G04_Dwell_ms Double
0.5
                , Maybe Double
-> Maybe Double -> Maybe Double -> Maybe Double -> GCode
G01_LinearFeedrateMove (Double -> Maybe Double
forall a. a -> Maybe a
Just (Double
60Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
3)) (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
xMax) (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
yMax) Maybe Double
forall a. Maybe a
Nothing
                , Double -> GCode
G04_Dwell_ms Double
0.5
                , Maybe Double
-> Maybe Double -> Maybe Double -> Maybe Double -> GCode
G01_LinearFeedrateMove (Double -> Maybe Double
forall a. a -> Maybe a
Just (Double
60Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
3)) (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
xMin) (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
yMax) Maybe Double
forall a. Maybe a
Nothing
                , Double -> GCode
G04_Dwell_ms Double
0.5
                , Maybe Double
-> Maybe Double -> Maybe Double -> Maybe Double -> GCode
G01_LinearFeedrateMove (Double -> Maybe Double
forall a. a -> Maybe a
Just (Double
60Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
3)) (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
xMin) (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
yMin) Maybe Double
forall a. Maybe a
Nothing
                , GCode
G94_Feedrate_UnitsPerMinute
                , GCode
M0_Pause
                ]
            ]

    setDefaultModes :: GCode
setDefaultModes = [GCode] -> GCode
GBlock
        [ GCode
G17_Plane_XY
        , GCode
G21_UseMm
        , GCode
G90_AbsoluteMovement
        , GCode
G94_Feedrate_UnitsPerMinute
        ]

    header :: DList GCode
header = [GCode] -> DList GCode
forall a. [a] -> DList a
DL.fromList
        [ Text -> GCode
GComment Text
"Header"
        , [GCode] -> GCode
GBlock
            [ Text -> GCode
GComment Text
"Normalize modal settings"
            , GCode
setDefaultModes ]
        , GCode
boundingBoxCheck
        , [GCode] -> GCode
GBlock
            [ Text -> GCode
GComment (Format Text (Double -> Text) -> Double -> Text
forall a. Format Text a -> a
format (Format (Double -> Text) (Double -> Text)
"Total drawing distance: " Format (Double -> Text) (Double -> Text)
-> Format Text (Double -> Text) -> Format Text (Double -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Int -> Format Text (Double -> Text)
forall a r. Real a => Int -> Format r (a -> r)
fixed Int
1 Format Text (Double -> Text)
-> Format Text Text -> Format Text (Double -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Text Text
"m") (PlottingState -> Double
_drawingDistance PlottingState
finalState Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
1000))
            , Text -> GCode
GComment (Format Text (Double -> Text) -> Double -> Text
forall a. Format Text a -> a
format (Format (Double -> Text) (Double -> Text)
"Total travel (non-drawing) distance: " Format (Double -> Text) (Double -> Text)
-> Format Text (Double -> Text) -> Format Text (Double -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Int -> Format Text (Double -> Text)
forall a r. Real a => Int -> Format r (a -> r)
fixed Int
1 Format Text (Double -> Text)
-> Format Text Text -> Format Text (Double -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Text Text
"m") (PlottingWriterLog -> Double
_penTravelDistance PlottingWriterLog
writerLogDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
1000))
            , Text -> GCode
GComment (Format Text (Int -> Text) -> Int -> Text
forall a. Format Text a -> a
format (Format (Int -> Text) (Int -> Text)
"Total number of elements (pen down events): " Format (Int -> Text) (Int -> Text)
-> Format Text (Int -> Text) -> Format Text (Int -> Text)
forall r a r'. Format r a -> Format r' r -> Format r' a
% Format Text (Int -> Text)
forall a r. Integral a => Format r (a -> r)
int) (PlottingWriterLog -> Int
_elementsDrawn PlottingWriterLog
writerLog))
            ]
        ]

    footer :: DList GCode
footer = [GCode] -> DList GCode
forall a. [a] -> DList a
DL.fromList
        [ Text -> GCode
GComment Text
"Footer"
        , GCode
finishMoveCheck
        ]

    finishMoveCheck :: GCode
finishMoveCheck = [GCode] -> GCode
GBlock ([GCode] -> GCode) -> [GCode] -> GCode
forall a b. (a -> b) -> a -> b
$ case PlottingSettings -> Maybe FinishMove
_finishMove PlottingSettings
settings of
        Maybe FinishMove
Nothing ->
            [ Text -> GCode
GComment Text
"Lift pen"
            , [GCode] -> GCode
GBlock [Maybe Double -> Maybe Double -> Maybe Double -> GCode
G00_LinearRapidMove Maybe Double
forall a. Maybe a
Nothing Maybe Double
forall a. Maybe a
Nothing (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
10)]
            ]
        Just FinishMove
FinishWithG28 ->
            [ Text -> GCode
GComment Text
"Move to predefined position"
            , [GCode] -> GCode
GBlock
                [ Maybe Double -> Maybe Double -> Maybe Double -> GCode
G00_LinearRapidMove Maybe Double
forall a. Maybe a
Nothing Maybe Double
forall a. Maybe a
Nothing (Double -> Maybe Double
forall a. a -> Maybe a
Just (PlottingSettings -> Double
_zTravelHeight PlottingSettings
settings))
                , Maybe Double -> Maybe Double -> Maybe Double -> GCode
G28_GotoPredefinedPosition Maybe Double
forall a. Maybe a
Nothing Maybe Double
forall a. Maybe a
Nothing Maybe Double
forall a. Maybe a
Nothing
                ]
            ]
        Just FinishMove
FinishWithG30 ->
            [ Text -> GCode
GComment Text
"Move to predefined position"
            , [GCode] -> GCode
GBlock
                [ Maybe Double -> Maybe Double -> Maybe Double -> GCode
G00_LinearRapidMove Maybe Double
forall a. Maybe a
Nothing Maybe Double
forall a. Maybe a
Nothing (Double -> Maybe Double
forall a. a -> Maybe a
Just (PlottingSettings -> Double
_zTravelHeight PlottingSettings
settings))
                , Maybe Double -> Maybe Double -> Maybe Double -> GCode
G30_GotoPredefinedPosition Maybe Double
forall a. Maybe a
Nothing Maybe Double
forall a. Maybe a
Nothing Maybe Double
forall a. Maybe a
Nothing
                ]
            ]
        Just FinishMove
FinishTopRight ->
            let BoundingBox Vec2
_ (Vec2 Double
xTopRight Double
yTopRight) = BoundingBox -> Maybe BoundingBox -> BoundingBox
forall a. a -> Maybe a -> a
fromMaybe BoundingBox
forall a. Monoid a => a
mempty (PlottingSettings -> Maybe BoundingBox
_canvasBoundingBox PlottingSettings
settings) BoundingBox -> BoundingBox -> BoundingBox
forall a. Semigroup a => a -> a -> a
<> PlottingState -> BoundingBox
_drawnBoundingBox PlottingState
finalState
            in [ Text -> GCode
GComment Text
"Move pen to top right"
               , [GCode] -> GCode
GBlock
                   [ Maybe Double -> Maybe Double -> Maybe Double -> GCode
G00_LinearRapidMove Maybe Double
forall a. Maybe a
Nothing Maybe Double
forall a. Maybe a
Nothing (Double -> Maybe Double
forall a. a -> Maybe a
Just (PlottingSettings -> Double
_zTravelHeight PlottingSettings
settings))
                   , Maybe Double -> Maybe Double -> Maybe Double -> GCode
G00_LinearRapidMove (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
xTopRight) (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
yTopRight) Maybe Double
forall a. Maybe a
Nothing
                   ]
               ]

decorateCairoPreview :: PlottingSettings -> PlottingState -> C.Render ()
decorateCairoPreview :: PlottingSettings -> PlottingState -> Render ()
decorateCairoPreview PlottingSettings
settings PlottingState
finalState = Render () -> Render ()
forall a. Render a -> Render a
D.cairoScope (Render () -> Render ()) -> Render () -> Render ()
forall a b. (a -> b) -> a -> b
$ Bool -> Render () -> Render ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PlottingSettings -> Bool
_previewDecorate PlottingSettings
settings) (Render () -> Render ()) -> Render () -> Render ()
forall a b. (a -> b) -> a -> b
$ do
    let colorGood :: Render ()
colorGood = Color Double -> Render ()
forall color. CairoColor color => color -> Render ()
D.setColor (Int -> Color Double
D.mma Int
2)
        colorBad :: Render ()
colorBad = Color Double -> Render ()
forall color. CairoColor color => color -> Render ()
D.setColor (Double -> Double -> Double -> Color Double
D.rgb Double
1 Double
0 Double
0)
        drawZeroMarker :: Render ()
drawZeroMarker = Render () -> Render ()
forall a. Render a -> Render a
D.cairoScope (Render () -> Render ()) -> Render () -> Render ()
forall a b. (a -> b) -> a -> b
$ do
            Render ()
colorGood
            Double -> Render ()
C.setLineWidth Double
3
            Line -> Render ()
forall a. Sketch a => a -> Render ()
D.sketch (Vec2 -> Vec2 -> Line
Line (Double -> Double -> Vec2
Vec2 (-Double
10) Double
0) (Double -> Double -> Vec2
Vec2 Double
10 Double
0))
            Line -> Render ()
forall a. Sketch a => a -> Render ()
D.sketch (Vec2 -> Vec2 -> Line
Line (Double -> Double -> Vec2
Vec2 Double
0 (-Double
10)) (Double -> Double -> Vec2
Vec2 Double
0 Double
10))
            Render ()
C.stroke
            Circle -> Render ()
forall a. Sketch a => a -> Render ()
D.sketch (Vec2 -> Double -> Circle
Circle Vec2
forall v. VectorSpace v => v
zero Double
10)
            Render ()
C.stroke
        drawDrawnShapeBB :: Render ()
drawDrawnShapeBB = Render () -> Render ()
forall a. Render a -> Render a
D.cairoScope (Render () -> Render ()) -> Render () -> Render ()
forall a b. (a -> b) -> a -> b
$ case PlottingSettings -> Maybe BoundingBox
_canvasBoundingBox PlottingSettings
settings of
            Maybe BoundingBox
_ | Bool -> Bool
not (PlottingSettings -> Bool
_previewDrawnShapesBoundingBox PlottingSettings
settings) -> () -> Render ()
forall a. a -> Render a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just BoundingBox
cbb | Bool -> Bool
not (PlottingState -> BoundingBox
_drawnBoundingBox PlottingState
finalState BoundingBox -> BoundingBox -> Bool
forall thing bigObject.
(HasBoundingBox thing, HasBoundingBox bigObject) =>
thing -> bigObject -> Bool
`insideBoundingBox` BoundingBox
cbb)
                -> Render ()
colorBad Render () -> Render () -> Render ()
forall a b. Render a -> Render b -> Render b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Double -> Render ()
C.setLineWidth Double
5 Render () -> Render () -> Render ()
forall a b. Render a -> Render b -> Render b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Polygon -> Render ()
forall a. Sketch a => a -> Render ()
D.sketch (BoundingBox -> Polygon
forall object. HasBoundingBox object => object -> Polygon
boundingBoxPolygon (PlottingState -> BoundingBox
_drawnBoundingBox PlottingState
finalState)) Render () -> Render () -> Render ()
forall a b. Render a -> Render b -> Render b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Render ()
C.stroke
            Just BoundingBox
bb -> Render ()
colorGood Render () -> Render () -> Render ()
forall a b. Render a -> Render b -> Render b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Polygon -> Render ()
forall a. Sketch a => a -> Render ()
D.sketch (BoundingBox -> Polygon
forall object. HasBoundingBox object => object -> Polygon
boundingBoxPolygon BoundingBox
bb) Render () -> Render () -> Render ()
forall a b. Render a -> Render b -> Render b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Render ()
C.stroke
            Maybe BoundingBox
_otherwise -> () -> Render ()
forall a. a -> Render a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        drawCanvasBB :: Render ()
drawCanvasBB = Render () -> Render ()
forall a. Render a -> Render a
D.cairoScope (Render () -> Render ()) -> Render () -> Render ()
forall a b. (a -> b) -> a -> b
$ case PlottingSettings -> Maybe BoundingBox
_canvasBoundingBox PlottingSettings
settings of
            Just BoundingBox
cbb -> Render ()
colorGood Render () -> Render () -> Render ()
forall a b. Render a -> Render b -> Render b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Polygon -> Render ()
forall a. Sketch a => a -> Render ()
D.sketch (BoundingBox -> Polygon
forall object. HasBoundingBox object => object -> Polygon
boundingBoxPolygon BoundingBox
cbb) Render () -> Render () -> Render ()
forall a b. Render a -> Render b -> Render b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Render ()
C.stroke
            Maybe BoundingBox
Nothing -> () -> Render ()
forall a. a -> Render a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Render ()
drawZeroMarker
    Render ()
drawCanvasBB
    Render ()
drawDrawnShapeBB

-- | Result of 'runPlot'; unifies convenience API and internals for tinkering.
data RunPlotResult = RunPlotResult
    { RunPlotResult -> [GCode]
_plotGCode :: [GCode]
        -- ^ The generated G code. Use 'writeGCodeFile' to store it to a file.

    , RunPlotResult -> Render ()
_plotPreview :: C.Render ()
        -- ^ Preview for the generated GCode. Use 'renderPreview' to convert it
        -- to an SVG or PNG file, or 'D.render' for more control in rendering.

    , RunPlotResult -> BoundingBox
_plotBoundingBox :: BoundingBox
        -- ^ The 'BoundingBox' of the resulting plot.

    , RunPlotResult -> BoundingBox
_totalBoundingBox :: BoundingBox
        -- ^ The total 'BoundingBox' of the preview, including origin and canvas.
        --
        -- Example to show the entire bounding box in the preview:
        --
        -- @
        -- let bb = '_plotBoundingBox' result
        --     (w, h) = 'boundingBoxSize' bb
        --     trafo = 'transformBoundingBox' bb ('BoundingBox' 'zero' ('Vec2' w h)) 'def'
        -- 'D.render' previewFileName w h $ do
        --     'C.transform ('D.toCairoMatrix' trafo)
        --     '_plotPreview' result
        -- @

    , RunPlotResult -> TinkeringInternals
_plotInternals :: TinkeringInternals
        -- ^ Internals calculated along the way. Useful for tinkering and testing.
    }

data TinkeringInternals = TinkeringInternals
    { TinkeringInternals -> PlottingSettings
_tinkeringSettings :: PlottingSettings -- ^ The settings used to run the plot.
    , TinkeringInternals -> PlottingWriterLog
_tinkeringWriterLog :: PlottingWriterLog
        -- ^ Writer log, decorated with information only available after the plot
        -- finishes. The GCode has header and footer, the Cairo preview includes
        -- bounding boxes, etc.
    , TinkeringInternals -> PlottingState
_tinkeringState :: PlottingState
        -- ^ Final state after running the plot. Includes data such as the
        -- total pen travel distance.
    }

writeGCodeFile :: FilePath -> RunPlotResult -> IO ()
writeGCodeFile :: [Char] -> RunPlotResult -> IO ()
writeGCodeFile [Char]
file = [Char] -> Text -> IO ()
TL.writeFile [Char]
file (Text -> IO ())
-> (RunPlotResult -> Text) -> RunPlotResult -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GCode] -> Text
renderGCode ([GCode] -> Text)
-> (RunPlotResult -> [GCode]) -> RunPlotResult -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunPlotResult -> [GCode]
_plotGCode

renderPreview
    :: FilePath
    -> Double -- ^ Output resolution in px/mm
    -> RunPlotResult
    -> IO ()
renderPreview :: [Char] -> Double -> RunPlotResult -> IO ()
renderPreview [Char]
file Double
pxPerMm RunPlotResult
result = do
    let bb :: BoundingBox
bb = RunPlotResult -> BoundingBox
_totalBoundingBox RunPlotResult
result
        (Double
w, Double
h) = let (Double
w',Double
h') = BoundingBox -> (Double, Double)
forall a. HasBoundingBox a => a -> (Double, Double)
boundingBoxSize (Double -> BoundingBox -> BoundingBox
forall boundingBox.
HasBoundingBox boundingBox =>
Double -> boundingBox -> BoundingBox
growBoundingBox Double
10 BoundingBox
bb)
                 in (Double
pxPerMmDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
w', Double
pxPerMmDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
h')
        trafo :: Transformation
trafo = BoundingBox -> BoundingBox -> TransformBBSettings -> Transformation
forall source target.
(HasBoundingBox source, HasBoundingBox target) =>
source -> target -> TransformBBSettings -> Transformation
transformBoundingBox BoundingBox
bb ([Vec2] -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox [Vec2
forall v. VectorSpace v => v
zero, Double -> Double -> Vec2
Vec2 Double
w Double
h]) TransformBBSettings
forall a. Default a => a
def
    [Char] -> Int -> Int -> Render () -> IO ()
D.render [Char]
file (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
w) (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
h) (Render () -> IO ()) -> Render () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        CoordinateSystem -> Render ()
D.coordinateSystem (Double -> CoordinateSystem
D.MathStandard_ZeroBottomLeft_XRight_YUp Double
h)
        Matrix -> Render ()
C.transform (Transformation -> Matrix
D.toCairoMatrix Transformation
trafo)
        Double -> Render ()
C.setLineWidth Double
1
        RunPlotResult -> Render ()
_plotPreview RunPlotResult
result

-- | Run the 'Plot' to easily generate the resulting GCode file. For convenience, this also generates a Cairo-based preview of the geometry.
--
-- @
-- let plotResult = 'runPlot' settings body
-- 'writeGCodeFile' "output.g" plotResult
-- 'renderPreview' "output.png" 3 plotResult
-- @
runPlot
    :: PlottingSettings
    -> Plot a
    -> RunPlotResult
runPlot :: forall a. PlottingSettings -> Plot a -> RunPlotResult
runPlot PlottingSettings
settings Plot a
body =
    let (a
_, PlottingState
finalState, PlottingWriterLog
writerLog) = RWS PlottingSettings PlottingWriterLog PlottingState a
-> PlottingSettings
-> PlottingState
-> (a, PlottingState, PlottingWriterLog)
forall r w s a. RWS r w s a -> r -> s -> (a, s, w)
runRWS RWS PlottingSettings PlottingWriterLog PlottingState a
body' PlottingSettings
settings PlottingState
initialState
        Plot RWS PlottingSettings PlottingWriterLog PlottingState a
body' = Plot a
body
        initialState :: PlottingState
initialState = PlottingState
            { _penState :: PenState
_penState = PenState
PenUp
            , _penXY :: Vec2
_penXY = Double -> Double -> Vec2
Vec2 (Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
0) (Double
1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
0) -- Nonsense value so we’re always misaligned in the beginning, making every move command actually move
            , _drawingDistance :: Double
_drawingDistance = Double
0
            , _drawnBoundingBox :: BoundingBox
_drawnBoundingBox = BoundingBox
forall a. Monoid a => a
mempty
            }

        decoratedGCode :: DList GCode
decoratedGCode = PlottingSettings
-> PlottingWriterLog -> PlottingState -> DList GCode
addHeaderFooter PlottingSettings
settings PlottingWriterLog
writerLog PlottingState
finalState

        decoratedCairoPreview :: Render ()
decoratedCairoPreview = Render () -> Render ()
forall a. Render a -> Render a
D.cairoScope (PlottingSettings -> PlottingState -> Render ()
decorateCairoPreview PlottingSettings
settings PlottingState
finalState Render () -> Render () -> Render ()
forall a b. Render a -> Render b -> Render b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PlottingWriterLog -> Render ()
_plottingCairoPreview PlottingWriterLog
writerLog)
        canvasBB :: Maybe BoundingBox
canvasBB = PlottingSettings -> Maybe BoundingBox
_canvasBoundingBox PlottingSettings
settings
        totalBB :: BoundingBox
totalBB = [BoundingBox] -> BoundingBox
forall a. Monoid a => [a] -> a
mconcat
            [ PlottingState -> BoundingBox
_drawnBoundingBox PlottingState
finalState
            , Maybe BoundingBox -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox Maybe BoundingBox
canvasBB
            , Vec2 -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox (Vec2
forall v. VectorSpace v => v
zero :: Vec2)
            ]

        decoratedWriterLog :: PlottingWriterLog
decoratedWriterLog = PlottingWriterLog
writerLog{_plottedGCode :: DList GCode
_plottedGCode=DList GCode
decoratedGCode, _plottingCairoPreview :: Render ()
_plottingCairoPreview=Render ()
decoratedCairoPreview}
    in RunPlotResult
        { _plotGCode :: [GCode]
_plotGCode = DList GCode -> [GCode]
forall a. DList a -> [a]
DL.toList DList GCode
decoratedGCode
        , _plotPreview :: Render ()
_plotPreview = Render ()
decoratedCairoPreview
        , _plotBoundingBox :: BoundingBox
_plotBoundingBox = PlottingState -> BoundingBox
_drawnBoundingBox PlottingState
finalState
        , _totalBoundingBox :: BoundingBox
_totalBoundingBox = BoundingBox
totalBB
        , _plotInternals :: TinkeringInternals
_plotInternals = TinkeringInternals
            { _tinkeringSettings :: PlottingSettings
_tinkeringSettings = PlottingSettings
settings
            , _tinkeringWriterLog :: PlottingWriterLog
_tinkeringWriterLog = PlottingWriterLog
decoratedWriterLog
            , _tinkeringState :: PlottingState
_tinkeringState = PlottingState
finalState
            }
        }

-- | Draw a shape by lowering the pen, setting the right speed, etc. The specifics
-- are defined in the configuration given in 'runPlot', or by the various utility
-- functions such as 'withFeedrate' or 'withDrawingHeight'
class Plotting a where
    plot :: a -> Plot ()

-- | Trace the bounding box without actually drawing anything to estimate result size
instance Plotting BoundingBox where
    plot :: BoundingBox -> Plot ()
plot (BoundingBox start :: Vec2
start@(Vec2 Double
xMin Double
yMin) (Vec2 Double
xMax Double
yMax)) = Text -> Plot () -> Plot ()
forall a. Text -> Plot a -> Plot a
commented Text
"Hover over bounding box" (Plot () -> Plot ()) -> Plot () -> Plot ()
forall a b. (a -> b) -> a -> b
$ do
        Vec2 -> Plot ()
repositionTo Vec2
start
        [GCode] -> Plot ()
gCode
            [ GCode
G93_Feedrate_TravelInFractionOfMinute
            , Double -> GCode
G04_Dwell_ms Double
500
            -- 60/n ==> n seconds to move
            , Maybe Double
-> Maybe Double -> Maybe Double -> Maybe Double -> GCode
G01_LinearFeedrateMove (Double -> Maybe Double
forall a. a -> Maybe a
Just (Double
60Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
3)) (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
xMax) (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
yMin) Maybe Double
forall a. Maybe a
Nothing
            , Double -> GCode
G04_Dwell_ms Double
500
            , Maybe Double
-> Maybe Double -> Maybe Double -> Maybe Double -> GCode
G01_LinearFeedrateMove (Double -> Maybe Double
forall a. a -> Maybe a
Just (Double
60Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
3)) (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
xMax) (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
yMax) Maybe Double
forall a. Maybe a
Nothing
            , Double -> GCode
G04_Dwell_ms Double
500
            , Maybe Double
-> Maybe Double -> Maybe Double -> Maybe Double -> GCode
G01_LinearFeedrateMove (Double -> Maybe Double
forall a. a -> Maybe a
Just (Double
60Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
3)) (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
xMin) (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
yMax) Maybe Double
forall a. Maybe a
Nothing
            , Double -> GCode
G04_Dwell_ms Double
500
            , Maybe Double
-> Maybe Double -> Maybe Double -> Maybe Double -> GCode
G01_LinearFeedrateMove (Double -> Maybe Double
forall a. a -> Maybe a
Just (Double
60Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
3)) (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
xMin) (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
yMin) Maybe Double
forall a. Maybe a
Nothing
            , GCode
G94_Feedrate_UnitsPerMinute
            ]

instance Plotting Line where
    plot :: Line -> Plot ()
plot (Line Vec2
a Vec2
b) = Text -> Plot () -> Plot ()
forall a. Text -> Plot a -> Plot a
commented Text
"Line" (Plot () -> Plot ()) -> Plot () -> Plot ()
forall a b. (a -> b) -> a -> b
$ do
        Vec2
current <- (PlottingState -> Vec2) -> Plot Vec2
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PlottingState -> Vec2
_penXY
        let (Vec2
start, Vec2
end) = if Vec2 -> Double
normSquare (Vec2
current Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
a) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Vec2 -> Double
normSquare (Vec2
current Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
b)
                then (Vec2
a,Vec2
b)
                else (Vec2
b,Vec2
a)
        Vec2 -> Plot ()
repositionTo Vec2
start
        Vec2 -> Plot ()
lineTo Vec2
end

instance Plotting Circle where
    plot :: Circle -> Plot ()
plot (Circle Vec2
center Double
radius) = Text -> Plot () -> Plot ()
forall a. Text -> Plot a -> Plot a
commented Text
"Circle" (Plot () -> Plot ()) -> Plot () -> Plot ()
forall a b. (a -> b) -> a -> b
$ do
        -- The naive way of painting a circle is by always starting them e.g.
        -- on the very left. This requires some unnecessary pen hovering, and
        -- for some pens creates a visible »pen down« dot. We therefore go the
        -- more complicated route here: start the circle at the point closest
        -- to the pen position. We only fall back to the naive way if the
        -- circles are very small.
        Vec2
current <- (PlottingState -> Vec2) -> Plot Vec2
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PlottingState -> Vec2
_penXY
        let distanceCenterCurrent2 :: Double
distanceCenterCurrent2 = Vec2 -> Double
normSquare (Vec2
center Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
current) -- Might be infinite if the current point isn’t defined yet!
            smartPaintThreshold :: Double
smartPaintThreshold = Double
0.1Double -> Integer -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
2
            radial :: Vec2
radial = if Double
smartPaintThreshold Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
distanceCenterCurrent2 Bool -> Bool -> Bool
&& Bool -> Bool
not (Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
distanceCenterCurrent2)
                then Double
radius Double -> Vec2 -> Vec2
forall v. VectorSpace v => Double -> v -> v
*. Line -> Vec2
direction (Vec2 -> Vec2 -> Line
Line Vec2
center Vec2
current)
                else Double -> Double -> Vec2
Vec2 Double
radius Double
0
            start :: Vec2
start = Vec2
center Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
+. Vec2
radial
            opposite :: Vec2
opposite = Vec2
center Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
radial

        -- FluidNC 3.4.2 has a bug where small circles (2mm radius) sometimes don’t
        -- do anything when we plot it with a single arc »from start to itself«. We
        -- work around this by explicitly chaining two half circles.
        Vec2 -> Plot ()
repositionTo Vec2
start
        Vec2 -> Vec2 -> Plot ()
clockwiseArcAroundTo Vec2
center Vec2
opposite
        Vec2 -> Vec2 -> Plot ()
clockwiseArcAroundTo Vec2
center Vec2
start

-- | Approximation by a number of points
instance Plotting Ellipse where
    plot :: Ellipse -> Plot ()
plot (Ellipse Transformation
trafo) = Text -> Plot () -> Plot ()
forall a. Text -> Plot a -> Plot a
commented Text
"Ellipse" (Plot () -> Plot ()) -> Plot () -> Plot ()
forall a b. (a -> b) -> a -> b
$ do
        Polygon -> Plot ()
forall a. Plotting a => a -> Plot ()
plot (Transformation -> Polygon -> Polygon
forall geo. Transform geo => Transformation -> geo -> geo
transform Transformation
trafo (Int -> Polygon
regularPolygon Int
64))

instance Plotting Polyline where
    plot :: Polyline -> Plot ()
plot (Polyline [Vec2]
xs) = Vector Vec2 -> Plot ()
go ([Vec2] -> Vector Vec2
forall a. [a] -> Vector a
forall (f :: * -> *) a. Sequential f => f a -> Vector a
toVector [Vec2]
xs)
      where
        go :: Vector Vec2 -> Plot ()
go Vector Vec2
points | Vector Vec2 -> Int
forall a. Vector a -> Int
V.length Vector Vec2
points Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 = () -> Plot ()
forall a. a -> Plot a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        go Vector Vec2
points = Text -> Plot () -> Plot ()
forall a. Text -> Plot a -> Plot a
commented Text
"Polyline" (Plot () -> Plot ()) -> Plot () -> Plot ()
forall a b. (a -> b) -> a -> b
$ do
            Vec2
current <- (PlottingState -> Vec2) -> Plot Vec2
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PlottingState -> Vec2
_penXY
            let pointsToPlot :: Vector Vec2
pointsToPlot = if Vec2 -> Double
normSquare (Vec2
current Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vector Vec2 -> Vec2
forall a. Vector a -> a
V.head Vector Vec2
points) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Vec2 -> Double
normSquare (Vec2
current Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vector Vec2 -> Vec2
forall a. Vector a -> a
V.last Vector Vec2
points)
                    then Vector Vec2
points
                    else Vector Vec2 -> Vector Vec2
forall a. Vector a -> Vector a
V.reverse Vector Vec2
points
                Just (Vec2
p,Vector Vec2
ointsToPlot) = Vector Vec2 -> Maybe (Vec2, Vector Vec2)
forall a. Vector a -> Maybe (a, Vector a)
V.uncons Vector Vec2
pointsToPlot
            Vec2 -> Plot ()
repositionTo Vec2
p
            (Vec2 -> Plot ()) -> Vector Vec2 -> Plot ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Vec2 -> Plot ()
lineTo Vector Vec2
ointsToPlot

-- | Draw each element (in order)
instance (Functor f, Sequential f, Plotting a) => Plotting (f a) where
    plot :: f a -> Plot ()
plot f a
x = Text -> Plot () -> Plot ()
forall a. Text -> Plot a -> Plot a
commented Text
"Sequential" ((a -> Plot ()) -> f a -> Plot ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ a -> Plot ()
forall a. Plotting a => a -> Plot ()
plot f a
x)

-- | Draw each element (in order)
instance (Plotting a, Plotting b) => Plotting (a,b) where
    plot :: (a, b) -> Plot ()
plot (a
a,b
b) = Text -> Plot () -> Plot ()
forall a. Text -> Plot a -> Plot a
commented Text
"2-tuple" (a -> Plot ()
forall a. Plotting a => a -> Plot ()
plot a
a Plot () -> Plot () -> Plot ()
forall a b. Plot a -> Plot b -> Plot b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> Plot ()
forall a. Plotting a => a -> Plot ()
plot b
b)

-- | Draw each element (in order)
instance (Plotting a, Plotting b, Plotting c) => Plotting (a,b,c) where
    plot :: (a, b, c) -> Plot ()
plot (a
a,b
b,c
c) = Text -> Plot () -> Plot ()
forall a. Text -> Plot a -> Plot a
commented Text
"3-tuple" (a -> Plot ()
forall a. Plotting a => a -> Plot ()
plot a
a Plot () -> Plot () -> Plot ()
forall a b. Plot a -> Plot b -> Plot b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> Plot ()
forall a. Plotting a => a -> Plot ()
plot b
b Plot () -> Plot () -> Plot ()
forall a b. Plot a -> Plot b -> Plot b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> c -> Plot ()
forall a. Plotting a => a -> Plot ()
plot c
c)

-- | Draw each element (in order)
instance (Plotting a, Plotting b, Plotting c, Plotting d) => Plotting (a,b,c,d) where
    plot :: (a, b, c, d) -> Plot ()
plot (a
a,b
b,c
c,d
d) = Text -> Plot () -> Plot ()
forall a. Text -> Plot a -> Plot a
commented Text
"4-tuple" (a -> Plot ()
forall a. Plotting a => a -> Plot ()
plot a
a Plot () -> Plot () -> Plot ()
forall a b. Plot a -> Plot b -> Plot b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> Plot ()
forall a. Plotting a => a -> Plot ()
plot b
b Plot () -> Plot () -> Plot ()
forall a b. Plot a -> Plot b -> Plot b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> c -> Plot ()
forall a. Plotting a => a -> Plot ()
plot c
c Plot () -> Plot () -> Plot ()
forall a b. Plot a -> Plot b -> Plot b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> d -> Plot ()
forall a. Plotting a => a -> Plot ()
plot d
d)

-- | Draw each element (in order)
instance (Plotting a, Plotting b, Plotting c, Plotting d, Plotting e) => Plotting (a,b,c,d,e) where
    plot :: (a, b, c, d, e) -> Plot ()
plot (a
a,b
b,c
c,d
d,e
e) = Text -> Plot () -> Plot ()
forall a. Text -> Plot a -> Plot a
commented Text
"5-tuple" (a -> Plot ()
forall a. Plotting a => a -> Plot ()
plot a
a Plot () -> Plot () -> Plot ()
forall a b. Plot a -> Plot b -> Plot b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> Plot ()
forall a. Plotting a => a -> Plot ()
plot b
b Plot () -> Plot () -> Plot ()
forall a b. Plot a -> Plot b -> Plot b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> c -> Plot ()
forall a. Plotting a => a -> Plot ()
plot c
c Plot () -> Plot () -> Plot ()
forall a b. Plot a -> Plot b -> Plot b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> d -> Plot ()
forall a. Plotting a => a -> Plot ()
plot d
d Plot () -> Plot () -> Plot ()
forall a b. Plot a -> Plot b -> Plot b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> e -> Plot ()
forall a. Plotting a => a -> Plot ()
plot e
e)

instance Plotting Polygon where
    -- Like polyline, but closes up the shape
    plot :: Polygon -> Plot ()
plot (Polygon []) = () -> Plot ()
forall a. a -> Plot a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    plot (Polygon [Vec2]
corners) = Text -> Plot () -> Plot ()
forall a. Text -> Plot a -> Plot a
commented Text
"Polygon" (Plot () -> Plot ()) -> Plot () -> Plot ()
forall a b. (a -> b) -> a -> b
$ do
        Vec2
current <- (PlottingState -> Vec2) -> Plot Vec2
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PlottingState -> Vec2
_penXY
        let Just Vec2
closestCorner = (Vec2 -> Double) -> [Vec2] -> Maybe Vec2
forall (f :: * -> *) ord a.
(Foldable f, Ord ord) =>
(a -> ord) -> f a -> Maybe a
minimumOn (\Vec2
corner -> Vec2 -> Double
norm (Vec2
current Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
corner)) [Vec2]
corners
            ([Vec2]
before, [Vec2]
after) = (Vec2 -> Bool) -> [Vec2] -> ([Vec2], [Vec2])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Vec2 -> Vec2 -> Bool
forall a. Eq a => a -> a -> Bool
== Vec2
closestCorner) [Vec2]
corners
            Vec2
r:[Vec2]
eorderedCorners = [Vec2]
after [Vec2] -> [Vec2] -> [Vec2]
forall a. [a] -> [a] -> [a]
++ [Vec2]
before

        Vec2 -> Plot ()
repositionTo Vec2
r
        (Vec2 -> Plot ()) -> [Vec2] -> Plot ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Vec2 -> Plot ()
lineTo [Vec2]
eorderedCorners
        Vec2 -> Plot ()
lineTo Vec2
r

-- | FluidNC doesn’t support G05, so we approximate Bezier curves with line pieces.
-- We use the naive Bezier interpolation 'bezierSubdivideEquiparametric', because it just so
-- happens to put more points in places with more curvature.
instance Plotting Bezier where
    plot :: Bezier -> Plot ()
plot Bezier
bezier = Text -> Plot () -> Plot ()
forall a. Text -> Plot a -> Plot a
commented Text
"Bezier (cubic)" (Plot () -> Plot ()) -> Plot () -> Plot ()
forall a b. (a -> b) -> a -> b
$ do
        let points :: [Vec2]
points = Int -> Bezier -> [Vec2]
bezierSubdivideEquiparametric Int
32 Bezier
bezier
        let Vec2
p:[Vec2]
ointsToPlot = [Vec2]
points
        Vec2 -> Plot ()
repositionTo Vec2
p
        (Vec2 -> Plot ()) -> [Vec2] -> Plot ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Vec2 -> Plot ()
lineTo [Vec2]
ointsToPlot

minimumOn :: (Foldable f, Ord ord) => (a -> ord) -> f a -> Maybe a
minimumOn :: forall (f :: * -> *) ord a.
(Foldable f, Ord ord) =>
(a -> ord) -> f a -> Maybe a
minimumOn a -> ord
f f a
xs
    | f a -> Bool
forall a. f a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null f a
xs = Maybe a
forall a. Maybe a
Nothing
    | Bool
otherwise = a -> Maybe a
forall a. a -> Maybe a
Just ((a -> a -> Ordering) -> f a -> a
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (\a
x a
y -> ord -> ord -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (a -> ord
f a
x) (a -> ord
f a
y)) f a
xs)

data MinimizePenHoveringSettings a = MinimizePenHoveringSettings
    { forall a. MinimizePenHoveringSettings a -> a -> (Vec2, Vec2)
_getStartEndPoint :: a -> (Vec2, Vec2)
    , forall a. MinimizePenHoveringSettings a -> Maybe (a -> a)
_flipObject :: Maybe (a -> a)
    , forall a.
MinimizePenHoveringSettings a -> Maybe (a -> a -> Maybe a)
_mergeObjects :: Maybe (a -> a -> Maybe a)
    }

-- | Similar to 'minimizePenHovering', but for arbitrary objects with a given start and end point.
minimizePenHoveringBy :: Ord a => MinimizePenHoveringSettings a -> S.Set a -> [a]
minimizePenHoveringBy :: forall a. Ord a => MinimizePenHoveringSettings a -> Set a -> [a]
minimizePenHoveringBy MinimizePenHoveringSettings a
settings = Vec2 -> Set a -> [a]
sortStep Vec2
forall v. VectorSpace v => v
zero (Set a -> [a]) -> (Set a -> Set a) -> Set a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> Set a
mergeStep
  where
    distanceNorm :: Vec2 -> a -> Double
distanceNorm = case MinimizePenHoveringSettings a -> Maybe (a -> a)
forall a. MinimizePenHoveringSettings a -> Maybe (a -> a)
_flipObject MinimizePenHoveringSettings a
settings of
        Maybe (a -> a)
Nothing -> \Vec2
penPos a
object -> let (Vec2
a, Vec2
_) = MinimizePenHoveringSettings a -> a -> (Vec2, Vec2)
forall a. MinimizePenHoveringSettings a -> a -> (Vec2, Vec2)
_getStartEndPoint MinimizePenHoveringSettings a
settings a
object in Vec2 -> Double
norm (Vec2
a Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
penPos)
        Just a -> a
_  -> \Vec2
penPos a
object -> let (Vec2
a, Vec2
b) = MinimizePenHoveringSettings a -> a -> (Vec2, Vec2)
forall a. MinimizePenHoveringSettings a -> a -> (Vec2, Vec2)
_getStartEndPoint MinimizePenHoveringSettings a
settings a
object in Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (Vec2 -> Double
norm (Vec2
a Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
penPos)) (Vec2 -> Double
norm (Vec2
b Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
penPos))
    reverseDistanceNorm :: Vec2 -> a -> Double
reverseDistanceNorm = case MinimizePenHoveringSettings a -> Maybe (a -> a)
forall a. MinimizePenHoveringSettings a -> Maybe (a -> a)
_flipObject MinimizePenHoveringSettings a
settings of
        Maybe (a -> a)
Nothing -> \Vec2
penPos a
object -> let (Vec2
_, Vec2
b) = MinimizePenHoveringSettings a -> a -> (Vec2, Vec2)
forall a. MinimizePenHoveringSettings a -> a -> (Vec2, Vec2)
_getStartEndPoint MinimizePenHoveringSettings a
settings a
object in Vec2 -> Double
norm (Vec2
b Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
penPos)
        Just a -> a
_  -> \Vec2
penPos a
object -> let (Vec2
a, Vec2
b) = MinimizePenHoveringSettings a -> a -> (Vec2, Vec2)
forall a. MinimizePenHoveringSettings a -> a -> (Vec2, Vec2)
_getStartEndPoint MinimizePenHoveringSettings a
settings a
object in Double -> Double -> Double
forall a. Ord a => a -> a -> a
min (Vec2 -> Double
norm (Vec2
a Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
penPos)) (Vec2 -> Double
norm (Vec2
b Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
penPos))
    rightWayRound :: Vec2 -> a -> (a, Vec2)
rightWayRound = case MinimizePenHoveringSettings a -> Maybe (a -> a)
forall a. MinimizePenHoveringSettings a -> Maybe (a -> a)
_flipObject MinimizePenHoveringSettings a
settings of
        Maybe (a -> a)
Nothing -> \Vec2
_ a
object ->
            let (Vec2
_, Vec2
b) = MinimizePenHoveringSettings a -> a -> (Vec2, Vec2)
forall a. MinimizePenHoveringSettings a -> a -> (Vec2, Vec2)
_getStartEndPoint MinimizePenHoveringSettings a
settings a
object
            in  (a
object, Vec2
b)
        Just a -> a
flipObject -> \Vec2
penPos a
object ->
            let (Vec2
a, Vec2
b) = MinimizePenHoveringSettings a -> a -> (Vec2, Vec2)
forall a. MinimizePenHoveringSettings a -> a -> (Vec2, Vec2)
_getStartEndPoint MinimizePenHoveringSettings a
settings a
object
            in  if Vec2 -> Double
norm (Vec2
a Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
penPos) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Vec2 -> Double
norm (Vec2
b Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
penPos)
                then (a -> a
flipObject a
object, Vec2
a)
                else (a
object, Vec2
b)
    reverseRightWayRound :: Vec2 -> a -> a
reverseRightWayRound = case MinimizePenHoveringSettings a -> Maybe (a -> a)
forall a. MinimizePenHoveringSettings a -> Maybe (a -> a)
_flipObject MinimizePenHoveringSettings a
settings of
        Maybe (a -> a)
Nothing -> \Vec2
_ a
object -> a
object
        Just a -> a
flipObject -> \Vec2
penPos a
object ->
            let (Vec2
a, Vec2
b) = MinimizePenHoveringSettings a -> a -> (Vec2, Vec2)
forall a. MinimizePenHoveringSettings a -> a -> (Vec2, Vec2)
_getStartEndPoint MinimizePenHoveringSettings a
settings a
object
            in  if Vec2 -> Double
norm (Vec2
a Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
penPos) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Vec2 -> Double
norm (Vec2
b Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
penPos)
                then a -> a
flipObject a
object
                else a
object
    -- Sort by minimal travel between adjacent lines
    sortStep :: Vec2 -> Set a -> [a]
sortStep Vec2
penPos Set a
pool =
        let closestNextObject :: Maybe a
closestNextObject = (a -> Double) -> Set a -> Maybe a
forall (f :: * -> *) ord a.
(Foldable f, Ord ord) =>
(a -> ord) -> f a -> Maybe a
minimumOn (Vec2 -> a -> Double
distanceNorm Vec2
penPos) Set a
pool
        in case Maybe a
closestNextObject of
            Maybe a
Nothing -> []
            Just a
object ->
                let (a
object', Vec2
end) = Vec2 -> a -> (a, Vec2)
rightWayRound Vec2
penPos a
object
                    remainingPool :: Set a
remainingPool = a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.delete a
object Set a
pool
                    newPenPos :: Vec2
newPenPos = Vec2
end
                in a
object' a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Vec2 -> Set a -> [a]
sortStep Vec2
newPenPos Set a
remainingPool
    mergeStep :: Set a -> Set a
mergeStep = case MinimizePenHoveringSettings a -> Maybe (a -> a -> Maybe a)
forall a.
MinimizePenHoveringSettings a -> Maybe (a -> a -> Maybe a)
_mergeObjects MinimizePenHoveringSettings a
settings of
        Maybe (a -> a -> Maybe a)
Nothing -> Set a -> Set a
forall a. a -> a
id
        Just a -> a -> Maybe a
merge -> \Set a
pool -> Set a -> Set a -> Set a
go Set a
pool Set a
forall a. Set a
S.empty
          where
            go :: Set a -> Set a -> Set a
go Set a
pool Set a
result =
                let closestNextObject :: Maybe a
closestNextObject = (a -> Double) -> Set a -> Maybe a
forall (f :: * -> *) ord a.
(Foldable f, Ord ord) =>
(a -> ord) -> f a -> Maybe a
minimumOn (Vec2 -> a -> Double
distanceNorm Vec2
forall v. VectorSpace v => v
zero) Set a
pool
                in case Maybe a
closestNextObject of
                    Maybe a
Nothing -> Set a
result
                    Just a
object ->
                        let result' :: Set a
result' = a -> Set a -> Set a
tryMerge a
object Set a
result
                        in  Set a -> Set a -> Set a
go (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.delete a
object Set a
pool) Set a
result'
            tryMerge :: a -> Set a -> Set a
tryMerge a
object Set a
pool =
                let (Vec2
a, Vec2
b) = MinimizePenHoveringSettings a -> a -> (Vec2, Vec2)
forall a. MinimizePenHoveringSettings a -> a -> (Vec2, Vec2)
_getStartEndPoint MinimizePenHoveringSettings a
settings a
object
                    closestNextObject :: Maybe a
closestNextObject = (a -> Double) -> Set a -> Maybe a
forall (f :: * -> *) ord a.
(Foldable f, Ord ord) =>
(a -> ord) -> f a -> Maybe a
minimumOn (Vec2 -> a -> Double
distanceNorm Vec2
b) Set a
pool
                    closestPreviousObject :: Maybe a
closestPreviousObject = (a -> Double) -> Set a -> Maybe a
forall (f :: * -> *) ord a.
(Foldable f, Ord ord) =>
(a -> ord) -> f a -> Maybe a
minimumOn (Vec2 -> a -> Double
reverseDistanceNorm Vec2
a) Set a
pool
                in case (Maybe a
closestPreviousObject, Maybe a
closestNextObject) of
                    (Just a
prevObject, Just a
nextObject) -- missing link between two objects
                        | Just a
object' <- a -> a -> Maybe a
merge (Vec2 -> a -> a
reverseRightWayRound Vec2
a a
prevObject) a
object, Just a
object'' <- a -> a -> Maybe a
merge a
object' ((a, Vec2) -> a
forall a b. (a, b) -> a
fst ((a, Vec2) -> a) -> (a, Vec2) -> a
forall a b. (a -> b) -> a -> b
$ Vec2 -> a -> (a, Vec2)
rightWayRound Vec2
b a
nextObject)
                        -> a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.insert a
object'' (Set a -> Set a) -> (Set a -> Set a) -> Set a -> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.delete a
prevObject (Set a -> Set a) -> (Set a -> Set a) -> Set a -> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.delete a
nextObject (Set a -> Set a) -> Set a -> Set a
forall a b. (a -> b) -> a -> b
$ Set a
pool
                    (Just a
prevObject, Maybe a
_) -- object can be appended
                        | Just a
object' <- a -> a -> Maybe a
merge (Vec2 -> a -> a
reverseRightWayRound Vec2
a a
prevObject) a
object
                        -> a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.insert a
object' (Set a -> Set a) -> (Set a -> Set a) -> Set a -> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.delete a
prevObject (Set a -> Set a) -> Set a -> Set a
forall a b. (a -> b) -> a -> b
$ Set a
pool
                    (Maybe a
_, Just a
nextObject) -- object can be prepended
                        | Just a
object' <- a -> a -> Maybe a
merge a
object ((a, Vec2) -> a
forall a b. (a, b) -> a
fst ((a, Vec2) -> a) -> (a, Vec2) -> a
forall a b. (a -> b) -> a -> b
$ Vec2 -> a -> (a, Vec2)
rightWayRound Vec2
b a
nextObject)
                        -> a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.insert a
object' (Set a -> Set a) -> (Set a -> Set a) -> Set a -> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.delete a
nextObject (Set a -> Set a) -> Set a -> Set a
forall a b. (a -> b) -> a -> b
$ Set a
pool
                    (Maybe a, Maybe a)
_otherwise
                        -> a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.insert a
object Set a
pool

-- | Sort a collection of polylines so that between each line pair, we only do the shortest move.
-- This is a local solution to what would be TSP if solved globally. Better than nothing I guess,
-- although this algorithm here is \(\mathcal O(n^2)\).
minimizePenHovering
    :: Sequential vector
    => S.Set (vector Vec2) -- ^ Elements of this set will be sorted in optimized order. The elements themselves remain untouched.
    -> [Vector Vec2]
minimizePenHovering :: forall (vector :: * -> *).
Sequential vector =>
Set (vector Vec2) -> [Vector Vec2]
minimizePenHovering = [Vector Vec2] -> [Vector Vec2]
mergeStep ([Vector Vec2] -> [Vector Vec2])
-> (Set (vector Vec2) -> [Vector Vec2])
-> Set (vector Vec2)
-> [Vector Vec2]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vec2 -> Set (Vector Vec2) -> [Vector Vec2]
sortStep (Double -> Double -> Vec2
Vec2 Double
0 Double
0) (Set (Vector Vec2) -> [Vector Vec2])
-> (Set (vector Vec2) -> Set (Vector Vec2))
-> Set (vector Vec2)
-> [Vector Vec2]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (vector Vec2 -> Vector Vec2)
-> Set (vector Vec2) -> Set (Vector Vec2)
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map vector Vec2 -> Vector Vec2
forall a. vector a -> Vector a
forall (f :: * -> *) a. Sequential f => f a -> Vector a
toVector
  where
    -- Sort by minimal travel between adjacent lines
    sortStep :: Vec2 -> S.Set (Vector Vec2) -> [Vector Vec2]
    sortStep :: Vec2 -> Set (Vector Vec2) -> [Vector Vec2]
sortStep Vec2
penPos Set (Vector Vec2)
pool =
        let closestNextLine :: Maybe (Vector Vec2)
closestNextLine = (Vector Vec2 -> Double) -> Set (Vector Vec2) -> Maybe (Vector Vec2)
forall (f :: * -> *) ord a.
(Foldable f, Ord ord) =>
(a -> ord) -> f a -> Maybe a
minimumOn (\Vector Vec2
candidate -> Vec2 -> Double
normSquare (Vector Vec2 -> Vec2
forall a. Vector a -> a
V.head Vector Vec2
candidate Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
penPos) Double -> Double -> Double
forall a. Ord a => a -> a -> a
`min` Vec2 -> Double
normSquare (Vector Vec2 -> Vec2
forall a. Vector a -> a
V.last Vector Vec2
candidate Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
penPos)) Set (Vector Vec2)
pool
        in case Maybe (Vector Vec2)
closestNextLine of
            Maybe (Vector Vec2)
Nothing -> []
            Just Vector Vec2
l ->
                let rightWayRound :: Vector Vec2
rightWayRound = if Vec2 -> Double
normSquare (Vector Vec2 -> Vec2
forall a. Vector a -> a
V.head Vector Vec2
l Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
penPos) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Vec2 -> Double
normSquare (Vector Vec2 -> Vec2
forall a. Vector a -> a
V.last Vector Vec2
l Vec2 -> Vec2 -> Vec2
forall v. VectorSpace v => v -> v -> v
-. Vec2
penPos)
                        then Vector Vec2 -> Vector Vec2
forall a. Vector a -> Vector a
V.reverse Vector Vec2
l
                        else Vector Vec2
l
                    remainingPool :: Set (Vector Vec2)
remainingPool = Vector Vec2 -> Set (Vector Vec2) -> Set (Vector Vec2)
forall a. Ord a => a -> Set a -> Set a
S.delete Vector Vec2
l Set (Vector Vec2)
pool
                    newPenPos :: Vec2
newPenPos = Vector Vec2 -> Vec2
forall a. Vector a -> a
V.last Vector Vec2
rightWayRound
                in Vector Vec2
rightWayRound Vector Vec2 -> [Vector Vec2] -> [Vector Vec2]
forall a. a -> [a] -> [a]
: Vec2 -> Set (Vector Vec2) -> [Vector Vec2]
sortStep Vec2
newPenPos Set (Vector Vec2)
remainingPool

    -- Merge adjacent polylines
    mergeStep :: [Vector Vec2] -> [Vector Vec2]
    mergeStep :: [Vector Vec2] -> [Vector Vec2]
mergeStep (Vector Vec2
t1:Vector Vec2
t2:[Vector Vec2]
rest) = case (Vector Vec2 -> Maybe (Vector Vec2, Vec2)
forall a. Vector a -> Maybe (Vector a, a)
V.unsnoc Vector Vec2
t1, Vector Vec2 -> Maybe (Vec2, Vector Vec2)
forall a. Vector a -> Maybe (a, Vector a)
V.uncons Vector Vec2
t2) of
        (Just (Vector Vec2
_t1Init, Vec2
t1Last), Just (Vec2
t2Head, Vector Vec2
t2Tail))
            | Vec2
t1Last Vec2 -> Vec2 -> Bool
forall a. Eq a => a -> a -> Bool
== Vec2
t2Head -> [Vector Vec2] -> [Vector Vec2]
mergeStep (Vector Vec2
t1 Vector Vec2 -> Vector Vec2 -> Vector Vec2
forall a. Semigroup a => a -> a -> a
<> Vector Vec2
t2TailVector Vec2 -> [Vector Vec2] -> [Vector Vec2]
forall a. a -> [a] -> [a]
:[Vector Vec2]
rest)
        (Maybe (Vector Vec2, Vec2), Maybe (Vec2, Vector Vec2))
_ -> Vector Vec2
t1 Vector Vec2 -> [Vector Vec2] -> [Vector Vec2]
forall a. a -> [a] -> [a]
: [Vector Vec2] -> [Vector Vec2]
mergeStep (Vector Vec2
t2Vector Vec2 -> [Vector Vec2] -> [Vector Vec2]
forall a. a -> [a] -> [a]
:[Vector Vec2]
rest)
    mergeStep [Vector Vec2]
other = [Vector Vec2]
other