;=======================================================================
;    ExtPFace.Lsp                                    Jun 14, 2003
;    Extrude a Coplaner PFACEE Mesh
;================== Start Program ======================================
(princ "\nCopyright (C) 2003, Fabricated Designs, Inc.")
(princ "\nLoading ExtPFace v1.0 ")
(setq epf_ nil lsp_file "ExtPFace")

;================== Macros =============================================
(defun PDot ()(princ "."))

(PDot);++++++++++++ Set Modes & Error ++++++++++++++++++++++++++++++++++
(defun epf_smd ()
 (SetUndo)
 (setq olderr *error*
      *error* (lambda (e)
                (while (> (getvar "CMDACTIVE") 0)
                       (command))
                (and (/= e "quit / exit abort")
                     (princ (strcat "\nError: *** " e " *** ")))
                (command "_.UNDO" "_END" "_.U")
                (epf_rmd))
       epf_var '(("CMDECHO"   . 0) ("MENUECHO"   . 0)
                ("MENUCTL"   . 0) ("MACROTRACE" . 0)
                ("OSMODE"    . 0) ("SORTENTS"   . 119)
                ("MODEMACRO" . ".")
                ("BLIPMODE"  . 0) ("EXPERT"     . 0)
                ("SNAPMODE"  . 1) ("PLINEWID"   . 0)
                ("ORTHOMODE" . 1) ("GRIDMODE"   . 0)
                ("ELEVATION" . 0) ("THICKNESS"  . 0)
                ("FILEDIA"   . 0) ("FILLMODE"   . 0)
                ("SPLFRAME"  . 0) ("UNITMODE"   . 0)
                ("TEXTEVAL"  . 0) ("ATTDIA"     . 0)
                ("AFLAGS"    . 0) ("ATTREQ"     . 1)
                ("ATTMODE"   . 1) ("UCSICON"    . 1)
                ("HIGHLIGHT" . 1) ("REGENMODE"  . 1)
                ("COORDS"    . 2) ("DRAGMODE"   . 2)
                ("DIMZIN"    . 1) ("PDMODE"     . 0)
                ("CECOLOR"   . "BYLAYER")
                ("CELTYPE"   . "BYLAYER")))
 (foreach v epf_var
      (setq epf_rst (cons (cons (car v) (getvar (car v))) epf_rst))
      (setvar (car v) (cdr v)))
 (princ (strcat (getvar "PLATFORM") " Release " (ver)
        " -  Extrude CoPlaner PFACE Mesh ....\n"))
 (princ))

(PDot);++++++++++++ Return Modes & Error +++++++++++++++++++++++++++++++
(defun epf_rmd ()
  (setq *error* olderr)
  (foreach v epf_rst (setvar (car v) (cdr v)))
  (command "_.UNDO" "_END")
  (prin1))

(PDot);++++++++++++ Set And Start An Undo Group ++++++++++++++++++++++++
(defun SetUndo ()
 (and (zerop (getvar "UNDOCTL"))
      (command "_.UNDO" "_ALL"))
 (and (= (logand (getvar "UNDOCTL") 2) 2)
      (command "_.UNDO" "_CONTROL" "_ALL"))
 (and (= (logand (getvar "UNDOCTL") 8) 8)
      (command "_.UNDO" "_END"))
 (command "_.UNDO" "_GROUP"))

