diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,22 @@ +# Version [0.1.2.0](https://github.com/distrap/gcodehs/compare/0.1.2.0...0.1.1.0) (2020-06-17) + +* Changelog started. Previous release was `0.1.1.0`. + +* Major rework, only core functionality and types unchanged + * Little changes to parser and pretty printer, APIs unchaged + +* Additions + * Canonical representation `Data.GCode.Canon` + * Interepreters for both `GCode` and canonical representation + * Line output + * Tests + * Helpers and monad for generating GCode + * Pipes now exposed from library via `Data.GCode.Pipes` + * `Data.GCode.RS274.Types` module with command decriptions + +--- + +`gcodehs` uses [PVP Versioning][1]. + +[1]: https://pvp.haskell.org + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,39 @@ +# gcodehs + +## Installing + +* `git clone https://github.com/distrap/gcodehs/` +* `cd gcodehs` +* `nix-build` or `nix-shell` + +## Usage + +To pretty-print `sample.gcode`:: + +```bash +gcodehs pretty sample.gcode +``` + +See `gcodehs --help` for usage information. + +## Development status + +Pretty printing is slow due to conversion +to text but we do have colors! + +Fast pretty printer is needed that operates +with ByteStrings directly. + +## Bash completion + +Generating bash completion:: + +```bash +gcodehs --bash-completion-script `which gcodehs` &> gcodehs-completion.sh +``` + +or sourcing directly:: + +```bash +source <(gcodehs --bash-completion-script `which gcodehs`) +``` diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -2,94 +2,95 @@ {-# LANGUAGE OverloadedStrings #-} module Main where -import Data.GCode -import Prelude hiding (readFile, putStrLn) +import Pipes (Pipe, (>->)) +import Pipes.Safe (SafeT) +import Data.ByteString (ByteString) import Control.Applicative - -import Pipes -import Pipes.Attoparsec as PA -import qualified Pipes.Prelude as P -import qualified Pipes.ByteString as B ---import Pipes.ByteString.MMap -import Pipes.Safe -import qualified System.IO as IO +import Options.Applicative -import Data.Monoid ((<>)) -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy as BL +import Data.GCode +import Data.GCode.Pipes.Transform +import Data.GCode.Line (prettyLine) -import Options.Applicative -import Options.Applicative.Builder +data Command = + Cat + | Pretty + | Analyze + | Totalize + | TranslateXY Double Double + | TranslateZ Double + | Rotate Double + | ScaleFeedrate Double + | ScaleXY Double Double + | Eval + | Canon + | Lines + -- TODO + | TravelDistance + | ExtrusionDistance + | Generate + -- disabled for now as they require interepreter not just looking at coords + -- (due to relative moves) + | Limits + | ToOrigin + deriving (Eq, Show, Ord) -data Flags = Flags { - input :: FilePath - , output :: FilePath - , pretty :: Bool - , analyze :: Bool +data Options = Options { + cmd :: Command + , input :: FilePath + , output :: Maybe FilePath } deriving (Show) --- switch to arguments when following is fixed and tab-completion --- prefers arguments before options --- https://github.com/pcapriotti/optparse-applicative/issues/173 --- <$> argument str (metavar "FILE") +cmdParser :: Parser Command +cmdParser = subparser + ( command "cat" (info (pure Cat) (progDesc "Parse and print GCode")) + <> command "pretty" (info (pure Pretty) (progDesc "Parse and pretty-print GCode")) +-- <> command "limits" (info (pure Limits) (progDesc "Compute axis movements limits")) +-- <> command "move-to-origin" (info (pure ToOrigin) (progDesc "Move GCode so it starts at X0 Y0")) + <> command "totalize" (info (pure Totalize) (progDesc "Walk GCode adding missing axes coordinates according to previous moves")) + <> command "translate-xy" (info (TranslateXY <$> argument auto (metavar "X") <*> argument auto (metavar "Y")) (progDesc "Translate GCode by X Y offsets")) + <> command "translate-z" (info (TranslateZ <$> argument auto (metavar "Z")) (progDesc "Translate GCode by Z offset")) + <> command "rotate" (info (Rotate <$> argument auto (metavar "DEG")) (progDesc "Rotate GCode by angle in degrees")) + <> command "scale-feedrate" (info (ScaleFeedrate <$> argument auto (metavar "MULTIPLIER")) (progDesc "Scale feedrates by multiplier")) + <> command "scale-xy" (info (ScaleXY <$> argument auto (metavar "X") <*> argument auto (metavar "Y")) (progDesc "Scale X/Y by multiplier")) + <> command "eval" (info (pure Eval) (progDesc "Evaluate GCode")) + <> command "canon" (info (pure Canon) (progDesc "Convert to canonical representation")) + <> command "lines" (info (pure Lines) (progDesc "Convert to lines")) + ) -flags :: Parser Flags -flags = Flags - <$> strOption ( long "input" <> short 'i' <> metavar "INPUT") - <*> strOption ( long "output" <> short 'o' <> metavar "OUTPUT" <> value "") - <*> switch ( long "pretty" <> short 'p' <> help "Pretty output") - <*> switch ( long "analyze" <> short 'a' <> help "Analyze GCode") +flags :: Parser Options +flags = Options + <$> cmdParser + <*> argument str (metavar "INPUT-FILE") + <*> (optional + $ strOption ( + long "output" + <> short 'o' + <> metavar "OUTPUT-FILE")) +main :: IO () main = - execParser opts >>= run + execParser opts >>= \Options{..} -> runPipe input output (toSink cmd) where opts = info (helper <*> flags) ( fullDesc - <> progDesc "Process GCode from INPUT" + <> progDesc "Process GCode from FILE" <> header "gcodehs - GCode processor" ) -run :: Flags -> IO () -run Flags{..} = - if analyze - then do - r <- foldedpipe input analyzefold - print r - else case output of - "" -> gcodepipe input $ fmt pretty >-> B.stdout - _ -> IO.withFile output IO.WriteMode $ \outhandle -> - gcodepipe input $ fmt pretty >-> B.toHandle outhandle - -bufsize = 1024 - -parseProducer handle = PA.parsed parseGCodeLine (B.hGetSome bufsize handle) - -gcodepipe filepath tail = - IO.withFile filepath IO.ReadMode $ \handle -> - runSafeT . runEffect $ - (() <$ parseProducer handle) - >-> tail - -foldedpipe filepath fold = - IO.withFile filepath IO.ReadMode $ \handle -> - runSafeT . runEffect $ - fold (() <$ parseProducer handle) - -analyzefold = P.fold step 0 id - where step x a = x + 1 -- travel a - ---analyzefold' = P.fold step 0 id --- where step x a | isG a = x + 1 --- step x a | otherwise = x +toSink :: Command -> Pipe Code ByteString (SafeT IO) () +toSink Cat = compactSink +toSink Pretty = prettySink +toSink Totalize = totalizeP >-> compactSink +toSink Eval = evalP >-> prettySink +toSink Canon = evalP >-> evalCanonP >-> prettySinkWith (wrapPrinter show) +toSink Lines = evalP >-> evalCanonLinesP >-> (prettySinkWith $ wrapPrinter $ prettyLine defaultStyle) -fmt True = P.map ppGCodeLine >-> P.map (BS.pack . (++"\n")) -fmt False = P.map ppGCodeLineCompact >-> P.map (BS.pack . (++"\n")) +toSink (TranslateXY xt yt) = translateXY xt yt >-> compactSink +toSink (TranslateZ zt) = translateZ zt >-> compactSink +toSink (ScaleXY xs ys) = scaleXY xs ys >-> compactSink +toSink (ScaleFeedrate s) = scaleFeedrate s >-> compactSink +toSink (Rotate a) = rotate a >-> compactSink --- mmaped version, requires pipes-bytestring-mmap ---main' = do --- file <- fmap Prelude.head getArgs --- runSafeT . runEffect $ --- (() <$ PA.parsed parseGCodeLine (unsafeMMapFile file) ) --- >-> P.map ppGCodeLine --- >-> P.stdoutLn +toSink _ = error "Currently not supported, sorry :(" diff --git a/gcodehs.cabal b/gcodehs.cabal --- a/gcodehs.cabal +++ b/gcodehs.cabal @@ -1,8 +1,8 @@ name: gcodehs -version: 0.1.1.0 +version: 0.1.2.0 synopsis: GCode processor description: GCode parser, pretty-printer and processing utils -homepage: https://github.com/hackerspace/gcodehs +homepage: https://github.com/distrap/gcodehs license: BSD3 license-file: LICENSE author: Richard Marko @@ -10,61 +10,88 @@ copyright: 2016 Richard Marko category: Parsing build-type: Simple --- extra-source-files: cabal-version: >=1.10 +extra-source-files: + CHANGELOG.md + README.md + LICENSE library + ghc-options: -Wall hs-source-dirs: src - exposed-modules: Data.GCode, Data.GCode.Types, Data.GCode.Parse, Data.GCode.Pretty, Data.GCode.Utils + exposed-modules: Data.GCode + , Data.GCode.Ann + , Data.GCode.Canon + , Data.GCode.Canon.Convert + , Data.GCode.Generate + , Data.GCode.Generate.Examples + , Data.GCode.Generate.ExamplesMonad + , Data.GCode.Eval + , Data.GCode.Line + , Data.GCode.Monad + , Data.GCode.Types + , Data.GCode.Parse + , Data.GCode.Pipes + , Data.GCode.Pipes.Transform + , Data.GCode.Pretty + , Data.GCode.RS274 + , Data.GCode.RS274.Types + , Data.GCode.TH + , Data.GCode.Utils build-depends: base >= 4.7 && < 5 , attoparsec , ansi-wl-pprint , bytestring , containers + , transformers , double-conversion , text + , template-haskell , pipes , pipes-attoparsec , pipes-bytestring - , mtl - , vty - , array +-- , pipes-bytestring-mmap + , pipes-safe + , pipes-parse default-language: Haskell2010 executable gcodehs hs-source-dirs: app main-is: Main.hs - ghc-options: -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: base , attoparsec , bytestring + , containers , double-conversion , gcodehs - , text , pipes - , pipes-attoparsec - , pipes-bytestring --- , pipes-bytestring-mmap , pipes-safe - , pipes-parse - , pipes-text + , text + , transformers , optparse-applicative + , optparse-applicative default-language: Haskell2010 ---test-suite gcodehs-test --- type: exitcode-stdio-1.0 --- hs-source-dirs: test --- main-is: Spec.hs --- build-depends: base --- , attoparsec --- , ansi-wl-pprint --- , bytestring --- , gcodehs --- , text --- , turtle --- ghc-options: -threaded -rtsopts -with-rtsopts=-N --- default-language: Haskell2010 +test-suite gcodehs-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: ParseSpec + GenSpec + EvalSpec + SpecHelper + build-depends: base + , attoparsec + , ansi-wl-pprint + , bytestring + , gcodehs + , hspec + , hspec-discover + , text + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 source-repository head type: git - location: https://github.com/hackerspace/gcodehs + location: https://github.com/distrap/gcodehs diff --git a/src/Data/GCode.hs b/src/Data/GCode.hs --- a/src/Data/GCode.hs +++ b/src/Data/GCode.hs @@ -1,12 +1,23 @@ {-| This module is an entry point to @gcodehs@ library -This module re-exports all Data.GCode submodules. +This module re-exports most of the "Data.GCode" submodules. -} - {-# LANGUAGE OverloadedStrings #-} -module Data.GCode (module X) where -import Data.GCode.Types as X -import Data.GCode.Parse as X -import Data.GCode.Pretty as X -import Data.GCode.Utils as X +module Data.GCode ( + module Data.GCode.Ann + , module Data.GCode.Eval + , module Data.GCode.Types + , module Data.GCode.Parse + , module Data.GCode.Pipes + , module Data.GCode.Pretty + , module Data.GCode.Utils + ) where + +import Data.GCode.Ann +import Data.GCode.Eval +import Data.GCode.Types +import Data.GCode.Parse +import Data.GCode.Pipes +import Data.GCode.Pretty +import Data.GCode.Utils diff --git a/src/Data/GCode/Ann.hs b/src/Data/GCode/Ann.hs new file mode 100644 --- /dev/null +++ b/src/Data/GCode/Ann.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DeriveFunctor #-} + +module Data.GCode.Ann ( + Ann(..) + , stripAnnotation + ) where + +{- +Type for annotating `Code` or `Canon` with source positions. +-} + + +data Ann a = SrcLine Integer a + deriving (Show, Eq, Ord, Functor) + +stripAnnotation :: Ann a -> a +stripAnnotation (SrcLine _ x) = x diff --git a/src/Data/GCode/Canon.hs b/src/Data/GCode/Canon.hs new file mode 100644 --- /dev/null +++ b/src/Data/GCode/Canon.hs @@ -0,0 +1,138 @@ +{- Canonnical representation + +Our IR +(work in progress) +-} + +module Data.GCode.Canon where + +import Data.ByteString (ByteString) +import Data.GCode.Types (Axes, zeroAxes) + +import qualified Data.Map + +data Plane = XY | YZ | ZX | UV | WU | VW + deriving (Show, Eq, Ord) + +data CutterCompenstationSide = + CutterCompensationRight + | CutterCompensationLeft + | CutterCompensationOff + deriving (Show, Eq, Ord) + +type Speed = Double +type Seconds = Double + +data RotationDirection = ClockWise | CounterClockWise + deriving (Show, Eq, Ord) + +data LengthUnit = Inches | MilliMeters | CentiMeters | Meters + deriving (Show, Eq, Ord) + +data HeaterType = HeatedExtruder | HeatedBed | HeatedChamber + deriving (Show, Eq, Ord) + +-- | Some heater with id or Nothing for current / default +data Heater = Heater HeaterType (Maybe Int) + deriving (Show, Eq, Ord) + +-- | Tool length compensation +data CompensationMode = + NoCompensation -- ^ Tool length compensation is disabled + | LengthTable -- ^ Following moves will take into account tool offset from tool table + | Dynamic Axes -- ^ Apply dynamic offset + | Add Int -- ^ Add tool offset of the tool specified by the parameter to currently selected tool offset + deriving (Show, Eq, Ord) + +-- Like linxucnc arcs, not used, subject to change +data ArcParams = ArcParams { + arcFirstEnd :: Double -- ^ first second coordinates according to selected plane + , arcSecondEnd :: Double + , arcFirstAxis :: Double + , arcSecondAxis :: Double + , arcRotation :: Int + , arcAxisEndPoint :: Double + , arcA :: Double + , arcB :: Double + , arcC :: Double + , arcU :: Double + , arcV :: Double + , arcW :: Double + } deriving (Eq, Show, Ord) + +data Canon = + StraightTraverse Axes -- ^ Rapid motion to end position specified by Axes + | StraightFeed Axes -- ^ Machining motion + | StraightProbe Axes -- ^ Straight probe towards workpeice + | SetCoords Axes -- ^ Set coordinates to provided values without motion + | ArcFeed ArcParams -- ^ Movement along arc + | ProgramEnd -- ^ End of the program + | SetFeedRate Speed -- ^ Set feed rate for machining moves + | SetTraverseRate Speed -- ^ Set feed rate for travel moves + | PlaneSelect Plane -- ^ Set plane + | PauseSeconds Double -- ^ Do nothing for specified number of seconds + | SpindleStart { + spindleDirection :: RotationDirection -- ^ Rotate spindle according to `RotationDirection` + , spindleWaitForSpeed :: Bool -- ^ Wait for spindle to reach desired RPM + } + | SpindleStop -- ^ Stop spindle + | SpindleSpeed Speed -- ^ Set spindle RPM + | CoolantMist -- ^ Enable mist coolant + | CoolantFlood -- ^ Enable flood coolant + | CoolantStop -- ^ Stop all coolant flows + -- Tools + | ToolSelect Int -- ^ Select tool by its index + | ToolChange -- ^ Perform tool change + | ToolLengthCompensation CompensationMode -- ^ Enable tool length compensation + -- Printer + | FanOn -- ^ Enable fan + | FanOff -- ^ Disable fan + | SetTemperature Heater Double -- ^ Set temperature of the specific heater + | SetTemperatureWait Heater Double -- ^ Set temperature and wait for it to be reached + | CancelWaitTemperature -- ^ Cancel all temperature waits + | LevelBed -- ^ Perform automated bed leveling + -- Misc + | DisableMotors Axes -- ^ Disable power to motors + | DisplayMessage ByteString -- ^ Display a message, typically on LCD + | Comment ByteString -- ^ Just a comment + deriving (Show, Eq, Ord) + +-- | State of the Canon interpreter +data CanonState = CanonState { + canonPosition :: Axes -- ^ Position + , canonTraverseRate :: Speed -- ^ Speed for travel moves + , canonFeedRate :: Speed -- ^ Speed for machining moves + , canonPlane :: Plane -- ^ Selected plane + } deriving (Show, Eq, Ord) + +-- | Initial state of the Canon interpreter +initCanonState :: CanonState +initCanonState = CanonState { + canonPosition = zeroAxes + , canonTraverseRate = 0 + , canonFeedRate = 0 + , canonPlane = XY + } + +-- | Step Canon interpreter, returning new state +stepCanon :: CanonState -> Canon -> CanonState +stepCanon s (StraightTraverse a) = s { canonPosition = Data.Map.union a (canonPosition s) } +stepCanon s (StraightFeed a) = s { canonPosition = Data.Map.union a (canonPosition s) } +stepCanon s (SetFeedRate r) = s { canonFeedRate = r } +stepCanon s (SetTraverseRate r) = s { canonTraverseRate = r } +stepCanon s (SetCoords a) = s { canonPosition = Data.Map.union a (canonPosition s) } +stepCanon s (PlaneSelect p) = s { canonPlane = p } + +-- | Fully eval list of `Canon` commands. +-- +-- Slow, only useful for testing, use `Data.GCode.Pipes` variant instead +evalCanon :: (CanonState -> CanonState -> Canon -> [a]) + -> [Canon] + -> [a] +evalCanon f cs = go initCanonState cs + where + go _ [] = [] + go st (c:rest) = + let + newSt = stepCanon st c + in (f st newSt c) ++ (go newSt rest) diff --git a/src/Data/GCode/Canon/Convert.hs b/src/Data/GCode/Canon/Convert.hs new file mode 100644 --- /dev/null +++ b/src/Data/GCode/Canon/Convert.hs @@ -0,0 +1,172 @@ +module Data.GCode.Canon.Convert where + +import Control.Applicative + +import Data.GCode.Types (Code(..), Class(..), Axes, ParamDesignator(..)) +import Data.GCode.Canon (Canon(..)) + +import qualified Data.Map +import qualified Data.GCode.Canon as C +import qualified Data.GCode.Types as T + +import Data.GCode.RS274 +import Data.GCode.Utils + +-- | Convert code to its canonical representation +toCanon :: Code -> [Canon] +toCanon c | isRapid c = + ifHasParam F c C.SetTraverseRate + <> ifNonEmptyAxes c C.StraightTraverse +toCanon c | isMove c = + ifHasParam F c C.SetFeedRate + <> ifNonEmptyAxes c C.StraightFeed + +-- :(( +--toCanon c | isArc c = ArcFeed + +toCanon c | isCoordinateSystemOffset c = pure $ C.SetCoords (codeAxes c) + +toCanon c | isDwell c + = pure . C.PauseSeconds $ getParamOrFail P c "No P for Dwell" + +-- Converted by step +toCanon c | isMillimeters c = empty +toCanon c | isInches c = empty +toCanon c | isAbsolute c = empty +toCanon c | isRelative c = empty + +-- Planes +toCanon c | isXYPlane c = pure $ C.PlaneSelect C.XY +toCanon c | isZXPlane c = pure $ C.PlaneSelect C.ZX +toCanon c | isYZPlane c = pure $ C.PlaneSelect C.YZ +toCanon c | isUVPlane c = pure $ C.PlaneSelect C.UV +toCanon c | isWUPlane c = pure $ C.PlaneSelect C.WU +toCanon c | isVWPlane c = pure $ C.PlaneSelect C.VW + +-- Standalone +toCanon Code { codeCls = Just FStandalone, codeNum = Just newFeed } + = pure $ C.SetFeedRate $ fromIntegral newFeed +toCanon Code { codeCls = Just SStandalone, codeNum = Just spindleRPM } + = pure $ C.SpindleSpeed $ fromIntegral spindleRPM + +-- Units +toCanon c | isUnitsPerMinute c = empty +toCanon c | isUnitsPerRevolution c = error "Don't know how to handle units per revolution" + +-- Spindle +toCanon c | isSpindleCW c = pure C.SpindleStart + { spindleDirection = C.ClockWise + , spindleWaitForSpeed = True } -- questionable +toCanon c | isSpindleCCW c = pure C.SpindleStart + { spindleDirection = C.CounterClockWise + , spindleWaitForSpeed = True } -- questionable +toCanon c | isSpindleStop c = pure C.SpindleStop + +-- Coolant +toCanon c | isCoolantMist c = pure C.CoolantMist +toCanon c | isCoolantFlood c = pure C.CoolantFlood +toCanon c | isCoolantStop c = pure C.CoolantStop + +-- Tool +toCanon c | isToolChange c = pure C.ToolChange +toCanon (Code{codeCls=(Just T), codeNum=(Just toolId)}) = pure $ C.ToolSelect toolId +toCanon c | isToolLength c = pure $ C.ToolLengthCompensation C.LengthTable +toCanon c | isToolLengthDynamic c = pure $ C.ToolLengthCompensation $ C.Dynamic + (codeAxes c) +toCanon c | isToolLengthAdd c = pure $ C.ToolLengthCompensation $ C.Add + (round $ getParamOrFail H c "Add tool change offset requires H parameter of the tool to grab offset from") +toCanon c | isToolLengthCancel c = pure $ C.ToolLengthCompensation C.NoCompensation + +-- Printer -- XXX: needs handling in step +toCanon c | isExtruderAbsolute c = empty +toCanon c | isExtruderRelative c = empty + +-- Printer heating +toCanon c | isSetExtruderTemperature c = pure $ C.SetTemperature + (C.Heater C.HeatedExtruder $ round <$> getParam P c) + (getParamOrFail S c "Set extruder temperature command missing S parameter for temperature value") +toCanon c | isSetBedTemperature c = pure $ C.SetTemperature + (C.Heater C.HeatedBed $ round <$> getParam P c) + (getParamOrFail S c "Set bed temperature command missing S parameter for temperature value") +toCanon c | isSetChamberTemperature c = pure $ C.SetTemperature + (C.Heater C.HeatedChamber $ round <$> getParam P c) + (getParamOrFail S c "Set heated chamber temperature command missing S parameter for temperature value") +toCanon c | isCancelWaitTemperature c = pure $ C.CancelWaitTemperature +-- Wait variants +toCanon c | isSetExtruderTemperatureAndWait c = pure $ C.SetTemperatureWait + (C.Heater C.HeatedExtruder $ round <$> getParam P c) + (getParamOrFail S c "Set extruder temperature and wait command missing S parameter for temperature value") +toCanon c | isSetBedTemperatureAndWait c = pure $ C.SetTemperatureWait + (C.Heater C.HeatedBed $ round <$> getParam P c) + (getParamOrFail S c "Set bed temperature and wait command missing S parameter for temperature value") +toCanon c | isSetChamberTemperatureAndWait c = pure $ C.SetTemperatureWait + (C.Heater C.HeatedChamber $ round <$> getParam P c) + (getParamOrFail S c "Set chamber temperature and wait command missing S parameter for temperature value") +-- Cancel +toCanon c | isCancelWaitTemperature c = pure $ C.CancelWaitTemperature + +-- Printer cooling +toCanon c | isFanOn c = pure C.FanOn +toCanon c | isFanOff c = pure C.FanOff + +-- Printer homing, XXX: this clashes with G28 of cnc which is StoredPositionMove +toCanon c | isGN 28 c = empty + +-- Printer leveling +toCanon c | isAutoBedLevel c = pure C.LevelBed + +-- Printer miscs, XXX: we probably can't even parse M117 Hello world +toCanon c | isDisplayMessage c = empty +toCanon c | isDisableActuators c = pure $ C.DisableMotors (codeAxes c) + +toCanon c | isProgramEnd c = pure C.ProgramEnd +toCanon c | isCommentOnly c = pure $ C.Comment (codeComment c) -- XXX: strip spaces +toCanon (T.Comment c) = pure $ C.Comment c +toCanon Empty = empty +toCanon (Other _) = empty -- questionable +-- this is bad but we can't use GHC to tell us about missing clauses +-- due to how Code type is freeform-ish (which is also the reason for Canon). +-- Lets stay on the safe side and error for now as ignoring could lead to +-- missing important commands. +toCanon c = error $ "No canon for " ++ show c + +-- Helpers + +-- Apply @f@ to parameter value only iff @p@ parameter is found, mempty otherwise +ifHasParam :: (Monoid (f a), Applicative f) + => ParamDesignator + -> Code + -> (Double -> a) + -> f a +ifHasParam p c f = case getParam p c of + Nothing -> mempty + Just val -> pure $ f val + +-- Apply @f@ to `Axes` value only iff `Code` has axes, mempty otherwise +ifNonEmptyAxes :: (Applicative f, Monoid (f a)) + => Code + -> (Axes -> a) + -> f a +ifNonEmptyAxes c f | codeAxes c /= mempty = pure $ f (codeAxes c) +ifNonEmptyAxes _ _ | otherwise = mempty + +-- Get parameter value or fail with `error`, useful for required parameters +getParamOrFail :: ParamDesignator + -> Code + -> [Char] + -> Double +getParamOrFail param code msg = maybe (error msg) id (getParam param code) + +-- brr +isCommentOnly :: Code -> Bool +isCommentOnly (Code { codeCls = Nothing + , codeNum = Nothing + , codeSub = Nothing + , codeAxes = a + , codeParams = p + , codeComment = x }) | + Data.Map.null a && Data.Map.null p && + x /= mempty = True +isCommentOnly _ = False + + diff --git a/src/Data/GCode/Eval.hs b/src/Data/GCode/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Data/GCode/Eval.hs @@ -0,0 +1,270 @@ +{-| GCode evaluator + +Evaluates RS274 GCode + +-} +{-# LANGUAGE RecordWildCards #-} +module Data.GCode.Eval where + +import Data.Maybe +import Data.Monoid +import Data.Map (Map) + +import qualified Data.Map + +import Data.GCode.Ann (Ann(SrcLine)) +import Data.GCode.Types +import Data.GCode.RS274 +import Data.GCode.RS274.Types +import Data.GCode.Utils +import Data.GCode.Canon (Canon) +import Data.GCode.Canon.Convert + +-- | Interpreter state +data IPState = IPState { + ipModalGroups :: Map RS274Group Code + , ipPosition :: Axes + , ipLine :: Integer + } deriving (Eq, Show, Ord) + +-- | Default modals +defaultModals :: Map RS274Group Code +defaultModals = Data.Map.fromList [ + (Units , millimeters) + , (Distance , absolute) + , (ArcDistance, absolute) + ] + +-- | Create new interpreter state +newState :: IPState +newState = IPState { + ipModalGroups = defaultModals + , ipPosition = mempty + , ipLine = 0 + } + +-- | Step `Code` interpreter +step :: IPState -> GCode -> (Maybe Code, IPState, GCode) +step is [] = (Nothing, is, []) +step is@IPState{..} (x@Code{}:xs) = + let (newCode, newModals) = updateCodeAndModals x ipModalGroups + -- update position with new codeAxes + newPosition = updateAxes ipPosition (codeAxes newCode) + in (Just $ newCode + , is { ipModalGroups = newModals + , ipPosition = newPosition + , ipLine = ipLine + 1 } + , xs) +-- handle empty/comments/other +step is (_:xs) = (Nothing, is, xs) + +-- | Evaluate GCode and return each evaluation step +evalSteps :: [Code] -> [([Maybe Code], IPState, [Code])] +evalSteps gcode = go initState + where + initState = ([], newState, gcode) + go x@(_, _, []) = [x] + go x@(acc, st, codes) = let (result, steppedState, rest) = step st codes in x:(go (result:acc, steppedState, rest)) + +-- interpreter *always* runs +-- * in absolute mode +-- * with millimeters as units +-- * with total commands in modal groups +-- convert accordingly! +-- | Convert all axis coordinates from inches to millimeters if needed +toMillimeters :: Map RS274Group Code -> Code -> Code +toMillimeters modals x | codeActive millimeters modals = x +toMillimeters modals x | codeActive inches modals = x & axes (Data.Map.map (*25.4) (codeAxes x)) + & modifyParams [F, R, I, J, K] (*25.4) +toMillimeters _ _ | otherwise = error "Neither millimeters nor inches set" + +-- | Convert all motion coordinates from relative to absolute +toAbsolute :: Map RS274Group Code -> Code -> Code +toAbsolute modals x | codeActive relative modals && isMotion x = + case Data.Map.lookup Motion modals of -- motion group + Nothing -> x + (Just e) -> x & (axes $ addRelative (codeAxes x) (codeAxes e)) + where + addRelative :: Axes -> Axes -> Axes + addRelative existing new = Data.Map.unionWith (+) existing new +toAbsolute _ x | otherwise = x + +-- | Convert all arc coordinates from relative to absolute +toAbsoluteArcs :: Map RS274Group Code -> Code -> Code +toAbsoluteArcs modals c | codeActive arcRelative modals && isMotion c = + case Data.Map.lookup Motion modals of -- motion group + Nothing -> c + (Just e) -> c & modifyParamsWithKey [I, J, K] (addRespective e) + where + addRespective code I x | hasAxis X code = fromJust (getAxis X code) + x + addRespective code J x | hasAxis Y code = fromJust (getAxis Y code) + x + addRespective code K x | hasAxis Z code = fromJust (getAxis Z code) + x + addRespective _ _ x | otherwise = x +toAbsoluteArcs _ c | otherwise = c + +-- | Return True if `code` is active (present) in `modals` +codeActive :: Code -> Map RS274Group Code -> Bool +codeActive code modals = case Data.Map.lookup (decimate code) codesToGroups of + Just group -> Data.Map.lookup group (Data.Map.map decimate modals) == (Just $ decimate code) + Nothing -> False + +-- | Return True if `code` is a motion comand +isMotion :: Code -> Bool +isMotion = flip codeInGroup Motion + +-- | Update `code` according to current `modals` +-- then update `modals` with a resulting code +-- +-- Return updated code and modals +updateCodeAndModals :: Code + -> Map RS274Group Code + -> (Code, Map RS274Group Code) +updateCodeAndModals code modals = + -- first we update current GCode with missing data + let newCode = updateFromCurrentModals modals + $ updateIncompleteFromCurrentModals modals + $ toAbsoluteArcs modals + $ toAbsolute modals + $ toMillimeters modals code + -- then we update stored modal groups with updated GCode + newModals = updateModals modals newCode + in (newCode, newModals) + +-- | Update modal groups according to Code `c` +updateModals :: Map RS274Group Code + -> Code + -> Map RS274Group Code +updateModals current c = case Data.Map.lookup (decimate c) codesToGroups of + Nothing -> current + Just group -> Data.Map.insert group c current + +-- | Take current motion group modal code and update this motion code +-- with missing coordinates of the stored one +updateFromCurrentModals :: Map RS274Group Code -> Code -> Code +updateFromCurrentModals modals x | isMotion x = do + case Data.Map.lookup Motion modals of -- motion group + Nothing -> x + (Just e) -> x & (axes $ appendOnlyAxes (codeAxes x) (codeAxes e)) +updateFromCurrentModals _ x | otherwise = x + +-- | Return True if this code contains only coordinates +incomplete :: Code -> Bool +incomplete Code{codeCls=Nothing, codeNum=Nothing, ..} | (Data.Map.null codeAxes /= True) = True +incomplete _ = False + +-- | Update incomplete motion Code with the stored one +updateIncompleteFromCurrentModals :: Map RS274Group Code -> Code -> Code +updateIncompleteFromCurrentModals modals x | incomplete x = do + case Data.Map.lookup Motion modals of -- motion group + Nothing -> x + (Just e) -> appEndo (mconcat $ map Endo [ + (cls $ fromJust $ codeCls e) + , (num $ fromJust $ codeNum e) + , (axes $ appendOnlyAxes (codeAxes x) (codeAxes e)) + ]) x +updateIncompleteFromCurrentModals _ x | otherwise = x + +-- | Update axes that aren't defined in target +appendOnlyAxes :: Ord k => Map k b -> Map k b -> Map k b +appendOnlyAxes target from = Data.Map.union target missingOnly + where missingOnly = Data.Map.difference from target + +-- | Update (replace) `target` axes with `from` axes +updateAxes :: Ord k => Map k a -> Map k a -> Map k a +updateAxes target from = Data.Map.union from target -- union in this order so `from` axes are preferred + +-- | Update `Limits` from this `Code` +updateLimitsCode :: Limits -> Code -> Limits +updateLimitsCode s Code{..} = updateLimits s codeAxes +updateLimitsCode s _ = s + +-- | Update `Limits` from `Axes` +updateLimits :: Limits -> Axes -> Limits +updateLimits s = Data.Map.foldlWithKey adj s + where + adj limits ax val = Data.Map.alter (alterfn val) ax limits + alterfn val (Just (min_c, max_c)) = Just (min min_c val, max max_c val) + alterfn val Nothing = Just (val, val) + +-- Slow evaluators for testing, use streaming variants from `Data.GCode.Pipes` instead. + +-- | Fully evaluate GCode +eval :: GCode -> ([Code], IPState) +eval = evalWith (\res _state -> Just res) + +-- | Evaluate GCode to canonical representation +evalToCanon :: GCode -> ([Canon], IPState) +evalToCanon = evalWith' (\c _ips -> toCanon c) + +-- | Evaluate GCode to annotated canonnical representation +evalToCanonAnn :: GCode -> ([Ann Canon], IPState) +evalToCanonAnn = evalWith' toCanonAnn + +-- | Same as toCanon but result is wrapped in `Ann` +-- according to current interpreter line +toCanonAnn :: Code -> IPState -> [Ann Canon] +toCanonAnn c is = SrcLine (ipLine is) <$> toCanon c + +-- | Evaluate GCode and and apply function `f` to each successfuly +-- evaluated Code +-- +-- Slow due to list concatenation, use streaming variants from `Data.GCode.Pipes` instead. +evalWith :: (Code -> IPState -> Maybe a) + -> GCode + -> ([a], IPState) +evalWith f gcode = let (accumulator, resultState, []) = go initState in (catMaybes accumulator, resultState) + where + initState = ([], newState, gcode) + go x@(_, _, []) = x + go (acc, st, codes) = + let (result, steppedState, rest) = step st codes + mapped = case result of + Nothing -> Nothing + Just x -> f x steppedState + in go (acc ++ [mapped], steppedState, rest) + +-- Like `evalWith` but allows multiple elements to be generated +evalWith' :: (Code -> IPState -> [a]) + -> GCode + -> ([a], IPState) +evalWith' f gcode = + let (accumulator, resultState, []) = go initState + in (accumulator, resultState) + where + initState = ([], newState, gcode) + go x@(_, _, []) = x + go (acc, st, codes) = + let (result, steppedState, rest) = step st codes + mapped = case result of + Nothing -> [] + Just r -> f r steppedState + in go (acc ++ mapped, steppedState, rest) + +-- | Walk GCode adding missing axes coordinates according to previous moves +-- +-- For example +-- G0 X1 +-- G0 Y2 +-- G0 Z3 +-- +-- becomes +-- G0 X1 +-- G0 X1 Y2 +-- G0 X1 Y2 Z3 +-- +-- also +-- +-- G0 X1 +-- Y2 Z2 +-- +-- becomes +-- +-- G0 X1 +-- G0 X1 Y2 Z2 +totalize :: GCode -> GCode +totalize = totalize' defaultModals + where + totalize' _ [] = [] + totalize' modals (x:rest) = + let (newCode, newModals) = updateCodeAndModals x modals + in (newCode:totalize' newModals rest) diff --git a/src/Data/GCode/Generate.hs b/src/Data/GCode/Generate.hs new file mode 100644 --- /dev/null +++ b/src/Data/GCode/Generate.hs @@ -0,0 +1,115 @@ +{-| GCode generation + +GCode generation functions & shortcuts + +-} +module Data.GCode.Generate where + +import Data.GCode.Types +import Data.GCode.RS274 +import Data.GCode.Utils + +-- |Generate G Code +g :: Code +g = cls G emptyCode + +-- |Generate M Code +m :: Code +m = cls M emptyCode + +-- |Generate S (set spindle feedrate) Code +s :: Code +s = emptyCode & cls SStandalone + +-- |Set GCode number +(<#>) :: Code -> Int -> Code +(<#>) a n = num n a + +-- |Set GCode feedrate (F parameter) +feed :: Double -> Code -> Code +feed = param F + +-- |Set `x` axis target +x :: Double -> Code -> Code +x = axis X + +-- |Set `y` axis target +y :: Double -> Code -> Code +y = axis Y + +-- |Set `z` axis target +z :: Double -> Code -> Code +z = axis Z + +-- |Set `x`, `y` coordinates for this Code +xy :: Double -> Double -> Code -> Code +xy xVal yVal = x xVal . y yVal + +-- |Set `x`, `y` and `z` coordinates +xyz :: Double -> Double -> Double -> Code -> Code +xyz xVal yVal zVal = x xVal . y yVal . z zVal + +-- |Set G0 and `x`, `y` coordinates +movexy :: Double -> Double -> Code +movexy xVal yVal = move & xy xVal yVal + +-- |Set `i`, `j` parameters for this Code +ij :: Double -> Double -> Code -> Code +ij iVal jVal = param I iVal . param J jVal + +arc :: Code +arc = arcCW + +-- |Generate points on a rectangle +rectangle :: (Num a, Num b) => a -> b -> [(a, b)] +rectangle xv yv = [(0, 0), (xv, 0), (xv, yv), (0, yv), (0,0)] + +-- |Rotate X/Y coordinates by angle `by` +rot :: Floating b => b -> b -> b -> (b, b) +rot by xv yv = (xv * (cos by) - yv * (sin by), yv * (cos by) + xv * (sin by)) + +-- |Generate a list of points laying on a circle with radius `r`, divides circle in `steps` number of points +circle :: (Floating b, Enum b) => b -> b -> [(b, b)] +circle r steps = map (\step -> rot (step * 2*pi / steps) (r/2) 0) [1..steps] + +-- |As `circle` with rotated by `rin` +circle' :: (Floating b, Enum b) => b -> b -> b -> [(b, b)] +circle' rin r steps = map (\step -> rot (rin + step * 2*pi / steps) (r/2) 0) [1..steps] + +-- |As `circle` but origin is the same as end point +closedCircle :: (Floating a, Enum a) => a -> a -> [(a, a)] +closedCircle r steps = map (\step -> rot (step * 2*pi / steps) (r/2) 0) [1..(steps+1)] + +-- |Join list of GCodes with travel moves inbetween +travelCat :: Code -> Code -> [GCode] -> [Code] +travelCat up down (block:rest) = (travel up down block) ++ (travelCat up down rest) +travelCat _ _ [] = [] + +-- |Join list of drilling GCodes with travel moves inbetween +travelCatDrill :: Code -> [GCode] -> [Code] +travelCatDrill up (block:rest) = (travelDrills up block) ++ (travelCatDrill up rest) +travelCatDrill _ [] = [] + +-- |Prepend codes with tool up command, rapid move to block start and tool down command +-- +-- Prepends `up` GCode representing tool moving up before +-- rapid move followed by `down` command to move tool down again. +travel :: Code -> Code -> GCode -> GCode +travel up down (c:rest) = [up, asRapidXY c, down, c] ++ rest +travel _ _ [] = [] + +-- |Prepend drilling codes with tool up command and rapid moves +-- +-- Prepends `up` GCode representing tool moving up before +-- rapid move to start of this block +travelDrills :: Code -> GCode -> GCode +travelDrills up block = travel up emptyCode block + +-- |Take X and Y coordinates of this code +-- and turn it into rapid move +asRapidXY :: Code -> Code +asRapidXY c@Code{} = + case getAxes [X,Y] c of + [Just xv, Just yv] -> rapid & xy xv yv + _ -> c +asRapidXY c = c diff --git a/src/Data/GCode/Generate/Examples.hs b/src/Data/GCode/Generate/Examples.hs new file mode 100644 --- /dev/null +++ b/src/Data/GCode/Generate/Examples.hs @@ -0,0 +1,95 @@ +{-| Examples of GCode generation + +-} +module Data.GCode.Generate.Examples where + +import Data.GCode +import Data.GCode.Generate +import Data.GCode.RS274 + +allExamples :: [(String, GCode)] +allExamples = [ + ("encoder_wheel_drilling", fst $ encoderWheel) + , ("encoder_wheel_milling", snd $ encoderWheel) + , ("rectangle10x20", rectangle10mm20mm) + ] + +preamble :: [Code] +preamble = [ + unitsPerMinute + , absolute + , millimeters + , g <#> 0 & param F 3000 + , s <#> 12000 + , spindleCW + , dwell & param P 10 + ] + +postamble :: [Code] +postamble = [ + spindleStop + , coolantStop + , programEnd + ] + +returnZ :: Double +returnZ = 1 + +safeZ :: Double +safeZ = 2 + +workZ :: Double +workZ = (-2) + +rapidFeedrate :: Double +rapidFeedrate = 250 + +downFeedrate :: Double +downFeedrate = 150 + +up :: Code +up = rapid & z safeZ & feed rapidFeedrate + +down :: Code +down = move & z workZ & feed downFeedrate + +program :: [Code] -> [Code] +program code = preamble ++ code ++ postamble + +rectangle10mm20mm :: GCode +rectangle10mm20mm = program $ map (uncurry movexy) (rectangle 10 20) + +encoderWheel :: (GCode, GCode) +encoderWheel = + let encoderRadius = 50 + encoderSteps = 100 + drillRadius = 0.6 + endmillRadius = 3.175 + innerOffset = 4 + encoderRadiusInner = encoderRadius - (2*drillRadius) - innerOffset + + -- drilling + drillPoints = circle encoderRadius encoderSteps + drillPointsInner = circle' (2*pi/360 * (360 / 200) * 1.5) encoderRadiusInner encoderSteps + + drill xv yv = drillingCycle & xyz xv yv workZ & feed 250 & param R returnZ + drillBlocks = [ map (uncurry drill) drillPoints + , map (uncurry drill) drillPointsInner ] + -- milling + anchor = circle (5.3 - endmillRadius) 360 + anchorPositions = circle (30) 4 + + anchors = travelCat up down $ map (\(xc, yc) -> + map (\(xv, yv) -> movexy (xc + xv) (yc + yv)) anchor) + anchorPositions + + encInner = circle (10.4 - endmillRadius) 360 + encOuter = circle (encoderRadius + innerOffset + endmillRadius) 3600 + + cut = map (uncurry movexy) + inner = cut encInner + outer = cut encOuter + + in ( program $ travelCatDrill up drillBlocks + , program $ travelCat up down [inner, anchors, outer] + ) diff --git a/src/Data/GCode/Generate/ExamplesMonad.hs b/src/Data/GCode/Generate/ExamplesMonad.hs new file mode 100644 --- /dev/null +++ b/src/Data/GCode/Generate/ExamplesMonad.hs @@ -0,0 +1,23 @@ +module Data.GCode.Generate.ExamplesMonad where + +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.State + +import Data.GCode.Generate (x, xy) +import Data.GCode.Monad + +xprog :: Program +xprog = prog $ do + move (x 10) + rapid (xy 15 15) + move (xy 0 0) + coolantStop' + +withState :: Program +withState = prog $ do + void $ flip runStateT 0 $ do + val <- get + lift $ rapid (x val) + forM_ (zip [0..10] [-10..0]) (move . uncurry xy) + diff --git a/src/Data/GCode/Line.hs b/src/Data/GCode/Line.hs new file mode 100644 --- /dev/null +++ b/src/Data/GCode/Line.hs @@ -0,0 +1,74 @@ +module Data.GCode.Line ( + Line(..) + , LineType(..) + , toLines + , prettyLine + ) where + +{- +Conversion to `Line` from one set of points to another. +Useful for GCode visualisation tools. +-} + +import Data.GCode.Canon (Canon(..), CanonState(..)) +import Data.GCode.Types (Axes, Style(..)) + +import Text.PrettyPrint.ANSI.Leijen + +import qualified Data.GCode.Pretty + +-- | Given two states of `Canon` interpreter output `Line` or empty list +-- if no line is produced by this `Canon`. +toLines :: CanonState -> CanonState -> Canon -> [Line] +toLines prevS nextS code | isTravelMove code || isSetCoords code = pure $ Line + (travelMoveType code) + (canonPosition prevS) + (canonPosition nextS) +toLines _ _ _ | otherwise = mempty + +data LineType = + LineTraverse -- ^ Travel move + | LineDrawing -- ^ Machining/drawing move + | LineJump -- ^ Produced by set coordinates `SetCoords` + deriving (Eq, Show, Ord) + +data Line = Line + LineType -- ^ Travel, drawing or set coordinates move + Axes -- ^ Start points + Axes -- ^ End points + deriving (Eq, Show, Ord) + +-- | Pretty print `Line` +prettyLine :: Style -> Line -> String +prettyLine style x = displayS ((renderer style) (ppLine style x)) "" + where renderer style' | styleColorful style' == True = renderPretty 0.4 80 + renderer _ = renderCompact + +ppLine :: Style -> Line -> Doc +ppLine style (Line typ from to) = + ppTyp typ + <+> string "from" + <+> Data.GCode.Pretty.ppAxesMap style from + <+> string "to" + <+> Data.GCode.Pretty.ppAxesMap style to + where + ppTyp LineTraverse = char ' ' + ppTyp LineDrawing = char '*' + ppTyp LineJump = char '>' + +-- Helpers + +isTravelMove :: Canon -> Bool +isTravelMove (StraightTraverse _) = True +isTravelMove (StraightFeed _) = True +isTravelMove _ = False + +isSetCoords :: Canon -> Bool +isSetCoords (SetCoords _) = True +isSetCoords _ = False + +travelMoveType :: Canon -> LineType +travelMoveType (StraightTraverse _) = LineTraverse +travelMoveType (StraightFeed _) = LineDrawing +travelMoveType (SetCoords _) = LineJump +travelMoveType _ = error "travelMoveType: Not a travel move" diff --git a/src/Data/GCode/Monad.hs b/src/Data/GCode/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Data/GCode/Monad.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +module Data.GCode.Monad where + +import Data.GCode.TH +import Data.GCode.Types +import Data.GCode.RS274.Types +import Data.GCode.RS274 (codeFromName) + +import Control.Monad.Trans.Writer.Lazy +import Data.Semigroup hiding (option) + + -- this gives us someCode and someCode' shortcuts generated from RS274/Types.hs +-- so we can write +-- > myP = prog $ do +-- > rapid (xy 5 10) +-- > move (x 0) +$(genWriterEndos ''RS274Name) + +data Program = Program { programCode :: GCode } + deriving (Eq, Show) + +type ProgramWriter a = Writer (Endo Program) a + +gen :: Code -> ProgramWriter () +gen c = tell $ Endo (\x -> x { programCode = c:(programCode x) } ) + +prog :: ProgramWriter a -> Program +prog builder = appEndo (execWriter (builder >> programEnd')) (Program mempty) + +generateName = gen . codeFromName +generateNameArgs name endoF = gen $ codeFromName name & endoF diff --git a/src/Data/GCode/Parse.hs b/src/Data/GCode/Parse.hs --- a/src/Data/GCode/Parse.hs +++ b/src/Data/GCode/Parse.hs @@ -1,19 +1,26 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + {-| GCode parsing functions -} -{-# LANGUAGE OverloadedStrings #-} module Data.GCode.Parse (parseGCode, parseGCodeLine, parseOnlyGCode) where import Data.GCode.Types -import Prelude hiding (take, takeWhile, mapM) import Control.Applicative -import qualified Data.ByteString as B + +import Prelude hiding (take, takeWhile, mapM) import Data.Attoparsec.ByteString.Char8 -import qualified Data.Map.Strict as M -import Data.Either (lefts, rights) +import Data.ByteString (ByteString) +import qualified Data.ByteString +import qualified Data.Char +import qualified Data.Either +import qualified Data.Map +import qualified Data.Maybe + -- |Parse single line of G-code into 'Code' parseGCodeLine :: Parser Code parseGCodeLine = between lskip lskip parseCodeParts <* endOfLine @@ -23,33 +30,39 @@ parseGCode = many1 parseGCodeLine -- |Parse lines of G-code returning either parsing error or 'GCode' -parseOnlyGCode :: B.ByteString -> Either String GCode +parseOnlyGCode :: ByteString -> Either String GCode parseOnlyGCode = parseOnly parseGCode - +lskip :: Parser () lskip = skipWhile (\x -> x == ' ' || x == '\t') -between open close p = do{ open; x <- p; close; return x } +between :: Monad m => m a1 -> m a2 -> m b -> m b +between open close p = do { _ <- open; x <- p; _ <- close; return x } + isEndOfLineChr :: Char -> Bool isEndOfLineChr '\n' = True isEndOfLineChr '\r' = True isEndOfLineChr _ = False +parseLead :: Parser Class parseLead = do - a <- satisfy $ (\c -> c == 'G' || c == 'M' || c == 'T' || c == 'P' || c == 'F' || c == 'S') - return $ codecls a + a <- satisfy $ inClass $ (asChars allClasses) ++ (map Data.Char.toLower $ asChars allClasses) + return $ Data.Maybe.fromJust $ toCodeClass a {-# INLINE parseLead #-} +parseAxisDes :: Parser AxisDesignator parseAxisDes = do - a <- satisfy $ (\c -> c == 'X' || c == 'Y' || c == 'Z' || c == 'A' || c == 'B' || c == 'C' || c == 'E' || c == 'L') - return $ axis a + a <- satisfy $ inClass $ asChars allAxisDesignators + return $ Data.Maybe.fromJust $ toAxis a {-# INLINE parseAxisDes #-} +parseParamDes :: Parser ParamDesignator parseParamDes = do - a <- satisfy $ inClass "SPF" - return $ param a + a <- satisfy $ inClass $ asChars allParamDesignators + return $ Data.Maybe.fromJust $ toParam a {-# INLINE parseParamDes #-} +parseParamOrAxis :: Parser (Either (AxisDesignator, Double) (ParamDesignator, Double)) parseParamOrAxis = do lskip ax <- option Nothing (Just <$> parseAxisDes) @@ -59,45 +72,49 @@ f <- double return $ Left (val, f) Nothing -> do - param <- parseParamDes + paramDes <- parseParamDes lskip f <- double - return $ Right (param, f) + return $ Right (paramDes, f) parseAxesParams :: Parser (Axes, Params) parseAxesParams = do a <- many parseParamOrAxis - return (M.fromList $ lefts a, M.fromList $ rights a) + return (Data.Map.fromList $ Data.Either.lefts a, Data.Map.fromList $ Data.Either.rights a) {-# INLINE parseAxesParams #-} - +parseCode :: Parser Code parseCode = do - lead <- optional parseLead - gcode <- optional decimal - subcode <- optional (char '.' *> decimal) + codeCls <- optional parseLead + codeNum <- optional decimal + codeSub <- optional (char '.' *> decimal) lskip - (axes, params) <- parseAxesParams + (codeAxes, codeParams) <- parseAxesParams lskip - comment <- option "" $ between lskip lskip parseComment' - let c = Code lead gcode subcode axes params comment + codeComment <- option "" $ between lskip lskip parseComment' + let c = Code{..} if c == emptyCode then return $ Empty else return c +parseComment' :: Parser ByteString parseComment' = do t <- many $ between (lskip *> char '(') (char ')' <* lskip) $ takeWhile1 (/=')') -- semiclone prefixed comments semisep <- option "" $ char ';' *> takeWhile (not . isEndOfLineChr) rest <- takeWhile (not . isEndOfLineChr) - return $ B.concat $ t ++ [semisep, rest] + return $ Data.ByteString.concat $ t ++ [semisep, rest] +parseComment :: Parser Code parseComment = Comment <$> parseComment' +parseOther :: Parser Code parseOther = do a <- takeWhile (not . isEndOfLineChr) return $ Other a +parseCodeParts :: Parser Code parseCodeParts = parseCode - <|> parseComment <|> parseOther + <|> parseComment diff --git a/src/Data/GCode/Pipes.hs b/src/Data/GCode/Pipes.hs new file mode 100644 --- /dev/null +++ b/src/Data/GCode/Pipes.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE OverloadedStrings #-} +module Data.GCode.Pipes where + +import Control.Monad +import Control.Monad.Trans.State.Strict + +import Data.ByteString (ByteString) + +import System.IO (Handle) + +import Data.GCode.Types +import Data.GCode.Canon +import Data.GCode.Eval +import Data.GCode.Line +import Data.GCode.Parse +import Data.GCode.Pretty +import qualified Data.GCode.Canon.Convert + +import Pipes +import Pipes.Attoparsec (ParsingError) +import Pipes.Safe (SafeT) + +import qualified Data.ByteString.Char8 +import qualified Data.Map.Strict +import qualified Pipes.Attoparsec +import qualified Pipes.ByteString +import qualified Pipes.Prelude +import qualified Pipes.Safe +import qualified System.IO + +-- something fishy about this type +parseProducer :: Handle -> Producer Code (SafeT IO) (Either (ParsingError, Producer ByteString (SafeT IO) ()) ()) +parseProducer = parseProducer' 1024 + +parseProducer' :: MonadIO m + => Int + -> Handle + -> Producer Code m (Either (ParsingError, Producer ByteString m ()) ()) +parseProducer' bufSize handle = Pipes.Attoparsec.parsed + parseGCodeLine (Pipes.ByteString.hGetSome bufSize handle) + +withFile :: FilePath -> (Handle -> (SafeT IO) r) -> IO r +withFile filepath job = + System.IO.withFile filepath System.IO.ReadMode $ \handle -> + Pipes.Safe.runSafeT $ job handle + +pipeToList :: FilePath -> Proxy () Code () a (SafeT IO) () -> IO [a] +pipeToList filepath pipeTail = withFile filepath $ \h -> + Pipes.Prelude.toListM + $ (() <$ parseProducer h) + >-> pipeTail + +gcodeToCanonList :: FilePath -> IO [Canon] +gcodeToCanonList filepath = pipeToList filepath $ evalP >-> evalCanonP + +gcodeToLines :: FilePath -> IO [Line] +gcodeToLines filepath = pipeToList filepath $ evalP >-> evalCanonLinesP + +gcodePipe :: FilePath -> (Consumer Code (SafeT IO) ()) -> IO () +gcodePipe filepath pipeTail = + System.IO.withFile filepath System.IO.ReadMode $ \handle -> + Pipes.Safe.runSafeT . runEffect $ + (() <$ parseProducer handle) + >-> pipeTail + +-- needs better name +runPipe :: FilePath + -> Maybe FilePath + -> (Pipe Code ByteString (SafeT IO) ()) + -> IO () +runPipe input Nothing pipeMiddle = gcodePipe input (pipeMiddle >-> Pipes.ByteString.stdout) +runPipe input (Just output) pipeMiddle = + System.IO.withFile output System.IO.WriteMode $ \outhandle -> + gcodePipe input (pipeMiddle >-> Pipes.ByteString.toHandle outhandle) + + +foldedPipe :: FilePath + -> (Producer Code (Pipes.Safe.SafeT IO) () -> Effect (Pipes.Safe.SafeT IO) r) + -> IO r +foldedPipe filepath fold = + System.IO.withFile filepath System.IO.ReadMode $ \handle -> + Pipes.Safe.runSafeT . runEffect $ + fold (() <$ parseProducer handle) + +-- evaluators + +totalizeP :: Pipe Code Code (SafeT IO) () +totalizeP = flip evalStateT Data.Map.Strict.empty $ forever $ do + x <- lift await + inEffect <- get + let updatedCode = updateFromCurrentModals inEffect x + updatedModals = updateModals inEffect updatedCode + + put updatedModals + lift $ yield updatedCode + +evalP :: Pipe Code Code (SafeT IO) () +evalP = flip evalStateT newState $ forever $ do + x <- lift await + st <- get + let (result, steppedState, _rest) = step st [x] + -- XXX: add pretty printer for IPState + --liftIO $ print steppedState + put steppedState + case result of + Just r -> lift $ yield r + Nothing -> return () + +evalCanonP :: Pipe Code Canon (SafeT IO) () +evalCanonP = flip evalStateT initCanonState $ forever $ do + x <- lift await + st <- get + + forM_ (Data.GCode.Canon.Convert.toCanon x) $ \c -> do + let steppedState = stepCanon st c + put steppedState + lift $ yield c + +evalCanonLinesP :: Pipe Code Line (SafeT IO) () +evalCanonLinesP = flip evalStateT initCanonState $ forever $ do + x <- lift await + st <- get + + forM_ (Data.GCode.Canon.Convert.toCanon x) $ \c -> do + let steppedState = stepCanon st c + put steppedState + forM_ (toLines st steppedState c) $ lift . yield + +-- mmaped experiment, requires pipes-bytestring-mmap +--import qualified Pipes.ByteString.MMap +--main' = do +-- file <- fmap Prelude.head getArgs +-- Pipes.Safe.runSafeT . Pipes.Safe.runEffect $ +-- (() <$ Pipes.Attoparsec.parsed parseGCodeLine (Pipes.ByteString.MMap.unsafeMMapFile file) ) +-- >-> Pipes.Prelude.map ppGCodeLine +-- >-> Pipes.Prelude.stdoutLn + +-- pretty print +prettySinkWith :: (a -> ByteString) -> Pipe a ByteString (SafeT IO) () +prettySinkWith fn = + Pipes.Prelude.map fn + +prettySink :: Pipe Code ByteString (SafeT IO) () +prettySink = + Pipes.Prelude.map ppGCodeLine + >-> Pipes.Prelude.map (Data.ByteString.Char8.pack . (++"\n")) + +compactSink :: Pipe Code ByteString (SafeT IO) () +compactSink = + Pipes.Prelude.map ppGCodeLineCompact + >-> Pipes.Prelude.map (Data.ByteString.Char8.pack . (++"\n")) + +-- Helpers + +addNewLine :: ByteString -> ByteString +addNewLine to = Data.ByteString.Char8.append to "\n" + +wrapPrinter :: (a -> String) -> a -> ByteString +wrapPrinter p = addNewLine . Data.ByteString.Char8.pack . p diff --git a/src/Data/GCode/Pipes/Transform.hs b/src/Data/GCode/Pipes/Transform.hs new file mode 100644 --- /dev/null +++ b/src/Data/GCode/Pipes/Transform.hs @@ -0,0 +1,29 @@ +module Data.GCode.Pipes.Transform where +{-- + +These are remnants from refactoring Main with various degree of usability. + +Do not rely on these as they might get removed (or ideally improved) in future versions. + +--} + +import Data.GCode +import Data.GCode.Generate (rot) + +import Pipes +import qualified Pipes.Prelude as P + +translateXY :: Functor m => Double -> Double -> Pipe Code Code m r +translateXY xtrans ytrans = P.map (modifyXY (\x y -> (x + xtrans, y + ytrans))) + +translateZ :: Functor m => Double -> Pipe Code Code m r +translateZ ztrans = P.map (modifyAxis Z (+ztrans)) + +rotate :: Functor m => Double -> Pipe Code Code m r +rotate angle = P.map (modifyXY (rot (angle*pi/180))) + +scaleFeedrate :: Functor m => Double -> Pipe Code Code m r +scaleFeedrate factor = P.map (modifyFeedrate (*factor)) + +scaleXY :: Functor m => Double -> Double -> Pipe Code Code m r +scaleXY xsc ysc = P.map (modifyXY (\x y -> (x*xsc, y*ysc))) diff --git a/src/Data/GCode/Pretty.hs b/src/Data/GCode/Pretty.hs --- a/src/Data/GCode/Pretty.hs +++ b/src/Data/GCode/Pretty.hs @@ -7,79 +7,96 @@ -} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} -module Data.GCode.Pretty(ppGCode, ppGCodeLine, ppGCodeCompact, ppGCodeLineCompact) where +module Data.GCode.Pretty( + ppGCode + , ppGCodeLine + , ppGCodeCompact + , ppGCodeLineCompact + , ppGCodeStyle + , ppGCodeLineStyle + , ppAxes + , ppAxesMap + ) where -import Data.ByteString.Char8 (pack, unpack) -import qualified Data.Text as T -import qualified Data.Map.Strict as M -import Data.Maybe +import Data.Map (Map) +import Data.ByteString (ByteString) -import Text.PrettyPrint.ANSI.Leijen -import Data.GCode.Types -import Data.GCode.Utils +import qualified Data.ByteString.Char8 +import qualified Data.Double.Conversion.Text +import qualified Data.Map +import qualified Data.Text -import Data.Double.Conversion.Text +import Data.GCode.Types +import Text.PrettyPrint.ANSI.Leijen --- |Pretty-print 'GCode' using colors +-- | Pretty-print 'GCode' using colors ppGCode :: GCode -> String -ppGCode = ppGCodeStyle defaultStyle - --- |Pretty-print 'GCode' using colors with custom floating precision width -ppGCodeStyle :: Style -> GCode -> String -ppGCodeStyle style res = displayS (renderPretty 0.4 80 (ppGCode' style res)) "" +ppGCode = ppGCodeStyle (defaultStyle { styleColorful = True }) --- |Pretty-print single 'Code' using colors +-- | Pretty-print single 'Code' using colors ppGCodeLine :: Code -> String -ppGCodeLine = ppGCodeLineStyle defaultStyle - --- |Pretty-print single 'Code' using colors with custom floating precision width -ppGCodeLineStyle :: Style -> Code -> String -ppGCodeLineStyle style res = displayS (renderPretty 0.4 80 (ppCode style res)) "" +ppGCodeLine = ppGCodeLineStyle (defaultStyle { styleColorful = True }) --- |Pretty-print 'GCode' without colors +-- | Pretty-print 'GCode' without colors ppGCodeCompact :: GCode -> String -ppGCodeCompact = ppGCodeCompactStyle defaultStyle - --- |Pretty-print 'GCode' without colors with custom floating precision width -ppGCodeCompactStyle :: Style -> GCode -> String -ppGCodeCompactStyle style res = displayS (renderCompact (ppGCode' style res)) "" +ppGCodeCompact = ppGCodeStyle defaultStyle --- |Pretty-print single 'Code' without colors +-- | Pretty-print single 'Code' without colors ppGCodeLineCompact :: Code -> String -ppGCodeLineCompact = ppGCodeLineCompactStyle defaultStyle +ppGCodeLineCompact = ppGCodeLineStyle defaultStyle --- |Pretty-print single 'Code' without colors with custom floating precision width -ppGCodeLineCompactStyle :: Style -> Code -> String -ppGCodeLineCompactStyle style res = displayS (renderCompact (ppCode style res)) "" +-- | Pretty-print 'GCode' with specified `Style` +ppGCodeStyle :: Style -> GCode -> String +ppGCodeStyle style res = displayS ((renderer style) (ppGCode' style res)) "" + where renderer style' | styleColorful style' == True = renderPretty 0.4 80 + renderer _ = renderCompact +-- | Pretty-print single 'Code' with specified `Style` +ppGCodeLineStyle :: Style -> Code -> String +ppGCodeLineStyle style res = displayS ((renderer style) (ppCode style res)) "" + where renderer style' | styleColorful style' == True = renderPretty 0.4 80 + renderer _ = renderCompact + +ppList :: (a -> Doc) -> [a] -> Doc ppList pp x = hsep $ map pp x -ppGCode' style = vsep . map (ppCode style) +ppGCode' :: Style -> [Code] -> Doc +ppGCode' style code = (vsep $ map (ppCode style) code) <> hardline +ppMaybe :: (t -> Doc) -> Maybe t -> Doc ppMaybe pp (Just x) = pp x -ppMaybe pp Nothing = empty +ppMaybe _ Nothing = empty +ppMaybeClass :: Maybe Class -> Doc ppMaybeClass = ppMaybe ppClass -ppClass G = yellow $ text "G" -ppClass M = red $ text "M" -ppClass T = magenta $ text "T" -ppClass StP = red $ text "P" -ppClass StF = red $ text "F" -ppClass StS = red $ text "S" +ppClass :: Class -> Doc +ppClass G = yellow $ text "G" +ppClass M = red $ text "M" +ppClass T = magenta $ text "T" +ppClass PStandalone = red $ text "P" +ppClass FStandalone = red $ text "F" +ppClass SStandalone = red $ text "S" -ccMaybes (Just cls) (Just num) = cc cls num +ccMaybes :: (Eq a, Num a) => Maybe Class -> Maybe a -> Doc -> Doc +ccMaybes (Just cls') (Just num') = cc cls' num' ccMaybes _ _ = id +cc :: (Eq a, Num a) => Class -> a -> Doc -> Doc cc G 0 = dullyellow cc G 1 = yellow cc _ _ = red +ppAxis :: Style -> (AxisDesignator, Double) -> Doc ppAxis style (des, val) = bold (axisColor des $ text $ show des) - <> cyan (text $ T.unpack $ toPrecision (stylePrecision style) val) - + <> cyan ( + text + $ Data.Text.unpack + $ Data.Double.Conversion.Text.toFixed (stylePrecision style) val + ) +axisColor :: AxisDesignator -> Doc -> Doc axisColor X = red axisColor Y = green axisColor Z = yellow @@ -87,29 +104,50 @@ axisColor B = green axisColor C = blue axisColor E = magenta +axisColor _ = id -ppAxes _ [] = empty -ppAxes style x = space <> ppList (ppAxis style) x +ppAxes :: Style -> [(AxisDesignator, Double)] -> Doc +ppAxes style x = ppList (ppAxis style) x +ppAxesMap :: Style -> Map AxisDesignator Double -> Doc +ppAxesMap style x = ppList (ppAxis style) (Data.Map.toList x) + +ppParam :: Show a => Style -> (a, Double) -> Doc ppParam style (des, val) = bold (blue $ text $ show des) - <> white (text $ T.unpack $ toPrecision (stylePrecision style) val) + <> white ( + text + $ Data.Text.unpack + $ Data.Double.Conversion.Text.toFixed (stylePrecision style) val + ) +ppParams :: Show a => Style -> [(a, Double)] -> Doc ppParams _ [] = empty ppParams style x = space <> ppList (ppParam style) x +ppComment :: ByteString -> Doc ppComment "" = empty ppComment c = space <> ppComment' c + +ppComment' :: ByteString -> Doc ppComment' "" = empty -ppComment' c = dullwhite $ parens $ text $ unpack c +ppComment' c = dullwhite $ parens $ text $ Data.ByteString.Char8.unpack c +ppCode :: Style -> Code -> Doc ppCode style Code{..} = ccMaybes codeCls codeNum ( bold $ ppMaybeClass codeCls) <> ccMaybes codeCls codeNum ( ppMaybe (text . show) codeNum) - <> ppAxes style (M.toList codeAxes) - <> ppParams style (M.toList codeParams) + <> ppMaybe (\x -> (text ".") <> (text $ show x)) codeSub + <> ifNonEmpty (\x -> space <> ppAxesMap style x) codeAxes + <> ppParams style (Data.Map.toList codeParams) <> ppComment codeComment ppCode _ (Comment x) = ppComment' x -ppCode _ (Other x) = dullred $ text $ unpack x +ppCode _ (Other x) = dullred $ text $ Data.ByteString.Char8.unpack x ppCode _ (Empty) = empty {-# INLINE ppCode #-} + +ifNonEmpty :: (Eq t, Monoid t) + => (t -> Doc) + -> t -> Doc +ifNonEmpty _ x | x == mempty = empty +ifNonEmpty f x | otherwise = f x diff --git a/src/Data/GCode/RS274.hs b/src/Data/GCode/RS274.hs new file mode 100644 --- /dev/null +++ b/src/Data/GCode/RS274.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +module Data.GCode.RS274 where + +import Data.GCode.TH +import Data.GCode.Types +import Data.GCode.RS274.Types + +import Data.Maybe (fromJust) +import qualified Data.Map.Strict as M + +$(genShortcuts ''RS274Name) + +namesToCodes = M.fromList . map (\x -> (defName x, toCode x)) $ allCodes +codesToNames = M.fromList . map (\x -> (toCode x, defName x)) $ allCodes +codesToGroups = M.fromList . map (\x -> (toCode x, defGroup x)) $ allCodes + +codesToDefs = M.fromList . map (\x -> (toCode x, x)) $ allCodes + +codeIsRS274 code name = (M.lookup (decimate code) codesToNames) == (Just name) +codeInGroup code group = (fmap defGroup $ M.lookup (decimate code) codesToDefs) == (Just group) + +explain code@Code{} = case M.lookup (decimate code) codesToDefs of + Nothing -> "" + Just def -> defHelp def +explain _ = "" + +-- only to be used by TH +codeFromName :: RS274Name -> Code +codeFromName n = fromJust $ M.lookup n namesToCodes + +-- unused +eqClassNumSub :: Code -> Code -> Bool +eqClassNumSub a b = (decimate a) == (decimate b) + +-- strip this code of its axes/parameters/comments +-- copy just class, code number and subcode +decimate :: Code -> Code +decimate x@Code{} | codeCls x `elem` (map Just [T, FStandalone, PStandalone, SStandalone]) = copyClass x emptyCode +decimate x@Code{} = copyClassNumSub x emptyCode +decimate x = x + + +copyClassNumSub from to = to { codeCls = codeCls from + , codeNum = codeNum from + , codeSub = codeSub from } + +copyClass from to = to { codeCls = codeCls from } diff --git a/src/Data/GCode/RS274/Types.hs b/src/Data/GCode/RS274/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/GCode/RS274/Types.hs @@ -0,0 +1,477 @@ +module Data.GCode.RS274.Types where + +import Data.GCode.Types + + -- G-code command definition +data GCodeDef = GCodeDef + { defCls :: Maybe Class + , defNum :: Maybe Int + , defSub :: Maybe Int + , defGroup :: RS274Group + , defName :: RS274Name + , defHelp :: String + } deriving (Show, Eq, Ord) + +defGCD :: GCodeDef +defGCD = GCodeDef { + defCls = Nothing + , defNum = Nothing + , defSub = Nothing + , defGroup = Unknown + , defName = Unnamed + , defHelp = "" + } + +-- utils for creating GCodeDefs +defG :: GCodeDef +defG = defGCD { defCls = Just G } + +defM :: GCodeDef +defM = defGCD { defCls = Just M } + +g :: Int -> RS274Name -> GCodeDef +g x n = defG { defNum = Just x , defName = n } + +m :: Int -> RS274Name -> GCodeDef +m x n = defM { defNum = Just x , defName = n } + +gsub :: Int -> Int -> RS274Name -> GCodeDef +gsub x s n = (g x n) { defSub = Just s } + +msub :: Int -> Int -> RS274Name -> GCodeDef +msub x s n = (m x n) { defSub = Just s } + +-- | Add help text to `GCodeDef` +help :: String -> GCodeDef -> GCodeDef +help txt x = x {defHelp = txt } + +-- | Turn `GCodeDef` into `Code` +toCode :: GCodeDef -> Code +toCode x = emptyCode { codeCls = defCls x + , codeNum = defNum x + , codeSub = defSub x + } + +-- set defGroup for each list member +makeGroup :: RS274Group -> [GCodeDef] -> [GCodeDef] +makeGroup group defs = map (\x -> x { defGroup = group }) defs + +data RS274Name = + Unnamed + | Rapid + | Move + | ArcCW + | ArcCCW + | Dwell + | CubicSpline + | QuadSpline + | NURBS + | XYPlane + | ZXPlane + | YZPlane + | UVPlane + | WUPlane + | VWPlane + | Inches + | Millimeters + | SpindleSync + | RigidTap + | Probe + | DrillingCycleCB + | ThreadingCycle + | DrillingCycleCancel + | DrillingCycle + | DrillingCycleDwell + | DrillingCyclePeck + | BoringCycle + | BoringCycleDwell + | Absolute + | Relative + | ArcAbsolute + | ArcRelative + | LatheDiameter + | LatheRadius + | InverseTime + | UnitsPerMinute + | UnitsPerRevolution + | SpindleOrient + | SpindleStop + | SpindleCW + | SpindleCCW + | SpindleModeConstantSurfaceSpeed + | SpindleModeRPM + | CoolantMist + | CoolantFlood + | CoolantStop + | ToolLength + | ToolLengthDynamic + | ToolLengthAdd + | ToolLengthCancel + | Pause + | OptionalPause + | ProgramEnd + | PalletChange + | PalletChangePause + | CutterCompensationOff + | CutterCompensationLeft + | CutterCompensationDynamicLeft + | CutterCompensationRight + | CutterCompensationDynamicRight + | ToolChange + | SetCurrentTool + | SetToolTable -- XXX this is composed from like five different commands with L parameter + | StoredPositionMove + | StoredPositionSet + | ToolChangePositionMove + | ToolChangePositionSet + | MoveInMachineCoordinates + | CoordinateSystemOffset + | ResetOffsetsParams + | ResetOffsets + | RestoreOffsets + | OverridesEnable + | OverridesDisable + | FeedRateOverride + | SpindleSpeedOverride + | AdaptiveFeedControl + | FeedStopControl + -- 3D printer specific + | ExtruderAbsolute + | ExtruderRelative + | SetExtruderTemperature + | GetExtruderTemperature + | SetExtruderTemperatureAndWait + | SetBedTemperature + | SetBedTemperatureAndWait + | SetChamberTemperature + | SetChamberTemperatureAndWait + | CancelWaitTemperature + | FanOn + | FanOff + | GetCurrentPosition + | DisplayMessage + | DisableActuators + | AutoBedLevel + deriving (Eq, Ord, Show) + +data RS274Group = + Motion + | Cycles + | Distance + | ArcDistance + | FeedRateMode + | SpindleControl + | CoolantControl + | Stopping + | Units + | Plane + | ToolLengthOffset + | CutterRadius + | LatheDiameterMode + | OtherModal + | NonModal + | Unknown + -- 3D printer specific + | Extruder + | Heating + | Cooling + | PrinterMisc + deriving (Eq, Ord, Show) + + +-- G-Codes + +groupMotion :: [GCodeDef] +groupMotion = makeGroup Motion [ + g 0 Rapid + & help "Rapid move" + , g 1 Move + & help "Linear move" + , g 2 ArcCW + & help "Clock-wise arc" + , g 3 ArcCCW + & help "Counter clock-wise arc" + , g 4 Dwell + & help "Do nothing for specified time" + , g 5 CubicSpline + & help "Cubic B-spline move" + , gsub 5 1 QuadSpline + & help "Quadratic B-spline move" + , gsub 5 2 NURBS + & help "NURBS curve move" + , g 33 SpindleSync + & help "Perform spindle synchronized motion" + , gsub 33 1 RigidTap + & help "Rigid Tapping" + , g 38 Probe + & help "Straight probe" + ] + +groupPlane :: [GCodeDef] +groupPlane = makeGroup Plane [ + g 17 XYPlane + & help "Select XY plane (default)" + , g 18 ZXPlane + & help "Select ZX plane" + , g 19 YZPlane + & help "Select YZ plane" + , gsub 17 1 UVPlane + & help "Select UV plane" + , gsub 18 1 WUPlane + & help "Select WU plane" + , gsub 19 1 VWPlane + & help "Select VW plane" + ] + +groupUnits :: [GCodeDef] +groupUnits = makeGroup Units [ + g 20 Inches + & help "Set units to inches" + , g 21 Millimeters + & help "Set units to millimeters" + ] + +groupCutterRadius :: [GCodeDef] +groupCutterRadius = makeGroup CutterRadius [ + g 40 CutterCompensationOff + , g 41 CutterCompensationLeft + , gsub 41 1 CutterCompensationDynamicLeft + , g 42 CutterCompensationRight + , gsub 42 1 CutterCompensationDynamicRight + ] + +groupToolLengthOffset :: [GCodeDef] +groupToolLengthOffset = makeGroup ToolLengthOffset [ + g 43 ToolLength + & help "Enables tool length compensation" + , gsub 43 1 ToolLengthDynamic + , gsub 43 2 ToolLengthAdd + & help "Apply additional tool length offset" + , g 49 ToolLengthCancel + & help "Cancel tool length compensation" + ] + +groupCycles :: [GCodeDef] +groupCycles = makeGroup Cycles [ + g 73 DrillingCycleCB + , g 76 ThreadingCycle + , g 80 DrillingCycleCancel + , g 81 DrillingCycle + , g 82 DrillingCycleDwell + , g 83 DrillingCyclePeck + , g 85 BoringCycle + , g 89 BoringCycleDwell + ] + +groupDistance :: [GCodeDef] +groupDistance = makeGroup Distance [ + g 90 Absolute + & help "Absolute distance mode" + , g 91 Relative + & help "Incremental distance mode" + ] + +groupArcDistance :: [GCodeDef] +groupArcDistance = makeGroup ArcDistance [ + gsub 90 1 ArcAbsolute + & help "Absolute distance mode for I, J & K offsets" + , gsub 91 1 ArcRelative + & help "Incremental distance mode for I, J & K offsets" + ] + +groupLatheDiameterMode :: [GCodeDef] +groupLatheDiameterMode = makeGroup LatheDiameterMode [ + g 7 LatheDiameter + , g 8 LatheRadius + ] + +groupFeedRateMode :: [GCodeDef] +groupFeedRateMode = makeGroup FeedRateMode [ + g 93 InverseTime + & help "Iverse time feed rate mode, move should be completed in 1/F minutes" + , g 94 UnitsPerMinute + & help "Feed rates in units per minute" + , g 95 UnitsPerRevolution + & help "Feed rates in units per revolution" + ] + + +-- mixed M/G + +groupSpindleControl :: [GCodeDef] +groupSpindleControl = makeGroup SpindleControl [ + m 3 SpindleCW + & help "Start the spindle clockwise at the S speed" + , m 4 SpindleCCW + & help "Start the spindle counterclockwise at the S speed" + , m 5 SpindleStop + & help "Stop spindle" + , m 19 SpindleOrient + & help "Orient spindle" + , g 96 SpindleModeConstantSurfaceSpeed + , g 97 SpindleModeRPM + ] + +-- M-Codes + +groupStopping :: [GCodeDef] +groupStopping = makeGroup Stopping [ + m 0 Pause + & help "Pause a running program temporarily" + , m 1 OptionalPause + & help "Pause a running program temporarily if the optional stop switch is on" + , m 2 ProgramEnd + & help "End the program" + , m 30 PalletChange + & help "Exchange pallet shuttles and end the program" + , m 60 PalletChangePause + & help "Exchange pallet shuttles and then pause a running program temporarily" + ] + +groupCoolantControl :: [GCodeDef] +groupCoolantControl = makeGroup CoolantControl [ + m 7 CoolantMist + & help "Turn mist coolant on" + , m 8 CoolantFlood + & help "Turn flood coolant on" + , m 9 CoolantStop + & help "Stop both coolants (M7 & M8)" + ] + +-- non-modal codes +groupNonModal :: [GCodeDef] +groupNonModal = makeGroup NonModal [ + m 6 ToolChange + & help "Stop machine and prompt for tool change" + , m 61 SetCurrentTool + & help "Change current tool number without tool-change (in MDI/Manual mode only)" + , g 10 SetToolTable -- XXX this is composed from like five different commands with L parameter + , g 28 StoredPositionMove + & help "Make a rapid move to position stored with G28.1" + , gsub 28 1 StoredPositionSet + & help "Store current absolute position" + , g 30 ToolChangePositionMove + & help "Make a rapid move to position stored with G30.1" + , gsub 30 1 ToolChangePositionSet + & help "Store current absolute position as tool change position" + , g 53 MoveInMachineCoordinates + & help "Move in the machine coordinate system" + , g 92 CoordinateSystemOffset + & help "Make the current point have the coordinates you want (without motion)" + , gsub 92 1 ResetOffsetsParams + & help "Turn off G92 offsets and reset parameters 5211 - 5219 to zero" + , gsub 92 2 ResetOffsets + & help "Turn off G92 offsets but keep parameters 5211 - 5219 available" + , gsub 92 3 RestoreOffsets + & help "Set the G92 offsets to the values saved in parameters 5211 - 5219" + ] + +groupOtherModal :: [GCodeDef] +groupOtherModal = makeGroup OtherModal [ + defGCD { defCls = Just FStandalone } + & help "Set feed rate" + , defGCD { defCls = Just SStandalone } + & help "Set spindle speed" + , defGCD { defCls = Just T } + & help "Select tool" + , m 48 OverridesEnable + & help "Enable the spindle speed and feed rate override controls" + , m 49 OverridesDisable + & help "Disable the spindle speed and feed rate override controls" + , m 50 FeedRateOverride + & help "Feed rate override control" + , m 51 SpindleSpeedOverride + & help "Spindle speed override control" + , m 52 AdaptiveFeedControl + & help "Adaptive feed control" + , m 53 FeedStopControl + & help "Feed stop control" + ] + +-- 3D printer specific + +groupExtruder :: [GCodeDef] +groupExtruder = makeGroup Extruder [ + m 82 ExtruderAbsolute + & help "Interpret extrusion parameters as absolution positions" + , m 83 ExtruderRelative + & help "Interpret extrusion parameters as relative positions" + ] + +groupHeating :: [GCodeDef] +groupHeating = makeGroup Heating [ + m 104 SetExtruderTemperature + & help "Set extruder temperature" + , m 105 GetExtruderTemperature + & help "Get current temperature of the selected extruder" + , m 109 SetExtruderTemperatureAndWait + & help "Set extruder temperature and wait for it to be reached" + , m 140 SetBedTemperature + & help "Set temperature of the heated bed" + , m 190 SetBedTemperatureAndWait + & help "Set heated bed temperature and wait for it to be reached" + , m 141 SetChamberTemperature + & help "Set temperature of the heated chamber" + , m 191 SetChamberTemperatureAndWait + & help "Set heated chamber and wait for it to be reached" + , m 108 CancelWaitTemperature + & help ("Stops waiting for temperature to be reached issued by M109, M190 or M191." + ++ " This won't disable heaters and will continue the print job.") + ] + +groupCooling :: [GCodeDef] +groupCooling = makeGroup Cooling [ + m 106 FanOn + & help "Enable fan" + , m 107 FanOff + & help "Disable fan" + ] + +groupPrinterMisc :: [GCodeDef] +groupPrinterMisc = makeGroup PrinterMisc [ + g 29 AutoBedLevel + & help "Run automatic heated bed leveling" + , m 84 DisableActuators + & help "Disable actuators, e.g. cut power to steppers" + , m 114 GetCurrentPosition + & help "Report current position of all axes and extruders" + , m 117 DisplayMessage + & help "Display a text message on LCD display" + ] + +cncGroups :: [(RS274Group, [GCodeDef])] +cncGroups = [ + (Motion , groupMotion) + , (Plane , groupPlane) + , (Units , groupUnits) + , (ToolLengthOffset , groupToolLengthOffset) + , (Cycles , groupCycles) + , (Distance , groupDistance) + , (ArcDistance , groupArcDistance) + , (FeedRateMode , groupFeedRateMode) + , (SpindleControl , groupSpindleControl) + , (Stopping , groupStopping) + , (CoolantControl , groupCoolantControl) + , (CutterRadius , groupCutterRadius) + , (LatheDiameterMode, groupLatheDiameterMode) + , (OtherModal , groupOtherModal) + , (NonModal , groupNonModal) + ] + +printerGroups :: [(RS274Group, [GCodeDef])] +printerGroups = [ + (Extruder , groupExtruder) + , (Heating , groupHeating) + , (Cooling , groupCooling) + , (PrinterMisc , groupPrinterMisc) + ] + +allGroups :: [(RS274Group, [GCodeDef])] +allGroups = cncGroups ++ printerGroups + +groupNames :: [RS274Group] +groupNames = map fst allGroups + +-- | All `GCodeDef`s known to us +allCodes :: [GCodeDef] +allCodes = concatMap snd allGroups diff --git a/src/Data/GCode/TH.hs b/src/Data/GCode/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/GCode/TH.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE TemplateHaskell #-} +module Data.GCode.TH where + +import Language.Haskell.TH + +import qualified Data.Char + +-- this walks constructors of a datatype +-- and creates isXYZ checks and CodeMod constructors +-- for example for constructor `Rapid` these two are generated +-- isRapid :: Code -> Bool +-- isRapid x = x `codeIsRS274` Rapid +-- +-- rapid :: Code +-- rapid = codeFromName Rapid +genShortcuts :: Name -> Q [Dec] +genShortcuts names = do + info <- reify names + case info of + TyConI (DataD _cxt _name _tyvarbndr _kind constructors _deriv) + -> do + a <- mapM genTests constructors + b <- mapM genConstructors constructors + return $ a ++ b + _ -> error "Unexpected reify input for genShortcuts" + + where + genTests (NormalC name _bangs) = do + varName <- newName "x" + let + funName = mkName $ "is" ++ (nameBase name) + + return $ FunD funName + [ Clause + [VarP varName] + (NormalB (InfixE (Just (VarE varName)) (VarE (mkName "codeIsRS274")) (Just (ConE name)))) + [] + ] + genTests _ = error "Unexpteced input for genTests" + + genConstructors (NormalC name _bangs) = do + let + funName = mkName $ (\(x:rest) -> (Data.Char.toLower x : rest)) (nameBase name) + return $ FunD funName + [ Clause + [] + (NormalB ( (VarE (mkName "codeFromName")) `AppE` (ConE name)) ) + [] + ] + genConstructors _ = error "Unexpteced input for genConstructors" + +-- this walks constructors of a datatype +-- and creates constructors to be used in writer monad +-- +-- for example for constructor `Move` these two are generated +-- move' :: Control.Monad.Trans.Writer.Lazy.Writer (Endo Program) () +-- move' = generateName Move +-- +-- and a wariant accepting Code endofunctor so we can do move' and also move (xy 2 3) +-- move :: (Code -> Code) -> Control.Monad.Trans.Writer.Lazy.Writer (Endo Program) () +-- move fn = generateNameArgs Move fn +-- +-- We prefer variant with args as it seems to be more common +-- to have GCodes with arguments than just standalone ones. +genWriterEndos :: Name -> Q [Dec] +genWriterEndos names = do + info <- reify names + case info of + TyConI (DataD _cxt _name _tyvarbndr _kind constructors _deriv) + -> do + a <- mapM genConstructors constructors + b <- mapM genConstructorsArgs constructors + return $ a ++ b + _ -> error "Unexpected reify input for genWriterEndos" + + where + genConstructors (NormalC name _bangs) = do + let + funName = mkName $ (\(x:rest) -> (Data.Char.toLower x : rest ++ "'")) (nameBase name) + return $ FunD funName + [ Clause + [] + (NormalB ( (VarE (mkName "generateName")) `AppE` (ConE name)) ) + [] + ] + genConstructors _ = error "Unexpteced input for genConstructors" + + genConstructorsArgs (NormalC name _bangs) = do + endoName <- newName "x" + let + funName = mkName $ (\(x:rest) -> (Data.Char.toLower x : rest)) (nameBase name) + return $ FunD funName + [ Clause + [VarP endoName] + (NormalB (((VarE (mkName "generateNameArgs")) `AppE` (ConE name)) `AppE` (VarE endoName)) ) + [] + ] + genConstructorsArgs _ = error "Unexpteced input for genConstructorArgs" diff --git a/src/Data/GCode/Types.hs b/src/Data/GCode/Types.hs --- a/src/Data/GCode/Types.hs +++ b/src/Data/GCode/Types.hs @@ -6,59 +6,60 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Data.GCode.Types ( Class(..) , AxisDesignator(..) , ParamDesignator(..) + , allClasses + , allAxisDesignators + , zeroAxes + , allParamDesignators + , asChars , Axes , Params , Limits , ParamLimits , Code(..) , GCode - , codecls + , toCodeClass + , toAxis + , toParam + , (&) + , cls , axis - , axis' , param - , param' - , CodeMod - , cls , num , sub , axes , params , comment - , appmod - , eval , emptyCode , defaultPrec , Style(..) , defaultStyle ) where -import qualified Data.ByteString as B -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE ---import qualified Foldable as F -import Data.Semigroup hiding (option) -import Control.Monad.State.Strict -import Control.Applicative - -import qualified Data.Map.Strict as M - +import Data.ByteString (ByteString) +import Data.Map (Map) +import qualified Data.Char +import qualified Data.Map -- | Code class data Class = - G -- ^ G-code - | M -- ^ M-code - | T -- ^ T-code (temperature) - | StP -- ^ Stand-alone P-code - | StF -- ^ Stand-alone F-code - | StS -- ^ Stand-alone S-code + G -- ^ G-code + | M -- ^ M-code + | T -- ^ T-code (select tool) + | PStandalone -- ^ Stand-alone P-code + | FStandalone -- ^ Stand-alone F-code + | SStandalone -- ^ Stand-alone S-code deriving (Show, Enum, Eq, Ord) +allClasses :: [Class] +allClasses = [G, M, T, PStandalone, FStandalone, SStandalone] + -- | Axis letter data AxisDesignator = X -- ^ X-axis @@ -67,118 +68,122 @@ | A -- ^ A-axis | B -- ^ B-axis | C -- ^ C-axis + | U -- ^ U-axis + | V -- ^ V-axis + | W -- ^ W-axis | E -- ^ Extruder axis | L deriving (Show, Enum, Eq, Ord) +allAxisDesignators :: [AxisDesignator] +allAxisDesignators = [X, Y, Z, A, B, C, U, V, W, E, L] + +-- | Return `Axes` with each known at zero position +zeroAxes :: Axes +zeroAxes = Data.Map.fromList $ map (\a -> (a, 0)) allAxisDesignators + -- | Param letter data ParamDesignator = S -- ^ S parameter - usually spindle RPM | P -- ^ P parameter | F -- ^ F parameter - usually feedrate + | H -- ^ H paramater - used by tool length offset | R -- ^ R parameter + | I -- ^ X offset for arcs + | J -- ^ Y offset for arcs + | K -- ^ Z offset for arcs deriving (Show, Enum, Eq, Ord) +allParamDesignators :: [ParamDesignator] +allParamDesignators = [S, P, F, R, I, J, K] + +asChars :: Show a => [a] -> [Char] +asChars types = map ((!! 0) . show) types + +fromChar :: Show a => Char -> [a] -> Maybe a +fromChar c types = Data.Map.lookup (Data.Char.toUpper c) + $ Data.Map.fromList (zip (asChars types) types) + -- |Convert 'Char' representation of a code to its 'Class' -codecls :: Char -> Class -codecls 'G' = G -codecls 'M' = M -codecls 'T' = T -codecls 'P' = StP -codecls 'F' = StF -codecls 'S' = StS +toCodeClass :: Char -> Maybe Class +toCodeClass c = fromChar c allClasses -- |Convert 'Char' representation of an axis to its 'AxisDesignator' -axis :: Char -> AxisDesignator -axis 'X' = X -axis 'Y' = Y -axis 'Z' = Z -axis 'A' = A -axis 'B' = B -axis 'C' = C -axis 'E' = E -axis 'L' = L +toAxis :: Char -> Maybe AxisDesignator +toAxis c = fromChar c allAxisDesignators -- |Convert 'Char' representation of a param to its 'ParamDesignator' -param :: Char -> ParamDesignator -param 'S' = S -param 'P' = P -param 'F' = F -param 'R' = R +toParam :: Char -> Maybe ParamDesignator +toParam c = fromChar c allParamDesignators -- | Map of 'AxisDesignator' to 'Double' -type Axes = M.Map AxisDesignator Double +type Axes = Map AxisDesignator Double -type Limits = M.Map AxisDesignator (Double, Double) +-- | Map of 'AxisDesignator' to pair of 'Double's indicating lower and upper limits of travel +type Limits = Map AxisDesignator (Double, Double) -- | Map of 'ParamDesignator' to 'Double' -type Params = M.Map ParamDesignator Double +type Params = Map ParamDesignator Double -type ParamLimits = M.Map ParamDesignator (Double, Double) +-- | Map of 'ParamDesignator' to pair of 'Double's indicating lower and upper limits of this parameter +type ParamLimits = Map ParamDesignator (Double, Double) -- | List of 'Code's type GCode = [Code] data Code = Code { - codeCls :: Maybe Class -- ^ Code 'Class' (M in M5) - , codeNum :: Maybe Int -- ^ Code value (81 in G81) - , codeSub :: Maybe Int -- ^ Code subcode (1 in G92.1) + codeCls :: Maybe Class -- ^ Code 'Class' (M in M5) + , codeNum :: Maybe Int -- ^ Code value (81 in G81) + , codeSub :: Maybe Int -- ^ Code subcode (1 in G92.1) , codeAxes :: Axes -- ^ Code 'Axes' , codeParams :: Params -- ^ Code 'Params' - , codeComment :: B.ByteString -- ^ Comment following this Code + , codeComment :: ByteString -- ^ Comment following this Code } - | Comment B.ByteString -- ^ Standalone comment - | Empty -- ^ Empty lines - | Other B.ByteString -- ^ Parser unhandled lines + | Comment ByteString -- ^ Standalone comment + | Empty -- ^ Empty lines + | Other ByteString -- ^ Parser unhandled lines deriving (Show, Eq, Ord) -newtype CodeMod = CodeMod - { applyCodeMod :: Code -> Code } -instance Monoid CodeMod where - mempty = CodeMod id - mappend = (<>) - -instance Semigroup CodeMod where - m1 <> m2 = CodeMod $ applyCodeMod m1 . applyCodeMod m2 - -cls :: Class -> CodeMod -cls x = CodeMod $ \c -> c { codeCls = Just x} - -num :: Int -> CodeMod -num x = CodeMod $ \c -> c { codeNum = Just x} - -sub :: Int -> CodeMod -sub x = CodeMod $ \c -> c { codeSub = Just x} - -axes :: Axes -> CodeMod -axes x = CodeMod $ \c -> c { codeAxes = x} +-- endofunctors for manipulating `Code` +cls :: Class -> Code -> Code +cls x c = c { codeCls = Just x} -axis' :: AxisDesignator -> Double -> CodeMod -axis' des val = CodeMod $ \c -> c { codeAxes = M.insert des val $ codeAxes c } +num :: Int -> Code -> Code +num x c = c { codeNum = Just x} -params :: Params -> CodeMod -params x = CodeMod $ \c -> c { codeParams = x} +sub :: Int -> Code -> Code +sub x c = c { codeSub = Just x} -param' :: ParamDesignator -> Double -> CodeMod -param' des val = CodeMod $ \c -> c { codeParams = M.insert des val $ codeParams c } +axes :: Axes -> Code -> Code +axes x c = c { codeAxes = x} -comment :: B.ByteString -> CodeMod -comment x = CodeMod $ \c -> c { codeComment = x} +axis :: AxisDesignator -> Double -> Code -> Code +axis des val c = c { codeAxes = Data.Map.insert des val $ codeAxes c } -appmod :: CodeMod -> Code -> Code -appmod m c = applyCodeMod m c +params :: Params -> Code -> Code +params x c = c { codeParams = x} ---data Sim = Empty --- | Line Axes Axes --- deriving (Show, Eq) +param :: ParamDesignator -> Double -> Code -> Code +param des val c = c { codeParams = Data.Map.insert des val $ codeParams c } ---eval c1 c2 = Line (codeAxes c1) (codeAxes c2) -eval = undefined +comment :: ByteString -> Code -> Code +comment x c = c { codeComment = x} -emptyCode = Code Nothing Nothing Nothing M.empty M.empty "" +-- code & num 10 & comment "& example" +(&) :: a -> (a -> c) -> c +(&) = flip ($) +emptyCode :: Code +emptyCode = Code { + codeCls = Nothing + , codeNum = Nothing + , codeSub = Nothing + , codeAxes = mempty + , codeParams = mempty + , codeComment = mempty + } data Style = @@ -190,4 +195,5 @@ defaultPrec :: Int defaultPrec = 6 +defaultStyle :: Style defaultStyle = Style defaultPrec False diff --git a/src/Data/GCode/Utils.hs b/src/Data/GCode/Utils.hs --- a/src/Data/GCode/Utils.hs +++ b/src/Data/GCode/Utils.hs @@ -4,324 +4,40 @@ -} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE BangPatterns #-} module Data.GCode.Utils where -import Debug.Trace import Data.Maybe -import Data.Monoid import Data.GCode.Types +import Data.GCode.RS274 (isMove, isRapid) import qualified Data.Map.Strict as M -import Control.Monad.State.Strict -import Control.Applicative - --- |True if 'Code' is a G-code +-- | True if 'Code' is a G-code isG :: Code -> Bool -isG Code{codeCls=(Just G), ..} = True +isG Code{codeCls=(Just G)} = True isG _ = False --- |True if 'Code' is a M-code +-- | True if 'Code' is a M-code isM :: Code -> Bool -isM Code{codeCls=(Just M), ..} = True +isM Code{codeCls=(Just M)} = True isM _ = False --- |True if 'Code' is a G{N} code +-- | True if 'Code' is a G{N} code isGN :: Int -> Code -> Bool -isGN n Code{codeCls=(Just G), codeNum=(Just x), ..} = x == n +isGN n Code{codeCls=(Just G), codeNum=(Just x)} = x == n isGN _ _ = False --- |True if 'Code' is a G{N}.{sub} code -isGNs n sub Code{codeCls=(Just G), codeNum=(Just x), codeSub=(Just sx), ..} = x == n && sx == sub -isGNs _ _ _ = False - --- |True if 'Code' is a M{N} code -isMN :: Int -> Code -> Bool -isMN n Code{codeCls=(Just M), codeNum=(Just x), ..} = x == n -isMN _ _ = False - --- |True if 'Code' is a M{N}.{sub} code -isMNs n sub Code{codeCls=(Just M), codeNum=(Just x), codeSub=(Just sx), ..} = x == n && sx == sub -isMNs _ _ _ = False - --- |True if 'Code' is a G0 code -isG0 :: Code -> Bool -isG0 = isGN 0 - --- |True if 'Code' is a G0 (rapid move) code, alias to 'isG0' -isRapid :: Code -> Bool -isRapid = isG0 - --- |True if 'Code' is a G1 code -isG1 :: Code -> Bool -isG1 = isGN 1 - --- |True if 'Code' is a G1 (move) code, alias to 'isG1' -isMove :: Code -> Bool -isMove = isG1 - --- |True if 'Code' is a G2 code -isG2 :: Code -> Bool -isG2 = isGN 2 - --- |True if 'Code' is a G2 (clockwise circular move) code, alias to 'isG2' -isArcCW :: Code -> Bool -isArcCW = isG2 - - -- |True if 'Code' is a G3 code -isG3 :: Code -> Bool -isG3 = isGN 3 - --- |True if 'Code' is a G3 (counter-clockwise circular move) code, alias to 'isG3' -isArcCCW :: Code -> Bool -isArcCCW = isG3 - --- |True if 'Code' is a G4 code -isG4 :: Code -> Bool -isG4 = isGN 4 - --- |True if 'Code' is a G4 (dwell) code, alias to 'isG4' -isDwell :: Code -> Bool -isDwell = isG4 - --- |True if 'Code' is a G5 code -isG5 :: Code -> Bool -isG5 = isGN 5 - --- |True if 'Code' is a G5 (cubic spline) code, alias to 'isG5' -isCubicSpline :: Code -> Bool -isCubicSpline = isG5 - - -- |True if 'Code' is a G5.1 code -isG5s1 :: Code -> Bool -isG5s1 = isGNs 5 1 - --- |True if 'Code' is a G5.1 (quadratic spline) code, alias to 'isG5s1' -isQuadSpline :: Code -> Bool -isQuadSpline = isG5s1 - --- |True if 'Code' is a G5.2 code -isG5s2 :: Code -> Bool -isG5s2 = isGNs 5 2 - --- |True if 'Code' is a G5.2 (NURBS) code, alias to 'isG5s2' -isNURBS :: Code -> Bool -isNURBS = isG5s2 - --- |True if 'Code' is a G17 (select XYZ plane) code -isXYZplane :: Code -> Bool -isXYZplane = isGN 17 - --- |True if 'Code' is a G18 (select XZY plane) code -isXZYplane :: Code -> Bool -isXZYplane = isGN 18 - --- |True if 'Code' is a G19 (select YZX plane) code -isYZXplane :: Code -> Bool -isYZXplane = isGN 19 - -groupPlane = [ isXYZplane, isXZYplane, isYZXplane ] - --- |True if 'Code' is a G20 (inch mode) code -isInch :: Code -> Bool -isInch = isGN 20 - --- |True if 'Code' is a G21 (millimeter mode) code -isMM :: Code -> Bool -isMM = isGN 21 - -groupUnits = [ isInch, isMM ] - --- |True if 'Code' is a G33 code -isG33 :: Code -> Bool -isG33 = isGN 33 - --- |True if 'Code' is a G33 (spindle synchronized motion) code, alias to 'isG33' -isSpindleSync :: Code -> Bool -isSpindleSync = isG33 - --- |True if 'Code' is a G33.1 code -isG33s1 :: Code -> Bool -isG33s1 = isGNs 33 1 - --- |True if 'Code' is a G33.1 (rigit tapping) code, alias to 'isG33s1' -isRigidTap :: Code -> Bool -isRigidTap = isG33s1 - --- |True if 'Code' is a G38 code -isG38 :: Code -> Bool -isG38 = isGN 38 - --- |True if 'Code' is a G38 (probe) code, alias to 'isG38' -isProbe :: Code -> Bool -isProbe = isG38 - -groupMotion = [isMove, isRapid, isArcCW, isArcCCW, - isCubicSpline, isQuadSpline, isNURBS, isProbe, isSpindleSync, isRigidTap] - --- |True if 'Code' is a G73 (drilling cycle, chip breaking) code -isDrillingCycleCB :: Code -> Bool -isDrillingCycleCB = isGN 73 - --- |True if 'Code' is a G76 (threading cycle) code -isThreadingCycle :: Code -> Bool -isThreadingCycle = isGN 76 - --- |True if 'Code' is a G80 (cancel drilling cycle) code -isDrillingCycleCancel :: Code -> Bool -isDrillingCycleCancel = isGN 80 - --- |True if 'Code' is a G81 (drilling cycle) code -isDrillingCycle :: Code -> Bool -isDrillingCycle = isGN 81 - --- |True if 'Code' is a G82 (drilling cycle, dwell) code -isDrillingCycleDwell :: Code -> Bool -isDrillingCycleDwell = isGN 82 - --- |True if 'Code' is a G83 (drilling cycle, pecky) code -isDrillingCyclePeck :: Code -> Bool -isDrillingCyclePeck = isGN 83 - --- |True if 'Code' is a G85 (boring cycle, feed out) code -isBoringCycle :: Code -> Bool -isBoringCycle = isGN 85 - --- |True if 'Code' is a G89 (boring cycle, dwell, feed out) code -isBoringCycleDwell :: Code -> Bool -isBoringCycleDwell = isGN 89 - -groupCycles = [isDrillingCycle, isDrillingCycleCB, isDrillingCyclePeck, - isDrillingCycleDwell, isDrillingCycleCancel, - isThreadingCycle, - isBoringCycle, isBoringCycleDwell ] - --- |True if 'Code' is a G90 (absolute mode) code -isAbsolute :: Code -> Bool -isAbsolute = isGN 90 - --- |True if 'Code' is a G91 (relative mode) code -isRelative :: Code -> Bool -isRelative = isGN 91 - --- |True if 'Code' is a G90.1 (absolute arc mode) code -isArcAbsolute :: Code -> Bool -isArcAbsolute = isGNs 90 1 - --- |True if 'Code' is a G91.1 (relative arc mode) code -isArcRelative :: Code -> Bool -isArcRelative = isGNs 91 1 - --- |True if 'Code' is a G7 (lathe diameter mode) code -isLatheDiameter :: Code -> Bool -isLatheDiameter = isGN 7 - --- |True if 'Code' is a G8 (lathe radius mode) code -isLatheRadius :: Code -> Bool -isLatheRadius = isGN 8 - -groupDistance = [ isAbsolute, isRelative, - isArcAbsolute, isArcRelative, isLatheDiameter, isLatheRadius ] - ---isModal = isModalGMotion || isModalPlane || isModalUnits || isModalAbsRel - --- |True if 'Code' is a G93 (inverse time mode) code -isInverseTime :: Code -> Bool -isInverseTime = isGN 93 - --- |True if 'Code' is a G94 (units per minute time mode) code -isUnitsPerMinute :: Code -> Bool -isUnitsPerMinute = isGN 94 - --- |True if 'Code' is a G95 (units per revolution time mode) code -isUnitsPerRevolution :: Code -> Bool -isUnitsPerRevolution = isGN 95 - -groupFeedRateMode = [ isInverseTime, isUnitsPerMinute, isUnitsPerRevolution ] - --- |True if 'Code' is a M3 (spindle start clockwise) code -isSpindleCW :: Code -> Bool -isSpindleCW = isMN 3 - --- |True if 'Code' is a M4 (spindle start counter-clockwise) code -isSpindleCCW :: Code -> Bool -isSpindleCCW = isMN 4 - --- |True if 'Code' is a M5 (spindle stop) code -isSpindleStop :: Code -> Bool -isSpindleStop = isMN 5 - -groupSpindleControl = [ isSpindleCW, isSpindleCCW, isSpindleStop, - isMN 19, isGN 96, isGN 97] - --- |True if 'Code' is a M7 (turn mist coolant on) code -isCoolantMist :: Code -> Bool -isCoolantMist = isMN 7 - --- |True if 'Code' is a M8 (turn flood coolant on) code -isCoolantFlood :: Code -> Bool -isCoolantFlood = isMN 8 - --- |True if 'Code' is a M9 (turn all coolant off) code -isCoolantStop :: Code -> Bool -isCoolantStop = isMN 9 - -groupCoolantControl = [ isCoolantMist, isCoolantFlood, isCoolantStop ] - --- |True if 'Code' is a G43 (tool length offset) code -isToolLength :: Code -> Bool -isToolLength = isGN 43 - --- |True if 'Code' is a G43.1 (dynamic tool length offset) code -isToolLengthDynamic :: Code -> Bool -isToolLengthDynamic = isGNs 43 1 - --- |True if 'Code' is a G43.2 (apply additional tool length offset) code -isToolLengthAdd :: Code -> Bool -isToolLengthAdd = isGNs 43 2 - --- |True if 'Code' is a G49 (cancel tool length offset) code -isToolLengthCancel :: Code -> Bool -isToolLengthCancel = isGN 49 - -groupToolLengthOffset = [ isToolLength, isToolLengthDynamic, - isToolLengthAdd, isToolLengthCancel ] - --- |True if 'Code' is a M0 (pause) code -isPause :: Code -> Bool -isPause = isMN 0 - --- |True if 'Code' is a M1 (optional pause) code -isOptionalPause :: Code -> Bool -isOptionalPause = isMN 1 - --- |True if 'Code' is a M2 (program end) code -isEnd :: Code -> Bool -isEnd = isMN 2 - --- |True if 'Code' is a M30 (exchange pallet shuttles) code -isExchange :: Code -> Bool -isExchange = isMN 30 - -groupStopping = [ isPause, isOptionalPause, isEnd, isExchange, isMN 60 ] - -groups = [ groupMotion, groupCycles, groupDistance, groupFeedRateMode, - groupSpindleControl, groupCoolantControl, groupStopping, groupUnits, - groupPlane ] - --- |True if 'Code' has a coordinate in axis 'a' +-- | True if 'Code' has a coordinate in axis 'a' hasAxis :: AxisDesignator -> Code -> Bool hasAxis a Code{..} = M.member a codeAxes -hasAxis a _ = False +hasAxis _ _ = False getAxis :: AxisDesignator -> Code -> Maybe Double getAxis a Code{..} = M.lookup a codeAxes getAxis _ _ = Nothing getAxes :: [AxisDesignator] -> Code -> [Maybe Double] -getAxes as c@Code{..} = map (\a-> getAxis a c) as -getAxes _ _ = [] +getAxes as c = map (\a-> getAxis a c) as getAxesToList :: Code -> [(AxisDesignator, Double)] getAxesToList Code{..} = M.toList codeAxes @@ -330,241 +46,166 @@ --filterAxes :: [AxisDesignator] -> Code -> [Double] --filterAxes ax Code{..} = map (\a -> M.lookup a codeAxes) ax --- |True if 'Code' contains 'X' axis +-- | True if 'Code' contains 'X' axis hasX :: Code -> Bool hasX = hasAxis X --- |True if 'Code' contains 'Y' axis +-- | True if 'Code' contains 'Y' axis hasY :: Code -> Bool hasY = hasAxis Y --- |True if 'Code' contains 'Z' axis +-- | True if 'Code' contains 'Z' axis hasZ :: Code -> Bool hasZ = hasAxis Z --- |True if 'Code' contains 'E' axis +-- | True if 'Code' contains 'E' axis hasE :: Code -> Bool hasE = hasAxis E --- |True if 'Code' contains parameter with 'ParamDesignator' +-- | True if 'Code' contains parameter with 'ParamDesignator' hasParam :: ParamDesignator -> Code -> Bool hasParam p Code{..} = M.member p codeParams -hasParam a _ = False +hasParam _ _ = False +-- | Get parameter if defined getParam :: ParamDesignator -> Code -> Maybe Double getParam p Code{..} = M.lookup p codeParams +getParam _ _ = Nothing --- |True if 'Code' contains feedrate parameter (e.g. G0 F3000) +-- | True if 'Code' contains feedrate parameter (e.g. G0 F3000) hasFeedrate :: Code -> Bool hasFeedrate = hasParam F --- |Filter G-codes +-- | Filter G-codes gcodes :: [Code] -> [Code] gcodes = filter isG --- |Filter M-codes +-- | Filter M-codes mcodes :: [Code] -> [Code] mcodes = filter isM --- |Filter rapid moves +-- | Filter rapid moves rapids :: [Code] -> [Code] rapids = filter isRapid --- |Filter moves +-- | Filter moves moves :: [Code] -> [Code] moves = filter isMove --- |Replace 'Class' of 'Code' (e.g. for chaning G0 to M0) +-- | Replace 'Class' of 'Code' (e.g. for chaning G0 to M0) replaceClass :: Class -> Code -> Code -replaceClass newclass c = appmod (cls newclass) c +replaceClass newclass c = cls newclass c --- |Replace code value of 'Code' (e.g. for chaning G0 to G1) +-- | Replace code value of 'Code' (e.g. for chaning G0 to G1) replaceCode :: Int -> Code -> Code -replaceCode newcode c = appmod (num newcode) c +replaceCode newcode c = num newcode c --- |Replace axis with 'AxisDesignator' in 'Code' returning new 'Code' +-- | Replace axis with 'AxisDesignator' in 'Code' returning new 'Code' replaceAxis :: AxisDesignator -> Double -> Code -> Code -replaceAxis de val c@Code{..} | hasAxis de c = addReplaceAxis de val c +replaceAxis de val c | hasAxis de c = addReplaceAxis de val c replaceAxis _ _ c = c +-- | Apply function to axis specified by 'AxisDesignator' modifyAxis :: AxisDesignator -> (Double -> Double) -> Code -> Code -modifyAxis de f c@Code{..} | hasAxis de c = addReplaceAxis de (f $ fromJust $ getAxis de c) c +modifyAxis de f c | hasAxis de c = addReplaceAxis de (f $ fromJust $ getAxis de c) c modifyAxis _ _ c = c +-- | Apply function to axes specified by '[AxisDesignator]' modifyAxes :: [AxisDesignator] -> (Double -> Double) -> Code -> Code -modifyAxes axes f c = foldl (\c1 ax -> modifyAxis ax f c1) c axes +modifyAxes axes' f c = foldl (\c1 ax -> modifyAxis ax f c1) c axes' +-- | Test if Code has X and Y axes +hasXY :: Code -> Bool hasXY c = hasAxis X c && hasAxis Y c +-- | Apply function to X and Y axes modifyXY :: (Double -> Double -> (Double, Double)) -> Code -> Code modifyXY f c | hasXY c = let x = fromJust $ getAxis X c y = fromJust $ getAxis Y c (nx, ny) = f x y - in appmod (axis' X nx <> axis' Y ny) c + in c & axis X nx & axis Y ny modifyXY _ c = c --- |Replace or add axis with 'AxisDesignator' in 'Code' returning new 'Code' +-- | Replace or add axis with 'AxisDesignator' in 'Code' returning new 'Code' addReplaceAxis :: AxisDesignator -> Double -> Code -> Code -addReplaceAxis de val c@Code{..} = appmod (axes $ newaxes $ codeAxes) c +addReplaceAxis de val c@Code{..} = c & (axes $ newaxes $ codeAxes) where newaxes = M.insert de val addReplaceAxis _ _ x = x --- |Replace X axis coordnate +-- | Replace X axis coordnate replaceX :: Double -> Code -> Code replaceX = replaceAxis X --- |Replace Y axis coordinate +-- | Replace Y axis coordinate replaceY :: Double -> Code -> Code replaceY = replaceAxis Y --- |Replace Z axis coordinate +-- | Replace Z axis coordinate replaceZ :: Double -> Code -> Code replaceZ = replaceAxis Z --- |Replace E axis coordinate +-- | Replace E axis coordinate replaceE :: Double -> Code -> Code replaceE = replaceAxis E --- |Replace or add X axis coordinate +-- | Replace or add X axis coordinate addReplaceX :: Double -> Code -> Code addReplaceX = addReplaceAxis X --- |Replace or add Y axis coordinate +-- | Replace or add Y axis coordinate addReplaceY :: Double -> Code -> Code addReplaceY = addReplaceAxis Y --- |Replace or add Z axis coordinate +-- | Replace or add Z axis coordinate addReplaceZ :: Double -> Code -> Code addReplaceZ = addReplaceAxis Z --- |Replace or add E axis coordinate +-- | Replace or add E axis coordinate addReplaceE :: Double -> Code -> Code addReplaceE = addReplaceAxis E - --- |Replace parameter with 'ParamDesignator' in 'Code' returning new 'Code' +-- | Replace parameter with 'ParamDesignator' in 'Code' returning new 'Code' replaceParam :: ParamDesignator -> Double -> Code -> Code -replaceParam de val c@Code{..} | hasParam de c = addReplaceParam de val c +replaceParam de val c | hasParam de c = addReplaceParam de val c replaceParam _ _ c = c +-- | Apply function to parameter with 'ParamDesignator' modifyParam :: ParamDesignator -> (Double -> Double) -> Code -> Code -modifyParam de f c@Code{..} | hasParam de c = addReplaceParam de (f $ fromJust $ getParam de c) c +modifyParam de f c | hasParam de c = addReplaceParam de (f $ fromJust $ getParam de c) c modifyParam _ _ c = c --- |Replace or add parameter with 'ParamDesignator' in 'Code' returning new 'Code' +-- | Apply function to parameters specified by '[ParamDesignator]' +modifyParams :: [ParamDesignator] -> (Double -> Double) -> Code -> Code +modifyParams params' f c = foldl (\c1 ax -> modifyParam ax f c1) c params' + +-- | Apply function to parameters specified by '[ParamDesignator]' +-- +-- Function gets 'ParameterDesignator' passed as its first argument +modifyParamsWithKey :: [ParamDesignator] -> (ParamDesignator -> Double -> Double) -> Code -> Code +modifyParamsWithKey params' f c = foldl (\c1 ax -> modifyParam ax (f ax) c1) c params' + +-- | Replace or add parameter with 'ParamDesignator' in 'Code' returning new 'Code' addReplaceParam :: ParamDesignator -> Double -> Code -> Code -addReplaceParam de val c@Code{..} = appmod (params $ newparams $ codeParams) c +addReplaceParam de val c@Code{..} = c & (params $ newparams $ codeParams) where newparams = M.insert de val addReplaceParam _ _ x = x --- |Replace feedrate (F parameter) in 'Code' returning new 'Code' +-- | Replace feedrate (F parameter) in 'Code' returning new 'Code' replaceFeedrate :: Double -> Code -> Code replaceFeedrate = replaceParam F +-- | Apply function to feedrate modifyFeedrate :: (Double -> Double) -> Code -> Code modifyFeedrate = modifyParam F --- |Sum of all axis distances of this 'Code' -travel :: Code -> Double -travel Code{codeCls=(Just G), ..} = M.foldl (+) 0 codeAxes -travel _ = 0 - --- |Test if 'Code' belongs to group g -inGroup c g = any (\x -> x c) g - --- |Test if 'Code' belongs to any group -known c = any (\x -> inGroup c x) groups - ---updateModals current c = trace (show $ zipWith (,) current $ map (\x -> inGroup c x) groups) $ zipWith maybeUpdate current $ map (\x -> inGroup c x) groups --- where --- maybeUpdate Nothing True = trace ("new modal" ++ show c) $ Just c --- maybeUpdate (Just old) True = trace ("change modal" ++ show (appendAxes c old)) $ Just (appendAxes c old) --- maybeUpdate old False = trace ("no match" ++ show old) $ old --- -updateModals current c = zipWith maybeUpdate current $ map (\x -> inGroup c x) groups - where - maybeUpdate Nothing True = Just c - maybeUpdate (Just old) True = Just (appendAxes c old) - maybeUpdate old False = old - -appendAxes cto cfrom = appmod (axes $ appendOnlyAxes (codeAxes cto) (codeAxes cfrom)) cto - -incomplete Code{codeCls=Nothing, ..} = True -incomplete Code{codeNum=Nothing, ..} = True -incomplete _ = False - -totalize :: GCode -> GCode -totalize = totalize' emptyGroups - where - totalize' inEffect [] = [] - totalize' inEffect (x:rest) = (updateFromEffect inEffect x):(totalize' (updateModals inEffect x) rest) - - -type Evaluator a = State [Maybe Code] a - -totalizer :: GCode -> Evaluator GCode -totalizer [] = return $ [] -totalizer (x:xs) = do - trace ("x " ++ show x) $ return () - cs <- get - let nx = updateFromEffect cs x - - modify' (flip updateModals $ nx) - - --trace ("cs " ++ show cs) $ return () - --trace ("nx " ++ show nx) $ return () - rest <- totalizer xs - - return $ (nx:rest) - -totalize' c = runState (totalizer c) emptyGroups - ---totalizeTrace' c = do --- (a, b) <- runState (totalizer c) emptyGroups --- return $ (a, b) - -updateFromEffect inEffect x = do - case (!!) inEffect 0 of -- motion group - Nothing -> x - (Just e) -> appmod ( - (cls $ fromJust $ codeCls e) - <> (num $ fromJust $ codeNum e) - <> (axes $ appendOnlyAxes (codeAxes x) (codeAxes e)) - ) x - -updateFromEffect _ x | otherwise = x - -updateIncompleteFromEffect inEffect x | incomplete x = do - case (!!) inEffect 0 of -- motion group - Nothing -> x - (Just e) -> appmod ( - (cls $ fromJust $ codeCls e) - <> (num $ fromJust $ codeNum e) - <> (axes $ appendOnlyAxes (codeAxes x) (codeAxes e)) - ) x - -updateIncompleteFromEffect _ x | otherwise = x - -emptyGroups = map (pure Nothing) groups - --- update axes that aren't defined in target -appendOnlyAxes target from = M.union target missingOnly - where missingOnly = M.difference from target - -rot by x y = (x * (cos by) - y * (sin by), y * (cos by) + x * (sin by)) +-- | Sum of all axis distances of this 'Code' +travelDistance :: Code -> Double +travelDistance Code{codeCls=(Just G), ..} = M.foldl (+) 0 codeAxes +travelDistance _ = 0 +-- | Round `x` with specified precision +roundprec :: (Integral a, RealFrac b, Fractional c) => a -> b -> c roundprec n x = (fromInteger $ round $ x * (10^n)) / (10.0^^n) - -updateLimitsCode :: Limits -> Code -> Limits -updateLimitsCode s Code{..} = updateLimits s codeAxes -updateLimitsCode s _ = s - -updateLimits :: Limits -> Axes -> Limits -updateLimits s = M.foldlWithKey adj s - where - adj limits ax val = M.alter (alterfn val) ax limits - alterfn val (Just (min_c, max_c)) = Just (min min_c val, max max_c val) - alterfn val Nothing = Just (val, val) diff --git a/test/EvalSpec.hs b/test/EvalSpec.hs new file mode 100644 --- /dev/null +++ b/test/EvalSpec.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE OverloadedStrings #-} + +module EvalSpec where + +import SpecHelper + +import Data.GCode.Generate +import Data.GCode.RS274 +import Data.GCode.Eval + + +shouldEvalEqually a b = (ipModalGroups . snd . eval $ a) `shouldBe` (ipModalGroups . snd . eval $ b) +shouldTotalizeEqually a b = (totalize a) `shouldBe` b + +spec :: Spec +spec = do + context "eval" $ do + it "replaces move commands" $ do + shouldEvalEqually [ move & xy 6 1 , rapid & xy 0 0 ] + [ rapid & xy 0 0 ] + + it "updates moves correctly" $ do + shouldEvalEqually [ move & xyz 6 1 2 , rapid & xy 0 0 ] + [ rapid & xyz 0 0 2] + + it "handles incompletes correctly" $ do + shouldEvalEqually [ move & xyz 6 1 2 , emptyCode & xy 0 0 ] + [ move & xyz 0 0 2] + + it "handles inches" $ do + shouldEvalEqually [ inches, move & xyz 0 0 1, move & xy 1 1 ] + [ move & xyz 25.4 25.4 25.4, inches ] + + it "handles feedrate in inches" $ do + shouldEvalEqually [ inches, move & xyz 0 0 1, move & xy 1 1 & feed 10 ] + [ move & xyz 25.4 25.4 25.4 & feed 254, inches ] + + it "handles relative moves" $ do + shouldEvalEqually [ relative, move & xyz 1 1 1, move & xy 2 3 ] + [ move & xyz 3 4 1, relative ] + + it "handles relative arcs" $ do + shouldEvalEqually [ arcRelative, move & xyz 1 1 1, arc & xy 10 10 & ij 5 5 ] + [ arc & xyz 10 10 1 & ij 6 6, arcRelative ] + + it "handles combined relative/absolute moves" $ do + shouldEvalEqually [ relative, move & xyz 10 15 19, absolute, move & z 20 ] + [ move & xyz 10 15 20 ] + + context "totalize" $ do + it "totalizes simple moves" $ do + shouldTotalizeEqually [ move & x 0 , move & y 1, move & z 2 ] + [ move & x 0, move & xy 0 1, move & xyz 0 1 2 ] + + it "totalizes incomplete moves" $ do + shouldTotalizeEqually [ move & x 0 , emptyCode & y 1, emptyCode & z 2 ] + [ move & x 0, move & xy 0 1, move & xyz 0 1 2 ] + + it "totalizes mixed moves/rapids" $ do + shouldTotalizeEqually [ spindleCW, move & x 0 , rapid & y 1, move & z 2 ] + [ spindleCW, move & x 0, rapid & xy 0 1, move & xyz 0 1 2 ] + + context "updateAxes" $ do + it "updates axes correctly" $ do + let from = codeAxes $ move & y 1 & z 2 + to = codeAxes $ move & x 0 + (updateAxes from to) `shouldBe` (codeAxes $ move & xyz 0 1 2) diff --git a/test/GenSpec.hs b/test/GenSpec.hs new file mode 100644 --- /dev/null +++ b/test/GenSpec.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedStrings #-} + +module GenSpec where + +import SpecHelper + +import Data.GCode.Generate +import Data.GCode.RS274 + +spec :: Spec +spec = do + it "moves" $ do + pp [ move & xyz 1 2 3 ] `shouldBe` "G1 X1.00 Y2.00 Z3.00\n" + + it "rapids" $ do + pp [ rapid & xy 13.37 48 ] `shouldBe` "G0 X13.37 Y48.00\n" + + it "mcodes" $ do + pp [ m <#> 5, m <#> 9, m <#> 2 ] `shouldBe` "M5\nM9\nM2\n" + + it "params" $ do + pp [ g <#> 4 & param P 10 ] `shouldBe` "G4 P10.00\n" + + it "subcodes" $ do + pp [ g <#> 5 & sub 2 ] `shouldBe` "G5.2\n" diff --git a/test/ParseSpec.hs b/test/ParseSpec.hs new file mode 100644 --- /dev/null +++ b/test/ParseSpec.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} + +module ParseSpec where + +import SpecHelper + +import qualified Data.ByteString.Char8 as BSC + +spec :: Spec +spec = do + let roundTrip n = (fmap pp $ parseOnly parseGCode n) `shouldBe` (Right (BSC.unpack n)) + it "roundtrips" $ do + roundTrip "M3\n" + + roundTrip "M117 L180.00 S8640.00\n" + + roundTrip "G0 X1.00 Y2.00 Z3.33\nM114\n" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs new file mode 100644 --- /dev/null +++ b/test/SpecHelper.hs @@ -0,0 +1,16 @@ +module SpecHelper + ( module Test.Hspec + , module Data.GCode + , parseOnly + , fromString + , pp + ) where + +import Test.Hspec +import Data.Attoparsec.ByteString (parseOnly) +import Data.GCode +import Data.GCode.Parse +import Data.GCode.Pretty +import Data.String (fromString) + +pp = ppGCodeStyle $ defaultStyle { stylePrecision = 2 }