;=======================================================================
;    TubePoly.Lsp                               May 30, 1998
;    Extrude Using LINE, ARC, or PLINE Centerline
;================== Start Program ======================================
(princ "\nCopyright (C) 1998, Fabricated Designs, Inc.")
(princ "\nLoading TubePoly v2.7 ")
(setq tp_ nil lsp_file "TubePoly")
;================== Macros =============================================
(defun PDot ()(princ "."))
(defun AtoR (a) (* pi (/ a 180.0)))
(defun RtoA (r) (/ (* r 180.0) pi))
(defun Beep (/ f)
 (and (wcmatch (getvar "PLATFORM") "*DOS*")
      (setq f (open "con" "w"))
      (write-char '7 f)
      (close f)))
(defun Err (e)
           (beep)
           (princ (strcat "\nError: ** " e " ** "))
           (quit))

(PDot);++++++++++++ Set Modes & Error ++++++++++++++++++++++++++++++++++
(defun tp_smd ()
 (SetUndo)
 (setq olderr *error*
      *error* (lambda (e)
                (while (> (getvar "CMDACTIVE") 0)
                       (command))
                (and (/= e "quit / exit abort");Replacement
                     (princ (strcat "\nError: *** " e " *** ")))
                (command "_.UNDO" "_END" "_.U")
                (tp_rmd))
       tp_var '(
  ("CMDECHO"   . 0) ("MENUECHO" . 0) ("MENUCTL"   . 0) ("MACROTRACE" . 0)
  ("OSMODE"    . 0) ("SORTENTS" . 119)("MODEMACRO" . ".")
  ("BLIPMODE"  . 0) ("EXPERT"   . 0) ("SNAPMODE"  . 1) ("PLINEWID"   . 0.0)
  ("ORTHOMODE" . 1) ("GRIDMODE" . 0) ("ELEVATION" . 0) ("THICKNESS"  . 0)
  ("FILEDIA"   . 0) ("FILLMODE" . 0) ("SPLFRAME"  . 0) ("UNITMODE"   . 0)
  ("ATTMODE"   . 1) ("UCSICON"  . 0) ("HIGHLIGHT" . 1) ("REGENMODE"  . 1)
  ("COORDS"    . 2) ("DRAGMODE" . 2) ("DIMZIN"    . 1) ("PDMODE"     . 0)
  ("CECOLOR"   . "BYLAYER") ("CELTYPE" . "BYLAYER")))
 (foreach v tp_var
      (setq m_v (cons (getvar (car v)) m_v)
            m_n (cons (car v) m_n))
      (setvar (car v) (cdr v)))
  (if (not (entnext))
      (err "There Are No Entities To Work With!"))
 (princ (strcat (getvar "PLATFORM") " Release " (ver)
   " -  3D Tubes ....\n"))
 (princ))

