home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 15 / CD_ASCQ_15_070894.iso / vrac / may94cad.zip / PXT.LSP < prev    next >
Lisp/Scheme  |  1994-04-25  |  10KB  |  326 lines
  1. ;; PXT.LSP   (c)1994, Christopher Crawford
  2.  
  3. ;; pxt.lsp
  4. ;; 3d extrusion for polylines
  5. ;;
  6. ;; pxt takes two polylines and extrudes the first 
  7. ;; around the second, creating
  8. ;; a polyface mesh.
  9. ;;
  10. ;; Revision History
  11. ;; CC 01.27.94  Created routine.
  12. ;; CC 02.02.94  Shows arrow and left/right
  13. ;; CC 02.16.94  Pick starting point on cross-section. 
  14. ;; Works with closed
  15. ;; cross-sections.  Works with extrusion plines not in WCS.
  16. ;; CC 02.17.94  
  17. ;; Support for bulge-specific plines in xsdef.  Bugs introduced.
  18. ;; CC 02.17.94  
  19. ;; Reworked interface.  Now, entity must be perpendicular to a
  20. ;; reference segment on the extrusion pline.  
  21. ;; Only two selections are necessary to start the routine. 
  22. ;; Implemented via (nentselp)
  23. ;; Release 11 users will need a different version (two selects).
  24. ;; CC 02.17.94  Fixed for spline and fit xsdef plines.
  25. ;; CC 02.18.94  Fixed bugs in bulge-specific arcs.
  26. ;;
  27. ;; vector is a vector generation routine.
  28. ;;
  29.  
  30. (defun vector (v1 v2 / out)
  31.    (setq out (list (- (car v1) (car v2)) (- (cadr v1) 
  32.      (cadr v2)) (- (caddr v1) (caddr v2))))
  33. )
  34.  
  35. ;;
  36. ;; magvec returns the magnitude of an input vector
  37. ;;
  38.  
  39. (defun magvec (v1 / out)
  40.    (setq out (sqrt (+ (expt (car v1) 2) (expt (cadr v1) 2) 
  41.       (expt (caddr v1) 2))))
  42. )
  43.  
  44. ;;
  45. ;; unitvec accepts a vector and returns a unit vector 
  46. ;; in the same direction.
  47. ;;
  48.  
  49. (defun unitvec (v1 / out)
  50.    (setq out (list (/ (car v1) (magvec v1)) (/ (cadr v1) 
  51.      (magvec v1))
  52.               (/ (caddr v1) (magvec v1)))
  53.    )
  54. )
  55. (defun arrow (p1 p2 / p3)
  56.    (setq p3 (list (+ (car p2) (/ (- (car p1) (car p2)) 4))
  57.                   (+ (cadr p2) (/ (- (cadr p1) (cadr p2)) 4))
  58.                   (+ (caddr p2) (/ (- (caddr p1) (caddr p2)) 4))
  59.             )
  60.    )
  61.    (grdraw p1 p2 3 1)
  62.    (grdraw p3 p2 1)
  63. )
  64. (defun divarc (p1 p2 blg div / xtravrt)
  65.    (setq a1 (angle p1 p2)
  66.         mp (polar p1 a1 (setq r (/ (distance p1 p2) 2)))
  67.         rarc r
  68.    )
  69.    (cond
  70.       ((= 0 blg) (setq r 0 rarc 0 cen mp div 1))
  71.       ((/= 1 (abs blg))
  72.          (progn
  73.             (setq r (/ (* r (cos (setq ia 
  74.                 (* 2 (atan (abs blg)))))) (sin ia))
  75.                   rarc (/ r (cos ia))
  76.             )
  77.             (if (minusp blg)
  78.                (setq a1 (- a1 (/ pi 2)))
  79.                (setq a1 (+ a1 (/ pi 2)))
  80.             )
  81.             (setq cen (polar mp a1 r)
  82.                   a (angle cen p1)
  83.                   b (angle cen p2)
  84.             )
  85.             (cond
  86.                ((and (< a b) (not (minusp blg))) 
  87.                    (setq frac (/ (- b a) div)))
  88.                ((and (< a b) (minusp blg)) 
  89.                    (setq frac (/ (- b a (* 2 pi)) div)))
  90.                ((and (> a b) (not (minusp blg))) 
  91.                   (setq frac (/ (+ (* 2 pi) (- b a)) div)))
  92.                (t (setq frac (/ (- b a) div)))
  93.             )
  94.          )
  95.       )
  96.       (t    (setq cen mp
  97.                   a (angle cen p1)
  98.                   frac (/ (* blg pi) div)
  99.             )
  100.       )
  101.    )
  102.    (setq i 1
  103.          xtravrt (append xtravrt (list p1))
  104.    )
  105.    (repeat (1- div)
  106.       (setq xtravrt (append xtravrt (list 
  107.           (polar cen (+ a (* i frac)) rarc)))
  108.             i (1+ i)
  109.       )
  110.    )
  111.    xtravrt
  112. )
  113. (defun c:pxt ( / osmode xspl xtpl sseg xtclosed xsvert xtvert
  114.                  xtvertlen pt1 pt2 pt3 pt4 xpt stpt xtclosed)
  115.    (setq osmode (getvar "OSMODE"))
  116.    (setvar "OSMODE" 0)
  117.    (command "UCS" "W")
  118.    (setq xspl nil xsclosed nil xtpl nil xtclosed nil 
  119.          #FUZZ 1e-10 rang (- (/ pi 2)))
  120.    (while (or (not xspl) (/= (cdr (assoc 0 (setq xsplent 
  121.          (entget xspl)))) "POLYLINE"))
  122.       (setq xspl (car (entsel 
  123.            "\nSelect cross-section polyline: ")))
  124.    )
  125.    (redraw xspl 3)
  126.    (while (or (not xtpl) (/= (cdr (assoc 0 (setq xtplent 
  127.          (entget xtpl)))) "POLYLINE"))
  128.       (setq attachent (entsel 
  129.          "\nSelect reference segment of extrusion polyline: ")
  130.             xtpl (car attachent)
  131.       )
  132.    )
  133.  
  134. ;; build cross-section vertex list
  135.    (setq xsvert nil
  136.          ename (entnext xspl)
  137.    )
  138.    (while (and ename (= (cdr (assoc 0 (entget ename)))
  139.          "VERTEX"))
  140.       (setq vrt (entget ename))
  141.       (if (= 0 (cdr (assoc 42 vrt)))
  142.          (if (/= 16 (cdr (assoc 70 vrt)))
  143.                           ;; make sure itÆs not a spline ref.
  144.              (setq xsvert (append xsvert (list 
  145.                    (cdr (assoc 10 vrt)))))
  146.          )
  147.          (if (and (setq nname (entnext ename))
  148.                   (setq nvrt (entget nname))
  149.                   (= (cdr (assoc 0 nvrt)) "VERTEX")
  150.              )
  151.              (progn
  152.                 (setq p1 (cdr (assoc 10 vrt))
  153.                       p2 (cdr (assoc 10 nvrt))
  154.                       blg (cdr (assoc 42 vrt))
  155.                       arcseg (getvar "SURFTAB1") 
  156.                             ;; div's for arc in xs
  157.                       xtravrt (divarc p1 p2 blg arcseg)
  158.                 )
  159.                 (foreach a xtravrt (setq xsvert 
  160.                     (append xsvert (list a))))
  161.              )
  162.              (setq xsvert (append xsvert (list 
  163.                     (cdr (assoc 10 vrt)))))
  164.          )
  165.       )
  166.       (setq ename (entnext ename))
  167.    )
  168. ;;if closed, add first vertex to end of list-This one's for Tony
  169.    (if (= (cdr (assoc 70 xsplent)) 1)
  170.       (setq xsvert (append xsvert (list (car xsvert))))
  171.    )
  172.  
  173. ;;
  174. ;; build extrusion pline vertex list
  175. ;;
  176.    (setq xtvert nil
  177.          ename (entnext xtpl)
  178.    )
  179.    (while (and ename (= (cdr (assoc 0 (entget ename))) "VERTEX"))
  180.       (setq vrt (entget ename)
  181.             xtvert (append xtvert (list (cdr (assoc 10 vrt))))
  182.             ename (entnext ename)
  183.       )
  184.    )
  185.    (if (= (cdr (assoc 70 xtplent)) 1)
  186.       (setq xtvert (append xtvert (list (car xtvert)))
  187.             xtclosed T
  188.       )
  189.    )
  190.    (setq xtvertlen (length xtvert))
  191.  
  192. ;;
  193. ;; extrusion pline finished
  194. ;;
  195. ;; find base point for offset vector list
  196. ;;
  197.    (setq attachseg (car (nentselp (last attachent))) 
  198.          attachv1 (cdr (assoc 10 (entget attachseg))) 
  199.          attachnum (- (length xtvert) (length 
  200.              (member attachv1 xtvert)))
  201.          attachv1 (nth attachnum xtvert)
  202.          attachv2 (nth (1+ attachnum) xtvert)
  203.    )
  204.    (arrow attachv1 attachv2)
  205. ;;
  206. ;; next few lines build offset vector list for 
  207. ;; cross-section pline
  208. ;;
  209.    (setq base (trans attachv1 xtpl xspl)
  210.          offv nil
  211.          i 0
  212.          xszvec (cdr (assoc 210 xsplent))
  213.          xtzvec (unitvec (vector attachv2 attachv1))
  214.    )
  215.    (if (equal xszvec xtzvec #FUZZ) (setq rang (/ pi 2)))
  216.    (repeat (length xsvert)
  217.       (setq offv (append offv (list 
  218.                 (vector (nth i xsvert) base)))
  219.             i (1+ i)
  220.       )
  221.    )
  222. ;;
  223. ;; offset vector list finished for cross-section pline
  224. ;;
  225.    (setq alist nil
  226.          i 0
  227.    )
  228.    (repeat (- (length xtvert) 1)
  229.       (setq pt1 (nth i xtvert)
  230.             pt2 (nth (1+ i) xtvert)
  231.             ang (angle pt1 pt2)
  232.             alist (append alist (list ang))
  233.             i (1+ i)
  234.       )
  235.    )
  236.    (setq alistlen (length alist))
  237. ;;
  238. ;; extrusion pline angles finished
  239. ;;
  240.    (setq j 0 xlist nil)
  241.    (repeat (length offv)
  242.       (if xtclosed
  243.          (setq pt1 (polar (nth 0 xtvert) (+ (nth 0 alist) rang)
  244.                    (car (nth j offv)))
  245.                pt2 (polar (nth 1 xtvert) (+ (nth 0 alist) rang)
  246.                    (car (nth j offv)))
  247.                pt3 (polar (nth (- xtvertlen 2) xtvert) 
  248.       (+ (nth (1- alistlen) alist) rang) (car (nth j offv)))
  249.                pt4 (polar (nth (- xtvertlen 1) xtvert) 
  250.       (+ (nth (1- alistlen) alist) rang) (car (nth j offv)))
  251.                stpt (inters pt1 pt2 pt3 pt4 nil)
  252.                tlist (list (list (car stpt) (cadr stpt) 
  253.       (+ (caddr stpt) (cadr (nth j offv)))))
  254.          )
  255.          (setq pt1 (polar (nth 0 xtvert) (+ (nth 0 alist) rang)
  256.                    (car (nth j offv)))
  257.                tlist (list (list (car pt1) (cadr pt1) 
  258.                    (+ (caddr pt1) (cadr (nth j offv)))))
  259.          )
  260.       )
  261.       (setq i 0)
  262.       (repeat (- (length xtvert) 2)
  263.          (setq pt1 (polar (nth i xtvert) (+ (nth i alist) rang)
  264.                     (car (nth j offv)))
  265.                pt2 (polar (nth (1+ i) xtvert) (+ (nth i alist)
  266.                     rang) (car (nth j offv)))
  267.                pt3 (polar (nth (1+ i) xtvert) (+ (nth (1+ i)
  268.                    alist) rang) (car (nth j offv)))
  269.                pt4 (polar (nth (+ i 2) xtvert) (+ (nth (1+ i)
  270.                    alist) rang) (car (nth j offv)))
  271.                xpt (inters pt1 pt2 pt3 pt4 nil)
  272.                xpt (list (car xpt) (cadr xpt) (+ (caddr xpt)
  273.                    (cadr (nth j offv))))
  274.                tlist (cons xpt tlist)
  275.                i (1+ i)
  276.          )
  277.       )
  278.       (if xtclosed
  279.          (setq tlist (cons (list (car stpt) (cadr stpt) 
  280.             (+ (caddr stpt) (cadr (nth j offv)))) tlist))
  281.          (setq pt1 (polar (nth (1+ i) xtvert) (+ (nth i alist)
  282.             rang) (car (nth j offv)))
  283.                tlist (cons (list (car pt1) (cadr pt1) 
  284.                  (+ (caddr pt1) (cadr (nth j offv)))) tlist)
  285.          )
  286.       )
  287.       (setq tlist (reverse tlist)
  288.             xlist (append xlist (list tlist))
  289.             j (1+ j)
  290.       )
  291.    )
  292.  
  293. ;;
  294. ;; mitered vertex list finished, begin PFACE
  295. ;;
  296.    (setq i 0)
  297.    (command "PFACE")
  298.    (repeat (length xlist)
  299.       (setq tlist (nth i xlist))
  300.       (foreach a tlist (command (trans a xtpl 0)))
  301.       (setq i (1+ i))
  302.    )
  303.    (command "")
  304.    (setq i 1 j (length xtvert))
  305.    (repeat (1- (length offv))
  306.       (repeat (1- (length xtvert))
  307.          (command i)
  308.          (command (1+ i))
  309.          (command (+ i 1 j))
  310.          (command (+ i j ))
  311.          (command "")
  312.          (setq i (1+ i))
  313.       )
  314.       (setq i (1+ i))
  315.    )
  316.    (command "")
  317.    (redraw xtpl 3)
  318.    (command "UCS" "P")
  319.    (setvar "OSMODE" osmode)
  320. );pxt
  321. (princ "\npxt is loaded.  Type pxt to execute")
  322. (princ)
  323. ;; end pxt.lsp
  324.  
  325.  
  326.