;; REALIZE supports converting LINE, CIRCLE, POLYLINE and POINT entities to
;; RS-274 GCODE for use with EMC.  
;; 
;; The layer of the drawing entity determines the drill or mill
;; description.  Entities on layer 0 are ignored.
;; 
;; The x and y work in the obvious way.  The z dimension determines the
;; cutting depth.  Therefore the z of all entities NOT on layer 0 must be
;; negative.
;; 
;; All cuts made with a particular tool are made in least-depth-first
;; order.
;; 
;; Tools are used in decreasing alphabetic order, so if you have paths on
;; layers named 250-MILL and 125-MILL, it will ask for the 1/4" before
;; the 1/8".
;; 
;; A text of the form "vfeed: [real number]" or "hfeed: [real number]" on
;; a tool layer will set the vertical/horizontal feed for that tool.
;; 
;; A text of the form "dwell: [real number]" on a drill layer will set
;; the dwell at the bottom of the drill cycle.
;; 
;; REALIZE is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by the
;; Free Software Foundation; either version 2 of the License, or (at your
;; option) any later version.  REALIZE is distributed in the hope that it
;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See
;; the GNU General Public License for more details.  You should have
;; received a copy of the GNU General Public License along with REALIZE; if
;; not, write to the Free Software Foundation, Inc., 59 Temple Place,
;; Suite 330, Boston, MA 02111-1307 USA
;; 
;; REALIZE is Copyright © 2005,2006,2007 Chris Radek
;; chris@timeguy.com


(defun preamble ()
  (write-line "G64\nG17 G20 G40 G49\nG54 G80 G90 G94" ofp))

(defun tool-change (layername description)
  (write-line (strcat 
               "M5\nG00 Z1.0000\n(INSERT " 
               description 
               " "
               layername
               ")\nM00\nS1000 M3\nG04 P3") ofp)

  (setq vfeed (get-value layername "vfeed:" 8.0))
  (princ (strcat "\nVertical feed for " layername 
                 " is " (rtos vfeed lunits 2)))
  (if (/= description "DRILL")
      (progn
        (setq hfeed (get-value layername "hfeed:" 8.0))
        (princ (strcat "\nHorizontal feed for " layername 
                       " is " (rtos hfeed lunits 2))))))

(defun sanity-check (/ sane ent etype z layer)
  (setq sane t)
  (foreach ent sslist
           (setq etype (cdr (assoc 0 ent)))
           (if (or (= etype "POLYLINE") (= etype "POINT") (= etype "LINE")) 
               (progn
                 (if (= etype "POLYLINE") 
                     (setq z (cadddr (assoc 10 (entget (entnext (cdr (assoc -1 ent)))))))
                   (setq z (cadddr (assoc 10 ent))))
                 (setq layer (cdr (assoc 8 ent)))
                 (if (and (/= layer "0") (>= z 0.0)) 
                     (progn
                       (princ (strcat "\n" etype " entity at z>=0.  Aborting."))
                       (princ)
                       (princ ent)
                       (princ (entget (entnext (cdr (assoc -1 ent)))))
                       (setq sane nil))))))
  sane)

(defun drill-holes-of-layer (s / ent etype layer x y z dwell)
  (setq dwell (get-value s "dwell:" 0.2))
  (write-line (strcat "G00 Z" (rtos sh lunits 4)) ofp)
  (foreach ent sslist
           (setq etype (cdr (assoc 0 ent)))
           (if (= etype "POINT") 
               (progn
                 (setq layer (cdr (assoc 8 ent)))
                 (if (= layer s) (progn
                                   (setq x (cadr (assoc 10 ent)))
                                   (setq y (caddr (assoc 10 ent)))
                                   (setq z (cadddr (assoc 10 ent)))
                                   (drill-point x y z dwell)))))))

(defun cut-line (ent / begin end)
  ;; pocketing with HATCH works better if the direction alternates,
  ;; since the parallel lines all go in the same direction.
  (setq cut-line-backward (not cut-line-backward))
  (if cut-line-backward
      (setq begin (assoc 10 ent) end (assoc 11 ent))
    (setq begin (assoc 11 ent) end (assoc 10 ent)))
  (start-cut (cadr begin) (caddr begin) (cadddr begin))
  (cut-to (cadr end) (caddr end) 0))
		