(PDot);++++++++++++ 3DFACE Set To PFACE Mesh +++++++++++++++++++++++++++
  (defun fa2pf (ss / slen i ed en ef vlist vlen tlist)
  (and (/= (type ss) 'PICKSET)
       (princ "*** Invalid Parameter To FA2PF *** ")
       (exit))
  (princ "\nDetermining Vertex Data\n")
  (setq slen (sslength ss)
           i 0)
  (repeat slen
      (setq en (ssname ss i)
            ed (entget en)
             i (1+ i))
       (and (/= (cdr (assoc 0 ed)) "3DFACE")
            (princ "\n*** 3DFACES Only *** ")
            (exit))
       (foreach g '(10 11 12 13)
              (if (not (member (cdr (assoc g ed)) vlist))
                  (setq vlist (cons (cdr (assoc g ed)) vlist))))
       (princ (strcat "\r" (rtos (/ (* 100 i) slen) 2 0) "% ")))
  (princ "\nDetermining Face Data\n")
  (setq vlen (length vlist))
  (entmake (list (cons 0 "POLYLINE")
                 (cons 10 (list 0 0 0))
                 (cons 66 1)
                 (cons 70 64)
                 (cons 71 vlen)
                 (cons 72 slen)
                 (cons 73 0)(cons 74 0)(cons 75 0)
                 (cons 210 (list 0 0 1))))
  (foreach v vlist
     (entmake (list (cons 0 "VERTEX")
                    (cons 10 (trans v 1 0))
                    (cons 70 192)
                    (cons 71 0)(cons 72 0)(cons 73 0)(cons 74 0))))
  (setq i 0)
  (repeat slen
    (setq en (ssname ss i)
          ed (entget en)
          ef (cdr (assoc 70 ed))
           i (1+ i)
       tlist nil)
    (foreach c '(1 2 3 4)
      (setq tlist (cons
        (cons (+ 70 c)
              (* (if (= (logand ef (expt 2 (1- c))) (expt 2 (1- c))) -1 1)
                 (1+ (- vlen (length (member (cdr (assoc (+ 9 c) ed)) vlist))))))
            tlist)))
    (entmake (list (cons 0 "VERTEX")
                   (assoc 8 ed)
                   (cons 10 (last vlist))
                   (if (assoc 62 ed)
                       (assoc 62 ed)
                       (cons 62 256))
                   (cons 70 128)
                   (nth 0 tlist)
                   (nth 1 tlist)
                   (nth 2 tlist)
                   (nth 3 tlist)))
     (princ (strcat "\r" (rtos (/ (* 100 i) slen) 2 0) "% ")))
  (entmake (list (cons 0 "SEQEND")))
  (command "_.ERASE" ss "")
  (redraw (entlast)))

(PDot);++++++++++++ Add Axis Extrusion To Point Value ++++++++++++++++++
(defun epf_add_axis (p a e)
  (cond ((= a "X")
         (list (+ (car p) e)
               (cadr p)
               (caddr p)))
        ((= a "Y")
         (list (car p)
               (+ (cadr p) e)
               (caddr p)))
        ((= a "Z")
         (list (car p)
               (cadr p)
               (+ (caddr p) e)))))

(PDot);************ Main Program ***************************************
(defun epf_ (/ olderr epf_var epf_rst ss pl pd ly pp pf pl pt lp
              f1 f2 f3 f4 fl flg flg1 flg2 flg3 flg4 fe fs axis ext)
  (epf_smd)

;;;GET PFACE MESH
  (while (or (not ss)
             (> (sslength ss) 1))
         (princ "\nSelect A PFACE Mesh To Extrude")
         (setq ss (ssget '((0 . "POLYLINE")(70 . 64)))))

;;;GET MESH DATA
  (setq pl (ssname ss 0)
        pd (entget pl)
        ly (cdr (assoc 8 pd))
        pp (cdr (assoc 71 pd))
        pf (cdr (assoc 72 pd)))

;;;GET POINT LIST
  (repeat pp
    (setq pl (entnext pl)
          pt (cdr (assoc 10 (entget pl)))
          lp (cons pt lp)))
  (setq lp (reverse lp))

;;;GET FACE LIST
  (repeat pf
    (setq pl (entnext pl)
          f1 (cdr (assoc 71 (entget pl)))
          f2 (cdr (assoc 72 (entget pl)))
          f3 (cdr (assoc 73 (entget pl)))
          f4 (cdr (assoc 74 (entget pl)))
          fl (cons (list f1 f2 f3 f4) fl)))
   (setq fl (reverse fl))

;;;FIND PLANER AXIS
  (cond ((apply '= (mapcar 'car lp))   (setq axis "X"))
        ((apply '= (mapcar 'cadr lp))  (setq axis "Y"))
        ((apply '= (mapcar 'caddr lp)) (setq axis "Z"))
        ((princ "\nPFACE Mesh Must Be COPLANER")
         (exit)))

;;;GET EXTRUSION DISTANCE
  (initget 7)
  (setq ext (getdist "\nExtrusion Distance:   "))

;;;MAKE FACES
  (foreach f fl

;;;SET END PANEL FACE FLAGS
    (setq flg 0)
    (if (minusp (nth 0 f))
        (setq flg (+ flg 1)))
    (if (minusp (nth 1 f))
        (setq flg (+ flg 2)))
    (if (minusp (nth 2 f))
        (setq flg (+ flg 4)))
    (if (minusp (nth 3 f))
        (setq flg (+ flg 8)))

;;;SET EXTRUDED FACE FLAGS
    (setq flg1 0 flg2 0 flg3 0 flg4 0)
    (if (minusp (nth 2 f))
        (setq flg1 (+ flg1 4)))
    (if (minusp (nth 3 f))
        (setq flg1 (+ flg1 1)))
    (if (minusp (nth 3 f))
        (setq flg2 (+ flg2 4)))
    (if (minusp (nth 0 f))
        (setq flg2 (+ flg2 1)))
    (if (minusp (nth 0 f))
        (setq flg3 (+ flg3 4)))
    (if (minusp (nth 1 f))
        (setq flg3 (+ flg3 1)))
    (if (minusp (nth 1 f))
        (setq flg4 (+ flg4 4)))
    (if (minusp (nth 2 f))
        (setq flg4 (+ flg4 1)))

;;;ORIGINAL END FACE
    (entmake (list (cons 0 "3DFACE")
                   (cons 8 ly)
                   (cons 10 (nth (1- (abs (nth 0 f))) lp))
                   (cons 11 (nth (1- (abs (nth 1 f))) lp))
                   (cons 12 (nth (1- (abs (nth 2 f))) lp))
                   (cons 13 (nth (1- (abs (nth 3 f))) lp))
                   (cons 70 flg)))

;;;RECORD FIRST FACE
    (if (not fe)
        (setq fe (entlast)))

;;;EXTRUDED END FACE
    (entmake (list (cons 0 "3DFACE")
                   (cons 8 ly)
                   (cons 10 (epf_add_axis (nth (1- (abs (nth 0 f))) lp) axis ext))
                   (cons 11 (epf_add_axis (nth (1- (abs (nth 1 f))) lp) axis ext))
                   (cons 12 (epf_add_axis (nth (1- (abs (nth 2 f))) lp) axis ext))
                   (cons 13 (epf_add_axis (nth (1- (abs (nth 3 f))) lp) axis ext))
                   (cons 70 flg)))

;;;EXTRUSION FACES
    (and (not (minusp (nth 0 f)))
         (entmake (list (cons 0 "3DFACE")
                        (cons 8 ly)
                        (cons 10 (nth (1- (abs (nth 0 f))) lp))
                        (cons 11 (epf_add_axis (nth (1- (abs (nth 0 f))) lp) axis ext))
                        (cons 12 (epf_add_axis (nth (1- (abs (nth 1 f))) lp) axis ext))
                        (cons 13 (nth (1- (abs (nth 1 f))) lp))
                        (cons 70 flg1))))
    (and (not (minusp (nth 1 f)))
         (entmake (list (cons 0 "3DFACE")
                        (cons 8 ly)
                        (cons 10 (nth (1- (abs (nth 1 f))) lp))
                        (cons 11 (epf_add_axis (nth (1- (abs (nth 1 f))) lp) axis ext))
                        (cons 12 (epf_add_axis (nth (1- (abs (nth 2 f))) lp) axis ext))
                        (cons 13 (nth (1- (abs (nth 2 f))) lp))
                        (cons 70 flg2))))
    (and (not (minusp (nth 2 f)))
         (entmake (list (cons 0 "3DFACE")
                        (cons 8 ly)
                        (cons 10 (nth (1- (abs (nth 2 f))) lp))
                        (cons 11 (epf_add_axis (nth (1- (abs (nth 2 f))) lp) axis ext))
                        (cons 12 (epf_add_axis (nth (1- (abs (nth 3 f))) lp) axis ext))
                        (cons 13 (nth (1- (abs (nth 3 f))) lp))
                        (cons 70 flg3))))
    (and (not (minusp (nth 3 f)))
         (entmake (list (cons 0 "3DFACE")
                        (cons 8 ly)
                        (cons 10 (nth (1- (abs (nth 3 f))) lp))
                        (cons 11 (epf_add_axis (nth (1- (abs (nth 3 f))) lp) axis ext))
                        (cons 12 (epf_add_axis (nth (1- (abs (nth 0 f))) lp) axis ext))
                        (cons 13 (nth (1- (abs (nth 0 f))) lp))
                        (cons 70 flg4)))))

;;;CONVERT FACES TO A MESH
  (setq fs (ssadd))
  (while fe
    (ssadd fe fs)
    (setq fe (entnext fe)))
  (fa2pf fs)

;;;DELETE ORIGINAL MESH AND CLEAN UP
  (entdel (ssname ss 0))
  (redraw)

  (epf_rmd))

(PDot);************ Load Program ***************************************
(defun C:ExtPFace () (epf_))
(if epf_ (princ "\nExtPFace Loaded\n"))
(prin1)
;|================== End Program =======================================