gcodehs 0.1.0.0 → 0.1.1.0
raw patch · 6 files changed
+605/−111 lines, 6 filesdep +arraydep +double-conversiondep +mtldep −aesondep −formattingdep −pipes-aeson
Dependencies added: array, double-conversion, mtl, pipes-text, vty
Dependencies removed: aeson, formatting, pipes-aeson
Files
- app/Main.hs +6/−15
- gcodehs.cabal +11/−6
- src/Data/GCode/Parse.hs +15/−7
- src/Data/GCode/Pretty.hs +52/−24
- src/Data/GCode/Types.hs +95/−41
- src/Data/GCode/Utils.hs +426/−18
app/Main.hs view
@@ -14,10 +14,9 @@ import qualified Pipes.ByteString as B --import Pipes.ByteString.MMap import Pipes.Safe-import Pipes.Aeson.Unchecked (encode) import qualified System.IO as IO -import Data.Aeson (decode)+import Data.Monoid ((<>)) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as BL @@ -27,7 +26,6 @@ data Flags = Flags { input :: FilePath , output :: FilePath- , json :: Bool , pretty :: Bool , analyze :: Bool } deriving (Show)@@ -41,7 +39,6 @@ flags = Flags <$> strOption ( long "input" <> short 'i' <> metavar "INPUT") <*> strOption ( long "output" <> short 'o' <> metavar "OUTPUT" <> value "")- <*> switch ( long "json" <> short 'j' <> help "JSON output") <*> switch ( long "pretty" <> short 'p' <> help "Pretty output") <*> switch ( long "analyze" <> short 'a' <> help "Analyze GCode") @@ -60,9 +57,9 @@ r <- foldedpipe input analyzefold print r else case output of- "" -> gcodepipe input $ fmt json pretty >-> B.stdout+ "" -> gcodepipe input $ fmt pretty >-> B.stdout _ -> IO.withFile output IO.WriteMode $ \outhandle ->- gcodepipe input $ fmt json pretty >-> B.toHandle outhandle+ gcodepipe input $ fmt pretty >-> B.toHandle outhandle bufsize = 1024 @@ -80,20 +77,14 @@ fold (() <$ parseProducer handle) analyzefold = P.fold step 0 id- where step x a = x + travel a+ 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 -fmt True _ = for Pipes.cat encode-fmt False True = P.map ppGCodeLine >-> P.map (BS.pack . (++"\n"))-fmt False False = P.map ppGCodeLineCompact >-> P.map (BS.pack . (++"\n"))---- doesn't work, probably due to bad FromJSON for maps-readjsonmain = do- f <- BL.readFile "a.json"- print (decode f :: Maybe GCode)+fmt True = P.map ppGCodeLine >-> P.map (BS.pack . (++"\n"))+fmt False = P.map ppGCodeLineCompact >-> P.map (BS.pack . (++"\n")) -- mmaped version, requires pipes-bytestring-mmap --main' = do
gcodehs.cabal view
@@ -1,12 +1,12 @@ name: gcodehs-version: 0.1.0.0+version: 0.1.1.0 synopsis: GCode processor description: GCode parser, pretty-printer and processing utils homepage: https://github.com/hackerspace/gcodehs license: BSD3 license-file: LICENSE author: Richard Marko-maintainer: rmarko@base48.cz+maintainer: srk@48.io copyright: 2016 Richard Marko category: Parsing build-type: Simple@@ -17,13 +17,18 @@ hs-source-dirs: src exposed-modules: Data.GCode, Data.GCode.Types, Data.GCode.Parse, Data.GCode.Pretty, Data.GCode.Utils build-depends: base >= 4.7 && < 5- , aeson , attoparsec , ansi-wl-pprint , bytestring , containers+ , double-conversion , text- , formatting+ , pipes+ , pipes-attoparsec+ , pipes-bytestring+ , mtl+ , vty+ , array default-language: Haskell2010 executable gcodehs@@ -31,18 +36,18 @@ main-is: Main.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base- , aeson , attoparsec , bytestring+ , double-conversion , gcodehs , text , pipes- , pipes-aeson , pipes-attoparsec , pipes-bytestring -- , pipes-bytestring-mmap , pipes-safe , pipes-parse+ , pipes-text , optparse-applicative default-language: Haskell2010
src/Data/GCode/Parse.hs view
@@ -27,7 +27,7 @@ parseOnlyGCode = parseOnly parseGCode -lskip = skipWhile (inClass " \t")+lskip = skipWhile (\x -> x == ' ' || x == '\t') between open close p = do{ open; x <- p; close; return x } isEndOfLineChr :: Char -> Bool@@ -36,16 +36,19 @@ isEndOfLineChr _ = False parseLead = do- a <- satisfy $ inClass "GMTPFS"+ a <- satisfy $ (\c -> c == 'G' || c == 'M' || c == 'T' || c == 'P' || c == 'F' || c == 'S') return $ codecls a+{-# INLINE parseLead #-} parseAxisDes = do- a <- satisfy $ inClass "XYZABCEL"+ a <- satisfy $ (\c -> c == 'X' || c == 'Y' || c == 'Z' || c == 'A' || c == 'B' || c == 'C' || c == 'E' || c == 'L') return $ axis a+{-# INLINE parseAxisDes #-} parseParamDes = do a <- satisfy $ inClass "SPF" return $ param a+{-# INLINE parseParamDes #-} parseParamOrAxis = do lskip@@ -65,16 +68,21 @@ parseAxesParams = do a <- many parseParamOrAxis return (M.fromList $ lefts a, M.fromList $ rights a)+{-# INLINE parseAxesParams #-} + parseCode = do- lead <- parseLead- gcode <- decimal- subcode <- option 0 (Just <$> char '.' *> decimal)+ lead <- optional parseLead+ gcode <- optional decimal+ subcode <- optional (char '.' *> decimal) lskip (axes, params) <- parseAxesParams lskip comment <- option "" $ between lskip lskip parseComment'- return $ Code lead gcode subcode axes params comment+ let c = Code lead gcode subcode axes params comment+ if c == emptyCode+ then return $ Empty+ else return c parseComment' = do t <- many $ between (lskip *> char '(') (char ')' <* lskip) $ takeWhile1 (/=')')
src/Data/GCode/Pretty.hs view
@@ -12,32 +12,55 @@ import Data.ByteString.Char8 (pack, unpack) import qualified Data.Text as T import qualified Data.Map.Strict as M-import Formatting (sformat)-import Formatting.ShortFormatters+import Data.Maybe import Text.PrettyPrint.ANSI.Leijen import Data.GCode.Types+import Data.GCode.Utils +import Data.Double.Conversion.Text+ -- |Pretty-print 'GCode' using colors ppGCode :: GCode -> String-ppGCode res = displayS (renderPretty 0.4 80 (ppGCode' res)) ""+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)) ""+ -- |Pretty-print single 'Code' using colors ppGCodeLine :: Code -> String-ppGCodeLine res = displayS (renderPretty 0.4 80 (ppCode res)) ""+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)) ""+ -- |Pretty-print 'GCode' without colors ppGCodeCompact :: GCode -> String-ppGCodeCompact res = displayS (renderCompact (ppGCode' res)) ""+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)) ""+ -- |Pretty-print single 'Code' without colors ppGCodeLineCompact :: Code -> String-ppGCodeLineCompact res = displayS (renderCompact (ppCode res)) ""+ppGCodeLineCompact = ppGCodeLineCompactStyle defaultStyle +-- |Pretty-print single 'Code' without colors with custom floating precision width+ppGCodeLineCompactStyle :: Style -> Code -> String+ppGCodeLineCompactStyle style res = displayS (renderCompact (ppCode style res)) ""+ ppList pp x = hsep $ map pp x -ppGCode' = vsep . map ppCode+ppGCode' style = vsep . map (ppCode style) +ppMaybe pp (Just x) = pp x+ppMaybe pp Nothing = empty++ppMaybeClass = ppMaybe ppClass+ ppClass G = yellow $ text "G" ppClass M = red $ text "M" ppClass T = magenta $ text "T"@@ -45,15 +68,18 @@ ppClass StF = red $ text "F" ppClass StS = red $ text "S" ---codecolor Code{..} = cc cls code+ccMaybes (Just cls) (Just num) = cc cls num+ccMaybes _ _ = id+ cc G 0 = dullyellow cc G 1 = yellow cc _ _ = red -ppAxis (des, val) =+ppAxis style (des, val) = bold (axisColor des $ text $ show des)- <> cyan (text $ T.unpack $ sformat sf val)+ <> cyan (text $ T.unpack $ toPrecision (stylePrecision style) val) + axisColor X = red axisColor Y = green axisColor Z = yellow@@ -62,26 +88,28 @@ axisColor C = blue axisColor E = magenta -ppAxes [] = empty-ppAxes x = space <> ppList ppAxis x+ppAxes _ [] = empty+ppAxes style x = space <> ppList (ppAxis style) x -ppParam (des, val) =+ppParam style (des, val) = bold (blue $ text $ show des)- <> white (text $ T.unpack $ sformat sf val)+ <> white (text $ T.unpack $ toPrecision (stylePrecision style) val) -ppParams [] = empty-ppParams x = space <> ppList ppParam x+ppParams _ [] = empty+ppParams style x = space <> ppList (ppParam style) x ppComment "" = empty ppComment c = space <> ppComment' c ppComment' "" = empty ppComment' c = dullwhite $ parens $ text $ unpack c -ppCode Code{..} =- cc cls code ( bold $ ppClass cls)- <> cc cls code ( text $ show code)- <> ppAxes (M.toList axes)- <> ppParams (M.toList params)- <> ppComment comment-ppCode (Comment x) = ppComment' x-ppCode (Other x) = dullred $ text $ unpack x+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)+ <> ppComment codeComment+ppCode _ (Comment x) = ppComment' x+ppCode _ (Other x) = dullred $ text $ unpack x+ppCode _ (Empty) = empty+{-# INLINE ppCode #-}
src/Data/GCode/Types.hs view
@@ -6,28 +6,49 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DeriveGeneric #-} module Data.GCode.Types ( Class(..) , AxisDesignator(..) , ParamDesignator(..) , Axes , Params+ , Limits+ , ParamLimits , Code(..) , GCode , codecls , 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 Data.Aeson-import GHC.Generics+--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 ++ -- | Code class data Class = G -- ^ G-code@@ -36,7 +57,7 @@ | StP -- ^ Stand-alone P-code | StF -- ^ Stand-alone F-code | StS -- ^ Stand-alone S-code- deriving (Generic, Show, Enum, Eq, Ord)+ deriving (Show, Enum, Eq, Ord) -- | Axis letter data AxisDesignator =@@ -48,14 +69,15 @@ | C -- ^ C-axis | E -- ^ Extruder axis | L- deriving (Generic, Show, Enum, Eq, Ord)+ deriving (Show, Enum, Eq, Ord) -- | Param letter data ParamDesignator = S -- ^ S parameter - usually spindle RPM | P -- ^ P parameter- | F -- ^ S parameter - usually feedrate- deriving (Generic, Show, Enum, Eq, Ord)+ | F -- ^ F parameter - usually feedrate+ | R -- ^ R parameter+ deriving (Show, Enum, Eq, Ord) -- |Convert 'Char' representation of a code to its 'Class' codecls :: Char -> Class@@ -82,58 +104,90 @@ param 'S' = S param 'P' = P param 'F' = F+param 'R' = R -- | Map of 'AxisDesignator' to 'Double' type Axes = M.Map AxisDesignator Double +type Limits = M.Map AxisDesignator (Double, Double)+ -- | Map of 'ParamDesignator' to 'Double' type Params = M.Map ParamDesignator Double +type ParamLimits = M.Map ParamDesignator (Double, Double)+ -- | List of 'Code's type GCode = [Code] data Code = Code {- cls :: Class -- ^ Code 'Class' (M in M5)- , code :: Int -- ^ Code value (81 in G81)- , sub :: Int -- ^ Code subcode (1 in G92.1)- , axes :: Axes -- ^ Code 'Axes'- , params :: Params -- ^ Code 'Params'- , comment :: B.ByteString -- ^ Comment following this 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)+ , codeAxes :: Axes -- ^ Code 'Axes'+ , codeParams :: Params -- ^ Code 'Params'+ , codeComment :: B.ByteString -- ^ Comment following this Code } | Comment B.ByteString -- ^ Standalone comment- | Other B.ByteString -- ^ Parser unhandled lines (should contain blank lines only)- deriving (Generic, Show, Eq, Ord)+ | Empty -- ^ Empty lines+ | Other B.ByteString -- ^ Parser unhandled lines+ deriving (Show, Eq, Ord) -instance ToJSON ParamDesignator-instance FromJSON ParamDesignator-instance ToJSON Class-instance ToJSON AxisDesignator-instance FromJSON AxisDesignator-instance FromJSON Class-instance ToJSON Code-instance FromJSON Code+newtype CodeMod = CodeMod+ { applyCodeMod :: Code -> Code } -instance ToJSON v => ToJSON (M.Map ParamDesignator v) where- toJSON = toJSON . M.mapKeys show+instance Monoid CodeMod where+ mempty = CodeMod id+ mappend = (<>) -instance FromJSON v => FromJSON (M.Map ParamDesignator v) where- parseJSON v = convert <$> parseJSON v- where convert :: M.Map T.Text v -> M.Map ParamDesignator v- convert = M.fromList . map (\(x,y) -> (param $ T.head x,y)) . M.toList+instance Semigroup CodeMod where+ m1 <> m2 = CodeMod $ applyCodeMod m1 . applyCodeMod m2 -instance ToJSON v => ToJSON (M.Map AxisDesignator v) where- toJSON = toJSON . M.mapKeys show+cls :: Class -> CodeMod+cls x = CodeMod $ \c -> c { codeCls = Just x} -instance FromJSON v => FromJSON (M.Map AxisDesignator v) where- parseJSON v = convert <$> parseJSON v- where convert :: M.Map T.Text v -> M.Map AxisDesignator v- convert = M.fromList . map (\(x,y) -> (axis $ T.head x,y)) . M.toList+num :: Int -> CodeMod+num x = CodeMod $ \c -> c { codeNum = Just x} -instance ToJSON B.ByteString where- toJSON = String . TE.decodeUtf8- {-# INLINE toJSON #-}+sub :: Int -> CodeMod+sub x = CodeMod $ \c -> c { codeSub = Just x} -instance FromJSON B.ByteString where- parseJSON = withText "ByteString" $ pure . TE.encodeUtf8- {-# INLINE parseJSON #-}+axes :: Axes -> CodeMod+axes x = CodeMod $ \c -> c { codeAxes = x}++axis' :: AxisDesignator -> Double -> CodeMod+axis' des val = CodeMod $ \c -> c { codeAxes = M.insert des val $ codeAxes c }++params :: Params -> CodeMod+params x = CodeMod $ \c -> c { codeParams = x}++param' :: ParamDesignator -> Double -> CodeMod+param' des val = CodeMod $ \c -> c { codeParams = M.insert des val $ codeParams c }++comment :: B.ByteString -> CodeMod+comment x = CodeMod $ \c -> c { codeComment = x}++appmod :: CodeMod -> Code -> Code+appmod m c = applyCodeMod m c++--data Sim = Empty+-- | Line Axes Axes+-- deriving (Show, Eq)++--eval c1 c2 = Line (codeAxes c1) (codeAxes c2)+eval = undefined++emptyCode = Code Nothing Nothing Nothing M.empty M.empty ""++++data Style =+ Style {+ stylePrecision :: Int+ , styleColorful :: Bool+ } deriving (Show)++defaultPrec :: Int+defaultPrec = 6++defaultStyle = Style defaultPrec False
src/Data/GCode/Utils.hs view
@@ -4,21 +4,47 @@ -} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE BangPatterns #-} module Data.GCode.Utils where +import Debug.Trace+import Data.Maybe+import Data.Monoid+ import Data.GCode.Types import qualified Data.Map.Strict as M +import Control.Monad.State.Strict+import Control.Applicative+ -- |True if 'Code' is a G-code isG :: Code -> Bool-isG Code{cls=G, ..} = True+isG Code{codeCls=(Just G), ..} = True isG _ = False +-- |True if 'Code' is a M-code+isM :: Code -> Bool+isM Code{codeCls=(Just M), ..} = True+isM _ = False+ -- |True if 'Code' is a G{N} code isGN :: Int -> Code -> Bool-isGN n Code{cls=G, code=x, ..} | x == n = True+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@@ -35,16 +61,275 @@ isMove :: Code -> Bool isMove = isG1 --- |True if 'Code' is a M-code-isM :: Code -> Bool-isM Code{cls=M, ..} = True-isM _ = False+-- |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' hasAxis :: AxisDesignator -> Code -> Bool-hasAxis a Code{..} = M.member a axes+hasAxis a Code{..} = M.member a codeAxes hasAxis a _ = 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 _ _ = []++getAxesToList :: Code -> [(AxisDesignator, Double)]+getAxesToList Code{..} = M.toList codeAxes+getAxesToList _ = []++--filterAxes :: [AxisDesignator] -> Code -> [Double]+--filterAxes ax Code{..} = map (\a -> M.lookup a codeAxes) ax+ -- |True if 'Code' contains 'X' axis hasX :: Code -> Bool hasX = hasAxis X@@ -63,9 +348,12 @@ -- |True if 'Code' contains parameter with 'ParamDesignator' hasParam :: ParamDesignator -> Code -> Bool-hasParam p Code{..} = M.member p params+hasParam p Code{..} = M.member p codeParams hasParam a _ = False +getParam :: ParamDesignator -> Code -> Maybe Double+getParam p Code{..} = M.lookup p codeParams+ -- |True if 'Code' contains feedrate parameter (e.g. G0 F3000) hasFeedrate :: Code -> Bool hasFeedrate = hasParam F@@ -88,27 +376,42 @@ -- |Replace 'Class' of 'Code' (e.g. for chaning G0 to M0) replaceClass :: Class -> Code -> Code-replaceClass newclass Code{..} = Code newclass code sub axes params comment-replaceClass _ x = x+replaceClass newclass c = appmod (cls newclass) c -- |Replace code value of 'Code' (e.g. for chaning G0 to G1) replaceCode :: Int -> Code -> Code-replaceCode newcode Code{..} = Code cls newcode sub axes params comment-replaceCode _ x = x+replaceCode newcode c = appmod (num newcode) c -- |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 _ _ c@Code{..} = c+replaceAxis _ _ c = c +modifyAxis :: AxisDesignator -> (Double -> Double) -> Code -> Code+modifyAxis de f c@Code{..} | hasAxis de c = addReplaceAxis de (f $ fromJust $ getAxis de c) c+modifyAxis _ _ c = c++modifyAxes :: [AxisDesignator] -> (Double -> Double) -> Code -> Code+modifyAxes axes f c = foldl (\c1 ax -> modifyAxis ax f c1) c axes++hasXY c = hasAxis X c && hasAxis Y c++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+modifyXY _ c = c+ -- |Replace or add axis with 'AxisDesignator' in 'Code' returning new 'Code' addReplaceAxis :: AxisDesignator -> Double -> Code -> Code-addReplaceAxis de val Code{..} = Code cls code sub (newaxes axes) params comment+addReplaceAxis de val c@Code{..} = appmod (axes $ newaxes $ codeAxes) c where newaxes = M.insert de val addReplaceAxis _ _ x = x --- |Replace X axis coordinate+-- |Replace X axis coordnate replaceX :: Double -> Code -> Code replaceX = replaceAxis X @@ -140,14 +443,19 @@ addReplaceE :: Double -> Code -> Code addReplaceE = addReplaceAxis E + -- |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 _ _ c@Code{..} = c+replaceParam _ _ c = c +modifyParam :: ParamDesignator -> (Double -> Double) -> Code -> Code+modifyParam de f c@Code{..} | 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' addReplaceParam :: ParamDesignator -> Double -> Code -> Code-addReplaceParam de val Code{..} = Code cls code sub axes (newparams params) comment+addReplaceParam de val c@Code{..} = appmod (params $ newparams $ codeParams) c where newparams = M.insert de val addReplaceParam _ _ x = x@@ -156,7 +464,107 @@ replaceFeedrate :: Double -> Code -> Code replaceFeedrate = replaceParam F +modifyFeedrate :: (Double -> Double) -> Code -> Code+modifyFeedrate = modifyParam F+ -- |Sum of all axis distances of this 'Code' travel :: Code -> Double-travel Code{cls=G, ..} = M.foldl (+) 0 axes+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))++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)