(defun cut-circle (ent / x y z rad)
  (setq   x (cadr (assoc 10 ent)) 
          y (caddr (assoc 10 ent))
          z (cadddr (assoc 10 ent))
          rad (cdr (assoc 40 ent)))
  (setq y (+ y rad))
  (write-line (strcat "G00 Z" (rtos sh lunits 4)) ofp)
  (write-line 
   (strcat "G00 X" (rtos x lunits 4) 
           " Y" (rtos y lunits 4)) ofp)
  (write-line 
   (strcat "G01 Z" (rtos z lunits 4) 
           " F" (rtos vfeed lunits 2)) ofp)
  (write-line
   (strcat "G03 X" (rtos x lunits 4) 
           " Y" (rtos y lunits 4)
           " I0 J-" (rtos rad lunits 4)
           " F" (rtos hfeed lunits 2)) ofp)
  (setq prev-x x prev-y y))

(defun cut-pline (ent / down close-pt ent x y z bulge last-bulge)
  (setq down nil)
  (setq last-bulge 0.0)
  (if (= (boole 1 (cdr (assoc 70 ent)) 1) 1)
      (setq close-pt (cdr (assoc 10 (entget (entnext (cdr (assoc -1 ent)))))))
    (setq close-pt nil))
  (while (and (setq ent (entget (entnext (cdr (assoc -1 ent)))))
              (= (cdr (assoc 0 ent)) "VERTEX"))
    (setq x (cadr (assoc 10 ent)))
    (setq y (caddr (assoc 10 ent)))
    (setq z (cadddr (assoc 10 ent)))
    (setq bulge (cdr (assoc 42 ent)))
    (if down
        (cut-to x y last-bulge)
      (start-cut x y z))
    (setq down t last-bulge bulge))
  (if close-pt (cut-to (car close-pt) (cadr close-pt) last-bulge)))
		

(defun cut-plines-of-layer (s / ent etype layer)
  (foreach ent sslist
           (setq etype (cdr (assoc 0 ent)))
           (if (= etype "POLYLINE") (progn
                                     (setq layer (cdr (assoc 8 ent)))
                                     (if (= layer s)
                                         (cut-pline ent))))))

(defun cut-lines-of-layer (s / ent etype layer)
  (foreach ent sslist
           (setq etype (cdr (assoc 0 ent)))
           (if (= etype "LINE") (progn
                                 (setq layer (cdr (assoc 8 ent)))
                                 (if (= layer s)
                                     (cut-line ent))))))

(defun cut-circles-of-layer (s / ent etype layer)
  (foreach ent sslist
           (setq etype (cdr (assoc 0 ent)))
           (if (= etype "CIRCLE") (progn
                                   (setq layer (cdr (assoc 8 ent)))
                                   (if (= layer s)
                                       (cut-circle ent))))))

(defun get-value (layer key default / value keylen)
  (setq value default)
  (setq keylen (strlen key))
  (foreach ent sslist
           (if 	(and (= layer (cdr (assoc 8 ent)))
                     (= "TEXT" (cdr (assoc 0 ent)))
                     (= key (substr (cdr (assoc 1 ent)) 1 keylen)))
               (setq value (substr (cdr (assoc 1 ent)) (1+ keylen)))))
  (if (numberp value) value (atof value)))

(defun get-drills (/ ent etype layer)
  (princ "\nSearching for drills...")
  (setq drills ())
  (foreach ent sslist
           (setq etype (cdr (assoc 0 ent)))
           (if (= etype "POINT") 
               (progn
                 (setq layer (cdr (assoc 8 ent)))
                 (if (and (/= layer "0") (not (member layer drills)))
                     (setq drills (cons layer drills)))))))

(defun get-mills (/ ent etype layer)
  (princ "\nSearching for mills...")
  (setq mills ())
  (foreach ent sslist
           (setq etype (cdr (assoc 0 ent)))
           (if (or (= etype "POLYLINE") 
                   (= etype "LINE") 
                   (= etype "CIRCLE")) (progn
                   (setq layer (cdr (assoc 8 ent)))
                   (if (and (/= layer "0") (not (member layer mills)))
                       (setq mills (cons layer mills)))))))

(defun init-depths ()
  (initget 6)                           ; not zero or neg
  (setq sh (getdist "\nSafety Height <0.02>: "))
  (cond ((null sh) (setq sh 0.02))))

(defun init-output ()
  (setq of (getstring "\nOutput file <H:\\ACAD.NGC>: "))
  (cond ((eq "" of) (setq of "h:\\acad.ngc"))))

;; G82 R0.040000 Z-0.080000 P200 X1.925000 Y0.687500
(defun drill-point (x y depth dwell)
  (write-line (strcat 
               "G82 R"
               (rtos sh lunits 4)
               " Z"
               (rtos depth lunits 4)
               " P"
               (rtos dwell lunits 2) 
               " X"
               (rtos x lunits 4)
               " Y"
               (rtos y lunits 4)
               " F"
               (rtos vfeed lunits 2)) ofp))

