├── .envrc ├── .github └── workflows │ └── ci.yaml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── app └── Main.hs ├── ci.dhall ├── ci.sh ├── default.nix ├── examples ├── Cat.hs ├── Limits.hs ├── Main.hs ├── Minimal.hs ├── Modify.hs ├── Naive.hs ├── Pretty.hs ├── Rotate.hs ├── Simple.hs ├── ToOrigin.hs └── Translate.hs ├── gcodehs.cabal ├── sample.gcode ├── shell.nix ├── src └── Data │ ├── GCode.hs │ └── GCode │ ├── Ann.hs │ ├── Canon.hs │ ├── Canon │ └── Convert.hs │ ├── Eval.hs │ ├── Generate.hs │ ├── Generate │ ├── Examples.hs │ └── ExamplesMonad.hs │ ├── Line.hs │ ├── Monad.hs │ ├── Parse.hs │ ├── Pipes.hs │ ├── Pipes │ └── Transform.hs │ ├── Pretty.hs │ ├── RS274.hs │ ├── RS274 │ └── Types.hs │ ├── TH.hs │ ├── Types.hs │ └── Utils.hs └── test ├── EvalSpec.hs ├── GenSpec.hs ├── ParseSpec.hs ├── Spec.hs └── SpecHelper.hs /.envrc: -------------------------------------------------------------------------------- 1 | use nix 2 | -------------------------------------------------------------------------------- /.github/workflows/ci.yaml: -------------------------------------------------------------------------------- 1 | # Code generated by dhall-to-yaml. DO NOT EDIT. 2 | jobs: 3 | build: 4 | name: "GHC ${{ matrix.ghc }}, Cabal ${{ matrix.cabal }}, OS ${{ matrix.os }}" 5 | "runs-on": "${{ matrix.os }}" 6 | steps: 7 | - uses: "actions/checkout@v4" 8 | with: 9 | submodules: recursive 10 | - id: "setup-haskell-cabal" 11 | uses: "haskell-actions/setup@v2" 12 | with: 13 | "cabal-version": "${{ matrix.cabal }}" 14 | "ghc-version": "${{ matrix.ghc }}" 15 | - name: Update Hackage repository 16 | run: cabal update 17 | - name: cabal.project.local.ci 18 | run: | 19 | if [ -e cabal.project.local.ci ]; then 20 | cp cabal.project.local.ci cabal.project.local 21 | fi 22 | - name: freeze 23 | run: "cabal freeze --enable-tests --enable-benchmarks" 24 | - uses: "actions/cache@v3" 25 | with: 26 | key: "${{ matrix.os }}-${{ matrix.ghc }}-${{ matrix.cabal}}-${{ hashFiles('cabal.project.freeze') }}" 27 | path: | 28 | ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 29 | dist-newstyle 30 | - name: Install dependencies 31 | run: "cabal build all --enable-tests --enable-benchmarks --only-dependencies" 32 | - name: build all 33 | run: "cabal build all --enable-tests --enable-benchmarks" 34 | - name: test all 35 | run: "cabal test all --enable-tests" 36 | - name: haddock all 37 | run: cabal haddock all 38 | strategy: 39 | matrix: 40 | cabal: 41 | - '3.10' 42 | ghc: 43 | - '9.6.3' 44 | os: 45 | - "ubuntu-latest" 46 | name: Haskell CI 47 | 'on': 48 | pull_request: {} 49 | push: {} 50 | schedule: 51 | - cron: "4 20 10 * *" 52 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | attic/* 2 | dist 3 | dist-newstyle 4 | result* 5 | .stack-work 6 | *.prof 7 | .ghc.* 8 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Version [0.1.2.0](https://github.com/distrap/gcodehs/compare/0.1.1.0...0.1.2.0) (2020-06-17) 2 | 3 | * Changelog started. Previous release was `0.1.1.0`. 4 | 5 | * Major rework, only core functionality and types unchanged 6 | * Little changes to parser and pretty printer, APIs unchaged 7 | 8 | * Additions 9 | * Canonical representation `Data.GCode.Canon` 10 | * Interepreters for both `GCode` and canonical representation 11 | * Line output 12 | * Tests 13 | * Helpers and monad for generating GCode 14 | * Pipes now exposed from library via `Data.GCode.Pipes` 15 | * `Data.GCode.RS274.Types` module with command decriptions 16 | 17 | --- 18 | 19 | `gcodehs` uses [PVP Versioning][1]. 20 | 21 | [1]: https://pvp.haskell.org 22 | 23 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Richard Marko (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # gcodehs 2 | 3 | [![GitHub Workflow Status](https://img.shields.io/github/actions/workflow/status/distrap/gcodehs/ci.yaml?branch=master)](https://github.com/distrap/gcodehs/actions/workflows/ci.yaml) 4 | [![Hackage version](https://img.shields.io/hackage/v/gcodehs.svg?color=success)](https://hackage.haskell.org/package/gcodehs) 5 | [![Dependencies](https://img.shields.io/hackage-deps/v/gcodehs?label=Dependencies)](https://packdeps.haskellers.com/feed?needle=gcodehs) 6 | 7 | ## Installing 8 | 9 | * `git clone https://github.com/distrap/gcodehs/` 10 | * `cd gcodehs` 11 | * `nix-build` or `nix-shell` 12 | 13 | ## Usage 14 | 15 | To pretty-print `sample.gcode`:: 16 | 17 | ```bash 18 | gcodehs pretty sample.gcode 19 | ``` 20 | 21 | See `gcodehs --help` for usage information. 22 | 23 | ## Development status 24 | 25 | Pretty printing is slow due to conversion 26 | to text but we do have colors! 27 | 28 | Fast pretty printer is needed that operates 29 | with ByteStrings directly. 30 | 31 | ## Bash completion 32 | 33 | Generating bash completion:: 34 | 35 | ```bash 36 | gcodehs --bash-completion-script `which gcodehs` &> gcodehs-completion.sh 37 | ``` 38 | 39 | or sourcing directly:: 40 | 41 | ```bash 42 | source <(gcodehs --bash-completion-script `which gcodehs`) 43 | ``` 44 | 45 | ## Examples 46 | 47 | ### Generating GCode 48 | 49 | * [with monoid](src/Data/GCode/Canon/Generate/Examples.hs) 50 | * [with monad](src/Data/GCode/Canon/Generate/ExamplesMonad.hs) 51 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Main where 4 | 5 | 6 | import Pipes (Pipe, (>->)) 7 | import Pipes.Safe (SafeT) 8 | import Data.ByteString (ByteString) 9 | 10 | import Control.Applicative 11 | import Options.Applicative 12 | 13 | import Data.GCode 14 | import Data.GCode.Pipes.Transform 15 | import Data.GCode.Line (prettyLine) 16 | 17 | data Command = 18 | Cat 19 | | Pretty 20 | | Analyze 21 | | Totalize 22 | | TranslateXY Double Double 23 | | TranslateZ Double 24 | | Rotate Double 25 | | ScaleFeedrate Double 26 | | ScaleXY Double Double 27 | | Eval 28 | | Canon 29 | | Lines 30 | -- TODO 31 | | TravelDistance 32 | | ExtrusionDistance 33 | | Generate 34 | -- disabled for now as they require interepreter not just looking at coords 35 | -- (due to relative moves) 36 | | Limits 37 | | ToOrigin 38 | deriving (Eq, Show, Ord) 39 | 40 | data Options = Options { 41 | cmd :: Command 42 | , input :: FilePath 43 | , output :: Maybe FilePath 44 | } deriving (Show) 45 | 46 | cmdParser :: Parser Command 47 | cmdParser = subparser 48 | ( command "cat" (info (pure Cat) (progDesc "Parse and print GCode")) 49 | <> command "pretty" (info (pure Pretty) (progDesc "Parse and pretty-print GCode")) 50 | -- <> command "limits" (info (pure Limits) (progDesc "Compute axis movements limits")) 51 | -- <> command "move-to-origin" (info (pure ToOrigin) (progDesc "Move GCode so it starts at X0 Y0")) 52 | <> command "totalize" (info (pure Totalize) (progDesc "Walk GCode adding missing axes coordinates according to previous moves")) 53 | <> command "translate-xy" (info (TranslateXY <$> argument auto (metavar "X") <*> argument auto (metavar "Y")) (progDesc "Translate GCode by X Y offsets")) 54 | <> command "translate-z" (info (TranslateZ <$> argument auto (metavar "Z")) (progDesc "Translate GCode by Z offset")) 55 | <> command "rotate" (info (Rotate <$> argument auto (metavar "DEG")) (progDesc "Rotate GCode by angle in degrees")) 56 | <> command "scale-feedrate" (info (ScaleFeedrate <$> argument auto (metavar "MULTIPLIER")) (progDesc "Scale feedrates by multiplier")) 57 | <> command "scale-xy" (info (ScaleXY <$> argument auto (metavar "X") <*> argument auto (metavar "Y")) (progDesc "Scale X/Y by multiplier")) 58 | <> command "eval" (info (pure Eval) (progDesc "Evaluate GCode")) 59 | <> command "canon" (info (pure Canon) (progDesc "Convert to canonical representation")) 60 | <> command "lines" (info (pure Lines) (progDesc "Convert to lines")) 61 | ) 62 | 63 | flags :: Parser Options 64 | flags = Options 65 | <$> cmdParser 66 | <*> argument str (metavar "INPUT-FILE") 67 | <*> (optional 68 | $ strOption ( 69 | long "output" 70 | <> short 'o' 71 | <> metavar "OUTPUT-FILE")) 72 | 73 | main :: IO () 74 | main = 75 | execParser opts >>= \Options{..} -> runPipe input output (toSink cmd) 76 | where 77 | opts = info (helper <*> flags) 78 | ( fullDesc 79 | <> progDesc "Process GCode from FILE" 80 | <> header "gcodehs - GCode processor" ) 81 | 82 | toSink :: Command -> Pipe Code ByteString (SafeT IO) () 83 | toSink Cat = compactSink 84 | toSink Pretty = prettySink 85 | toSink Totalize = totalizeP >-> compactSink 86 | toSink Eval = evalP >-> prettySink 87 | toSink Canon = evalP >-> evalCanonP >-> prettySinkWith (wrapPrinter show) 88 | toSink Lines = evalP >-> evalCanonLinesP >-> (prettySinkWith $ wrapPrinter $ prettyLine defaultStyle) 89 | 90 | toSink (TranslateXY xt yt) = translateXY xt yt >-> compactSink 91 | toSink (TranslateZ zt) = translateZ zt >-> compactSink 92 | toSink (ScaleXY xs ys) = scaleXY xs ys >-> compactSink 93 | toSink (ScaleFeedrate s) = scaleFeedrate s >-> compactSink 94 | toSink (Rotate a) = rotate a >-> compactSink 95 | 96 | toSink _ = error "Currently not supported, sorry :(" 97 | -------------------------------------------------------------------------------- /ci.dhall: -------------------------------------------------------------------------------- 1 | let haskellCi = 2 | https://raw.githubusercontent.com/sorki/github-actions-dhall/main/haskell-ci.dhall 3 | 4 | in haskellCi.defaultCi 5 | -------------------------------------------------------------------------------- /ci.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # Script by @fisx 3 | 4 | set -eo pipefail 5 | cd "$( dirname "${BASH_SOURCE[0]}" )" 6 | 7 | echo "regenerating .github/workflows/ci.yaml" 8 | mkdir -p .github/workflows 9 | 10 | which dhall-to-yaml-ng || cabal install dhall-yaml 11 | dhall-to-yaml-ng --generated-comment --file ci.dhall > .github/workflows/ci.yaml 12 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import {}}: 2 | nixpkgs.haskell.lib.buildFromSdist 3 | (nixpkgs.haskellPackages.callCabal2nix "gcodehs" ./. { }) 4 | -------------------------------------------------------------------------------- /examples/Cat.hs: -------------------------------------------------------------------------------- 1 | import Data.GCode 2 | 3 | import Pipes 4 | import Pipes.Attoparsec as PA 5 | import qualified Pipes.Prelude as P 6 | import qualified Pipes.ByteString as B 7 | import Pipes.Safe 8 | import qualified System.IO as IO 9 | import qualified System.Environment as E 10 | 11 | bufsize = 1024 12 | 13 | main :: IO () 14 | main = do 15 | file <- fmap Prelude.head E.getArgs 16 | IO.withFile file IO.ReadMode $ \handle -> 17 | runSafeT . runEffect $ 18 | (() <$ PA.parsed parseGCodeLine (B.hGetSome bufsize handle) ) 19 | >-> P.map ppGCodeLineCompact 20 | >-> P.stdoutLn 21 | -------------------------------------------------------------------------------- /examples/Limits.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | import Data.GCode 4 | 5 | import Pipes 6 | import Pipes.Attoparsec as PA 7 | import qualified Pipes.Prelude as P 8 | import qualified Pipes.ByteString as B 9 | import Pipes.Safe 10 | import qualified System.IO as IO 11 | import qualified System.Environment as E 12 | 13 | import Formatting (sformat) 14 | import Formatting.ShortFormatters 15 | 16 | import Data.Map as M 17 | import Data.Text as T 18 | import Data.Text.IO as TIO 19 | 20 | bufsize = 1024 21 | 22 | -- compute gcode limits 23 | 24 | ppLimit (ax, (low, high)) = T.intercalate " " [T.pack $ show ax, (sformat sf low), (sformat sf high)] 25 | foldLimits = P.fold (\s x -> updateLimitsCode s x) M.empty id 26 | 27 | 28 | main :: IO () 29 | main = do 30 | file <- fmap Prelude.head E.getArgs 31 | a <- IO.withFile file IO.ReadMode $ \handle -> 32 | runSafeT . runEffect $ 33 | foldLimits (() <$ PA.parsed parseGCodeLine (B.hGetSome bufsize handle)) 34 | 35 | mapM_ (TIO.putStrLn . ppLimit) $ M.toList a 36 | -------------------------------------------------------------------------------- /examples/Main.hs: -------------------------------------------------------------------------------- 1 | import Data.GCode 2 | 3 | import Pipes 4 | import Pipes.Attoparsec as PA 5 | import qualified Pipes.Prelude as P 6 | import qualified Pipes.ByteString as B 7 | import Pipes.Safe 8 | import qualified System.IO as IO 9 | import qualified System.Environment as E 10 | 11 | bufsize = 1024 12 | 13 | main :: IO () 14 | main = do 15 | file <- fmap Prelude.head E.getArgs 16 | IO.withFile file IO.ReadMode $ \handle -> 17 | runSafeT . runEffect $ 18 | (() <$ PA.parsed parseGCodeLine (B.hGetSome bufsize handle) ) 19 | >-> P.filter isRapid 20 | >-> P.filter hasFeedrate 21 | >-> P.map (replaceFeedrate 666) 22 | >-> P.map (replaceY 3.14) 23 | >-> P.map (addReplaceZ 48) 24 | >-> P.map ppGCodeLine 25 | >-> P.stdoutLn 26 | -------------------------------------------------------------------------------- /examples/Minimal.hs: -------------------------------------------------------------------------------- 1 | import Data.GCode 2 | 3 | import Pipes 4 | import Pipes.Attoparsec as PA 5 | import qualified Pipes.Prelude as P 6 | import qualified Pipes.ByteString as B 7 | import Pipes.Safe 8 | import qualified System.IO as IO 9 | import qualified System.Environment as E 10 | 11 | bufsize = 1024 12 | 13 | main :: IO () 14 | main = do 15 | file <- fmap Prelude.head E.getArgs 16 | IO.withFile file IO.ReadMode $ \handle -> 17 | runSafeT . runEffect $ 18 | (() <$ PA.parsed parseGCodeLine (B.hGetSome bufsize handle) ) 19 | >-> P.filter isRapid 20 | >-> P.filter hasFeedrate 21 | >-> P.map (replaceFeedrate 666) 22 | >-> P.map (replaceY 3.14) 23 | >-> P.map (addReplaceZ 48) 24 | >-> P.map ppGCodeLine 25 | -- or 26 | -- >-> P.map ppGCodeLineCompact 27 | >-> P.stdoutLn 28 | -- 29 | -- non-streaming version, will eat a lot of ram 30 | --main = do 31 | -- file <- fmap Prelude.head getArgs 32 | -- f <- BS.readFile file 33 | -- case parseOnlyGCode f of 34 | -- Left err -> print err 35 | -- Right result -> BS.putStr $ BS.pack $ ppGCode result 36 | -------------------------------------------------------------------------------- /examples/Modify.hs: -------------------------------------------------------------------------------- 1 | import Data.GCode 2 | 3 | import Pipes 4 | import Pipes.Attoparsec as PA 5 | import qualified Pipes.Prelude as P 6 | import qualified Pipes.ByteString as B 7 | import Pipes.Safe 8 | import qualified System.IO as IO 9 | import qualified System.Environment as E 10 | 11 | import GHC.Base 12 | 13 | bufsize = 1024 14 | 15 | -- complex modify 16 | 17 | main :: IO () 18 | main = do 19 | file <- fmap Prelude.head E.getArgs 20 | IO.withFile file IO.ReadMode $ \handle -> 21 | runSafeT . runEffect $ 22 | (() <$ PA.parsed parseGCodeLine (B.hGetSome bufsize handle) ) 23 | >-> P.filter (liftM2 (||) isRapid isMove) 24 | -- >-> P.filter (isRapid) 25 | >-> P.map (modifyFeedrate (pure 666)) 26 | -- >-> P.map (replaceY 3.14) 27 | -- >-> P.map (modifyAxes [X,Z] (*1000)) 28 | -- >-> P.map (modifyXY (\x y -> (x**2, y-100))) 29 | >-> P.map (modifyXY (rot (2.5*pi/2))) 30 | -- >-> P.map ppGCodeLine 31 | >-> P.map ppGCodeLineCompact 32 | >-> P.stdoutLn 33 | -------------------------------------------------------------------------------- /examples/Naive.hs: -------------------------------------------------------------------------------- 1 | import Data.GCode 2 | 3 | import qualified System.IO as IO 4 | import qualified System.Environment as E 5 | 6 | import qualified Data.ByteString.Char8 as BS 7 | 8 | -- non-streaming version, will eat a lot of ram 9 | -- if used on bigger files, only for demo purposes 10 | main = do 11 | file <- fmap Prelude.head E.getArgs 12 | f <- BS.readFile file 13 | case parseOnlyGCode f of 14 | Left err -> print err 15 | Right result -> BS.putStr $ BS.pack $ ppGCode result 16 | -------------------------------------------------------------------------------- /examples/Pretty.hs: -------------------------------------------------------------------------------- 1 | import Data.GCode 2 | 3 | import Pipes 4 | import Pipes.Attoparsec as PA 5 | import qualified Pipes.Prelude as P 6 | import qualified Pipes.ByteString as B 7 | import Pipes.Safe 8 | import qualified System.IO as IO 9 | import qualified System.Environment as E 10 | 11 | bufsize = 1024 12 | 13 | main :: IO () 14 | main = do 15 | file <- fmap Prelude.head E.getArgs 16 | IO.withFile file IO.ReadMode $ \handle -> 17 | runSafeT . runEffect $ 18 | (() <$ PA.parsed parseGCodeLine (B.hGetSome bufsize handle) ) 19 | >-> P.map ppGCodeLine 20 | >-> P.stdoutLn 21 | -------------------------------------------------------------------------------- /examples/Rotate.hs: -------------------------------------------------------------------------------- 1 | import Data.GCode 2 | 3 | import Pipes 4 | import Pipes.Attoparsec as PA 5 | import qualified Pipes.Prelude as P 6 | import qualified Pipes.ByteString as B 7 | import Pipes.Safe 8 | import qualified System.IO as IO 9 | import qualified System.Environment as E 10 | 11 | import GHC.Base 12 | 13 | bufsize = 1024 14 | 15 | -- rotate by angle 16 | angle = 90 17 | 18 | main :: IO () 19 | main = do 20 | file <- fmap Prelude.head E.getArgs 21 | IO.withFile file IO.ReadMode $ \handle -> 22 | runSafeT . runEffect $ 23 | (() <$ PA.parsed parseGCodeLine (B.hGetSome bufsize handle) ) 24 | >-> P.map (modifyXY (rot (angle*pi/180))) 25 | >-> P.map ppGCodeLineCompact 26 | >-> P.stdoutLn 27 | -------------------------------------------------------------------------------- /examples/Simple.hs: -------------------------------------------------------------------------------- 1 | import Data.GCode 2 | 3 | import Pipes 4 | import Pipes.Attoparsec as PA 5 | import qualified Pipes.Prelude as P 6 | import qualified Pipes.ByteString as B 7 | import Pipes.Safe 8 | import qualified System.IO as IO 9 | import qualified System.Environment as E 10 | 11 | bufsize = 1024 12 | 13 | main :: IO () 14 | main = do 15 | file <- fmap Prelude.head E.getArgs 16 | IO.withFile file IO.ReadMode $ \handle -> 17 | runSafeT . runEffect $ 18 | (() <$ PA.parsed parseGCodeLine (B.hGetSome bufsize handle) ) 19 | >-> P.map ppGCodeLineCompact 20 | >-> P.stdoutLn 21 | -------------------------------------------------------------------------------- /examples/ToOrigin.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | import Data.GCode 4 | 5 | import Pipes 6 | import Pipes.Attoparsec as PA 7 | import qualified Pipes.Prelude as P 8 | import qualified Pipes.ByteString as B 9 | import Pipes.Safe 10 | import qualified System.IO as IO 11 | import qualified System.Environment as E 12 | 13 | import Formatting (sformat) 14 | import Formatting.ShortFormatters 15 | 16 | import Data.Map as M 17 | import Data.Text as T 18 | import Data.Text.IO as TIO 19 | 20 | bufsize = 1024 21 | 22 | ppLimit (ax, (low, high)) = T.intercalate " " [T.pack $ show ax, (sformat sf low), (sformat sf high)] 23 | foldLimits = P.fold (\s x -> updateLimitsCode s x) M.empty id 24 | 25 | 26 | 27 | main :: IO () 28 | main = do 29 | file <- fmap Prelude.head E.getArgs 30 | lim <- IO.withFile file IO.ReadMode $ \handle -> 31 | runSafeT . runEffect $ 32 | foldLimits (() <$ PA.parsed parseGCodeLine (B.hGetSome bufsize handle) ) 33 | 34 | case (M.lookup X lim, M.lookup Y lim) of 35 | (Just (xmin, xmax), Just (ymin, ymax)) -> do 36 | let mov = \x y -> (x - xmin, y - ymin) 37 | 38 | IO.withFile file IO.ReadMode $ \handle -> 39 | runSafeT . runEffect $ 40 | (() <$ PA.parsed parseGCodeLine (B.hGetSome bufsize handle) ) 41 | >-> P.map (modifyXY (mov)) 42 | >-> P.map ppGCodeLineCompact 43 | >-> P.stdoutLn 44 | _ -> do TIO.putStrLn "X or Y limit(s) not found" 45 | 46 | -------------------------------------------------------------------------------- /examples/Translate.hs: -------------------------------------------------------------------------------- 1 | import Data.GCode 2 | 3 | import Pipes 4 | import Pipes.Attoparsec as PA 5 | import qualified Pipes.Prelude as P 6 | import qualified Pipes.ByteString as B 7 | import Pipes.Safe 8 | import qualified System.IO as IO 9 | import qualified System.Environment as E 10 | 11 | import GHC.Base 12 | 13 | bufsize = 1024 14 | 15 | -- translate X asix coordinates by +10, y -100 16 | 17 | main :: IO () 18 | main = do 19 | file <- fmap Prelude.head E.getArgs 20 | IO.withFile file IO.ReadMode $ \handle -> 21 | runSafeT . runEffect $ 22 | (() <$ PA.parsed parseGCodeLine (B.hGetSome bufsize handle) ) 23 | >-> P.map (modifyXY (\x y -> (x + 10, y - 100))) 24 | >-> P.map ppGCodeLineCompact 25 | >-> P.stdoutLn 26 | -------------------------------------------------------------------------------- /gcodehs.cabal: -------------------------------------------------------------------------------- 1 | name: gcodehs 2 | version: 0.1.2.0 3 | synopsis: GCode processor 4 | description: GCode parser, pretty-printer and processing utils 5 | homepage: https://github.com/distrap/gcodehs 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Richard Marko 9 | maintainer: srk@48.io 10 | copyright: 2016 Richard Marko 11 | category: Parsing 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | extra-source-files: 15 | CHANGELOG.md 16 | README.md 17 | LICENSE 18 | 19 | library 20 | ghc-options: -Wall 21 | hs-source-dirs: src 22 | exposed-modules: Data.GCode 23 | , Data.GCode.Ann 24 | , Data.GCode.Canon 25 | , Data.GCode.Canon.Convert 26 | , Data.GCode.Generate 27 | , Data.GCode.Generate.Examples 28 | , Data.GCode.Generate.ExamplesMonad 29 | , Data.GCode.Eval 30 | , Data.GCode.Line 31 | , Data.GCode.Monad 32 | , Data.GCode.Types 33 | , Data.GCode.Parse 34 | , Data.GCode.Pipes 35 | , Data.GCode.Pipes.Transform 36 | , Data.GCode.Pretty 37 | , Data.GCode.RS274 38 | , Data.GCode.RS274.Types 39 | , Data.GCode.TH 40 | , Data.GCode.Utils 41 | build-depends: base >= 4.7 && < 5 42 | , attoparsec 43 | , ansi-wl-pprint 44 | , bytestring 45 | , containers 46 | , transformers 47 | , double-conversion 48 | , text 49 | , template-haskell 50 | , pipes 51 | , pipes-attoparsec 52 | , pipes-bytestring 53 | -- , pipes-bytestring-mmap 54 | , pipes-safe 55 | , pipes-parse 56 | default-language: Haskell2010 57 | 58 | executable gcodehs 59 | hs-source-dirs: app 60 | main-is: Main.hs 61 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 62 | build-depends: base 63 | , bytestring 64 | , gcodehs 65 | , pipes 66 | , pipes-safe 67 | , optparse-applicative 68 | default-language: Haskell2010 69 | 70 | test-suite gcodehs-test 71 | type: exitcode-stdio-1.0 72 | hs-source-dirs: test 73 | main-is: Spec.hs 74 | other-modules: ParseSpec 75 | GenSpec 76 | EvalSpec 77 | SpecHelper 78 | build-depends: base 79 | , attoparsec 80 | , bytestring 81 | , gcodehs 82 | , hspec 83 | 84 | build-tool-depends: hspec-discover:hspec-discover 85 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall 86 | default-language: Haskell2010 87 | 88 | source-repository head 89 | type: git 90 | location: https://github.com/distrap/gcodehs 91 | -------------------------------------------------------------------------------- /sample.gcode: -------------------------------------------------------------------------------- 1 | ( pcb2gcode 1.2.1 ) 2 | ( Software-independent Gcode ) 3 | 4 | G94 ( Millimeters per minute feed rate. ) 5 | G21 ( Units == Millimeters. ) 6 | 7 | G90 ( Absolute coordinates. ) 8 | G00 Z2.00000 9 | S30000 10 | 11 | G00 X2.05580 Y31.49440 F9000 ( rapid move to begin. ) 12 | F200 13 | G01 Z-0.05000 14 | G01 X2.05580 Y31.49440 F600.00000 15 | G01 X2.28440 Y31.34200 F600.00000 16 | G01 X2.43680 Y31.08800 F600.00000 17 | G01 X2.51300 Y30.75780 F600.00000 18 | G01 X2.48760 Y30.47840 F600.00000 19 | G01 X14.47640 Y14.01920 F600.00000 20 | G01 X14.67960 Y14.01920 F600.00000 21 | G01 X14.80660 Y13.94300 F600.00000 22 | G01 X14.80660 Y13.58740 F600.00000 23 | G01 X14.52720 Y13.46040 F600.00000 24 | G01 X14.01920 Y13.46040 F600.00000 25 | G01 X13.79060 Y13.63820 F600.00000 26 | G01 X13.71440 Y13.76520 F600.00000 27 | G01 X13.71440 Y14.57800 F600.00000 28 | G01 X13.76520 Y14.73040 F600.00000 29 | G01 X13.99380 Y14.90820 F600.00000 30 | G01 X14.57800 Y14.93360 F600.00000 31 | G00 Z2.00000 F200 ( retract ) 32 | 33 | G00 X2.05580 Y13.71440 F9000 ( rapid move to begin. ) 34 | G01 Z-0.05000 35 | G01 X2.05580 Y13.71440 F600.00000 36 | G01 X2.28440 Y13.56200 F600.00000 37 | G01 X2.36060 Y13.43500 F600.00000 38 | G01 X3.98620 Y13.43500 F600.00000 39 | G01 X4.31640 Y13.35880 F600.00000 40 | G01 X4.49420 Y13.13020 F600.00000 41 | G01 X4.54500 Y12.97780 F600.00000 42 | G01 X4.54500 Y12.11420 F600.00000 43 | G01 X5.96740 Y12.11420 F600.00000 44 | G01 X6.29760 Y12.19040 F600.00000 45 | G01 X8.07560 Y12.13960 F600.00000 46 | G01 X8.20260 Y12.06340 F600.00000 47 | G01 X8.35500 Y11.80940 F600.00000 48 | G01 X13.18100 Y7.08500 F600.00000 49 | G01 X13.46040 Y7.05960 F600.00000 50 | G01 X13.58740 Y6.98340 F600.00000 51 | G01 X13.84140 Y6.98340 F600.00000 52 | G01 X13.84140 Y6.06900 F600.00000 53 | G01 X13.76520 Y6.04360 F600.00000 54 | G01 X13.73980 Y3.83380 F600.00000 55 | G01 X13.68900 Y3.78300 F600.00000 56 | G01 X13.68900 Y3.47820 F600.00000 57 | G01 X13.61280 Y3.45280 F600.00000 58 | G01 X13.63820 Y3.27500 F600.00000 59 | G01 X25.60160 Y3.30040 F600.00000 60 | G01 X25.62700 Y5.51020 F600.00000 61 | G01 X25.80480 Y5.73880 F600.00000 62 | G01 X26.13500 Y5.81500 F600.00000 63 | G01 X27.93840 Y5.84040 F600.00000 64 | G01 X28.01460 Y5.96740 F600.00000 65 | G01 X28.26860 Y6.11980 F600.00000 66 | G01 X28.59880 Y6.19600 F600.00000 67 | G01 X29.20840 Y6.19600 F600.00000 68 | G01 X29.46240 Y6.14520 F600.00000 69 | G01 X29.69100 Y5.96740 F600.00000 70 | G01 X29.86880 Y5.73880 F600.00000 71 | G01 X29.94500 Y5.40860 F600.00000 72 | G01 X29.94500 Y5.05300 F600.00000 73 | G01 X29.86880 Y4.72280 F600.00000 74 | G01 X29.69100 Y4.49420 F600.00000 75 | G01 X29.43700 Y4.34180 F600.00000 76 | G01 X29.08140 Y4.29100 F600.00000 77 | G01 X28.67500 Y4.29100 F600.00000 78 | G01 X28.31940 Y4.34180 F600.00000 79 | G01 X28.06540 Y4.49420 F600.00000 80 | G01 X27.91300 Y4.64660 F600.00000 81 | G01 X26.79540 Y4.64660 F600.00000 82 | G01 X26.79540 Y3.27500 F600.00000 83 | G01 X27.91300 Y3.27500 F600.00000 84 | G01 X27.98920 Y3.40200 F600.00000 85 | G01 X28.21780 Y3.57980 F600.00000 86 | G01 X28.54800 Y3.65600 F600.00000 87 | G01 X29.33540 Y3.63060 F600.00000 88 | G01 X29.61480 Y3.50360 F600.00000 89 | G01 X29.81800 Y3.30040 F600.00000 90 | G01 X29.94500 Y3.02100 F600.00000 91 | G01 X29.97040 Y2.64000 F600.00000 92 | G01 X29.91960 Y2.28440 F600.00000 93 | G01 X29.76720 Y2.03040 F600.00000 94 | G01 X29.53860 Y1.85260 F600.00000 95 | G01 X29.23380 Y1.75100 F600.00000 96 | G01 X28.26860 Y1.80180 F600.00000 97 | G01 X27.93840 Y2.08120 F600.00000 98 | G01 X12.72380 Y2.10660 F600.00000 99 | G01 X12.44440 Y2.23360 F600.00000 100 | G01 X12.34280 Y2.33520 F600.00000 101 | G01 X12.26660 Y2.66540 F600.00000 102 | G01 X12.26660 Y2.86860 F600.00000 103 | G01 X12.31740 Y3.02100 F600.00000 104 | G01 X12.41900 Y3.12260 F600.00000 105 | G01 X12.44440 Y3.45280 F600.00000 106 | G01 X12.34280 Y3.45280 F600.00000 107 | G01 X12.34280 Y4.46880 F600.00000 108 | G01 X12.59680 Y4.51960 F600.00000 109 | G01 X12.59680 Y5.94200 F600.00000 110 | G01 X12.44440 Y5.99280 F600.00000 111 | G01 X7.56760 Y10.86960 F600.00000 112 | G01 X6.37380 Y10.89500 F600.00000 113 | G01 X6.01820 Y10.94580 F600.00000 114 | G01 X4.54500 Y10.94580 F600.00000 115 | G01 X4.51960 Y7.51680 F600.00000 116 | G01 X4.34180 Y7.28820 F600.00000 117 | G01 X4.21480 Y7.21200 F600.00000 118 | G01 X2.41140 Y7.18660 F600.00000 119 | G01 X2.00500 Y6.88180 F600.00000 120 | G01 X1.64940 Y6.83100 F600.00000 121 | G01 X1.03980 Y6.83100 F600.00000 122 | G01 X0.73500 Y6.93260 F600.00000 123 | G01 X0.50640 Y7.11040 F600.00000 124 | G01 X0.35400 Y7.36440 F600.00000 125 | G01 X0.30320 Y7.72000 F600.00000 126 | G01 X0.32860 Y8.10100 F600.00000 127 | G01 X0.45560 Y8.38040 F600.00000 128 | G01 X0.65880 Y8.58360 F600.00000 129 | G01 X0.93820 Y8.71060 F600.00000 130 | G01 X1.72560 Y8.73600 F600.00000 131 | G01 X2.05580 Y8.65980 F600.00000 132 | G01 X2.28440 Y8.48200 F600.00000 133 | G01 X2.36060 Y8.35500 F600.00000 134 | G01 X3.37660 Y8.35500 F600.00000 135 | G01 X3.37660 Y9.72660 F600.00000 136 | G01 X2.36060 Y9.72660 F600.00000 137 | G01 X2.15740 Y9.52340 F600.00000 138 | G01 X1.87800 Y9.39640 F600.00000 139 | G01 X1.09060 Y9.37100 F600.00000 140 | G01 X0.76040 Y9.44720 F600.00000 141 | G01 X0.53180 Y9.62500 F600.00000 142 | G01 X0.37940 Y9.87900 F600.00000 143 | G01 X0.30320 Y10.20920 F600.00000 144 | G01 X0.32860 Y10.59020 F600.00000 145 | G01 X0.45560 Y10.86960 F600.00000 146 | G01 X0.63340 Y11.09820 F600.00000 147 | G01 X0.81120 Y11.22520 F600.00000 148 | G01 X1.16680 Y11.27600 F600.00000 149 | G01 X1.77640 Y11.27600 F600.00000 150 | G01 X2.08120 Y11.17440 F600.00000 151 | G01 X2.30980 Y10.99660 F600.00000 152 | G01 X2.33520 Y10.92040 F600.00000 153 | G01 X3.37660 Y10.89500 F600.00000 154 | G01 X3.37660 Y12.26660 F600.00000 155 | G01 X2.36060 Y12.26660 F600.00000 156 | G01 X2.15740 Y12.06340 F600.00000 157 | G01 X1.87800 Y11.93640 F600.00000 158 | G01 X1.09060 Y11.91100 F600.00000 159 | G01 X0.76040 Y11.98720 F600.00000 160 | G01 X0.53180 Y12.16500 F600.00000 161 | G01 X0.37940 Y12.41900 F600.00000 162 | G01 X0.30320 Y12.74920 F600.00000 163 | G01 X0.32860 Y13.13020 F600.00000 164 | G01 X0.45560 Y13.40960 F600.00000 165 | G01 X0.63340 Y13.63820 F600.00000 166 | G01 X0.81120 Y13.76520 F600.00000 167 | G01 X1.16680 Y13.81600 F600.00000 168 | G01 X1.77640 Y13.81600 F600.00000 169 | G01 X2.05580 Y13.73980 F600.00000 170 | G00 Z2.00000 F200 ( retract ) 171 | 172 | G00 X21.30900 Y6.98340 F9000 ( rapid move to begin. ) 173 | G01 Z-0.05000 174 | G01 X21.30900 Y6.98340 F600.00000 175 | G01 X21.30900 Y5.99280 F600.00000 176 | G01 X20.92800 Y5.96740 F600.00000 177 | G01 X20.77560 Y5.91660 F600.00000 178 | G01 X18.54040 Y5.91660 F600.00000 179 | G01 X18.18480 Y6.06900 F600.00000 180 | G01 X18.08320 Y6.37380 F600.00000 181 | G01 X18.10860 Y6.75480 F600.00000 182 | G01 X18.18480 Y6.88180 F600.00000 183 | G01 X18.18480 Y6.98340 F600.00000 184 | G01 X18.28640 Y6.98340 F600.00000 185 | G01 X18.41340 Y7.05960 F600.00000 186 | G01 X20.82640 Y7.08500 F600.00000 187 | G01 X20.97880 Y7.03420 F600.00000 188 | G01 X21.28360 Y7.03420 F600.00000 189 | G00 Z2.00000 F200 ( retract ) 190 | 191 | G00 X17.54980 Y4.44340 F9000 ( rapid move to begin. ) 192 | G01 Z-0.05000 193 | G01 X17.54980 Y4.44340 F600.00000 194 | G01 X17.62600 Y4.44340 F600.00000 195 | G01 X17.72760 Y4.24020 F600.00000 196 | G01 X17.72760 Y3.68140 F600.00000 197 | G01 X17.54980 Y3.45280 F600.00000 198 | G01 X17.21960 Y3.37660 F600.00000 199 | G01 X15.18760 Y3.37660 F600.00000 200 | G01 X14.85740 Y3.45280 F600.00000 201 | G01 X14.55260 Y3.45280 F600.00000 202 | G01 X14.52720 Y4.49420 F600.00000 203 | G01 X14.93360 Y4.49420 F600.00000 204 | G01 X15.08600 Y4.54500 F600.00000 205 | G01 X17.32120 Y4.54500 F600.00000 206 | G01 X17.54980 Y4.46880 F600.00000 207 | 208 | G04 P0 ( dwell for no time -- G64 should not smooth over this point ) 209 | G00 Z2.00000 ( retract ) 210 | 211 | M5 ( Spindle off. ) 212 | M9 ( Coolant off. ) 213 | M2 ( Program end. ) 214 | 215 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import {}}: 2 | (import ./default.nix { inherit nixpkgs; }).env 3 | -------------------------------------------------------------------------------- /src/Data/GCode.hs: -------------------------------------------------------------------------------- 1 | {-| This module is an entry point to @gcodehs@ library 2 | 3 | This module re-exports most of the "Data.GCode" submodules. 4 | 5 | -} 6 | 7 | module Data.GCode ( 8 | module Data.GCode.Ann 9 | , module Data.GCode.Eval 10 | , module Data.GCode.Types 11 | , module Data.GCode.Parse 12 | , module Data.GCode.Pipes 13 | , module Data.GCode.Pretty 14 | , module Data.GCode.Utils 15 | ) where 16 | 17 | import Data.GCode.Ann 18 | import Data.GCode.Eval 19 | import Data.GCode.Types 20 | import Data.GCode.Parse 21 | import Data.GCode.Pipes 22 | import Data.GCode.Pretty 23 | import Data.GCode.Utils 24 | -------------------------------------------------------------------------------- /src/Data/GCode/Ann.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | 3 | module Data.GCode.Ann ( 4 | Ann(..) 5 | , stripAnnotation 6 | ) where 7 | 8 | {- 9 | Type for annotating `Code` or `Canon` with source positions. 10 | -} 11 | 12 | 13 | data Ann a = SrcLine Integer a 14 | deriving (Show, Eq, Ord, Functor) 15 | 16 | stripAnnotation :: Ann a -> a 17 | stripAnnotation (SrcLine _ x) = x 18 | -------------------------------------------------------------------------------- /src/Data/GCode/Canon.hs: -------------------------------------------------------------------------------- 1 | {- Canonnical representation 2 | 3 | Our IR 4 | (work in progress) 5 | -} 6 | 7 | module Data.GCode.Canon where 8 | 9 | import Data.ByteString (ByteString) 10 | import Data.GCode.Types (Axes, zeroAxes) 11 | 12 | import qualified Data.Map 13 | 14 | data Plane = XY | YZ | ZX | UV | WU | VW 15 | deriving (Show, Eq, Ord) 16 | 17 | data CutterCompenstationSide = 18 | CutterCompensationRight 19 | | CutterCompensationLeft 20 | | CutterCompensationOff 21 | deriving (Show, Eq, Ord) 22 | 23 | type Speed = Double 24 | type Seconds = Double 25 | 26 | data RotationDirection = ClockWise | CounterClockWise 27 | deriving (Show, Eq, Ord) 28 | 29 | data LengthUnit = Inches | MilliMeters | CentiMeters | Meters 30 | deriving (Show, Eq, Ord) 31 | 32 | data HeaterType = HeatedExtruder | HeatedBed | HeatedChamber 33 | deriving (Show, Eq, Ord) 34 | 35 | -- | Some heater with id or Nothing for current / default 36 | data Heater = Heater HeaterType (Maybe Int) 37 | deriving (Show, Eq, Ord) 38 | 39 | -- | Tool length compensation 40 | data CompensationMode = 41 | NoCompensation -- ^ Tool length compensation is disabled 42 | | LengthTable -- ^ Following moves will take into account tool offset from tool table 43 | | Dynamic Axes -- ^ Apply dynamic offset 44 | | Add Int -- ^ Add tool offset of the tool specified by the parameter to currently selected tool offset 45 | deriving (Show, Eq, Ord) 46 | 47 | -- Like linxucnc arcs, not used, subject to change 48 | data ArcParams = ArcParams { 49 | arcFirstEnd :: Double -- ^ first second coordinates according to selected plane 50 | , arcSecondEnd :: Double 51 | , arcFirstAxis :: Double 52 | , arcSecondAxis :: Double 53 | , arcRotation :: Int 54 | , arcAxisEndPoint :: Double 55 | , arcA :: Double 56 | , arcB :: Double 57 | , arcC :: Double 58 | , arcU :: Double 59 | , arcV :: Double 60 | , arcW :: Double 61 | } deriving (Eq, Show, Ord) 62 | 63 | data Canon = 64 | StraightTraverse Axes -- ^ Rapid motion to end position specified by Axes 65 | | StraightFeed Axes -- ^ Machining motion 66 | | StraightProbe Axes -- ^ Straight probe towards workpeice 67 | | SetCoords Axes -- ^ Set coordinates to provided values without motion 68 | | ArcFeed ArcParams -- ^ Movement along arc 69 | | ProgramEnd -- ^ End of the program 70 | | SetFeedRate Speed -- ^ Set feed rate for machining moves 71 | | SetTraverseRate Speed -- ^ Set feed rate for travel moves 72 | | PlaneSelect Plane -- ^ Set plane 73 | | PauseSeconds Double -- ^ Do nothing for specified number of seconds 74 | | SpindleStart { 75 | spindleDirection :: RotationDirection -- ^ Rotate spindle according to `RotationDirection` 76 | , spindleWaitForSpeed :: Bool -- ^ Wait for spindle to reach desired RPM 77 | } 78 | | SpindleStop -- ^ Stop spindle 79 | | SpindleSpeed Speed -- ^ Set spindle RPM 80 | | CoolantMist -- ^ Enable mist coolant 81 | | CoolantFlood -- ^ Enable flood coolant 82 | | CoolantStop -- ^ Stop all coolant flows 83 | -- Tools 84 | | ToolSelect Int -- ^ Select tool by its index 85 | | ToolChange -- ^ Perform tool change 86 | | ToolLengthCompensation CompensationMode -- ^ Enable tool length compensation 87 | -- Printer 88 | | FanOn -- ^ Enable fan 89 | | FanOff -- ^ Disable fan 90 | | SetTemperature Heater Double -- ^ Set temperature of the specific heater 91 | | SetTemperatureWait Heater Double -- ^ Set temperature and wait for it to be reached 92 | | CancelWaitTemperature -- ^ Cancel all temperature waits 93 | | LevelBed -- ^ Perform automated bed leveling 94 | -- Misc 95 | | DisableMotors Axes -- ^ Disable power to motors 96 | | DisplayMessage ByteString -- ^ Display a message, typically on LCD 97 | | Comment ByteString -- ^ Just a comment 98 | deriving (Show, Eq, Ord) 99 | 100 | -- | State of the Canon interpreter 101 | data CanonState = CanonState { 102 | canonPosition :: Axes -- ^ Position 103 | , canonTraverseRate :: Speed -- ^ Speed for travel moves 104 | , canonFeedRate :: Speed -- ^ Speed for machining moves 105 | , canonPlane :: Plane -- ^ Selected plane 106 | } deriving (Show, Eq, Ord) 107 | 108 | -- | Initial state of the Canon interpreter 109 | initCanonState :: CanonState 110 | initCanonState = CanonState { 111 | canonPosition = zeroAxes 112 | , canonTraverseRate = 0 113 | , canonFeedRate = 0 114 | , canonPlane = XY 115 | } 116 | 117 | -- | Step Canon interpreter, returning new state 118 | stepCanon :: CanonState -> Canon -> CanonState 119 | stepCanon s (StraightTraverse a) = s { canonPosition = Data.Map.union a (canonPosition s) } 120 | stepCanon s (StraightFeed a) = s { canonPosition = Data.Map.union a (canonPosition s) } 121 | stepCanon s (SetFeedRate r) = s { canonFeedRate = r } 122 | stepCanon s (SetTraverseRate r) = s { canonTraverseRate = r } 123 | stepCanon s (SetCoords a) = s { canonPosition = Data.Map.union a (canonPosition s) } 124 | stepCanon s (PlaneSelect p) = s { canonPlane = p } 125 | 126 | -- | Fully eval list of `Canon` commands. 127 | -- 128 | -- Slow, only useful for testing, use `Data.GCode.Pipes` variant instead 129 | evalCanon :: (CanonState -> CanonState -> Canon -> [a]) 130 | -> [Canon] 131 | -> [a] 132 | evalCanon f cs = go initCanonState cs 133 | where 134 | go _ [] = [] 135 | go st (c:rest) = 136 | let 137 | newSt = stepCanon st c 138 | in (f st newSt c) ++ (go newSt rest) 139 | -------------------------------------------------------------------------------- /src/Data/GCode/Canon/Convert.hs: -------------------------------------------------------------------------------- 1 | module Data.GCode.Canon.Convert where 2 | 3 | import Control.Applicative 4 | 5 | import Data.GCode.Types (Code(..), Class(..), Axes, ParamDesignator(..)) 6 | import Data.GCode.Canon (Canon(..)) 7 | 8 | import qualified Data.Map 9 | import qualified Data.GCode.Canon as C 10 | import qualified Data.GCode.Types as T 11 | 12 | import Data.GCode.RS274 13 | import Data.GCode.Utils 14 | 15 | -- | Convert code to its canonical representation 16 | toCanon :: Code -> [Canon] 17 | toCanon c | isRapid c = 18 | ifHasParam F c C.SetTraverseRate 19 | <> ifNonEmptyAxes c C.StraightTraverse 20 | toCanon c | isMove c = 21 | ifHasParam F c C.SetFeedRate 22 | <> ifNonEmptyAxes c C.StraightFeed 23 | 24 | -- :(( 25 | --toCanon c | isArc c = ArcFeed 26 | 27 | toCanon c | isCoordinateSystemOffset c = pure $ C.SetCoords (codeAxes c) 28 | 29 | toCanon c | isDwell c 30 | = pure . C.PauseSeconds $ getParamOrFail P c "No P for Dwell" 31 | 32 | -- Converted by step 33 | toCanon c | isMillimeters c = empty 34 | toCanon c | isInches c = empty 35 | toCanon c | isAbsolute c = empty 36 | toCanon c | isRelative c = empty 37 | 38 | -- Planes 39 | toCanon c | isXYPlane c = pure $ C.PlaneSelect C.XY 40 | toCanon c | isZXPlane c = pure $ C.PlaneSelect C.ZX 41 | toCanon c | isYZPlane c = pure $ C.PlaneSelect C.YZ 42 | toCanon c | isUVPlane c = pure $ C.PlaneSelect C.UV 43 | toCanon c | isWUPlane c = pure $ C.PlaneSelect C.WU 44 | toCanon c | isVWPlane c = pure $ C.PlaneSelect C.VW 45 | 46 | -- Standalone 47 | toCanon Code { codeCls = Just FStandalone, codeNum = Just newFeed } 48 | = pure $ C.SetFeedRate $ fromIntegral newFeed 49 | toCanon Code { codeCls = Just SStandalone, codeNum = Just spindleRPM } 50 | = pure $ C.SpindleSpeed $ fromIntegral spindleRPM 51 | 52 | -- Units 53 | toCanon c | isUnitsPerMinute c = empty 54 | toCanon c | isUnitsPerRevolution c = error "Don't know how to handle units per revolution" 55 | 56 | -- Spindle 57 | toCanon c | isSpindleCW c = pure C.SpindleStart 58 | { spindleDirection = C.ClockWise 59 | , spindleWaitForSpeed = True } -- questionable 60 | toCanon c | isSpindleCCW c = pure C.SpindleStart 61 | { spindleDirection = C.CounterClockWise 62 | , spindleWaitForSpeed = True } -- questionable 63 | toCanon c | isSpindleStop c = pure C.SpindleStop 64 | 65 | -- Coolant 66 | toCanon c | isCoolantMist c = pure C.CoolantMist 67 | toCanon c | isCoolantFlood c = pure C.CoolantFlood 68 | toCanon c | isCoolantStop c = pure C.CoolantStop 69 | 70 | -- Tool 71 | toCanon c | isToolChange c = pure C.ToolChange 72 | toCanon (Code{codeCls=(Just T), codeNum=(Just toolId)}) = pure $ C.ToolSelect toolId 73 | toCanon c | isToolLength c = pure $ C.ToolLengthCompensation C.LengthTable 74 | toCanon c | isToolLengthDynamic c = pure $ C.ToolLengthCompensation $ C.Dynamic 75 | (codeAxes c) 76 | toCanon c | isToolLengthAdd c = pure $ C.ToolLengthCompensation $ C.Add 77 | (round $ getParamOrFail H c "Add tool change offset requires H parameter of the tool to grab offset from") 78 | toCanon c | isToolLengthCancel c = pure $ C.ToolLengthCompensation C.NoCompensation 79 | 80 | -- Printer -- XXX: needs handling in step 81 | toCanon c | isExtruderAbsolute c = empty 82 | toCanon c | isExtruderRelative c = empty 83 | 84 | -- Printer heating 85 | toCanon c | isSetExtruderTemperature c = pure $ C.SetTemperature 86 | (C.Heater C.HeatedExtruder $ round <$> getParam P c) 87 | (getParamOrFail S c "Set extruder temperature command missing S parameter for temperature value") 88 | toCanon c | isSetBedTemperature c = pure $ C.SetTemperature 89 | (C.Heater C.HeatedBed $ round <$> getParam P c) 90 | (getParamOrFail S c "Set bed temperature command missing S parameter for temperature value") 91 | toCanon c | isSetChamberTemperature c = pure $ C.SetTemperature 92 | (C.Heater C.HeatedChamber $ round <$> getParam P c) 93 | (getParamOrFail S c "Set heated chamber temperature command missing S parameter for temperature value") 94 | toCanon c | isCancelWaitTemperature c = pure $ C.CancelWaitTemperature 95 | -- Wait variants 96 | toCanon c | isSetExtruderTemperatureAndWait c = pure $ C.SetTemperatureWait 97 | (C.Heater C.HeatedExtruder $ round <$> getParam P c) 98 | (getParamOrFail S c "Set extruder temperature and wait command missing S parameter for temperature value") 99 | toCanon c | isSetBedTemperatureAndWait c = pure $ C.SetTemperatureWait 100 | (C.Heater C.HeatedBed $ round <$> getParam P c) 101 | (getParamOrFail S c "Set bed temperature and wait command missing S parameter for temperature value") 102 | toCanon c | isSetChamberTemperatureAndWait c = pure $ C.SetTemperatureWait 103 | (C.Heater C.HeatedChamber $ round <$> getParam P c) 104 | (getParamOrFail S c "Set chamber temperature and wait command missing S parameter for temperature value") 105 | -- Cancel 106 | toCanon c | isCancelWaitTemperature c = pure $ C.CancelWaitTemperature 107 | 108 | -- Printer cooling 109 | toCanon c | isFanOn c = pure C.FanOn 110 | toCanon c | isFanOff c = pure C.FanOff 111 | 112 | -- Printer homing, XXX: this clashes with G28 of cnc which is StoredPositionMove 113 | toCanon c | isGN 28 c = empty 114 | 115 | -- Printer leveling 116 | toCanon c | isAutoBedLevel c = pure C.LevelBed 117 | 118 | -- Printer miscs, XXX: we probably can't even parse M117 Hello world 119 | toCanon c | isDisplayMessage c = empty 120 | toCanon c | isDisableActuators c = pure $ C.DisableMotors (codeAxes c) 121 | 122 | toCanon c | isProgramEnd c = pure C.ProgramEnd 123 | toCanon c | isCommentOnly c = pure $ C.Comment (codeComment c) -- XXX: strip spaces 124 | toCanon (T.Comment c) = pure $ C.Comment c 125 | toCanon Empty = empty 126 | toCanon (Other _) = empty -- questionable 127 | -- this is bad but we can't use GHC to tell us about missing clauses 128 | -- due to how Code type is freeform-ish (which is also the reason for Canon). 129 | -- Lets stay on the safe side and error for now as ignoring could lead to 130 | -- missing important commands. 131 | toCanon c = error $ "No canon for " ++ show c 132 | 133 | -- Helpers 134 | 135 | -- Apply @f@ to parameter value only iff @p@ parameter is found, mempty otherwise 136 | ifHasParam :: (Monoid (f a), Applicative f) 137 | => ParamDesignator 138 | -> Code 139 | -> (Double -> a) 140 | -> f a 141 | ifHasParam p c f = case getParam p c of 142 | Nothing -> mempty 143 | Just val -> pure $ f val 144 | 145 | -- Apply @f@ to `Axes` value only iff `Code` has axes, mempty otherwise 146 | ifNonEmptyAxes :: (Applicative f, Monoid (f a)) 147 | => Code 148 | -> (Axes -> a) 149 | -> f a 150 | ifNonEmptyAxes c f | codeAxes c /= mempty = pure $ f (codeAxes c) 151 | ifNonEmptyAxes _ _ | otherwise = mempty 152 | 153 | -- Get parameter value or fail with `error`, useful for required parameters 154 | getParamOrFail :: ParamDesignator 155 | -> Code 156 | -> [Char] 157 | -> Double 158 | getParamOrFail param code msg = maybe (error msg) id (getParam param code) 159 | 160 | -- brr 161 | isCommentOnly :: Code -> Bool 162 | isCommentOnly (Code { codeCls = Nothing 163 | , codeNum = Nothing 164 | , codeSub = Nothing 165 | , codeAxes = a 166 | , codeParams = p 167 | , codeComment = x }) | 168 | Data.Map.null a && Data.Map.null p && 169 | x /= mempty = True 170 | isCommentOnly _ = False 171 | 172 | 173 | -------------------------------------------------------------------------------- /src/Data/GCode/Eval.hs: -------------------------------------------------------------------------------- 1 | {-| GCode evaluator 2 | 3 | Evaluates RS274 GCode 4 | 5 | -} 6 | {-# LANGUAGE RecordWildCards #-} 7 | module Data.GCode.Eval where 8 | 9 | import Data.Maybe 10 | import Data.Monoid 11 | import Data.Map (Map) 12 | 13 | import qualified Data.Map 14 | 15 | import Data.GCode.Ann (Ann(SrcLine)) 16 | import Data.GCode.Types 17 | import Data.GCode.RS274 18 | import Data.GCode.RS274.Types 19 | import Data.GCode.Utils 20 | import Data.GCode.Canon (Canon) 21 | import Data.GCode.Canon.Convert 22 | 23 | -- | Interpreter state 24 | data IPState = IPState { 25 | ipModalGroups :: Map RS274Group Code 26 | , ipPosition :: Axes 27 | , ipLine :: Integer 28 | } deriving (Eq, Show, Ord) 29 | 30 | -- | Default modals 31 | defaultModals :: Map RS274Group Code 32 | defaultModals = Data.Map.fromList [ 33 | (Units , millimeters) 34 | , (Distance , absolute) 35 | , (ArcDistance, absolute) 36 | ] 37 | 38 | -- | Create new interpreter state 39 | newState :: IPState 40 | newState = IPState { 41 | ipModalGroups = defaultModals 42 | , ipPosition = mempty 43 | , ipLine = 0 44 | } 45 | 46 | -- | Step `Code` interpreter 47 | step :: IPState -> GCode -> (Maybe Code, IPState, GCode) 48 | step is [] = (Nothing, is, []) 49 | step is@IPState{..} (x@Code{}:xs) = 50 | let (newCode, newModals) = updateCodeAndModals x ipModalGroups 51 | -- update position with new codeAxes 52 | newPosition = updateAxes ipPosition (codeAxes newCode) 53 | in (Just $ newCode 54 | , is { ipModalGroups = newModals 55 | , ipPosition = newPosition 56 | , ipLine = ipLine + 1 } 57 | , xs) 58 | -- handle empty/comments/other 59 | step is (_:xs) = (Nothing, is, xs) 60 | 61 | -- | Evaluate GCode and return each evaluation step 62 | evalSteps :: [Code] -> [([Maybe Code], IPState, [Code])] 63 | evalSteps gcode = go initState 64 | where 65 | initState = ([], newState, gcode) 66 | go x@(_, _, []) = [x] 67 | go x@(acc, st, codes) = let (result, steppedState, rest) = step st codes in x:(go (result:acc, steppedState, rest)) 68 | 69 | -- interpreter *always* runs 70 | -- * in absolute mode 71 | -- * with millimeters as units 72 | -- * with total commands in modal groups 73 | -- convert accordingly! 74 | -- | Convert all axis coordinates from inches to millimeters if needed 75 | toMillimeters :: Map RS274Group Code -> Code -> Code 76 | toMillimeters modals x | codeActive millimeters modals = x 77 | toMillimeters modals x | codeActive inches modals = x & axes (Data.Map.map (*25.4) (codeAxes x)) 78 | & modifyParams [F, R, I, J, K] (*25.4) 79 | toMillimeters _ _ | otherwise = error "Neither millimeters nor inches set" 80 | 81 | -- | Convert all motion coordinates from relative to absolute 82 | toAbsolute :: Map RS274Group Code -> Code -> Code 83 | toAbsolute modals x | codeActive relative modals && isMotion x = 84 | case Data.Map.lookup Motion modals of -- motion group 85 | Nothing -> x 86 | (Just e) -> x & (axes $ addRelative (codeAxes x) (codeAxes e)) 87 | where 88 | addRelative :: Axes -> Axes -> Axes 89 | addRelative existing new = Data.Map.unionWith (+) existing new 90 | toAbsolute _ x | otherwise = x 91 | 92 | -- | Convert all arc coordinates from relative to absolute 93 | toAbsoluteArcs :: Map RS274Group Code -> Code -> Code 94 | toAbsoluteArcs modals c | codeActive arcRelative modals && isMotion c = 95 | case Data.Map.lookup Motion modals of -- motion group 96 | Nothing -> c 97 | (Just e) -> c & modifyParamsWithKey [I, J, K] (addRespective e) 98 | where 99 | addRespective code I x | hasAxis X code = fromJust (getAxis X code) + x 100 | addRespective code J x | hasAxis Y code = fromJust (getAxis Y code) + x 101 | addRespective code K x | hasAxis Z code = fromJust (getAxis Z code) + x 102 | addRespective _ _ x | otherwise = x 103 | toAbsoluteArcs _ c | otherwise = c 104 | 105 | -- | Return True if `code` is active (present) in `modals` 106 | codeActive :: Code -> Map RS274Group Code -> Bool 107 | codeActive code modals = case Data.Map.lookup (decimate code) codesToGroups of 108 | Just group -> Data.Map.lookup group (Data.Map.map decimate modals) == (Just $ decimate code) 109 | Nothing -> False 110 | 111 | -- | Return True if `code` is a motion comand 112 | isMotion :: Code -> Bool 113 | isMotion = flip codeInGroup Motion 114 | 115 | -- | Update `code` according to current `modals` 116 | -- then update `modals` with a resulting code 117 | -- 118 | -- Return updated code and modals 119 | updateCodeAndModals :: Code 120 | -> Map RS274Group Code 121 | -> (Code, Map RS274Group Code) 122 | updateCodeAndModals code modals = 123 | -- first we update current GCode with missing data 124 | let newCode = updateFromCurrentModals modals 125 | $ updateIncompleteFromCurrentModals modals 126 | $ toAbsoluteArcs modals 127 | $ toAbsolute modals 128 | $ toMillimeters modals code 129 | -- then we update stored modal groups with updated GCode 130 | newModals = updateModals modals newCode 131 | in (newCode, newModals) 132 | 133 | -- | Update modal groups according to Code `c` 134 | updateModals :: Map RS274Group Code 135 | -> Code 136 | -> Map RS274Group Code 137 | updateModals current c = case Data.Map.lookup (decimate c) codesToGroups of 138 | Nothing -> current 139 | Just group -> Data.Map.insert group c current 140 | 141 | -- | Take current motion group modal code and update this motion code 142 | -- with missing coordinates of the stored one 143 | updateFromCurrentModals :: Map RS274Group Code -> Code -> Code 144 | updateFromCurrentModals modals x | isMotion x = do 145 | case Data.Map.lookup Motion modals of -- motion group 146 | Nothing -> x 147 | (Just e) -> x & (axes $ appendOnlyAxes (codeAxes x) (codeAxes e)) 148 | updateFromCurrentModals _ x | otherwise = x 149 | 150 | -- | Return True if this code contains only coordinates 151 | incomplete :: Code -> Bool 152 | incomplete Code{codeCls=Nothing, codeNum=Nothing, ..} | (Data.Map.null codeAxes /= True) = True 153 | incomplete _ = False 154 | 155 | -- | Update incomplete motion Code with the stored one 156 | updateIncompleteFromCurrentModals :: Map RS274Group Code -> Code -> Code 157 | updateIncompleteFromCurrentModals modals x | incomplete x = do 158 | case Data.Map.lookup Motion modals of -- motion group 159 | Nothing -> x 160 | (Just e) -> appEndo (mconcat $ map Endo [ 161 | (cls $ fromJust $ codeCls e) 162 | , (num $ fromJust $ codeNum e) 163 | , (axes $ appendOnlyAxes (codeAxes x) (codeAxes e)) 164 | ]) x 165 | updateIncompleteFromCurrentModals _ x | otherwise = x 166 | 167 | -- | Update axes that aren't defined in target 168 | appendOnlyAxes :: Ord k => Map k b -> Map k b -> Map k b 169 | appendOnlyAxes target from = Data.Map.union target missingOnly 170 | where missingOnly = Data.Map.difference from target 171 | 172 | -- | Update (replace) `target` axes with `from` axes 173 | updateAxes :: Ord k => Map k a -> Map k a -> Map k a 174 | updateAxes target from = Data.Map.union from target -- union in this order so `from` axes are preferred 175 | 176 | -- | Update `Limits` from this `Code` 177 | updateLimitsCode :: Limits -> Code -> Limits 178 | updateLimitsCode s Code{..} = updateLimits s codeAxes 179 | updateLimitsCode s _ = s 180 | 181 | -- | Update `Limits` from `Axes` 182 | updateLimits :: Limits -> Axes -> Limits 183 | updateLimits s = Data.Map.foldlWithKey adj s 184 | where 185 | adj limits ax val = Data.Map.alter (alterfn val) ax limits 186 | alterfn val (Just (min_c, max_c)) = Just (min min_c val, max max_c val) 187 | alterfn val Nothing = Just (val, val) 188 | 189 | -- Slow evaluators for testing, use streaming variants from `Data.GCode.Pipes` instead. 190 | 191 | -- | Fully evaluate GCode 192 | eval :: GCode -> ([Code], IPState) 193 | eval = evalWith (\res _state -> Just res) 194 | 195 | -- | Evaluate GCode to canonical representation 196 | evalToCanon :: GCode -> ([Canon], IPState) 197 | evalToCanon = evalWith' (\c _ips -> toCanon c) 198 | 199 | -- | Evaluate GCode to annotated canonnical representation 200 | evalToCanonAnn :: GCode -> ([Ann Canon], IPState) 201 | evalToCanonAnn = evalWith' toCanonAnn 202 | 203 | -- | Same as toCanon but result is wrapped in `Ann` 204 | -- according to current interpreter line 205 | toCanonAnn :: Code -> IPState -> [Ann Canon] 206 | toCanonAnn c is = SrcLine (ipLine is) <$> toCanon c 207 | 208 | -- | Evaluate GCode and and apply function `f` to each successfuly 209 | -- evaluated Code 210 | -- 211 | -- Slow due to list concatenation, use streaming variants from `Data.GCode.Pipes` instead. 212 | evalWith :: (Code -> IPState -> Maybe a) 213 | -> GCode 214 | -> ([a], IPState) 215 | evalWith f gcode = let (accumulator, resultState, []) = go initState in (catMaybes accumulator, resultState) 216 | where 217 | initState = ([], newState, gcode) 218 | go x@(_, _, []) = x 219 | go (acc, st, codes) = 220 | let (result, steppedState, rest) = step st codes 221 | mapped = case result of 222 | Nothing -> Nothing 223 | Just x -> f x steppedState 224 | in go (acc ++ [mapped], steppedState, rest) 225 | 226 | -- Like `evalWith` but allows multiple elements to be generated 227 | evalWith' :: (Code -> IPState -> [a]) 228 | -> GCode 229 | -> ([a], IPState) 230 | evalWith' f gcode = 231 | let (accumulator, resultState, []) = go initState 232 | in (accumulator, resultState) 233 | where 234 | initState = ([], newState, gcode) 235 | go x@(_, _, []) = x 236 | go (acc, st, codes) = 237 | let (result, steppedState, rest) = step st codes 238 | mapped = case result of 239 | Nothing -> [] 240 | Just r -> f r steppedState 241 | in go (acc ++ mapped, steppedState, rest) 242 | 243 | -- | Walk GCode adding missing axes coordinates according to previous moves 244 | -- 245 | -- For example 246 | -- G0 X1 247 | -- G0 Y2 248 | -- G0 Z3 249 | -- 250 | -- becomes 251 | -- G0 X1 252 | -- G0 X1 Y2 253 | -- G0 X1 Y2 Z3 254 | -- 255 | -- also 256 | -- 257 | -- G0 X1 258 | -- Y2 Z2 259 | -- 260 | -- becomes 261 | -- 262 | -- G0 X1 263 | -- G0 X1 Y2 Z2 264 | totalize :: GCode -> GCode 265 | totalize = totalize' defaultModals 266 | where 267 | totalize' _ [] = [] 268 | totalize' modals (x:rest) = 269 | let (newCode, newModals) = updateCodeAndModals x modals 270 | in (newCode:totalize' newModals rest) 271 | -------------------------------------------------------------------------------- /src/Data/GCode/Generate.hs: -------------------------------------------------------------------------------- 1 | {-| GCode generation 2 | 3 | GCode generation functions & shortcuts 4 | 5 | -} 6 | module Data.GCode.Generate where 7 | 8 | import Data.GCode.Types 9 | import Data.GCode.RS274 10 | import Data.GCode.Utils 11 | 12 | -- |Generate G Code 13 | g :: Code 14 | g = cls G emptyCode 15 | 16 | -- |Generate M Code 17 | m :: Code 18 | m = cls M emptyCode 19 | 20 | -- |Generate S (set spindle feedrate) Code 21 | s :: Code 22 | s = emptyCode & cls SStandalone 23 | 24 | -- |Set GCode number 25 | (<#>) :: Code -> Int -> Code 26 | (<#>) a n = num n a 27 | 28 | -- |Set GCode feedrate (F parameter) 29 | feed :: Double -> Code -> Code 30 | feed = param F 31 | 32 | -- |Set `x` axis target 33 | x :: Double -> Code -> Code 34 | x = axis X 35 | 36 | -- |Set `y` axis target 37 | y :: Double -> Code -> Code 38 | y = axis Y 39 | 40 | -- |Set `z` axis target 41 | z :: Double -> Code -> Code 42 | z = axis Z 43 | 44 | -- |Set `x`, `y` coordinates for this Code 45 | xy :: Double -> Double -> Code -> Code 46 | xy xVal yVal = x xVal . y yVal 47 | 48 | -- |Set `x`, `y` and `z` coordinates 49 | xyz :: Double -> Double -> Double -> Code -> Code 50 | xyz xVal yVal zVal = x xVal . y yVal . z zVal 51 | 52 | -- |Set G0 and `x`, `y` coordinates 53 | movexy :: Double -> Double -> Code 54 | movexy xVal yVal = move & xy xVal yVal 55 | 56 | -- |Set `i`, `j` parameters for this Code 57 | ij :: Double -> Double -> Code -> Code 58 | ij iVal jVal = param I iVal . param J jVal 59 | 60 | arc :: Code 61 | arc = arcCW 62 | 63 | -- |Generate points on a rectangle 64 | rectangle :: (Num a, Num b) => a -> b -> [(a, b)] 65 | rectangle xv yv = [(0, 0), (xv, 0), (xv, yv), (0, yv), (0,0)] 66 | 67 | -- |Rotate X/Y coordinates by angle `by` 68 | rot :: Floating b => b -> b -> b -> (b, b) 69 | rot by xv yv = (xv * (cos by) - yv * (sin by), yv * (cos by) + xv * (sin by)) 70 | 71 | -- |Generate a list of points laying on a circle with radius `r`, divides circle in `steps` number of points 72 | circle :: (Floating b, Enum b) => b -> b -> [(b, b)] 73 | circle r steps = map (\step -> rot (step * 2*pi / steps) (r/2) 0) [1..steps] 74 | 75 | -- |As `circle` with rotated by `rin` 76 | circle' :: (Floating b, Enum b) => b -> b -> b -> [(b, b)] 77 | circle' rin r steps = map (\step -> rot (rin + step * 2*pi / steps) (r/2) 0) [1..steps] 78 | 79 | -- |As `circle` but origin is the same as end point 80 | closedCircle :: (Floating a, Enum a) => a -> a -> [(a, a)] 81 | closedCircle r steps = map (\step -> rot (step * 2*pi / steps) (r/2) 0) [1..(steps+1)] 82 | 83 | -- |Join list of GCodes with travel moves inbetween 84 | travelCat :: Code -> Code -> [GCode] -> [Code] 85 | travelCat up down (block:rest) = (travel up down block) ++ (travelCat up down rest) 86 | travelCat _ _ [] = [] 87 | 88 | -- |Join list of drilling GCodes with travel moves inbetween 89 | travelCatDrill :: Code -> [GCode] -> [Code] 90 | travelCatDrill up (block:rest) = (travelDrills up block) ++ (travelCatDrill up rest) 91 | travelCatDrill _ [] = [] 92 | 93 | -- |Prepend codes with tool up command, rapid move to block start and tool down command 94 | -- 95 | -- Prepends `up` GCode representing tool moving up before 96 | -- rapid move followed by `down` command to move tool down again. 97 | travel :: Code -> Code -> GCode -> GCode 98 | travel up down (c:rest) = [up, asRapidXY c, down, c] ++ rest 99 | travel _ _ [] = [] 100 | 101 | -- |Prepend drilling codes with tool up command and rapid moves 102 | -- 103 | -- Prepends `up` GCode representing tool moving up before 104 | -- rapid move to start of this block 105 | travelDrills :: Code -> GCode -> GCode 106 | travelDrills up block = travel up emptyCode block 107 | 108 | -- |Take X and Y coordinates of this code 109 | -- and turn it into rapid move 110 | asRapidXY :: Code -> Code 111 | asRapidXY c@Code{} = 112 | case getAxes [X,Y] c of 113 | [Just xv, Just yv] -> rapid & xy xv yv 114 | _ -> c 115 | asRapidXY c = c 116 | -------------------------------------------------------------------------------- /src/Data/GCode/Generate/Examples.hs: -------------------------------------------------------------------------------- 1 | {-| Examples of GCode generation 2 | 3 | -} 4 | module Data.GCode.Generate.Examples where 5 | 6 | import Data.GCode 7 | import Data.GCode.Generate 8 | import Data.GCode.RS274 9 | 10 | allExamples :: [(String, GCode)] 11 | allExamples = [ 12 | ("encoder_wheel_drilling", fst $ encoderWheel) 13 | , ("encoder_wheel_milling", snd $ encoderWheel) 14 | , ("rectangle10x20", rectangle10mm20mm) 15 | ] 16 | 17 | preamble :: [Code] 18 | preamble = [ 19 | unitsPerMinute 20 | , absolute 21 | , millimeters 22 | , g <#> 0 & param F 3000 23 | , s <#> 12000 24 | , spindleCW 25 | , dwell & param P 10 26 | ] 27 | 28 | postamble :: [Code] 29 | postamble = [ 30 | spindleStop 31 | , coolantStop 32 | , programEnd 33 | ] 34 | 35 | returnZ :: Double 36 | returnZ = 1 37 | 38 | safeZ :: Double 39 | safeZ = 2 40 | 41 | workZ :: Double 42 | workZ = (-2) 43 | 44 | rapidFeedrate :: Double 45 | rapidFeedrate = 250 46 | 47 | downFeedrate :: Double 48 | downFeedrate = 150 49 | 50 | up :: Code 51 | up = rapid & z safeZ & feed rapidFeedrate 52 | 53 | down :: Code 54 | down = move & z workZ & feed downFeedrate 55 | 56 | program :: [Code] -> [Code] 57 | program code = preamble ++ code ++ postamble 58 | 59 | rectangle10mm20mm :: GCode 60 | rectangle10mm20mm = program $ map (uncurry movexy) (rectangle 10 20) 61 | 62 | encoderWheel :: (GCode, GCode) 63 | encoderWheel = 64 | let encoderRadius = 50 65 | encoderSteps = 100 66 | drillRadius = 0.6 67 | endmillRadius = 3.175 68 | innerOffset = 4 69 | encoderRadiusInner = encoderRadius - (2*drillRadius) - innerOffset 70 | 71 | -- drilling 72 | drillPoints = circle encoderRadius encoderSteps 73 | drillPointsInner = circle' (2*pi/360 * (360 / 200) * 1.5) encoderRadiusInner encoderSteps 74 | 75 | drill xv yv = drillingCycle & xyz xv yv workZ & feed 250 & param R returnZ 76 | drillBlocks = [ map (uncurry drill) drillPoints 77 | , map (uncurry drill) drillPointsInner ] 78 | -- milling 79 | anchor = circle (5.3 - endmillRadius) 360 80 | anchorPositions = circle (30) 4 81 | 82 | anchors = travelCat up down $ map (\(xc, yc) -> 83 | map (\(xv, yv) -> movexy (xc + xv) (yc + yv)) anchor) 84 | anchorPositions 85 | 86 | encInner = circle (10.4 - endmillRadius) 360 87 | encOuter = circle (encoderRadius + innerOffset + endmillRadius) 3600 88 | 89 | cut = map (uncurry movexy) 90 | inner = cut encInner 91 | outer = cut encOuter 92 | 93 | in ( program $ travelCatDrill up drillBlocks 94 | , program $ travelCat up down [inner, anchors, outer] 95 | ) 96 | -------------------------------------------------------------------------------- /src/Data/GCode/Generate/ExamplesMonad.hs: -------------------------------------------------------------------------------- 1 | module Data.GCode.Generate.ExamplesMonad where 2 | 3 | import Control.Monad 4 | import Control.Monad.Trans.Class 5 | import Control.Monad.Trans.State 6 | 7 | import Data.GCode.Generate (x, xy) 8 | import Data.GCode.Monad 9 | 10 | xprog :: Program 11 | xprog = prog $ do 12 | move (x 10) 13 | rapid (xy 15 15) 14 | move (xy 0 0) 15 | coolantStop' 16 | 17 | withState :: Program 18 | withState = prog $ do 19 | void $ flip runStateT 0 $ do 20 | val <- get 21 | lift $ rapid (x val) 22 | forM_ (zip [0..10] [-10..0]) (move . uncurry xy) 23 | 24 | -------------------------------------------------------------------------------- /src/Data/GCode/Line.hs: -------------------------------------------------------------------------------- 1 | module Data.GCode.Line ( 2 | Line(..) 3 | , LineType(..) 4 | , toLines 5 | , prettyLine 6 | ) where 7 | 8 | {- 9 | Conversion to `Line` from one set of points to another. 10 | Useful for GCode visualisation tools. 11 | -} 12 | 13 | import Data.GCode.Canon (Canon(..), CanonState(..)) 14 | import Data.GCode.Types (Axes, Style(..)) 15 | 16 | import Text.PrettyPrint.ANSI.Leijen 17 | 18 | import qualified Data.GCode.Pretty 19 | 20 | -- | Given two states of `Canon` interpreter output `Line` or empty list 21 | -- if no line is produced by this `Canon`. 22 | toLines :: CanonState -> CanonState -> Canon -> [Line] 23 | toLines prevS nextS code | isTravelMove code || isSetCoords code = pure $ Line 24 | (travelMoveType code) 25 | (canonPosition prevS) 26 | (canonPosition nextS) 27 | toLines _ _ _ | otherwise = mempty 28 | 29 | data LineType = 30 | LineTraverse -- ^ Travel move 31 | | LineDrawing -- ^ Machining/drawing move 32 | | LineJump -- ^ Produced by set coordinates `SetCoords` 33 | deriving (Eq, Show, Ord) 34 | 35 | data Line = Line 36 | LineType -- ^ Travel, drawing or set coordinates move 37 | Axes -- ^ Start points 38 | Axes -- ^ End points 39 | deriving (Eq, Show, Ord) 40 | 41 | -- | Pretty print `Line` 42 | prettyLine :: Style -> Line -> String 43 | prettyLine style x = displayS ((renderer style) (ppLine style x)) "" 44 | where renderer style' | styleColorful style' == True = renderPretty 0.4 80 45 | renderer _ = renderCompact 46 | 47 | ppLine :: Style -> Line -> Doc 48 | ppLine style (Line typ from to) = 49 | ppTyp typ 50 | <+> string "from" 51 | <+> Data.GCode.Pretty.ppAxesMap style from 52 | <+> string "to" 53 | <+> Data.GCode.Pretty.ppAxesMap style to 54 | where 55 | ppTyp LineTraverse = char ' ' 56 | ppTyp LineDrawing = char '*' 57 | ppTyp LineJump = char '>' 58 | 59 | -- Helpers 60 | 61 | isTravelMove :: Canon -> Bool 62 | isTravelMove (StraightTraverse _) = True 63 | isTravelMove (StraightFeed _) = True 64 | isTravelMove _ = False 65 | 66 | isSetCoords :: Canon -> Bool 67 | isSetCoords (SetCoords _) = True 68 | isSetCoords _ = False 69 | 70 | travelMoveType :: Canon -> LineType 71 | travelMoveType (StraightTraverse _) = LineTraverse 72 | travelMoveType (StraightFeed _) = LineDrawing 73 | travelMoveType (SetCoords _) = LineJump 74 | travelMoveType _ = error "travelMoveType: Not a travel move" 75 | -------------------------------------------------------------------------------- /src/Data/GCode/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 4 | 5 | module Data.GCode.Monad where 6 | 7 | import Data.GCode.TH 8 | import Data.GCode.Types 9 | import Data.GCode.RS274.Types 10 | import Data.GCode.RS274 (codeFromName) 11 | 12 | import Control.Monad.Trans.Writer.Lazy 13 | import Data.Semigroup hiding (option) 14 | 15 | -- this gives us someCode and someCode' shortcuts generated from RS274/Types.hs 16 | -- so we can write 17 | -- > myP = prog $ do 18 | -- > rapid (xy 5 10) 19 | -- > move (x 0) 20 | $(genWriterEndos ''RS274Name) 21 | 22 | data Program = Program { programCode :: GCode } 23 | deriving (Eq, Show) 24 | 25 | type ProgramWriter a = Writer (Endo Program) a 26 | 27 | gen :: Code -> ProgramWriter () 28 | gen c = tell $ Endo (\x -> x { programCode = c:(programCode x) } ) 29 | 30 | prog :: ProgramWriter a -> Program 31 | prog builder = appEndo (execWriter (builder >> programEnd')) (Program mempty) 32 | 33 | generateName = gen . codeFromName 34 | generateNameArgs name endoF = gen $ codeFromName name & endoF 35 | -------------------------------------------------------------------------------- /src/Data/GCode/Parse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | 4 | {-| GCode parsing functions 5 | -} 6 | 7 | module Data.GCode.Parse (parseGCode, parseGCodeLine, parseOnlyGCode) where 8 | 9 | import Data.GCode.Types 10 | 11 | import Control.Applicative 12 | 13 | import Prelude hiding (take, takeWhile, mapM) 14 | import Data.Attoparsec.ByteString.Char8 15 | 16 | import Data.ByteString (ByteString) 17 | 18 | import qualified Data.ByteString 19 | import qualified Data.Char 20 | import qualified Data.Either 21 | import qualified Data.Map 22 | import qualified Data.Maybe 23 | 24 | -- |Parse single line of G-code into 'Code' 25 | parseGCodeLine :: Parser Code 26 | parseGCodeLine = between lskip lskip parseCodeParts <* endOfLine 27 | 28 | -- |Parse lines of G-code into 'GCode' 29 | parseGCode :: Parser GCode 30 | parseGCode = many1 parseGCodeLine 31 | 32 | -- |Parse lines of G-code returning either parsing error or 'GCode' 33 | parseOnlyGCode :: ByteString -> Either String GCode 34 | parseOnlyGCode = parseOnly parseGCode 35 | 36 | lskip :: Parser () 37 | lskip = skipWhile (\x -> x == ' ' || x == '\t') 38 | 39 | between :: Monad m => m a1 -> m a2 -> m b -> m b 40 | between open close p = do { _ <- open; x <- p; _ <- close; return x } 41 | 42 | isEndOfLineChr :: Char -> Bool 43 | isEndOfLineChr '\n' = True 44 | isEndOfLineChr '\r' = True 45 | isEndOfLineChr _ = False 46 | 47 | parseLead :: Parser Class 48 | parseLead = do 49 | a <- satisfy $ inClass $ (asChars allClasses) ++ (map Data.Char.toLower $ asChars allClasses) 50 | return $ Data.Maybe.fromJust $ toCodeClass a 51 | {-# INLINE parseLead #-} 52 | 53 | parseAxisDes :: Parser AxisDesignator 54 | parseAxisDes = do 55 | a <- satisfy $ inClass $ asChars allAxisDesignators 56 | return $ Data.Maybe.fromJust $ toAxis a 57 | {-# INLINE parseAxisDes #-} 58 | 59 | parseParamDes :: Parser ParamDesignator 60 | parseParamDes = do 61 | a <- satisfy $ inClass $ asChars allParamDesignators 62 | return $ Data.Maybe.fromJust $ toParam a 63 | {-# INLINE parseParamDes #-} 64 | 65 | parseParamOrAxis :: Parser (Either (AxisDesignator, Double) (ParamDesignator, Double)) 66 | parseParamOrAxis = do 67 | lskip 68 | ax <- option Nothing (Just <$> parseAxisDes) 69 | case ax of 70 | Just val -> do 71 | lskip 72 | f <- double 73 | return $ Left (val, f) 74 | Nothing -> do 75 | paramDes <- parseParamDes 76 | lskip 77 | f <- double 78 | return $ Right (paramDes, f) 79 | 80 | parseAxesParams :: Parser (Axes, Params) 81 | parseAxesParams = do 82 | a <- many parseParamOrAxis 83 | return (Data.Map.fromList $ Data.Either.lefts a, Data.Map.fromList $ Data.Either.rights a) 84 | {-# INLINE parseAxesParams #-} 85 | 86 | parseCode :: Parser Code 87 | parseCode = do 88 | codeCls <- optional parseLead 89 | codeNum <- optional decimal 90 | codeSub <- optional (char '.' *> decimal) 91 | lskip 92 | (codeAxes, codeParams) <- parseAxesParams 93 | lskip 94 | codeComment <- option "" $ between lskip lskip parseComment' 95 | let c = Code{..} 96 | if c == emptyCode 97 | then return $ Empty 98 | else return c 99 | 100 | parseComment' :: Parser ByteString 101 | parseComment' = do 102 | t <- many $ between (lskip *> char '(') (char ')' <* lskip) $ takeWhile1 (/=')') 103 | -- semiclone prefixed comments 104 | semisep <- option "" $ char ';' *> takeWhile (not . isEndOfLineChr) 105 | rest <- takeWhile (not . isEndOfLineChr) 106 | return $ Data.ByteString.concat $ t ++ [semisep, rest] 107 | 108 | parseComment :: Parser Code 109 | parseComment = Comment <$> parseComment' 110 | 111 | parseOther :: Parser Code 112 | parseOther = do 113 | a <- takeWhile (not . isEndOfLineChr) 114 | return $ Other a 115 | 116 | parseCodeParts :: Parser Code 117 | parseCodeParts = 118 | parseCode 119 | <|> parseOther 120 | <|> parseComment 121 | -------------------------------------------------------------------------------- /src/Data/GCode/Pipes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | module Data.GCode.Pipes ( 4 | runPipe 5 | , gcodePipe 6 | , pipeToList 7 | 8 | , evalP 9 | , evalCanonP 10 | , evalCanonStateP 11 | , evalCanonLinesP 12 | , totalizeP 13 | 14 | , gcodeToLines 15 | , gcodeToCanonList 16 | 17 | , compactSink 18 | , prettySink 19 | , prettySinkWith 20 | , wrapPrinter 21 | 22 | , gcodePipe' 23 | , pipeToList' 24 | , evalCanonLinesP' 25 | , evalCanonStateP' 26 | , trackAllLimits 27 | , trackWorkLimits 28 | 29 | ) where 30 | 31 | import Control.Monad 32 | import Control.Monad.Trans.State.Strict 33 | 34 | import Data.ByteString (ByteString) 35 | 36 | import System.IO (Handle) 37 | 38 | import Data.GCode.Types 39 | import Data.GCode.Canon 40 | import Data.GCode.Eval 41 | import Data.GCode.Line 42 | import Data.GCode.Parse 43 | import Data.GCode.Pretty 44 | import qualified Data.GCode.Canon.Convert 45 | 46 | import Pipes 47 | import Pipes.Core 48 | import Pipes.Attoparsec (ParsingError) 49 | import Pipes.Safe (SafeT) 50 | 51 | import qualified Data.ByteString.Char8 52 | import qualified Data.Map.Strict 53 | import qualified Pipes.Attoparsec 54 | import qualified Pipes.ByteString 55 | import qualified Pipes.Prelude 56 | import qualified Pipes.Safe 57 | import qualified System.IO 58 | 59 | -- | Parse GCodes from @Handle@ producing @Code@ stream 60 | parseProducer 61 | :: Handle 62 | -> Producer Code (SafeT IO) (Either (ParsingError, Producer ByteString (SafeT IO) ()) ()) 63 | parseProducer = parseProducer' 1024 64 | 65 | -- | Generalized @parseProducer@ with buffer size parameter 66 | parseProducer' 67 | :: MonadIO m 68 | => Int 69 | -> Handle 70 | -> Producer Code m (Either (ParsingError, Producer ByteString m ()) ()) 71 | parseProducer' bufSize handle = Pipes.Attoparsec.parsed 72 | parseGCodeLine (Pipes.ByteString.hGetSome bufSize handle) 73 | 74 | -- | Run job with file handle in @SafeT IO@ 75 | withFile :: FilePath -> (Handle -> (SafeT IO) r) -> IO r 76 | withFile filepath job = 77 | System.IO.withFile filepath System.IO.ReadMode $ \handle -> 78 | Pipes.Safe.runSafeT $ job handle 79 | 80 | -- | Run pipe to completion and collect results as list 81 | pipeToList :: FilePath -> Proxy () Code () a (SafeT IO) () -> IO [a] 82 | pipeToList filepath pipeTail = withFile filepath $ \h -> 83 | Pipes.Prelude.toListM 84 | $ (() <$ parseProducer h) 85 | >-> pipeTail 86 | 87 | -- | Evaluate GCode file to list of @Canon@s 88 | gcodeToCanonList :: FilePath -> IO [Canon] 89 | gcodeToCanonList filepath = pipeToList filepath $ evalP >-> evalCanonP 90 | 91 | -- | Evaluate GCode file to list of @Line@s 92 | gcodeToLines :: FilePath -> IO [Line] 93 | gcodeToLines filepath = pipeToList filepath $ evalP >-> evalCanonLinesP 94 | 95 | -- | Run @Consumer Code@ with input file 96 | gcodePipe :: FilePath -> Consumer Code (SafeT IO) () -> IO () 97 | gcodePipe filepath pipeTail = 98 | withFile filepath $ \handle -> 99 | runEffect $ 100 | (() <$ parseProducer handle) 101 | >-> pipeTail 102 | 103 | -- | Run @Pipe Code ByteString (SafeT IO)@ with input file, optionally 104 | -- writing contents to output file. 105 | runPipe :: FilePath -- ^ Input file 106 | -> Maybe FilePath -- ^ Nothing mean stdout, Just file output 107 | -> Pipe Code ByteString (SafeT IO) () 108 | -> IO () 109 | runPipe input Nothing pipeMiddle = gcodePipe input (pipeMiddle >-> Pipes.ByteString.stdout) 110 | runPipe input (Just output) pipeMiddle = 111 | System.IO.withFile output System.IO.WriteMode $ \outhandle -> 112 | gcodePipe input (pipeMiddle >-> Pipes.ByteString.toHandle outhandle) 113 | 114 | -- evaluators 115 | 116 | -- | Run stateful @Code@ evaluator, applying @totalize@ 117 | totalizeP :: Pipe Code Code (SafeT IO) () 118 | totalizeP = flip evalStateT Data.Map.Strict.empty $ forever $ do 119 | x <- lift await 120 | inEffect <- get 121 | let updatedCode = updateFromCurrentModals inEffect x 122 | updatedModals = updateModals inEffect updatedCode 123 | 124 | put updatedModals 125 | lift $ yield updatedCode 126 | 127 | -- | Run stateful @Code@ evaluator. 128 | evalP :: Pipe Code Code (SafeT IO) () 129 | evalP = flip evalStateT newState $ forever $ do 130 | x <- lift await 131 | st <- get 132 | let (result, steppedState, _rest) = step st [x] 133 | -- XXX: add pretty printer for IPState 134 | --liftIO $ print steppedState 135 | put steppedState 136 | case result of 137 | Just r -> lift $ yield r 138 | Nothing -> return () 139 | 140 | -- | Stateful pipe evaluating `Code` to `Canon` 141 | evalCanonP :: Pipe Code Canon (SafeT IO) () 142 | evalCanonP = flip evalStateT initCanonState $ forever $ do 143 | x <- lift await 144 | st <- get 145 | 146 | forM_ (Data.GCode.Canon.Convert.toCanon x) $ \c -> do 147 | let steppedState = stepCanon st c 148 | put steppedState 149 | lift $ yield c 150 | 151 | -- | Stateful pipe evaluating `Code` to `Canon` `CanonState` tuples 152 | -- Similar to @evalCanonP@ but also forwards @CanonState@ downstream. 153 | evalCanonStateP :: Pipe Code (Canon, CanonState) (SafeT IO) () 154 | evalCanonStateP = flip evalStateT initCanonState $ forever $ do 155 | x <- lift await 156 | st <- get 157 | 158 | forM_ (Data.GCode.Canon.Convert.toCanon x) $ \c -> do 159 | let steppedState = stepCanon st c 160 | put steppedState 161 | lift $ yield (c, steppedState) 162 | 163 | -- | Stateful pipe evaluating `Code` to `Line` 164 | evalCanonLinesP :: Pipe Code Line (SafeT IO) () 165 | evalCanonLinesP = flip evalStateT initCanonState $ forever $ do 166 | x <- lift await 167 | st <- get 168 | 169 | forM_ (Data.GCode.Canon.Convert.toCanon x) $ \c -> do 170 | let steppedState = stepCanon st c 171 | put steppedState 172 | forM_ (toLines st steppedState c) $ lift . yield 173 | 174 | -- * Pipes with termination including result values 175 | 176 | type Downstreamed a = 177 | (Either 178 | (Either 179 | (ParsingError , Producer ByteString (SafeT IO) ()) 180 | () 181 | ) 182 | a 183 | ) 184 | 185 | -- | Similar to @gcodePipe@ but uses @Downstreamed@ 186 | -- to indicate termination to downstream pipe with @Left@ 187 | -- 188 | -- Usage: 189 | -- > gcodePipe' "./sample.gcode" 190 | -- > $ (fmap Left evalCanonStateP') 191 | -- > >-> (fmap Right trackAllLimits) 192 | -- > >-> (fmap Left (prettySinkWith (wrapPrinter Prelude.show) 193 | -- > >-> Pipes.ByteString.stdout)) 194 | gcodePipe' 195 | :: FilePath 196 | -> Proxy () (Downstreamed Code) () X (Pipes.Safe.SafeT IO) r 197 | -> IO (Either b r) 198 | gcodePipe' filepath pipeTail = 199 | System.IO.withFile filepath System.IO.ReadMode $ \handle -> 200 | Pipes.Safe.runSafeT . runEffect $ 201 | returnDownstream (parseProducer handle) 202 | >-> fmap Right pipeTail 203 | 204 | -- | Similar to @pipeToList@ but uses @Downstreamed@ 205 | -- to indicate termination to downstream pipe with @Left@ 206 | -- 207 | -- Usage: 208 | -- > pipeToList' "./sample.gcode" 209 | -- > $ (fmap Left evalCanonStateP' ) 210 | -- > >-> (fmap Right trackWorkLimits) 211 | pipeToList' 212 | :: FilePath 213 | -> Proxy () (Downstreamed Code) () a (Pipes.Safe.SafeT IO) r 214 | -> IO ([a], Either b r) 215 | pipeToList' filepath pipeTail = withFile filepath $ \h -> 216 | Pipes.Prelude.toListM' 217 | $ returnDownstream (parseProducer h) 218 | >-> fmap Right pipeTail 219 | 220 | -- | Turn `Proxy` into another `Proxy` capturing its return value and sending it downstream 221 | -- in form of `Either` 222 | returnDownstream :: Monad m => Proxy a' a b' b m r -> Proxy a' a b' (Either r b) m r' 223 | returnDownstream = (forever . respond . Left) <=< (respond . Right <\\) 224 | 225 | -- | Stateful pipe evaluating `Code` to `Canon` `CanonState` tuples. 226 | -- Variant of @evalCanonState@ using @Downstreamed@, where Left 227 | -- indicates time to stop evaluation. 228 | evalCanonStateP' :: Pipe 229 | (Downstreamed Code) (Either () (Canon, CanonState)) (SafeT IO) () 230 | evalCanonStateP' = flip evalStateT initCanonState $ go 231 | where 232 | go = do 233 | x' <- lift await 234 | case x' of 235 | Left _ -> lift $ yield $ Left () 236 | Right x -> do 237 | st <- get 238 | forM_ (Data.GCode.Canon.Convert.toCanon x) $ \c -> do 239 | let steppedState = stepCanon st c 240 | put steppedState 241 | lift $ yield $ Right (c, steppedState) 242 | go 243 | 244 | -- | Wrapper for stateful evaluators where receiving 245 | -- @Left _@ means query local state and use it as return value. 246 | untilLeft 247 | :: Functor m 248 | => (t -> StateT b (Proxy () (Either a1 t) y' y m) a2) 249 | -> StateT b (Proxy () (Either a1 t) y' y m) b 250 | untilLeft p = do 251 | x' <- lift await 252 | case x' of 253 | Left _ -> get 254 | Right x -> p x >> untilLeft p 255 | 256 | -- | Track limits of working area, including travel moves 257 | trackAllLimits:: (Monad m) => Pipe (Either () (Canon, CanonState)) (Canon, CanonState) m Limits 258 | trackAllLimits = 259 | flip evalStateT mempty 260 | $ untilLeft 261 | $ \(c,s) -> do 262 | modify (`updateLimits` canonPosition s) 263 | lift $ yield (c, s) 264 | 265 | -- | Track limits of working area, excluding travel moves 266 | trackWorkLimits :: (Monad m) => Pipe (Either () (Canon, CanonState)) (Canon, CanonState) m Limits 267 | trackWorkLimits = 268 | flip evalStateT mempty 269 | $ untilLeft 270 | $ \(c,s) -> do 271 | -- TODO: shouldn't ignore arcs 272 | -- TODO: maybe flip the logic to ignore @StraightTraverse@ 273 | case c of 274 | StraightFeed _ -> modify (`updateLimits` canonPosition s) 275 | _ -> return () 276 | 277 | lift $ yield (c, s) 278 | 279 | -- | Stateful pipe evaluating `Canon` to `Line` 280 | evalCanonLinesP' :: Pipe Canon Line (SafeT IO) () 281 | evalCanonLinesP' = flip evalStateT initCanonState $ forever $ do 282 | x <- lift await 283 | st <- get 284 | 285 | let steppedState = stepCanon st x 286 | put steppedState 287 | forM_ (toLines st steppedState x) $ lift . yield 288 | 289 | -- mmaped experiment, requires pipes-bytestring-mmap 290 | --import qualified Pipes.ByteString.MMap 291 | --main' = do 292 | -- file <- fmap Prelude.head getArgs 293 | -- Pipes.Safe.runSafeT . Pipes.Safe.runEffect $ 294 | -- (() <$ Pipes.Attoparsec.parsed parseGCodeLine (Pipes.ByteString.MMap.unsafeMMapFile file) ) 295 | -- >-> Pipes.Prelude.map ppGCodeLine 296 | -- >-> Pipes.Prelude.stdoutLn 297 | 298 | -- pretty print 299 | prettySinkWith :: (a -> ByteString) -> Pipe a ByteString (SafeT IO) () 300 | prettySinkWith = Pipes.Prelude.map 301 | 302 | prettySink :: Pipe Code ByteString (SafeT IO) () 303 | prettySink = 304 | Pipes.Prelude.map ppGCodeLine 305 | >-> Pipes.Prelude.map (Data.ByteString.Char8.pack . (++"\n")) 306 | 307 | compactSink :: Pipe Code ByteString (SafeT IO) () 308 | compactSink = 309 | Pipes.Prelude.map ppGCodeLineCompact 310 | >-> Pipes.Prelude.map (Data.ByteString.Char8.pack . (++"\n")) 311 | 312 | -- Helpers 313 | 314 | addNewLine :: ByteString -> ByteString 315 | addNewLine to = Data.ByteString.Char8.append to "\n" 316 | 317 | wrapPrinter :: (a -> String) -> a -> ByteString 318 | wrapPrinter p = addNewLine . Data.ByteString.Char8.pack . p 319 | -------------------------------------------------------------------------------- /src/Data/GCode/Pipes/Transform.hs: -------------------------------------------------------------------------------- 1 | module Data.GCode.Pipes.Transform where 2 | {-- 3 | 4 | These are remnants from refactoring Main with various degree of usability. 5 | 6 | Do not rely on these as they might get removed (or ideally improved) in future versions. 7 | 8 | --} 9 | 10 | import Data.GCode 11 | import Data.GCode.Generate (rot) 12 | 13 | import Pipes 14 | import qualified Pipes.Prelude as P 15 | 16 | translateXY :: Functor m => Double -> Double -> Pipe Code Code m r 17 | translateXY xtrans ytrans = P.map (modifyXY (\x y -> (x + xtrans, y + ytrans))) 18 | 19 | translateZ :: Functor m => Double -> Pipe Code Code m r 20 | translateZ ztrans = P.map (modifyAxis Z (+ztrans)) 21 | 22 | rotate :: Functor m => Double -> Pipe Code Code m r 23 | rotate angle = P.map (modifyXY (rot (angle*pi/180))) 24 | 25 | scaleFeedrate :: Functor m => Double -> Pipe Code Code m r 26 | scaleFeedrate factor = P.map (modifyFeedrate (*factor)) 27 | 28 | scaleXY :: Functor m => Double -> Double -> Pipe Code Code m r 29 | scaleXY xsc ysc = P.map (modifyXY (\x y -> (x*xsc, y*ysc))) 30 | -------------------------------------------------------------------------------- /src/Data/GCode/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-| GCode pretty-printing functions 2 | 3 | Please do note that these are extremely slow as they do conversion 4 | from ByteStrings to Text and vice-verse. Float formatting is probably 5 | not the fastest as well. Colorfull versions are especially slow. 6 | 7 | -} 8 | {-# LANGUAGE RecordWildCards #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | module Data.GCode.Pretty( 11 | ppGCode 12 | , ppGCodeLine 13 | , ppGCodeCompact 14 | , ppGCodeLineCompact 15 | , ppGCodeStyle 16 | , ppGCodeLineStyle 17 | , ppAxes 18 | , ppAxesMap 19 | ) where 20 | 21 | import Data.Map (Map) 22 | import Data.ByteString (ByteString) 23 | 24 | import qualified Data.ByteString.Char8 25 | import qualified Data.Double.Conversion.Text 26 | import qualified Data.Map 27 | import qualified Data.Text 28 | 29 | import Data.GCode.Types 30 | import Text.PrettyPrint.ANSI.Leijen 31 | 32 | -- | Pretty-print 'GCode' using colors 33 | ppGCode :: GCode -> String 34 | ppGCode = ppGCodeStyle (defaultStyle { styleColorful = True }) 35 | 36 | -- | Pretty-print single 'Code' using colors 37 | ppGCodeLine :: Code -> String 38 | ppGCodeLine = ppGCodeLineStyle (defaultStyle { styleColorful = True }) 39 | 40 | -- | Pretty-print 'GCode' without colors 41 | ppGCodeCompact :: GCode -> String 42 | ppGCodeCompact = ppGCodeStyle defaultStyle 43 | 44 | -- | Pretty-print single 'Code' without colors 45 | ppGCodeLineCompact :: Code -> String 46 | ppGCodeLineCompact = ppGCodeLineStyle defaultStyle 47 | 48 | -- | Pretty-print 'GCode' with specified `Style` 49 | ppGCodeStyle :: Style -> GCode -> String 50 | ppGCodeStyle style res = displayS ((renderer style) (ppGCode' style res)) "" 51 | where renderer style' | styleColorful style' == True = renderPretty 0.4 80 52 | renderer _ = renderCompact 53 | 54 | -- | Pretty-print single 'Code' with specified `Style` 55 | ppGCodeLineStyle :: Style -> Code -> String 56 | ppGCodeLineStyle style res = displayS ((renderer style) (ppCode style res)) "" 57 | where renderer style' | styleColorful style' == True = renderPretty 0.4 80 58 | renderer _ = renderCompact 59 | 60 | ppList :: (a -> Doc) -> [a] -> Doc 61 | ppList pp x = hsep $ map pp x 62 | 63 | ppGCode' :: Style -> [Code] -> Doc 64 | ppGCode' style code = (vsep $ map (ppCode style) code) <> hardline 65 | 66 | ppMaybe :: (t -> Doc) -> Maybe t -> Doc 67 | ppMaybe pp (Just x) = pp x 68 | ppMaybe _ Nothing = empty 69 | 70 | ppMaybeClass :: Maybe Class -> Doc 71 | ppMaybeClass = ppMaybe ppClass 72 | 73 | ppClass :: Class -> Doc 74 | ppClass G = yellow $ text "G" 75 | ppClass M = red $ text "M" 76 | ppClass T = magenta $ text "T" 77 | ppClass PStandalone = red $ text "P" 78 | ppClass FStandalone = red $ text "F" 79 | ppClass SStandalone = red $ text "S" 80 | 81 | ccMaybes :: (Eq a, Num a) => Maybe Class -> Maybe a -> Doc -> Doc 82 | ccMaybes (Just cls') (Just num') = cc cls' num' 83 | ccMaybes _ _ = id 84 | 85 | cc :: (Eq a, Num a) => Class -> a -> Doc -> Doc 86 | cc G 0 = dullyellow 87 | cc G 1 = yellow 88 | cc _ _ = red 89 | 90 | ppAxis :: Style -> (AxisDesignator, Double) -> Doc 91 | ppAxis style (des, val) = 92 | bold (axisColor des $ text $ show des) 93 | <> cyan ( 94 | text 95 | $ Data.Text.unpack 96 | $ Data.Double.Conversion.Text.toFixed (stylePrecision style) val 97 | ) 98 | 99 | axisColor :: AxisDesignator -> Doc -> Doc 100 | axisColor X = red 101 | axisColor Y = green 102 | axisColor Z = yellow 103 | axisColor A = red 104 | axisColor B = green 105 | axisColor C = blue 106 | axisColor E = magenta 107 | axisColor _ = id 108 | 109 | ppAxes :: Style -> [(AxisDesignator, Double)] -> Doc 110 | ppAxes style x = ppList (ppAxis style) x 111 | 112 | ppAxesMap :: Style -> Map AxisDesignator Double -> Doc 113 | ppAxesMap style x = ppList (ppAxis style) (Data.Map.toList x) 114 | 115 | ppParam :: Show a => Style -> (a, Double) -> Doc 116 | ppParam style (des, val) = 117 | bold (blue $ text $ show des) 118 | <> white ( 119 | text 120 | $ Data.Text.unpack 121 | $ Data.Double.Conversion.Text.toFixed (stylePrecision style) val 122 | ) 123 | 124 | ppParams :: Show a => Style -> [(a, Double)] -> Doc 125 | ppParams _ [] = empty 126 | ppParams style x = space <> ppList (ppParam style) x 127 | 128 | ppComment :: ByteString -> Doc 129 | ppComment "" = empty 130 | ppComment c = space <> ppComment' c 131 | 132 | ppComment' :: ByteString -> Doc 133 | ppComment' "" = empty 134 | ppComment' c = dullwhite $ parens $ text $ Data.ByteString.Char8.unpack c 135 | 136 | ppCode :: Style -> Code -> Doc 137 | ppCode style Code{..} = 138 | ccMaybes codeCls codeNum ( bold $ ppMaybeClass codeCls) 139 | <> ccMaybes codeCls codeNum ( ppMaybe (text . show) codeNum) 140 | <> ppMaybe (\x -> (text ".") <> (text $ show x)) codeSub 141 | <> ifNonEmpty (\x -> space <> ppAxesMap style x) codeAxes 142 | <> ppParams style (Data.Map.toList codeParams) 143 | <> ppComment codeComment 144 | ppCode _ (Comment x) = ppComment' x 145 | ppCode _ (Other x) = dullred $ text $ Data.ByteString.Char8.unpack x 146 | ppCode _ (Empty) = empty 147 | {-# INLINE ppCode #-} 148 | 149 | ifNonEmpty :: (Eq t, Monoid t) 150 | => (t -> Doc) 151 | -> t -> Doc 152 | ifNonEmpty _ x | x == mempty = empty 153 | ifNonEmpty f x | otherwise = f x 154 | -------------------------------------------------------------------------------- /src/Data/GCode/RS274.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 4 | 5 | module Data.GCode.RS274 where 6 | 7 | import Data.GCode.TH 8 | import Data.GCode.Types 9 | import Data.GCode.RS274.Types 10 | 11 | import Data.Maybe (fromJust) 12 | import qualified Data.Map.Strict as M 13 | 14 | $(genShortcuts ''RS274Name) 15 | 16 | namesToCodes = M.fromList . map (\x -> (defName x, toCode x)) $ allCodes 17 | codesToNames = M.fromList . map (\x -> (toCode x, defName x)) $ allCodes 18 | codesToGroups = M.fromList . map (\x -> (toCode x, defGroup x)) $ allCodes 19 | 20 | codesToDefs = M.fromList . map (\x -> (toCode x, x)) $ allCodes 21 | 22 | codeIsRS274 code name = (M.lookup (decimate code) codesToNames) == (Just name) 23 | codeInGroup code group = (fmap defGroup $ M.lookup (decimate code) codesToDefs) == (Just group) 24 | 25 | explain code@Code{} = case M.lookup (decimate code) codesToDefs of 26 | Nothing -> "" 27 | Just def -> defHelp def 28 | explain _ = "" 29 | 30 | -- only to be used by TH 31 | codeFromName :: RS274Name -> Code 32 | codeFromName n = fromJust $ M.lookup n namesToCodes 33 | 34 | -- unused 35 | eqClassNumSub :: Code -> Code -> Bool 36 | eqClassNumSub a b = (decimate a) == (decimate b) 37 | 38 | -- strip this code of its axes/parameters/comments 39 | -- copy just class, code number and subcode 40 | decimate :: Code -> Code 41 | decimate x@Code{} | codeCls x `elem` (map Just [T, FStandalone, PStandalone, SStandalone]) = copyClass x emptyCode 42 | decimate x@Code{} = copyClassNumSub x emptyCode 43 | decimate x = x 44 | 45 | 46 | copyClassNumSub from to = to { codeCls = codeCls from 47 | , codeNum = codeNum from 48 | , codeSub = codeSub from } 49 | 50 | copyClass from to = to { codeCls = codeCls from } 51 | -------------------------------------------------------------------------------- /src/Data/GCode/RS274/Types.hs: -------------------------------------------------------------------------------- 1 | module Data.GCode.RS274.Types where 2 | 3 | import Data.GCode.Types 4 | 5 | -- G-code command definition 6 | data GCodeDef = GCodeDef 7 | { defCls :: Maybe Class 8 | , defNum :: Maybe Int 9 | , defSub :: Maybe Int 10 | , defGroup :: RS274Group 11 | , defName :: RS274Name 12 | , defHelp :: String 13 | } deriving (Show, Eq, Ord) 14 | 15 | defGCD :: GCodeDef 16 | defGCD = GCodeDef { 17 | defCls = Nothing 18 | , defNum = Nothing 19 | , defSub = Nothing 20 | , defGroup = Unknown 21 | , defName = Unnamed 22 | , defHelp = "" 23 | } 24 | 25 | -- utils for creating GCodeDefs 26 | defG :: GCodeDef 27 | defG = defGCD { defCls = Just G } 28 | 29 | defM :: GCodeDef 30 | defM = defGCD { defCls = Just M } 31 | 32 | g :: Int -> RS274Name -> GCodeDef 33 | g x n = defG { defNum = Just x , defName = n } 34 | 35 | m :: Int -> RS274Name -> GCodeDef 36 | m x n = defM { defNum = Just x , defName = n } 37 | 38 | gsub :: Int -> Int -> RS274Name -> GCodeDef 39 | gsub x s n = (g x n) { defSub = Just s } 40 | 41 | msub :: Int -> Int -> RS274Name -> GCodeDef 42 | msub x s n = (m x n) { defSub = Just s } 43 | 44 | -- | Add help text to `GCodeDef` 45 | help :: String -> GCodeDef -> GCodeDef 46 | help txt x = x {defHelp = txt } 47 | 48 | -- | Turn `GCodeDef` into `Code` 49 | toCode :: GCodeDef -> Code 50 | toCode x = emptyCode { codeCls = defCls x 51 | , codeNum = defNum x 52 | , codeSub = defSub x 53 | } 54 | 55 | -- set defGroup for each list member 56 | makeGroup :: RS274Group -> [GCodeDef] -> [GCodeDef] 57 | makeGroup group defs = map (\x -> x { defGroup = group }) defs 58 | 59 | data RS274Name = 60 | Unnamed 61 | | Rapid 62 | | Move 63 | | ArcCW 64 | | ArcCCW 65 | | Dwell 66 | | CubicSpline 67 | | QuadSpline 68 | | NURBS 69 | | XYPlane 70 | | ZXPlane 71 | | YZPlane 72 | | UVPlane 73 | | WUPlane 74 | | VWPlane 75 | | Inches 76 | | Millimeters 77 | | SpindleSync 78 | | RigidTap 79 | | Probe 80 | | DrillingCycleCB 81 | | ThreadingCycle 82 | | DrillingCycleCancel 83 | | DrillingCycle 84 | | DrillingCycleDwell 85 | | DrillingCyclePeck 86 | | BoringCycle 87 | | BoringCycleDwell 88 | | Absolute 89 | | Relative 90 | | ArcAbsolute 91 | | ArcRelative 92 | | LatheDiameter 93 | | LatheRadius 94 | | InverseTime 95 | | UnitsPerMinute 96 | | UnitsPerRevolution 97 | | SpindleOrient 98 | | SpindleStop 99 | | SpindleCW 100 | | SpindleCCW 101 | | SpindleModeConstantSurfaceSpeed 102 | | SpindleModeRPM 103 | | CoolantMist 104 | | CoolantFlood 105 | | CoolantStop 106 | | ToolLength 107 | | ToolLengthDynamic 108 | | ToolLengthAdd 109 | | ToolLengthCancel 110 | | Pause 111 | | OptionalPause 112 | | ProgramEnd 113 | | PalletChange 114 | | PalletChangePause 115 | | CutterCompensationOff 116 | | CutterCompensationLeft 117 | | CutterCompensationDynamicLeft 118 | | CutterCompensationRight 119 | | CutterCompensationDynamicRight 120 | | ToolChange 121 | | SetCurrentTool 122 | | SetToolTable -- XXX this is composed from like five different commands with L parameter 123 | | StoredPositionMove 124 | | StoredPositionSet 125 | | ToolChangePositionMove 126 | | ToolChangePositionSet 127 | | MoveInMachineCoordinates 128 | | CoordinateSystemOffset 129 | | ResetOffsetsParams 130 | | ResetOffsets 131 | | RestoreOffsets 132 | | OverridesEnable 133 | | OverridesDisable 134 | | FeedRateOverride 135 | | SpindleSpeedOverride 136 | | AdaptiveFeedControl 137 | | FeedStopControl 138 | -- 3D printer specific 139 | | ExtruderAbsolute 140 | | ExtruderRelative 141 | | SetExtruderTemperature 142 | | GetExtruderTemperature 143 | | SetExtruderTemperatureAndWait 144 | | SetBedTemperature 145 | | SetBedTemperatureAndWait 146 | | SetChamberTemperature 147 | | SetChamberTemperatureAndWait 148 | | CancelWaitTemperature 149 | | FanOn 150 | | FanOff 151 | | GetCurrentPosition 152 | | DisplayMessage 153 | | DisableActuators 154 | | AutoBedLevel 155 | deriving (Eq, Ord, Show) 156 | 157 | data RS274Group = 158 | Motion 159 | | Cycles 160 | | Distance 161 | | ArcDistance 162 | | FeedRateMode 163 | | SpindleControl 164 | | CoolantControl 165 | | Stopping 166 | | Units 167 | | Plane 168 | | ToolLengthOffset 169 | | CutterRadius 170 | | LatheDiameterMode 171 | | OtherModal 172 | | NonModal 173 | | Unknown 174 | -- 3D printer specific 175 | | Extruder 176 | | Heating 177 | | Cooling 178 | | PrinterMisc 179 | deriving (Eq, Ord, Show) 180 | 181 | 182 | -- G-Codes 183 | 184 | groupMotion :: [GCodeDef] 185 | groupMotion = makeGroup Motion [ 186 | g 0 Rapid 187 | & help "Rapid move" 188 | , g 1 Move 189 | & help "Linear move" 190 | , g 2 ArcCW 191 | & help "Clock-wise arc" 192 | , g 3 ArcCCW 193 | & help "Counter clock-wise arc" 194 | , g 4 Dwell 195 | & help "Do nothing for specified time" 196 | , g 5 CubicSpline 197 | & help "Cubic B-spline move" 198 | , gsub 5 1 QuadSpline 199 | & help "Quadratic B-spline move" 200 | , gsub 5 2 NURBS 201 | & help "NURBS curve move" 202 | , g 33 SpindleSync 203 | & help "Perform spindle synchronized motion" 204 | , gsub 33 1 RigidTap 205 | & help "Rigid Tapping" 206 | , g 38 Probe 207 | & help "Straight probe" 208 | ] 209 | 210 | groupPlane :: [GCodeDef] 211 | groupPlane = makeGroup Plane [ 212 | g 17 XYPlane 213 | & help "Select XY plane (default)" 214 | , g 18 ZXPlane 215 | & help "Select ZX plane" 216 | , g 19 YZPlane 217 | & help "Select YZ plane" 218 | , gsub 17 1 UVPlane 219 | & help "Select UV plane" 220 | , gsub 18 1 WUPlane 221 | & help "Select WU plane" 222 | , gsub 19 1 VWPlane 223 | & help "Select VW plane" 224 | ] 225 | 226 | groupUnits :: [GCodeDef] 227 | groupUnits = makeGroup Units [ 228 | g 20 Inches 229 | & help "Set units to inches" 230 | , g 21 Millimeters 231 | & help "Set units to millimeters" 232 | ] 233 | 234 | groupCutterRadius :: [GCodeDef] 235 | groupCutterRadius = makeGroup CutterRadius [ 236 | g 40 CutterCompensationOff 237 | , g 41 CutterCompensationLeft 238 | , gsub 41 1 CutterCompensationDynamicLeft 239 | , g 42 CutterCompensationRight 240 | , gsub 42 1 CutterCompensationDynamicRight 241 | ] 242 | 243 | groupToolLengthOffset :: [GCodeDef] 244 | groupToolLengthOffset = makeGroup ToolLengthOffset [ 245 | g 43 ToolLength 246 | & help "Enables tool length compensation" 247 | , gsub 43 1 ToolLengthDynamic 248 | , gsub 43 2 ToolLengthAdd 249 | & help "Apply additional tool length offset" 250 | , g 49 ToolLengthCancel 251 | & help "Cancel tool length compensation" 252 | ] 253 | 254 | groupCycles :: [GCodeDef] 255 | groupCycles = makeGroup Cycles [ 256 | g 73 DrillingCycleCB 257 | , g 76 ThreadingCycle 258 | , g 80 DrillingCycleCancel 259 | , g 81 DrillingCycle 260 | , g 82 DrillingCycleDwell 261 | , g 83 DrillingCyclePeck 262 | , g 85 BoringCycle 263 | , g 89 BoringCycleDwell 264 | ] 265 | 266 | groupDistance :: [GCodeDef] 267 | groupDistance = makeGroup Distance [ 268 | g 90 Absolute 269 | & help "Absolute distance mode" 270 | , g 91 Relative 271 | & help "Incremental distance mode" 272 | ] 273 | 274 | groupArcDistance :: [GCodeDef] 275 | groupArcDistance = makeGroup ArcDistance [ 276 | gsub 90 1 ArcAbsolute 277 | & help "Absolute distance mode for I, J & K offsets" 278 | , gsub 91 1 ArcRelative 279 | & help "Incremental distance mode for I, J & K offsets" 280 | ] 281 | 282 | groupLatheDiameterMode :: [GCodeDef] 283 | groupLatheDiameterMode = makeGroup LatheDiameterMode [ 284 | g 7 LatheDiameter 285 | , g 8 LatheRadius 286 | ] 287 | 288 | groupFeedRateMode :: [GCodeDef] 289 | groupFeedRateMode = makeGroup FeedRateMode [ 290 | g 93 InverseTime 291 | & help "Iverse time feed rate mode, move should be completed in 1/F minutes" 292 | , g 94 UnitsPerMinute 293 | & help "Feed rates in units per minute" 294 | , g 95 UnitsPerRevolution 295 | & help "Feed rates in units per revolution" 296 | ] 297 | 298 | 299 | -- mixed M/G 300 | 301 | groupSpindleControl :: [GCodeDef] 302 | groupSpindleControl = makeGroup SpindleControl [ 303 | m 3 SpindleCW 304 | & help "Start the spindle clockwise at the S speed" 305 | , m 4 SpindleCCW 306 | & help "Start the spindle counterclockwise at the S speed" 307 | , m 5 SpindleStop 308 | & help "Stop spindle" 309 | , m 19 SpindleOrient 310 | & help "Orient spindle" 311 | , g 96 SpindleModeConstantSurfaceSpeed 312 | , g 97 SpindleModeRPM 313 | ] 314 | 315 | -- M-Codes 316 | 317 | groupStopping :: [GCodeDef] 318 | groupStopping = makeGroup Stopping [ 319 | m 0 Pause 320 | & help "Pause a running program temporarily" 321 | , m 1 OptionalPause 322 | & help "Pause a running program temporarily if the optional stop switch is on" 323 | , m 2 ProgramEnd 324 | & help "End the program" 325 | , m 30 PalletChange 326 | & help "Exchange pallet shuttles and end the program" 327 | , m 60 PalletChangePause 328 | & help "Exchange pallet shuttles and then pause a running program temporarily" 329 | ] 330 | 331 | groupCoolantControl :: [GCodeDef] 332 | groupCoolantControl = makeGroup CoolantControl [ 333 | m 7 CoolantMist 334 | & help "Turn mist coolant on" 335 | , m 8 CoolantFlood 336 | & help "Turn flood coolant on" 337 | , m 9 CoolantStop 338 | & help "Stop both coolants (M7 & M8)" 339 | ] 340 | 341 | -- non-modal codes 342 | groupNonModal :: [GCodeDef] 343 | groupNonModal = makeGroup NonModal [ 344 | m 6 ToolChange 345 | & help "Stop machine and prompt for tool change" 346 | , m 61 SetCurrentTool 347 | & help "Change current tool number without tool-change (in MDI/Manual mode only)" 348 | , g 10 SetToolTable -- XXX this is composed from like five different commands with L parameter 349 | , g 28 StoredPositionMove 350 | & help "Make a rapid move to position stored with G28.1" 351 | , gsub 28 1 StoredPositionSet 352 | & help "Store current absolute position" 353 | , g 30 ToolChangePositionMove 354 | & help "Make a rapid move to position stored with G30.1" 355 | , gsub 30 1 ToolChangePositionSet 356 | & help "Store current absolute position as tool change position" 357 | , g 53 MoveInMachineCoordinates 358 | & help "Move in the machine coordinate system" 359 | , g 92 CoordinateSystemOffset 360 | & help "Make the current point have the coordinates you want (without motion)" 361 | , gsub 92 1 ResetOffsetsParams 362 | & help "Turn off G92 offsets and reset parameters 5211 - 5219 to zero" 363 | , gsub 92 2 ResetOffsets 364 | & help "Turn off G92 offsets but keep parameters 5211 - 5219 available" 365 | , gsub 92 3 RestoreOffsets 366 | & help "Set the G92 offsets to the values saved in parameters 5211 - 5219" 367 | ] 368 | 369 | groupOtherModal :: [GCodeDef] 370 | groupOtherModal = makeGroup OtherModal [ 371 | defGCD { defCls = Just FStandalone } 372 | & help "Set feed rate" 373 | , defGCD { defCls = Just SStandalone } 374 | & help "Set spindle speed" 375 | , defGCD { defCls = Just T } 376 | & help "Select tool" 377 | , m 48 OverridesEnable 378 | & help "Enable the spindle speed and feed rate override controls" 379 | , m 49 OverridesDisable 380 | & help "Disable the spindle speed and feed rate override controls" 381 | , m 50 FeedRateOverride 382 | & help "Feed rate override control" 383 | , m 51 SpindleSpeedOverride 384 | & help "Spindle speed override control" 385 | , m 52 AdaptiveFeedControl 386 | & help "Adaptive feed control" 387 | , m 53 FeedStopControl 388 | & help "Feed stop control" 389 | ] 390 | 391 | -- 3D printer specific 392 | 393 | groupExtruder :: [GCodeDef] 394 | groupExtruder = makeGroup Extruder [ 395 | m 82 ExtruderAbsolute 396 | & help "Interpret extrusion parameters as absolution positions" 397 | , m 83 ExtruderRelative 398 | & help "Interpret extrusion parameters as relative positions" 399 | ] 400 | 401 | groupHeating :: [GCodeDef] 402 | groupHeating = makeGroup Heating [ 403 | m 104 SetExtruderTemperature 404 | & help "Set extruder temperature" 405 | , m 105 GetExtruderTemperature 406 | & help "Get current temperature of the selected extruder" 407 | , m 109 SetExtruderTemperatureAndWait 408 | & help "Set extruder temperature and wait for it to be reached" 409 | , m 140 SetBedTemperature 410 | & help "Set temperature of the heated bed" 411 | , m 190 SetBedTemperatureAndWait 412 | & help "Set heated bed temperature and wait for it to be reached" 413 | , m 141 SetChamberTemperature 414 | & help "Set temperature of the heated chamber" 415 | , m 191 SetChamberTemperatureAndWait 416 | & help "Set heated chamber and wait for it to be reached" 417 | , m 108 CancelWaitTemperature 418 | & help ("Stops waiting for temperature to be reached issued by M109, M190 or M191." 419 | ++ " This won't disable heaters and will continue the print job.") 420 | ] 421 | 422 | groupCooling :: [GCodeDef] 423 | groupCooling = makeGroup Cooling [ 424 | m 106 FanOn 425 | & help "Enable fan" 426 | , m 107 FanOff 427 | & help "Disable fan" 428 | ] 429 | 430 | groupPrinterMisc :: [GCodeDef] 431 | groupPrinterMisc = makeGroup PrinterMisc [ 432 | g 29 AutoBedLevel 433 | & help "Run automatic heated bed leveling" 434 | , m 84 DisableActuators 435 | & help "Disable actuators, e.g. cut power to steppers" 436 | , m 114 GetCurrentPosition 437 | & help "Report current position of all axes and extruders" 438 | , m 117 DisplayMessage 439 | & help "Display a text message on LCD display" 440 | ] 441 | 442 | cncGroups :: [(RS274Group, [GCodeDef])] 443 | cncGroups = [ 444 | (Motion , groupMotion) 445 | , (Plane , groupPlane) 446 | , (Units , groupUnits) 447 | , (ToolLengthOffset , groupToolLengthOffset) 448 | , (Cycles , groupCycles) 449 | , (Distance , groupDistance) 450 | , (ArcDistance , groupArcDistance) 451 | , (FeedRateMode , groupFeedRateMode) 452 | , (SpindleControl , groupSpindleControl) 453 | , (Stopping , groupStopping) 454 | , (CoolantControl , groupCoolantControl) 455 | , (CutterRadius , groupCutterRadius) 456 | , (LatheDiameterMode, groupLatheDiameterMode) 457 | , (OtherModal , groupOtherModal) 458 | , (NonModal , groupNonModal) 459 | ] 460 | 461 | printerGroups :: [(RS274Group, [GCodeDef])] 462 | printerGroups = [ 463 | (Extruder , groupExtruder) 464 | , (Heating , groupHeating) 465 | , (Cooling , groupCooling) 466 | , (PrinterMisc , groupPrinterMisc) 467 | ] 468 | 469 | allGroups :: [(RS274Group, [GCodeDef])] 470 | allGroups = cncGroups ++ printerGroups 471 | 472 | groupNames :: [RS274Group] 473 | groupNames = map fst allGroups 474 | 475 | -- | All `GCodeDef`s known to us 476 | allCodes :: [GCodeDef] 477 | allCodes = concatMap snd allGroups 478 | -------------------------------------------------------------------------------- /src/Data/GCode/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Data.GCode.TH where 3 | 4 | import Language.Haskell.TH 5 | 6 | import qualified Data.Char 7 | 8 | -- this walks constructors of a datatype 9 | -- and creates isXYZ checks and CodeMod constructors 10 | -- for example for constructor `Rapid` these two are generated 11 | -- isRapid :: Code -> Bool 12 | -- isRapid x = x `codeIsRS274` Rapid 13 | -- 14 | -- rapid :: Code 15 | -- rapid = codeFromName Rapid 16 | genShortcuts :: Name -> Q [Dec] 17 | genShortcuts names = do 18 | info <- reify names 19 | case info of 20 | TyConI (DataD _cxt _name _tyvarbndr _kind constructors _deriv) 21 | -> do 22 | a <- mapM genTests constructors 23 | b <- mapM genConstructors constructors 24 | return $ a ++ b 25 | _ -> error "Unexpected reify input for genShortcuts" 26 | 27 | where 28 | genTests (NormalC name _bangs) = do 29 | varName <- newName "x" 30 | let 31 | funName = mkName $ "is" ++ (nameBase name) 32 | 33 | return $ FunD funName 34 | [ Clause 35 | [VarP varName] 36 | (NormalB (InfixE (Just (VarE varName)) (VarE (mkName "codeIsRS274")) (Just (ConE name)))) 37 | [] 38 | ] 39 | genTests _ = error "Unexpteced input for genTests" 40 | 41 | genConstructors (NormalC name _bangs) = do 42 | let 43 | funName = mkName $ (\(x:rest) -> (Data.Char.toLower x : rest)) (nameBase name) 44 | return $ FunD funName 45 | [ Clause 46 | [] 47 | (NormalB ( (VarE (mkName "codeFromName")) `AppE` (ConE name)) ) 48 | [] 49 | ] 50 | genConstructors _ = error "Unexpteced input for genConstructors" 51 | 52 | -- this walks constructors of a datatype 53 | -- and creates constructors to be used in writer monad 54 | -- 55 | -- for example for constructor `Move` these two are generated 56 | -- move' :: Control.Monad.Trans.Writer.Lazy.Writer (Endo Program) () 57 | -- move' = generateName Move 58 | -- 59 | -- and a wariant accepting Code endofunctor so we can do move' and also move (xy 2 3) 60 | -- move :: (Code -> Code) -> Control.Monad.Trans.Writer.Lazy.Writer (Endo Program) () 61 | -- move fn = generateNameArgs Move fn 62 | -- 63 | -- We prefer variant with args as it seems to be more common 64 | -- to have GCodes with arguments than just standalone ones. 65 | genWriterEndos :: Name -> Q [Dec] 66 | genWriterEndos names = do 67 | info <- reify names 68 | case info of 69 | TyConI (DataD _cxt _name _tyvarbndr _kind constructors _deriv) 70 | -> do 71 | a <- mapM genConstructors constructors 72 | b <- mapM genConstructorsArgs constructors 73 | return $ a ++ b 74 | _ -> error "Unexpected reify input for genWriterEndos" 75 | 76 | where 77 | genConstructors (NormalC name _bangs) = do 78 | let 79 | funName = mkName $ (\(x:rest) -> (Data.Char.toLower x : rest ++ "'")) (nameBase name) 80 | return $ FunD funName 81 | [ Clause 82 | [] 83 | (NormalB ( (VarE (mkName "generateName")) `AppE` (ConE name)) ) 84 | [] 85 | ] 86 | genConstructors _ = error "Unexpteced input for genConstructors" 87 | 88 | genConstructorsArgs (NormalC name _bangs) = do 89 | endoName <- newName "x" 90 | let 91 | funName = mkName $ (\(x:rest) -> (Data.Char.toLower x : rest)) (nameBase name) 92 | return $ FunD funName 93 | [ Clause 94 | [VarP endoName] 95 | (NormalB (((VarE (mkName "generateNameArgs")) `AppE` (ConE name)) `AppE` (VarE endoName)) ) 96 | [] 97 | ] 98 | genConstructorsArgs _ = error "Unexpteced input for genConstructorArgs" 99 | -------------------------------------------------------------------------------- /src/Data/GCode/Types.hs: -------------------------------------------------------------------------------- 1 | {-| GCode types 2 | 3 | This module exports types for constructing 'Code' values 4 | 5 | -} 6 | 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 10 | module Data.GCode.Types ( 11 | Class(..) 12 | , AxisDesignator(..) 13 | , ParamDesignator(..) 14 | , allClasses 15 | , allAxisDesignators 16 | , zeroAxes 17 | , allParamDesignators 18 | , asChars 19 | , Axes 20 | , Params 21 | , Limits 22 | , ParamLimits 23 | , Code(..) 24 | , GCode 25 | , toCodeClass 26 | , toAxis 27 | , toParam 28 | , (&) 29 | , cls 30 | , axis 31 | , param 32 | , num 33 | , sub 34 | , axes 35 | , params 36 | , comment 37 | , emptyCode 38 | , defaultPrec 39 | , Style(..) 40 | , defaultStyle 41 | ) where 42 | 43 | 44 | import Data.ByteString (ByteString) 45 | import Data.Map (Map) 46 | 47 | import qualified Data.Char 48 | import qualified Data.Map 49 | 50 | -- | Code class 51 | data Class = 52 | G -- ^ G-code 53 | | M -- ^ M-code 54 | | T -- ^ T-code (select tool) 55 | | PStandalone -- ^ Stand-alone P-code 56 | | FStandalone -- ^ Stand-alone F-code 57 | | SStandalone -- ^ Stand-alone S-code 58 | deriving (Show, Enum, Eq, Ord) 59 | 60 | allClasses :: [Class] 61 | allClasses = [G, M, T, PStandalone, FStandalone, SStandalone] 62 | 63 | -- | Axis letter 64 | data AxisDesignator = 65 | X -- ^ X-axis 66 | | Y -- ^ Y-axis 67 | | Z -- ^ Z-axis 68 | | A -- ^ A-axis 69 | | B -- ^ B-axis 70 | | C -- ^ C-axis 71 | | U -- ^ U-axis 72 | | V -- ^ V-axis 73 | | W -- ^ W-axis 74 | | E -- ^ Extruder axis 75 | | L 76 | deriving (Show, Enum, Eq, Ord) 77 | 78 | allAxisDesignators :: [AxisDesignator] 79 | allAxisDesignators = [X, Y, Z, A, B, C, U, V, W, E, L] 80 | 81 | -- | Return `Axes` with each known at zero position 82 | zeroAxes :: Axes 83 | zeroAxes = Data.Map.fromList $ map (\a -> (a, 0)) allAxisDesignators 84 | 85 | -- | Param letter 86 | data ParamDesignator = 87 | S -- ^ S parameter - usually spindle RPM 88 | | P -- ^ P parameter 89 | | F -- ^ F parameter - usually feedrate 90 | | H -- ^ H paramater - used by tool length offset 91 | | R -- ^ R parameter 92 | | I -- ^ X offset for arcs 93 | | J -- ^ Y offset for arcs 94 | | K -- ^ Z offset for arcs 95 | deriving (Show, Enum, Eq, Ord) 96 | 97 | allParamDesignators :: [ParamDesignator] 98 | allParamDesignators = [S, P, F, R, I, J, K] 99 | 100 | asChars :: Show a => [a] -> [Char] 101 | asChars types = map ((!! 0) . show) types 102 | 103 | fromChar :: Show a => Char -> [a] -> Maybe a 104 | fromChar c types = Data.Map.lookup (Data.Char.toUpper c) 105 | $ Data.Map.fromList (zip (asChars types) types) 106 | 107 | -- |Convert 'Char' representation of a code to its 'Class' 108 | toCodeClass :: Char -> Maybe Class 109 | toCodeClass c = fromChar c allClasses 110 | 111 | -- |Convert 'Char' representation of an axis to its 'AxisDesignator' 112 | toAxis :: Char -> Maybe AxisDesignator 113 | toAxis c = fromChar c allAxisDesignators 114 | 115 | -- |Convert 'Char' representation of a param to its 'ParamDesignator' 116 | toParam :: Char -> Maybe ParamDesignator 117 | toParam c = fromChar c allParamDesignators 118 | 119 | -- | Map of 'AxisDesignator' to 'Double' 120 | type Axes = Map AxisDesignator Double 121 | 122 | -- | Map of 'AxisDesignator' to pair of 'Double's indicating lower and upper limits of travel 123 | type Limits = Map AxisDesignator (Double, Double) 124 | 125 | -- | Map of 'ParamDesignator' to 'Double' 126 | type Params = Map ParamDesignator Double 127 | 128 | -- | Map of 'ParamDesignator' to pair of 'Double's indicating lower and upper limits of this parameter 129 | type ParamLimits = Map ParamDesignator (Double, Double) 130 | 131 | -- | List of 'Code's 132 | type GCode = [Code] 133 | 134 | data Code = 135 | Code { 136 | codeCls :: Maybe Class -- ^ Code 'Class' (M in M5) 137 | , codeNum :: Maybe Int -- ^ Code value (81 in G81) 138 | , codeSub :: Maybe Int -- ^ Code subcode (1 in G92.1) 139 | , codeAxes :: Axes -- ^ Code 'Axes' 140 | , codeParams :: Params -- ^ Code 'Params' 141 | , codeComment :: ByteString -- ^ Comment following this Code 142 | } 143 | | Comment ByteString -- ^ Standalone comment 144 | | Empty -- ^ Empty lines 145 | | Other ByteString -- ^ Parser unhandled lines 146 | deriving (Show, Eq, Ord) 147 | 148 | 149 | -- endofunctors for manipulating `Code` 150 | cls :: Class -> Code -> Code 151 | cls x c = c { codeCls = Just x} 152 | 153 | num :: Int -> Code -> Code 154 | num x c = c { codeNum = Just x} 155 | 156 | sub :: Int -> Code -> Code 157 | sub x c = c { codeSub = Just x} 158 | 159 | axes :: Axes -> Code -> Code 160 | axes x c = c { codeAxes = x} 161 | 162 | axis :: AxisDesignator -> Double -> Code -> Code 163 | axis des val c = c { codeAxes = Data.Map.insert des val $ codeAxes c } 164 | 165 | params :: Params -> Code -> Code 166 | params x c = c { codeParams = x} 167 | 168 | param :: ParamDesignator -> Double -> Code -> Code 169 | param des val c = c { codeParams = Data.Map.insert des val $ codeParams c } 170 | 171 | comment :: ByteString -> Code -> Code 172 | comment x c = c { codeComment = x} 173 | 174 | -- code & num 10 & comment "& example" 175 | (&) :: a -> (a -> c) -> c 176 | (&) = flip ($) 177 | 178 | emptyCode :: Code 179 | emptyCode = Code { 180 | codeCls = Nothing 181 | , codeNum = Nothing 182 | , codeSub = Nothing 183 | , codeAxes = mempty 184 | , codeParams = mempty 185 | , codeComment = mempty 186 | } 187 | 188 | 189 | data Style = 190 | Style { 191 | stylePrecision :: Int 192 | , styleColorful :: Bool 193 | } deriving (Show) 194 | 195 | defaultPrec :: Int 196 | defaultPrec = 6 197 | 198 | defaultStyle :: Style 199 | defaultStyle = Style defaultPrec False 200 | -------------------------------------------------------------------------------- /src/Data/GCode/Utils.hs: -------------------------------------------------------------------------------- 1 | {-| GCode pretty-printing functions 2 | 3 | Utilities for manipulating and filtering 'GCode' 4 | 5 | -} 6 | {-# LANGUAGE RecordWildCards #-} 7 | module Data.GCode.Utils where 8 | 9 | import Data.Maybe 10 | 11 | import Data.GCode.Types 12 | import Data.GCode.RS274 (isMove, isRapid) 13 | import qualified Data.Map.Strict as M 14 | 15 | -- | True if 'Code' is a G-code 16 | isG :: Code -> Bool 17 | isG Code{codeCls=(Just G)} = True 18 | isG _ = False 19 | 20 | -- | True if 'Code' is a M-code 21 | isM :: Code -> Bool 22 | isM Code{codeCls=(Just M)} = True 23 | isM _ = False 24 | 25 | -- | True if 'Code' is a G{N} code 26 | isGN :: Int -> Code -> Bool 27 | isGN n Code{codeCls=(Just G), codeNum=(Just x)} = x == n 28 | isGN _ _ = False 29 | 30 | -- | True if 'Code' has a coordinate in axis 'a' 31 | hasAxis :: AxisDesignator -> Code -> Bool 32 | hasAxis a Code{..} = M.member a codeAxes 33 | hasAxis _ _ = False 34 | 35 | getAxis :: AxisDesignator -> Code -> Maybe Double 36 | getAxis a Code{..} = M.lookup a codeAxes 37 | getAxis _ _ = Nothing 38 | 39 | getAxes :: [AxisDesignator] -> Code -> [Maybe Double] 40 | getAxes as c = map (\a-> getAxis a c) as 41 | 42 | getAxesToList :: Code -> [(AxisDesignator, Double)] 43 | getAxesToList Code{..} = M.toList codeAxes 44 | getAxesToList _ = [] 45 | 46 | --filterAxes :: [AxisDesignator] -> Code -> [Double] 47 | --filterAxes ax Code{..} = map (\a -> M.lookup a codeAxes) ax 48 | 49 | -- | True if 'Code' contains 'X' axis 50 | hasX :: Code -> Bool 51 | hasX = hasAxis X 52 | 53 | -- | True if 'Code' contains 'Y' axis 54 | hasY :: Code -> Bool 55 | hasY = hasAxis Y 56 | 57 | -- | True if 'Code' contains 'Z' axis 58 | hasZ :: Code -> Bool 59 | hasZ = hasAxis Z 60 | 61 | -- | True if 'Code' contains 'E' axis 62 | hasE :: Code -> Bool 63 | hasE = hasAxis E 64 | 65 | -- | True if 'Code' contains parameter with 'ParamDesignator' 66 | hasParam :: ParamDesignator -> Code -> Bool 67 | hasParam p Code{..} = M.member p codeParams 68 | hasParam _ _ = False 69 | 70 | -- | Get parameter if defined 71 | getParam :: ParamDesignator -> Code -> Maybe Double 72 | getParam p Code{..} = M.lookup p codeParams 73 | getParam _ _ = Nothing 74 | 75 | -- | True if 'Code' contains feedrate parameter (e.g. G0 F3000) 76 | hasFeedrate :: Code -> Bool 77 | hasFeedrate = hasParam F 78 | 79 | -- | Filter G-codes 80 | gcodes :: [Code] -> [Code] 81 | gcodes = filter isG 82 | 83 | -- | Filter M-codes 84 | mcodes :: [Code] -> [Code] 85 | mcodes = filter isM 86 | 87 | -- | Filter rapid moves 88 | rapids :: [Code] -> [Code] 89 | rapids = filter isRapid 90 | 91 | -- | Filter moves 92 | moves :: [Code] -> [Code] 93 | moves = filter isMove 94 | 95 | -- | Replace 'Class' of 'Code' (e.g. for chaning G0 to M0) 96 | replaceClass :: Class -> Code -> Code 97 | replaceClass newclass c = cls newclass c 98 | 99 | -- | Replace code value of 'Code' (e.g. for chaning G0 to G1) 100 | replaceCode :: Int -> Code -> Code 101 | replaceCode newcode c = num newcode c 102 | 103 | -- | Replace axis with 'AxisDesignator' in 'Code' returning new 'Code' 104 | replaceAxis :: AxisDesignator -> Double -> Code -> Code 105 | replaceAxis de val c | hasAxis de c = addReplaceAxis de val c 106 | replaceAxis _ _ c = c 107 | 108 | -- | Apply function to axis specified by 'AxisDesignator' 109 | modifyAxis :: AxisDesignator -> (Double -> Double) -> Code -> Code 110 | modifyAxis de f c | hasAxis de c = addReplaceAxis de (f $ fromJust $ getAxis de c) c 111 | modifyAxis _ _ c = c 112 | 113 | -- | Apply function to axes specified by '[AxisDesignator]' 114 | modifyAxes :: [AxisDesignator] -> (Double -> Double) -> Code -> Code 115 | modifyAxes axes' f c = foldl (\c1 ax -> modifyAxis ax f c1) c axes' 116 | 117 | -- | Test if Code has X and Y axes 118 | hasXY :: Code -> Bool 119 | hasXY c = hasAxis X c && hasAxis Y c 120 | 121 | -- | Apply function to X and Y axes 122 | modifyXY :: (Double -> Double -> (Double, Double)) -> Code -> Code 123 | modifyXY f c | hasXY c = 124 | let x = fromJust $ getAxis X c 125 | y = fromJust $ getAxis Y c 126 | (nx, ny) = f x y 127 | in c & axis X nx & axis Y ny 128 | modifyXY _ c = c 129 | 130 | -- | Replace or add axis with 'AxisDesignator' in 'Code' returning new 'Code' 131 | addReplaceAxis :: AxisDesignator -> Double -> Code -> Code 132 | addReplaceAxis de val c@Code{..} = c & (axes $ newaxes $ codeAxes) 133 | where 134 | newaxes = M.insert de val 135 | addReplaceAxis _ _ x = x 136 | 137 | -- | Replace X axis coordnate 138 | replaceX :: Double -> Code -> Code 139 | replaceX = replaceAxis X 140 | 141 | -- | Replace Y axis coordinate 142 | replaceY :: Double -> Code -> Code 143 | replaceY = replaceAxis Y 144 | 145 | -- | Replace Z axis coordinate 146 | replaceZ :: Double -> Code -> Code 147 | replaceZ = replaceAxis Z 148 | 149 | -- | Replace E axis coordinate 150 | replaceE :: Double -> Code -> Code 151 | replaceE = replaceAxis E 152 | 153 | -- | Replace or add X axis coordinate 154 | addReplaceX :: Double -> Code -> Code 155 | addReplaceX = addReplaceAxis X 156 | 157 | -- | Replace or add Y axis coordinate 158 | addReplaceY :: Double -> Code -> Code 159 | addReplaceY = addReplaceAxis Y 160 | 161 | -- | Replace or add Z axis coordinate 162 | addReplaceZ :: Double -> Code -> Code 163 | addReplaceZ = addReplaceAxis Z 164 | 165 | -- | Replace or add E axis coordinate 166 | addReplaceE :: Double -> Code -> Code 167 | addReplaceE = addReplaceAxis E 168 | 169 | -- | Replace parameter with 'ParamDesignator' in 'Code' returning new 'Code' 170 | replaceParam :: ParamDesignator -> Double -> Code -> Code 171 | replaceParam de val c | hasParam de c = addReplaceParam de val c 172 | replaceParam _ _ c = c 173 | 174 | -- | Apply function to parameter with 'ParamDesignator' 175 | modifyParam :: ParamDesignator -> (Double -> Double) -> Code -> Code 176 | modifyParam de f c | hasParam de c = addReplaceParam de (f $ fromJust $ getParam de c) c 177 | modifyParam _ _ c = c 178 | 179 | -- | Apply function to parameters specified by '[ParamDesignator]' 180 | modifyParams :: [ParamDesignator] -> (Double -> Double) -> Code -> Code 181 | modifyParams params' f c = foldl (\c1 ax -> modifyParam ax f c1) c params' 182 | 183 | -- | Apply function to parameters specified by '[ParamDesignator]' 184 | -- 185 | -- Function gets 'ParameterDesignator' passed as its first argument 186 | modifyParamsWithKey :: [ParamDesignator] -> (ParamDesignator -> Double -> Double) -> Code -> Code 187 | modifyParamsWithKey params' f c = foldl (\c1 ax -> modifyParam ax (f ax) c1) c params' 188 | 189 | -- | Replace or add parameter with 'ParamDesignator' in 'Code' returning new 'Code' 190 | addReplaceParam :: ParamDesignator -> Double -> Code -> Code 191 | addReplaceParam de val c@Code{..} = c & (params $ newparams $ codeParams) 192 | where 193 | newparams = M.insert de val 194 | addReplaceParam _ _ x = x 195 | 196 | -- | Replace feedrate (F parameter) in 'Code' returning new 'Code' 197 | replaceFeedrate :: Double -> Code -> Code 198 | replaceFeedrate = replaceParam F 199 | 200 | -- | Apply function to feedrate 201 | modifyFeedrate :: (Double -> Double) -> Code -> Code 202 | modifyFeedrate = modifyParam F 203 | 204 | -- | Sum of all axis distances of this 'Code' 205 | travelDistance :: Code -> Double 206 | travelDistance Code{codeCls=(Just G), ..} = M.foldl (+) 0 codeAxes 207 | travelDistance _ = 0 208 | 209 | -- | Round `x` with specified precision 210 | roundprec :: (Integral a, RealFrac b, Fractional c) => a -> b -> c 211 | roundprec n x = (fromInteger $ round $ x * (10^n)) / (10.0^^n) 212 | -------------------------------------------------------------------------------- /test/EvalSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module EvalSpec where 4 | 5 | import SpecHelper 6 | 7 | import Data.GCode.Generate 8 | import Data.GCode.RS274 9 | import Data.GCode.Eval 10 | 11 | 12 | shouldEvalEqually a b = (ipModalGroups . snd . eval $ a) `shouldBe` (ipModalGroups . snd . eval $ b) 13 | shouldTotalizeEqually a b = (totalize a) `shouldBe` b 14 | 15 | spec :: Spec 16 | spec = do 17 | context "eval" $ do 18 | it "replaces move commands" $ do 19 | shouldEvalEqually [ move & xy 6 1 , rapid & xy 0 0 ] 20 | [ rapid & xy 0 0 ] 21 | 22 | it "updates moves correctly" $ do 23 | shouldEvalEqually [ move & xyz 6 1 2 , rapid & xy 0 0 ] 24 | [ rapid & xyz 0 0 2] 25 | 26 | it "handles incompletes correctly" $ do 27 | shouldEvalEqually [ move & xyz 6 1 2 , emptyCode & xy 0 0 ] 28 | [ move & xyz 0 0 2] 29 | 30 | it "handles inches" $ do 31 | shouldEvalEqually [ inches, move & xyz 0 0 1, move & xy 1 1 ] 32 | [ move & xyz 25.4 25.4 25.4, inches ] 33 | 34 | it "handles feedrate in inches" $ do 35 | shouldEvalEqually [ inches, move & xyz 0 0 1, move & xy 1 1 & feed 10 ] 36 | [ move & xyz 25.4 25.4 25.4 & feed 254, inches ] 37 | 38 | it "handles relative moves" $ do 39 | shouldEvalEqually [ relative, move & xyz 1 1 1, move & xy 2 3 ] 40 | [ move & xyz 3 4 1, relative ] 41 | 42 | it "handles relative arcs" $ do 43 | shouldEvalEqually [ arcRelative, move & xyz 1 1 1, arc & xy 10 10 & ij 5 5 ] 44 | [ arc & xyz 10 10 1 & ij 6 6, arcRelative ] 45 | 46 | it "handles combined relative/absolute moves" $ do 47 | shouldEvalEqually [ relative, move & xyz 10 15 19, absolute, move & z 20 ] 48 | [ move & xyz 10 15 20 ] 49 | 50 | context "totalize" $ do 51 | it "totalizes simple moves" $ do 52 | shouldTotalizeEqually [ move & x 0 , move & y 1, move & z 2 ] 53 | [ move & x 0, move & xy 0 1, move & xyz 0 1 2 ] 54 | 55 | it "totalizes incomplete moves" $ do 56 | shouldTotalizeEqually [ move & x 0 , emptyCode & y 1, emptyCode & z 2 ] 57 | [ move & x 0, move & xy 0 1, move & xyz 0 1 2 ] 58 | 59 | it "totalizes mixed moves/rapids" $ do 60 | shouldTotalizeEqually [ spindleCW, move & x 0 , rapid & y 1, move & z 2 ] 61 | [ spindleCW, move & x 0, rapid & xy 0 1, move & xyz 0 1 2 ] 62 | 63 | context "updateAxes" $ do 64 | it "updates axes correctly" $ do 65 | let from = codeAxes $ move & y 1 & z 2 66 | to = codeAxes $ move & x 0 67 | (updateAxes from to) `shouldBe` (codeAxes $ move & xyz 0 1 2) 68 | -------------------------------------------------------------------------------- /test/GenSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module GenSpec where 4 | 5 | import SpecHelper 6 | 7 | import Data.GCode.Generate 8 | import Data.GCode.RS274 9 | 10 | spec :: Spec 11 | spec = do 12 | it "moves" $ do 13 | pp [ move & xyz 1 2 3 ] `shouldBe` "G1 X1.00 Y2.00 Z3.00\n" 14 | 15 | it "rapids" $ do 16 | pp [ rapid & xy 13.37 48 ] `shouldBe` "G0 X13.37 Y48.00\n" 17 | 18 | it "mcodes" $ do 19 | pp [ m <#> 5, m <#> 9, m <#> 2 ] `shouldBe` "M5\nM9\nM2\n" 20 | 21 | it "params" $ do 22 | pp [ g <#> 4 & param P 10 ] `shouldBe` "G4 P10.00\n" 23 | 24 | it "subcodes" $ do 25 | pp [ g <#> 5 & sub 2 ] `shouldBe` "G5.2\n" 26 | -------------------------------------------------------------------------------- /test/ParseSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module ParseSpec where 4 | 5 | import SpecHelper 6 | 7 | import qualified Data.ByteString.Char8 as BSC 8 | 9 | spec :: Spec 10 | spec = do 11 | let roundTrip n = (fmap pp $ parseOnly parseGCode n) `shouldBe` (Right (BSC.unpack n)) 12 | it "roundtrips" $ do 13 | roundTrip "M3\n" 14 | 15 | roundTrip "M117 L180.00 S8640.00\n" 16 | 17 | roundTrip "G0 X1.00 Y2.00 Z3.33\nM114\n" 18 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /test/SpecHelper.hs: -------------------------------------------------------------------------------- 1 | module SpecHelper 2 | ( module Test.Hspec 3 | , module Data.GCode 4 | , parseOnly 5 | , fromString 6 | , pp 7 | ) where 8 | 9 | import Test.Hspec 10 | import Data.Attoparsec.ByteString (parseOnly) 11 | import Data.GCode 12 | import Data.GCode.Parse 13 | import Data.GCode.Pretty 14 | import Data.String (fromString) 15 | 16 | pp = ppGCodeStyle $ defaultStyle { stylePrecision = 2 } 17 | --------------------------------------------------------------------------------