; 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 "peck: [real number]" on a drill layer will set
;; the peck drill increment.
;; 
;; 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 "G17G90" ofp))

(defun tool-change (layername description)
  (write-line (strcat "T" layername "M26;" 
                      (if (/= description "MILL") description "")
                      " "
                      (get-string layername "tool:" "?")) ofp)
  (write-line (strcat "G0G90Z" (rtos sh lunits 4)) ofp)
  (write-line "/M0" ofp)
  (write-line "S1000M3" ofp)

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

(defun sanity-check (/ sane ent type z layer)
  (setq sane t)
  (foreach ent sslist
           (setq type (cdr (assoc 0 ent)))
           (if (or (= type "POLYLINE") (= type "POINT") (= type "LINE")) 
               (progn
                 (if (= type "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" type " 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 type layer x y z peck)
  (setq peck (get-value s "peck:" 0.0))
  (write-line (strcat "G0G90Z" (rtos sh lunits 4)) ofp)
  (foreach ent sslist
           (setq type (cdr (assoc 0 ent)))
           (if (= type "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 peck)))))))

(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 "G0G90Z" (rtos sh lunits 4)) ofp)
  (write-line 
   (strcat "G0X" (rtos x lunits 4) 
           "Y" (rtos y lunits 4)) ofp)
  (write-line 
   (strcat "G1Z" (rtos z lunits 4) 
           "F" (rtos vfeed lunits 1)) ofp)
  (write-line
   (strcat "G3G91X0.Y0.I0.J-" (rtos rad lunits 4)
           "F" (rtos hfeed lunits 1)) 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 type layer)
  (foreach ent sslist
           (setq type (cdr (assoc 0 ent)))
           (if (= type "POLYLINE") (progn
                                     (setq layer (cdr (assoc 8 ent)))
                                     (if (= layer s)
                                         (cut-pline ent))))))

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

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

(defun get-value (layer key default)
  (atof (get-string layer key (rtos default lunits 2))))

(defun get-string (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)))))
  value)
; (if (numberp value) value (atof value)))

(defun get-drills (/ ent type layer)
  (princ "\nSearching for drills...")
  (setq drills ())
  (foreach ent sslist
           (setq type (cdr (assoc 0 ent)))
           (if (= type "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 type layer)
  (princ "\nSearching for mills...")
  (setq mills ())
  (foreach ent sslist
           (setq type (cdr (assoc 0 ent)))
           (if (or (= type "POLYLINE") 
                   (= type "LINE") 
                   (= type "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.125>: "))
  (cond ((null sh) (setq sh 0.125))))

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

;; G82 R0.040000 Z-0.080000 P200 X1.925000 Y0.687500
(defun drill-point (x y depth peck)
  (if (> peck 0.0)
      (write-line (strcat 
                   "G83X" (rtos x lunits 4)
                   "Y" (rtos y lunits 4)
                   "Z" (rtos (+ sh (- 0.0 depth)) lunits 4) ; total depth
                   "Z" (rtos (+ sh peck) lunits 4) ; first peck
                   "Z" (rtos peck lunits 4) ; subsequent pecks
                   "F" (rtos vfeed lunits 1)) ofp)
    (write-line (strcat
                 "G81X" (rtos x lunits 4)
                 "Y" (rtos y lunits 4)
                 "Z" (rtos (+ sh (- 0.0 depth)) lunits 4)
                 "F" (rtos vfeed lunits 1)) ofp)))

(defun start-cut (x y depth)
  (write-line (strcat "G0G90Z" (rtos sh lunits 4)) ofp)
  (write-line (strcat "G0X" (rtos x lunits 4) 
                      "Y"    (rtos y lunits 4))  ofp)
  (write-line (strcat "G1Z" (rtos depth lunits 4)
                      "F" (rtos vfeed lunits 1)) ofp)
  (setq prev-x x prev-y y))

;; arcs in relative mode because emc and boss8 agree how that works
(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) "G2G91" "G3G91")
         i (- cx prev-x) j (- cy prev-y))
        (write-line (strcat arcdir 
                            "X" (rtos (- x prev-x) lunits 4)
                            "Y" (rtos (- y prev-y) lunits 4) 
                            "I" (rtos i lunits 4) 
                            "J" (rtos j lunits 4)
                            "F" (rtos hfeed lunits 1)) ofp))
    (write-line (strcat "G1G90X" (rtos x lunits 4) 
			"Y" (rtos y lunits 4)
			"F" (rtos hfeed lunits 1))  ofp))
  (setq prev-x x prev-y y))

(defun finish ()
  (write-line (strcat "G0G90Z" (rtos sh lunits 4)) ofp)
  (write-line "M2" 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)) 
                       (write-line (strcat "G0G90Z" (rtos sh lunits 4)) ofp)
                       (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)) 
                      (write-line (strcat "G0G90Z" (rtos sh lunits 4)) ofp)
                      (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))