Generate NC files for PRODIA M45

generate_nc.purs

-- Generate NC files for PRODIA M45

module Main where

import Prelude
import Math hiding (log)

import Data.Array
import Data.Monoid
-- import Data.List (foldl)
import Data.Foldable (foldl)
import Control.Monad.Eff
import Control.Monad.Eff.Console
import Node.FS.Sync (writeTextFile,readTextFile	)
import Node.Encoding
import Data.Int (toNumber)
import Data.Maybe
import Data.Maybe.Unsafe (fromJust)
import Data.Foldable
import Number.Format
import Data.JSON
import Data.Generic
import Data.Either
import Data.Tuple
import Data.Date
import Data.Date.Locale (toLocaleString)

data Sgn = Posi | Neg

instance eqSgn :: Eq Sgn where
    eq Posi Neg = false
    eq Posi Posi = true
    eq Neg Neg = true
    eq Neg Posi = false

data FP = FP Int Int Sgn | FPInt Int | FPDouble Number

fp = FPDouble
int = FPInt

max_fp :: FP -> FP -> FP
max_fp (FPDouble a) (FPDouble b) = FPDouble $ max a b

instance showFP :: Show FP where
    show (FP a b s) = (if s == Posi then "" else "-") ++ show a ++ "." ++ show b
    show (FPInt a) = show a
    show (FPDouble v) = fromMaybe "" $ toFixed 3	 v

data Step = G81 FP FP FP FP FP | G80 | G00 FP FP FP
    | G79 | G90 | G49 | G77 Int | S Int | M03 | X FP | Y FP | Z FP | RA FP | RB FP
    | M05 | M09 | M30 | Comment String

instance showStep :: Show Step where
    show (G81 x y z r f) = "G81X"++ show x ++ "Y" ++ show y ++ "Z" ++ show z
            ++ "R" ++ show r ++ "F" ++ show f
    show G80 = "G80"
    show (G00 z x y) = "G00Z" ++ show z ++ "\nX" ++ show x ++ "Y" ++ show y
    show G79 = "G79"
    show G90 = "G90"
    show G49 = "G49"
    show (G77 v) = "G77Q" ++ show v
    show (S v) = "S" ++ show v
    show M03 = "M03"
    show (X v) = "X" ++ show v
    show (Y v) = "Y" ++ show v
    show (Z v) = "Z" ++ show v
    show (RA v) = "A" ++ show v
    show (RB v) = "B" ++ show v
    show M05 = "M05"
    show M09 = "M09"
    show M30 = "M30"
    show (Comment s) = "(" ++ s ++ ")"

newtype Steps = Steps (Array Step)

-- Steps is a monoid, just like a list.
instance monoidSteps :: Monoid Steps where
    mempty = Steps []

instance monoidSemigroup :: Semigroup Steps where
    append (Steps a) (Steps b) = Steps (a++b)

instance showSteps :: Show Steps where
    show (Steps ss) = foldl (\a b -> a++b++"\r\n") "" $ map show ss

type Coord = {x :: FP, y :: FP, z :: FP}

instance semiRingFP :: Semiring FP where
    one = FPDouble 1.0
    mul (FPDouble a) (FPDouble b) = FPDouble (a*b)
    -- mul _ _ = error "Not covered"
    add (FPDouble a) (FPDouble b) = FPDouble (a+b)
    -- add _ _ = error "Not covered"
    zero = FPDouble 0.0

-- |Single point drilling.
drill :: Coord -> Coord -> Steps
drill {x: x,y: y,z: z} {x: x2,y: y2,z: z2} = Steps [G81 x y z (fp 10.0) (int 200),
        G80, G00 (max_fp z2 z + fp 10.0) x y]

-- |Generate a grid from dimension parameters.
mkPos :: Number -> Number -> Int -> Int ->
            Number -> Number -> Number -> Number -> Array Coord
mkPos ox oy nx ny
    pitch_x pitch_y depth tilt =
    let
        x xi = ox + pitch_x * toNumber xi
        y yi = oy + pitch_y * toNumber yi
        z yi = -depth - (tan $ tilt * pi / 180.0) * (y yi)
    in do
        xi <- 0..(nx-1)
        yi <- 0..(ny-1)
        return {x: (fp $ x xi), y:(fp $ y (-yi)), z:(fp $ z (-yi))}

translate :: Coord -> Array Coord -> Array Coord
translate d ps = map f ps
    where
        f p = {x: d.x + p.x, y: d.y + p.y, z: d.z + p.z}

header :: Number -> Coord -> Steps
header deg {x:x,y:y,z:z} = Steps [G79, G90, G49, G77 2000, S 5000, M03, X x, Y y, Z (fp 10.0 + z), RA (fp deg), RB (fp 0.0)]

footer = Steps [M05, M09, M30]

-- |Make a Steps from tilt degree and positions (each position has x,y,z).
process :: Number -> Array Coord -> Steps
process deg ps =
    case head ps of
        Just p -> 
        	let ts = fromJust $ tail (ps++[fromJust $ last ps])
        	in mconcat [header deg p, mconcat $ zipWith drill ps ts, footer]
        Nothing -> Steps []

data Design = Design {output_path :: String, tilt :: Number, sections :: Array Section}

instance designFromJSON :: FromJSON Design where
    parseJSON (JObject o) = do
        path <- o .: "output_path"
        deg <- o .: "tilt"
        secs <- o .: "sections"
        return $ Design {output_path: path, tilt: deg, sections: secs}
    parseJSON _ = fail "Could not parse"

data Section = Section
    {
        originX :: Number,
        originY :: Number,
        pitchX :: Number,
        pitchY :: Number,
        nx :: Int,
        ny :: Int,
        depth :: Number
    }

derive instance genericSection :: Generic Section

instance showSection :: Show Section where
    show = gShow

instance sectionFromJSON :: FromJSON Section where
    parseJSON (JObject o) = do
        px <- o .: "pitchX"
        py <- o .: "pitchY"
        ox <- o .: "originX"
        oy <- o .: "originY"
        nx <- o .: "nx"
        ny <- o .: "ny"
        d <- o .: "depth"
        return $ Section {originX: ox, originY: oy, pitchX: px, pitchY: py, nx: nx, ny: ny, depth: d}
    parseJSON _ = fail "Could not parse"

multiple_depths :: Array Section -> Number -> String -> Steps
multiple_depths ss deg time =
    append (Steps (map Comment comments))
        (process deg $ concat $ map ps ss)
    where
        comments = ["Time: " ++ time,
        			"Input file: " ++ design_path,
        			"Tilt: " ++ fromMaybe "N/A" (toFixed 2 deg),
        			"Sections: " ++ show (length ss)
        			]
        			++ concat (map f $ zip ss (1..length ss))
       	f :: Tuple Section Int -> Array String
       	f (Tuple s@(Section sec) i) = ["Section " ++ show i, show s]
        ps :: Section -> Array Coord
        ps (Section sec) = mkPos sec.originX sec.originY sec.nx sec.ny
                        sec.pitchX sec.pitchY sec.depth deg

design_path = "../20150819/design20150819-10.json"

-- I don't know how to decompose ADT in place... :/
f (Design d) time = multiple_depths d.sections d.tilt time
g (Design d) = d.output_path

main = do
    s <- readTextFile ASCII design_path
    let d = fromMaybe (Design {output_path: "out.txt", tilt: 0.0, sections: []}) (decode s)
    time <- now >>= toLocaleString
    writeTextFile ASCII (g d) $ show $ f d time