(defun start-cut (x y depth)
  (write-line (strcat "G00 Z" (rtos sh lunits 4)) ofp)
  (write-line (strcat "G00 X" (rtos x lunits 4) 
                      " Y"    (rtos y lunits 4))  ofp)
  (write-line (strcat "G01 Z" (rtos depth lunits 4)
                      " F" (rtos vfeed lunits 2)) ofp)
  (setq prev-x x prev-y y))

(defun cut-to (x y bulge / cot cx cy rad arcdir i j)
  (if (/= 0.0 bulge)
      (progn
        (setq 
         cot (* 0.5 (- (/ 1.0 bulge) bulge))
         cx (/ (- (+ prev-x x) (* (- y prev-y) cot)) 2.0)
         cy (/ (+ (+ prev-y y) (* (- x prev-x) cot)) 2.0)
         rad (distance (list prev-x prev-y) (list cx cy))
         arcdir (if (< bulge 0.0) "G02" "G03")
         i (- cx prev-x) j (- cy prev-y))
        (write-line (strcat arcdir 
                            " X" (rtos x lunits 4)
                            " Y" (rtos y lunits 4) 
                            " I" (rtos i lunits 4) 
                            " J" (rtos j lunits 4)
                            " F" (rtos hfeed lunits 2)) ofp))
    (write-line (strcat "G01 X" (rtos x lunits 4) 
			" Y" (rtos y lunits 4)
			" F" (rtos hfeed lunits 2))  ofp))
  (setq prev-x x prev-y y))

(defun finish ()
  (write-line "G00 Z1.0000\nM02" ofp)
  (close ofp))

(defun compare-entity-height (a b)
  (> (cadddr (assoc 10 a)) (cadddr (assoc 10 b))))

(defun ins-sort (L cmp / M N O)
  (setq O L L (list (car O)))
  (while (setq M nil N L O (cdr O))
    (while (and O N (apply cmp (list (car N) (car O))))
      (setq M (append M (list (car N))) N (cdr N)))
    (setq N (cons (car O) N) L (append M N))) L)

(defun myerror (s)                      ; If an error (such as CTRL-C) occurs
                                        ; while this command is active...
  (if (/= s "Function cancelled")
      (princ (strcat "\nError: " s))
    )
  (setvar "cmdecho" ocmd)               ; Restore saved modes
  (setvar "blipmode" oblp)
  (setq *error* olderr)                 ; Restore old *error* handler
  (princ))

(defun C:REALIZE (/ olderr ocmd oblp ss i) 
  (setq olderr  *error*
	*error* myerror)
  (setq ocmd (getvar "cmdecho"))
  (setq oblp (getvar "blipmode"))
  (setvar "cmdecho" 0)

  (setq lunits (getvar "lunits"))
  (init-depths)
  (init-output)

  (setq ss (ssget))
  (princ "\nGetting selection...")
  (setq sslist ())
  (setq i 0)
  (repeat (sslength ss)
          (setq sslist (cons (entget (ssname ss i)) sslist))
          (setq i (1+ i)))

  (princ "\nSorting selection...")
  (setq sslist (ins-sort sslist 'compare-entity-height))

  (if (sanity-check) 
      (progn
        (setq ofp (open of "w"))
        (preamble)
        (get-drills)
        (if drills (progn
                     (setq drills (ins-sort drills '>))
                     (princ "\nDrills: ")
                     (princ drills)
                     (setq d drills)
                     (tool-change (car d) "DRILL")
                     (drill-holes-of-layer (car d))
                     (while (setq d (cdr d)) 
                       (tool-change (car d) "DRILL")
                       (drill-holes-of-layer (car d)))))

        (get-mills)
        (if mills (progn
                    (setq mills (ins-sort mills '>))
                    (princ "\nMills: ")
                    (princ mills)
                    (setq c mills)
                    (tool-change (car c) "MILL")
                    (cut-plines-of-layer (car c))
                    (cut-lines-of-layer (car c))
                    (cut-circles-of-layer (car c))
                    (while (setq c (cdr c)) 
                      (tool-change (car c) "MILL")
                      (cut-plines-of-layer (car c))
                      (cut-lines-of-layer (car c))
                      (cut-circles-of-layer (car c)))))

        (finish)))

  (setvar "cmdecho" ocmd)
  (setvar "blipmode" oblp)
  (setq *error* olderr)                 ; Restore old *error* handler
  (princ))