(PDot);++++++++++++ Return Modes & Error +++++++++++++++++++++++++++++++
(defun tp_rmd ()
  (command "_.UNDO" "_END")
  (setq *error* olderr)
  (mapcar 'setvar m_n m_v)
  (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);++++++++++++ Get Entity Name ++++++++++++++++++++++++++++++++++++
(defun GetOne (/ st os)
 (setq os (getvar "SNAPMODE") s nil)
 (setvar "SNAPMODE" 0)
 (while (not st)
        (setq st (ssget)))
 (while (> (sslength st) 1)
        (setq st nil)
        (princ "\nOnly 1 At A Time Please\n")
        (while (not st)
               (setq st (ssget))))
 (setvar "SNAPMODE" os)
 (setq s (ssname st 0)))

(PDot);++++++++++++ Profile A Rectangle ++++++++++++++++++++++++++++++++
  (defun tp_rect ()
  (initget 7)
  (setq wid (getdist "\nWidth Of Rectangle Start:   "))
  (initget 6)
  (setq ewid (getdist (strcat "\nWidth Of Rectangle End <" (rtos wid) ">:   ")))
  (if (not ewid) (setq ewid wid))
  (initget 7)
  (setq hgt (getdist "\nHeight Of Rectangle Start:   "))
  (initget 6)
  (setq ehgt (getdist (strcat "\nWidth Of Height End <" (rtos hgt) ">:   ")))
  (if (not ehgt) (setq ehgt hgt))
  (tp_list)
  (setq wic (/ (- ewid wid) (length plist))
        hic (/ (- ehgt hgt) (length plist))
        seg 4))

(PDot);++++++++++++ Get PLINE Profile ++++++++++++++++++++++++++++++++++
(defun tp_shape (/ tmp_list cpt)
  (princ "\nSelect PLINE Profile To Extrude")
  (GetOne)
  (setq ed (entget s))

;  (initget 6)
;  (setq sscl (getreal "\nStarting Scale <1>:  "))
;  (and (not ssl)
;       (setq sscl 1))
;  (initget 6)
;  (setq escl (getreal "\nEnding Scale <1>:  "))
;  (and (not escl)
;       (setq escl 1))
;  (setq sic (/ (- escl sscl) (length plist)))

  (command "_.POINT" '(0 0))
  (setq cucs (cdr (assoc 210 (entget (entlast)))))
  (entdel (entlast))
  (if (not (equal cucs (cdr (assoc 210 (entget s))) 0.0001))
      (err "Not Current UCS"))
  (initget 1)
  (setq cpt (getpoint "\nPath Point Of The Profile:  "))
  (command "_.UCS" "_World")
  (setq flist (findpath s))
  (if (and (= (logand (cdr (assoc 70 (entget s))) 1) 1)
           (not (equal (car flist) (last flist) 0.00001)))
      (setq flist (cons (last flist) flist)))
  (foreach v flist
      (setq tmp_list (cons (list (- (car cpt) (car v))
                                 (- (cadr cpt) (cadr v))
                                 0) tmp_list)))
   (setq flist tmp_list)
   (setq seg (length flist))
   (and (> seg 256)
        (err "Profile Is To Large Or Complex - 256 Vertices Max"))
   (tp_list))

(PDot);++++++++++++ Profile A Polygon ++++++++++++++++++++++++++++++++++
(defun tp_poly ()
  (initget 7)
  (setq rad (getdist "\nRadius Of Polygon Start:   "))
  (initget 6)
  (setq erad (getdist (strcat "\nRadius Of Polygon End <" (rtos rad) ">:   ")))
  (if (not erad) (setq erad rad))
  (initget 7)
  (setq seg (getint "\nNumber Of Segments Around Polygon:   "))
  (and (> seg 256)
       (err "Polygon Is To Large Or Complex - 256 Vertices Max"))
  (and (< seg 2)
       (err "Single Vertex Not Allowed"))
  (setq inc (/ (AtoR 360.0) seg)
          i 0)
  (tp_list)
  (setq ric (/ (- erad rad) (length plist))))

(PDot);++++++++++++ Export Rect Points +++++++++++++++++++++++++++++++++
(defun tp_exf ()
  (setq wid (+ wid wic)
        hgt (+ hgt hic)
      vlist (cons (trans (list 0.0 (* -0.5 wid ys) (* -0.5 hgt zs)) 1 0) vlist)
      vlist (cons (trans (list 0.0 (*  0.5 wid ys) (* -0.5 hgt zs)) 1 0) vlist)
      vlist (cons (trans (list 0.0 (*  0.5 wid ys) (*  0.5 hgt zs)) 1 0) vlist)
      vlist (cons (trans (list 0.0 (* -0.5 wid ys) (*  0.5 hgt zs)) 1 0) vlist)))

(PDot);++++++++++++ Export Regular Shaped Poly Points ++++++++++++++++++
(defun tp_exp ()
  (command "_UCS" "_Z" 90.0 "_.UCS" "_X" -90.0)
  (setq major (* rad ys)
        minor (* rad zs)
           es (/ major minor))
  (if (<= major minor)
      (setq ec 0.0)
      (setq ec (sqrt (- (* es es) 1))))
  (setq ea (angle '(0 0) (list ec 1.0))
       cti 0
       rad (+ rad ric))
  (repeat seg
          (setq na (* cti inc)
               cti (1+ cti)
                np (polar '(0 0) na minor)
                ny (cadr np)
                nz (car (polar '(0 0) ea (* major (cos na))))
                nx (distance (list 0 ny 0) (list (car np) ny nz)))
          (if (and (> na (* 0.5 pi))
                   (< na (* 1.5 pi)))
              (setq nx (* -1 nx)))
          (setq vlist (cons (trans (list nx ny 0) 1 0) vlist))))

(PDot);++++++++++++ Export PLINE Points ++++++++++++++++++++++++++++++++
(defun tp_esh ()
  (setq shlist nil)
  (foreach v flist
    (setq shlist
      (append shlist
        (list (list (* ys (car v))
                    (* zs (cadr v))
                    0)))))
  (command "_UCS" "_X" -90.0 "_.UCS" "_Y" -90.0 "_.UCS" "_Z" 180.0)

  (foreach p shlist
    (setq vlist (cons (trans p 1 0) vlist))))

(PDot);++++++++++++ Middle UCS Of 2 Intersecting Lines +++++++++++++++++
(defun miducs (pt1 origin pt2)
 (if (not ta) (setq ta 0.0))

 (command "_.UCS" "_3Point" origin pt2 (polar origin (+ (/ pi 2.0) (angle origin pt2)) 1.0))

 (setq tpt (trans pt1 0 1))

 (cond ((zerop (cadr tpt)) (setq ha 0.0 ys 1.0))
       ((minusp (cadr tpt))
        (setq ha (* -0.5 (- pi (angle '(0 0) tpt))))
        (command "_.UCS" "_Z" (RtoA ha)))
       ((setq ha (* 0.5 (- (angle '(0 0) tpt) pi)))
        (command "_.UCS" "_Z" (RtoA ha))))
 (cond ((zerop (caddr tpt)) (setq za 0.0 zs 1.0))
       ((minusp (caddr tpt))
        (setq za (+ (/ pi 2.0) (* -0.5 (angle '(0 0) (list (car tpt) (caddr tpt))))))
        (command "_.UCS" "_Y" (RtoA za)))
       ((setq za (+ (/ pi 2.0) (* -0.5 (angle '(0 0) (list (car tpt) (caddr tpt))))))
        (command "_.UCS" "_Y" (RtoA za))))
  (setq ys (abs (/ 1.0 (cos ha)))
        zs (abs (/ 1.0 (cos za)))))

(PDot);++++++++++++ Get PLINE Vertex List ++++++++++++++++++++++++++++++
(defun tp_list (/ tmp_list)
  (princ "\nSelect Centerline")
  (GetOne)
  (if (and cucs
          (not (equal (cdr (assoc 210 (entget s))) cucs 0.0001)))
      (progn
        (princ "\nProfile And Center Line Are Not Same UCS - Strange Results")
        (initget "Yes No")
        (if (/= "Yes" (getkword "\nContinue? <N>:  "))
            (exit))))
  (if (or (= (cdr (assoc 0 (entget s))) "LINE")
          (= (cdr (assoc 0 (entget s))) "ARC"))
      (progn
        (command "_.UCS" "_E" s
                 "_.PEDIT" s "_Yes" "_Exit"
                 "_.UCS" "_Prev")
        (setq s (entlast))))
  (setq plist (findpath s))
  (if (or (equal (car plist) (last plist))
          (= (logand (cdr (assoc 70 (entget s))) 1) 1))
      (setq closed T))
  (foreach v plist
     (setq tmp_list (cons (trans v s 0) tmp_list)))
  (setq plist tmp_list)
  (and (> (length plist) 256)
       (err "Center Line Is To Large Or Complex - 256 Vertices Max")))

(PDot);++++++++++++ FINDPATH +++++++++++++++++++++++++++++++++++++++++++
;;;Returns ECS Point Values Of PLINE
(defun findpath (en / pl ed sp_flg cl_flg bf nl i vp bf vf pl_flg)
  (setq ed (entget en))
  (and (/= "POLYLINE" (cdr (assoc 0 ed)))
       (princ "\nUnable To Find The Path For This Entity ")
       (exit))
  (setq pl_flg (cdr (assoc 70 ed)))
  (and (= (logand pl_flg 1) 1)
       (setq cl_flg T))
  (and (= (logand pl_flg 4) 4)
       (setq sp_flg T))
  (and (or (= (logand pl_flg 16) 16)
           (= (logand pl_flg 64) 64))
       (princ "\nInvalid POLYLINE Mesh ")
       (exit))
  (while (/= "SEQEND" (cdr (assoc 0 (entget (entnext en)))))
         (setq en (entnext en)
               ed (entget en)
               vp (cdr (assoc 10 ed))
               bf (cdr (assoc 42 ed))
               vf (cdr (assoc 70 ed)))
         (cond ((= "SEQEND" (cdr (assoc 0 (entget (entnext en)))))
                (setq pl (cons vp pl)))
               ((and (/= bf 0.0)
                     (/= "SEQEND" (cdr (assoc 0 (entget (entnext en))))))
                (add_arc vp (cdr (assoc 10 (entget (entnext en)))) bf))
               ((and (/= bf 0.0)
                     cl_flg
                     (= "SEQEND" (cdr (assoc 0 (entget (entnext en))))))
                (add_arc vp (last pl) bf))
               ((and (= bf 1.0)
                     (not cl_flg)
                     (= "SEQEND" (cdr (assoc 0 (entget (entnext en))))))
                (princ))
               ((and sp_flg
                     (= bf 0.0)
                     (= (logand vf 8) 8))
                (setq pl (cons vp pl)))
               ((and (not sp_flg)
                     (= bf 0.0)
                     (/= (logand vf 8) 8))
                (setq pl (cons vp pl)))))
  (if (and cl_flg
           (not (equal (car pl) (last pl))))
      (setq pl (cons (last pl) pl)))
  (setq i 0)
  (while (< i (length pl))
         (while (equal (nth i pl) (nth (1+ i) pl) 0.0001)
                (setq i (1+ i)))
         (and (nth i pl)
              (setq nl (cons (nth i pl) nl)))
         (setq i (1+ i)))
   nl)

(defun add_arc (sp ep bulge / alist x1 x2 y1 y2 cotbce
                ce ra sa ea ia inc qty na temp rseg)
  (setq x1 (car sp);;Modified Bulge
        x2 (car ep);;Conversion By
        y1 (cadr sp);;Duff Kurland
        y2 (cadr ep);;Autodesk, Inc.
    cotbce (/ (- (/ 1.0 bulge) bulge) 2.0)
        ce (list (/ (+ x1 x2 (- (* (- y2 y1) cotbce))) 2.0)
                 (/ (+ y1 y2    (* (- x2 x1) cotbce) ) 2.0)
                 (caddr sp))
        ra (distance ce sp)
        sa (atan (- y1 (cadr ce)) (- x1 (car ce)))
        ea (atan (- y2 (cadr ce)) (- x2 (car ce))))
  (if (minusp sa)
      (setq sa (+ sa (* 2.0 pi))))
  (if (minusp ea)
      (setq ea (+ ea (* 2.0 pi))))
  (if (minusp bulge)
      (setq temp sa sa ea ea temp))
  (if (> sa ea)
      (setq ia (+ (- (* pi 2.0) sa) ea))
      (setq ia (- ea sa)))
  (if (not rseg)
      (progn
        (initget 6)
        (setq rseg (getint "\nNumber Of Segments To A 180 Degree Arc <16>:   "))
        (and (not rseg)
             (setq rseg 16))))
  (setq qty (abs (fix (/ ia (/ pi rseg)))))
  (if (< qty 2)
      (setq qty 2))
  (setq na sa
       inc (/ (abs ia) qty))
  (repeat (1+ qty)
      (setq alist (cons (polar ce na ra) alist)
               na (+ sa inc)
               sa na))
  (if (not (equal sp (car alist) 0.0001))
      (setq alist (reverse alist)))
  (foreach a alist
      (setq pl (cons a pl))))

(PDot);++++++++++++ Construct Profiles And Mesh ++++++++++++++++++++++++
(defun tp_con ()
  (setq c 1)
  (setq vlen (length plist)
           i 0)
  (terpri)
  (repeat vlen
    (command "_.UCS" "_World")
    (cond ((and (not closed)
                (= i 0))
           (setq v1 (nth i plist)
                 v2 (nth (1+ i) plist)
                 ys 1.0
                 zs 1.0)
           (command "_.UCS" "_3Point" v1 v2
                    (polar v1 (+ (AtoR 90.0) (angle v1 v2)) 1.0))
           (if (< (caddr (trans '(0 0 1) 1 0))
                  (caddr (trans '(0 0 0) 1 0)))
              (command "_.UCS" "_X" 180.0)))
          ((and (not closed)
                (= i (1- vlen)))
           (setq v1 (nth i plist)
                 v0 (nth (1- i) plist)
                 ys 1.0
                 zs 1.0)
           (command "_.UCS" "_3Point" v1 v0
                     (polar v1 (+ (AtoR 90.0) (angle v0 v1)) 1.0))
           (if (< (caddr (trans '(0 0 1) 1 0))
                  (caddr (trans '(0 0 0) 1 0)))
               (command "_.UCS" "_X" 180.0 "_.UCS" "_Z" 180.0)))
          ((or (= i 0)
               (= i (1- vlen)))
           (miducs (nth (- vlen 2) plist) (nth 0 plist) (nth 1 plist)))
          ((/= i (1- vlen))
           (miducs (nth (1- i) plist) (nth i plist) (nth (1+ i) plist))))

    (cond ((= ptype "Rect")
           (tp_exf))
          ((= ptype "Shape")
           (tp_esh))
          ((= ptype "Poly")
           (tp_exp)))
    (setq i (1+ i))
    (princ (strcat "\r" (rtos (/ (* 100 i) vlen) 2 0) "% ")))
  (reverse vlist)
  (command "_.UCS" "_World")
  (tp_mesh vlist (fix (/ (length vlist) seg)) seg closed))

(PDot);++++++++++++ Draw A 3D Mesh +++++++++++++++++++++++++++++++++++++
(defun tp_mesh (vlist nmesh mmesh closeflg)
(and (/= (length vlist) (* nmesh mmesh))
     (princ "\n*** Invalid List *** ")
     (exit))
(cond ((= ptype "Rect")  (setq closeflg T))
      ((= ptype "Poly")  (setq closeflg T))
      ((and flist (equal (car flist) (last flist) 0.00001))
                         (setq closeflg T)))
(setq i 0)
(setq c 1)
(entmake (list (cons 0 "POLYLINE")(cons 66 1)
               (cons 6 "BYLAYER")
               (cons 10 (list 0.0 0.0 0.0))
               (cons 70 (if closeflg 48 16))
               (cons 40 0.0)(cons 41 0.0)
               (cons 71 nmesh)(cons 72 mmesh)
               (cons 73 0)(cons 74 0)(cons 75 0)
               (cons 39 0.0)
               (cons 210 (list 0.0 0.0 1.0))))
(foreach v vlist
        (entmake (list (cons 0 "VERTEX")
                       (cons 6 "BYLAYER")
                       (cons 10 v)
                       (cons 40 0.0)(cons 41 0.0)(cons 42 0.0)
                       (cons 50 0.0)
                       (cons 71 0)(cons 72 0)(cons 73 0)(cons 74 0)
                       (cons 70 64))))

(entmake (list (cons 0 "SEQEND"))))

(PDot);************ Main Program ***************************************
(defun tp_ (/ m_v m_n olderr tp_var
              plist ha ptype vlen za tpt v0 v1 v2
              wid hgt ewid ehgt erad i closed
              vlist s inc rad seg cti ea ec ed es
              major minor na np nx ny nz shlist flist
              wic hic ric zs ys cucs)
  (tp_smd)
  (initget 1 "Rect Poly Shape")
  (setq ptype (getkword "\nProfile - Rect/Poly/Shape:   "))
  (cond ((= ptype "Rect")    (tp_rect))
        ((= ptype "Poly")    (tp_poly))
        ((= ptype "Shape")   (tp_shape)))
  (tp_con)
  (tp_rmd))

(PDot);************ Load Program ***************************************
(defun C:TubePoly () (tp_))
(if tp_ (princ "\nTubePoly Loaded\n"))
(prin1)
;================== End Program ========================================