{-# 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
isG :: Code -> Bool
isG Code{codeCls=(Just G), ..} = True
isG _ = False
isM :: Code -> Bool
isM Code{codeCls=(Just M), ..} = True
isM _ = False
isGN :: Int -> Code -> Bool
isGN n Code{codeCls=(Just G), codeNum=(Just x), ..} = x == n
isGN _ _ = False
isGNs n sub Code{codeCls=(Just G), codeNum=(Just x), codeSub=(Just sx), ..} = x == n && sx == sub
isGNs _ _ _ = False
isMN :: Int -> Code -> Bool
isMN n Code{codeCls=(Just M), codeNum=(Just x), ..} = x == n
isMN _ _ = False
isMNs n sub Code{codeCls=(Just M), codeNum=(Just x), codeSub=(Just sx), ..} = x == n && sx == sub
isMNs _ _ _ = False
isG0 :: Code -> Bool
isG0 = isGN 0
isRapid :: Code -> Bool
isRapid = isG0
isG1 :: Code -> Bool
isG1 = isGN 1
isMove :: Code -> Bool
isMove = isG1
isG2 :: Code -> Bool
isG2 = isGN 2
isArcCW :: Code -> Bool
isArcCW = isG2
isG3 :: Code -> Bool
isG3 = isGN 3
isArcCCW :: Code -> Bool
isArcCCW = isG3
isG4 :: Code -> Bool
isG4 = isGN 4
isDwell :: Code -> Bool
isDwell = isG4
isG5 :: Code -> Bool
isG5 = isGN 5
isCubicSpline :: Code -> Bool
isCubicSpline = isG5
isG5s1 :: Code -> Bool
isG5s1 = isGNs 5 1
isQuadSpline :: Code -> Bool
isQuadSpline = isG5s1
isG5s2 :: Code -> Bool
isG5s2 = isGNs 5 2
isNURBS :: Code -> Bool
isNURBS = isG5s2
isXYZplane :: Code -> Bool
isXYZplane = isGN 17
isXZYplane :: Code -> Bool
isXZYplane = isGN 18
isYZXplane :: Code -> Bool
isYZXplane = isGN 19
groupPlane = [ isXYZplane, isXZYplane, isYZXplane ]
isInch :: Code -> Bool
isInch = isGN 20
isMM :: Code -> Bool
isMM = isGN 21
groupUnits = [ isInch, isMM ]
isG33 :: Code -> Bool
isG33 = isGN 33
isSpindleSync :: Code -> Bool
isSpindleSync = isG33
isG33s1 :: Code -> Bool
isG33s1 = isGNs 33 1
isRigidTap :: Code -> Bool
isRigidTap = isG33s1
isG38 :: Code -> Bool
isG38 = isGN 38
isProbe :: Code -> Bool
isProbe = isG38
groupMotion = [isMove, isRapid, isArcCW, isArcCCW,
isCubicSpline, isQuadSpline, isNURBS, isProbe, isSpindleSync, isRigidTap]
isDrillingCycleCB :: Code -> Bool
isDrillingCycleCB = isGN 73
isThreadingCycle :: Code -> Bool
isThreadingCycle = isGN 76
isDrillingCycleCancel :: Code -> Bool
isDrillingCycleCancel = isGN 80
isDrillingCycle :: Code -> Bool
isDrillingCycle = isGN 81
isDrillingCycleDwell :: Code -> Bool
isDrillingCycleDwell = isGN 82
isDrillingCyclePeck :: Code -> Bool
isDrillingCyclePeck = isGN 83
isBoringCycle :: Code -> Bool
isBoringCycle = isGN 85
isBoringCycleDwell :: Code -> Bool
isBoringCycleDwell = isGN 89
groupCycles = [isDrillingCycle, isDrillingCycleCB, isDrillingCyclePeck,
isDrillingCycleDwell, isDrillingCycleCancel,
isThreadingCycle,
isBoringCycle, isBoringCycleDwell ]
isAbsolute :: Code -> Bool
isAbsolute = isGN 90
isRelative :: Code -> Bool
isRelative = isGN 91
isArcAbsolute :: Code -> Bool
isArcAbsolute = isGNs 90 1
isArcRelative :: Code -> Bool
isArcRelative = isGNs 91 1
isLatheDiameter :: Code -> Bool
isLatheDiameter = isGN 7
isLatheRadius :: Code -> Bool
isLatheRadius = isGN 8
groupDistance = [ isAbsolute, isRelative,
isArcAbsolute, isArcRelative, isLatheDiameter, isLatheRadius ]
isInverseTime :: Code -> Bool
isInverseTime = isGN 93
isUnitsPerMinute :: Code -> Bool
isUnitsPerMinute = isGN 94
isUnitsPerRevolution :: Code -> Bool
isUnitsPerRevolution = isGN 95
groupFeedRateMode = [ isInverseTime, isUnitsPerMinute, isUnitsPerRevolution ]
isSpindleCW :: Code -> Bool
isSpindleCW = isMN 3
isSpindleCCW :: Code -> Bool
isSpindleCCW = isMN 4
isSpindleStop :: Code -> Bool
isSpindleStop = isMN 5
groupSpindleControl = [ isSpindleCW, isSpindleCCW, isSpindleStop,
isMN 19, isGN 96, isGN 97]
isCoolantMist :: Code -> Bool
isCoolantMist = isMN 7
isCoolantFlood :: Code -> Bool
isCoolantFlood = isMN 8
isCoolantStop :: Code -> Bool
isCoolantStop = isMN 9
groupCoolantControl = [ isCoolantMist, isCoolantFlood, isCoolantStop ]
isToolLength :: Code -> Bool
isToolLength = isGN 43
isToolLengthDynamic :: Code -> Bool
isToolLengthDynamic = isGNs 43 1
isToolLengthAdd :: Code -> Bool
isToolLengthAdd = isGNs 43 2
isToolLengthCancel :: Code -> Bool
isToolLengthCancel = isGN 49
groupToolLengthOffset = [ isToolLength, isToolLengthDynamic,
isToolLengthAdd, isToolLengthCancel ]
isPause :: Code -> Bool
isPause = isMN 0
isOptionalPause :: Code -> Bool
isOptionalPause = isMN 1
isEnd :: Code -> Bool
isEnd = isMN 2
isExchange :: Code -> Bool
isExchange = isMN 30
groupStopping = [ isPause, isOptionalPause, isEnd, isExchange, isMN 60 ]
groups = [ groupMotion, groupCycles, groupDistance, groupFeedRateMode,
groupSpindleControl, groupCoolantControl, groupStopping, groupUnits,
groupPlane ]
hasAxis :: AxisDesignator -> Code -> Bool
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 _ = []
hasX :: Code -> Bool
hasX = hasAxis X
hasY :: Code -> Bool
hasY = hasAxis Y
hasZ :: Code -> Bool
hasZ = hasAxis Z
hasE :: Code -> Bool
hasE = hasAxis E
hasParam :: ParamDesignator -> Code -> Bool
hasParam p Code{..} = M.member p codeParams
hasParam a _ = False
getParam :: ParamDesignator -> Code -> Maybe Double
getParam p Code{..} = M.lookup p codeParams
hasFeedrate :: Code -> Bool
hasFeedrate = hasParam F
gcodes :: [Code] -> [Code]
gcodes = filter isG
mcodes :: [Code] -> [Code]
mcodes = filter isM
rapids :: [Code] -> [Code]
rapids = filter isRapid
moves :: [Code] -> [Code]
moves = filter isMove
replaceClass :: Class -> Code -> Code
replaceClass newclass c = appmod (cls newclass) c
replaceCode :: Int -> Code -> Code
replaceCode newcode c = appmod (num newcode) c
replaceAxis :: AxisDesignator -> Double -> Code -> Code
replaceAxis de val c@Code{..} | hasAxis de c = addReplaceAxis de val 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
addReplaceAxis :: AxisDesignator -> Double -> Code -> Code
addReplaceAxis de val c@Code{..} = appmod (axes $ newaxes $ codeAxes) c
where
newaxes = M.insert de val
addReplaceAxis _ _ x = x
replaceX :: Double -> Code -> Code
replaceX = replaceAxis X
replaceY :: Double -> Code -> Code
replaceY = replaceAxis Y
replaceZ :: Double -> Code -> Code
replaceZ = replaceAxis Z
replaceE :: Double -> Code -> Code
replaceE = replaceAxis E
addReplaceX :: Double -> Code -> Code
addReplaceX = addReplaceAxis X
addReplaceY :: Double -> Code -> Code
addReplaceY = addReplaceAxis Y
addReplaceZ :: Double -> Code -> Code
addReplaceZ = addReplaceAxis Z
addReplaceE :: Double -> Code -> Code
addReplaceE = addReplaceAxis E
replaceParam :: ParamDesignator -> Double -> Code -> Code
replaceParam de val c@Code{..} | hasParam de c = addReplaceParam de val 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
addReplaceParam :: ParamDesignator -> Double -> Code -> Code
addReplaceParam de val c@Code{..} = appmod (params $ newparams $ codeParams) c
where
newparams = M.insert de val
addReplaceParam _ _ x = x
replaceFeedrate :: Double -> Code -> Code
replaceFeedrate = replaceParam F
modifyFeedrate :: (Double -> Double) -> Code -> Code
modifyFeedrate = modifyParam F
travel :: Code -> Double
travel Code{codeCls=(Just G), ..} = M.foldl (+) 0 codeAxes
travel _ = 0
inGroup c g = any (\x -> x c) g
known c = any (\x -> inGroup c x) groups
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)
rest <- totalizer xs
return $ (nx:rest)
totalize' c = runState (totalizer c) emptyGroups
updateFromEffect inEffect x = do
case (!!) inEffect 0 of
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
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
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)