home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p024 / 11.img / BONUS2.LIB / PROJECT.LSP < prev    next >
Encoding:
Text File  |  1993-02-09  |  36.3 KB  |  1,195 lines
  1. ;;;  PROJECT.LSP / R10 ⌐╬ R11
  2. ;;;   (C) ¬⌐┼v 1988-1992  Autodesk ñ╜Ñq
  3. ;;;
  4. ;;;   Ñ╗╡{ªíñwÑ╤ Autodesk ñ╜Ñq╡∙ÑU¬⌐┼v, ╢╚⌐≤ñU¡z▒í¬pñUÑi▒┬╗P▒zíu│\ÑiívíC
  5. ;;;   ╗╒ñUñú▒oÑHÑ⌠ª≤º╬ªí╡oªµ⌐╬ÑX¬⌐ª╣╡{ªí¬║íu¡∞⌐l╜Xív; ª²ñ╣│\▒zªb»S⌐w¡lÑ═
  6. ;;;   ¬║ñuº@ñW╡▓ªXª╣╡{ªí¬║íuÑ╪¬║╜Xív¿╧Ñ╬íCª│├÷│o├■¡lÑ═ñuº@¬║▒°Ñ≤ªpñU:
  7. ;;;
  8. ;;;   ( i)  │]¡pñW╗Pñuº@ñW¼╥»┬║Θ░w╣∩ Autodesk ñ╜Ñq¬║▓ú½~íC
  9. ;;;   (ii)  ╕ⁿª│íu¬⌐┼v  (C) 1988-1992  Autodesk ñ╜Ñqív¬║¬⌐┼v│qºiíC
  10. ;;;
  11. ;;;
  12. ;;;
  13. ;;;   AUTODESKñ╜Ñq┤ú¿╤ª╣╡{ªí╢╚¿╤º@íu├■ªⁿív¬║░╤ª╥, ª╙ÑBñú▒╞░úª│Ñ⌠ª≤┐∙╗~¬║
  14. ;;;   Ñi»αíCAUTODESKñ╜Ñq»Sª╣º_╗{Ñ⌠ª≤»S⌐wÑ╬│~ñº╛A║┘⌐╩, ÑHñ╬░╙╖~╛P░Γ⌐╥┴⌠ºt
  15. ;;;   ÑX¿π¬║½O├╥íCAUTODESKñ╜ÑqªP«╔ÑτñúÑX¿πª╣╡{ªí░⌡ªµ«╔ñ@⌐wñú╖|íuññ┬_ív⌐╬
  16. ;;;   íuº╣Ñ■╡L╗~ív¬║½O├╥íC
  17. ;;;
  18. ;;;
  19. ;;;--------------------------------------------------------------------------
  20. ;;; DESCRIPTION
  21. ;;;
  22. ;;;  This LISP routine allows for two different kinds of
  23. ;;;  projection.  The commands are named:
  24. ;;;
  25. ;;;     PROJECT
  26. ;;;     PROJECT1
  27. ;;;     PROJECT2
  28. ;;;
  29. ;;;  An explanation of each command is shown below.
  30. ;;;
  31. ;;;  (C:PROJECT)
  32. ;;;  Calls up a menu with a choice of projections.
  33. ;;;
  34. ;;;  (C:PROJECT1)
  35. ;;;  Allows a "flat" projection of wireframe 3D models (lines,
  36. ;;;  arcs, circles, polylines, solids, points) onto the current
  37. ;;;  UCS.  This could be a useful aid for generating working
  38. ;;;  drawings from a 3D model.  Width information will be
  39. ;;;  ignored.   Entities not capable of projection (3Dmesh,
  40. ;;;  text, blocks) will be highlighted and tallied.
  41. ;;;
  42. ;;;  After projection, the user is allowed to make the
  43. ;;;  projected entities into a block, or write it out as a
  44. ;;;  drawing file.  These blocks or drawing files (typically
  45. ;;;  Top, Front, Side, and Iso projections) could be re-
  46. ;;;  inserted onto a single UCS and annotated to create a
  47. ;;;  multi-view orthographic drawing.  The prompt sequence is:
  48. ;;;
  49. ;;;    Layer name <current>:
  50. ;;;    Select entities:  {do so}
  51. ;;;    Project more entities? <N>:  {Y or N}
  52. ;;;    Make projected entity(s) into a block? <N>:  {Y or N}
  53. ;;;    Write projected entities to disk as DWG file? <N>:  {Y or N}
  54. ;;;
  55. ;;;
  56. ;;;  (C:PROJECT2)
  57. ;;;  This routine projects an entity normal from the current
  58. ;;;  UCS onto a designated oblique construction plane.  This
  59. ;;;  may be useful in the construction of 3D wireframe and
  60. ;;;  surface models.
  61. ;;;
  62. ;;;  The user is prompted to enter the name of the UCS he
  63. ;;;  wishes to project onto, or to select 3 points which lie on
  64. ;;;  the construction plane.  The prompt sequence is:
  65. ;;;
  66. ;;;    Layer name <current>:
  67. ;;;    UCS namd or <RETURN> to select 3 points:
  68. ;;;    Select entities:  {do so}
  69. ;;;    Project more entities? <N>:  {Y or N}
  70. ;;;
  71. ;;;  Lines, arcs, circles, solids, 3d faces, polylines, and
  72. ;;;  3d polylines will be projected.  The routine will not
  73. ;;;  project text, meshes, or blocks.  Width information will
  74. ;;;  be ignored.
  75. ;;;
  76. ;;;  *** Word of Caution ***
  77. ;;;  If you try to project an entity onto a plane that is near
  78. ;;;  perpendicular to the current plane, then the entity will
  79. ;;;  be projected over a very great distance.  When you do a
  80. ;;;  "ZOOM All" your drawing will appear to disappear.
  81. ;;;
  82. ;;;  Autodesk Training Department
  83. ;;;  9/10/90
  84. ;;;
  85. ;;;-----------------------------------------------------------
  86.  
  87. (vmon)
  88.  
  89. ;;;  Won't fit in 40K heap unless VMON is enabled
  90. ;;;  Extended AutoLISP is highly recommended
  91.  
  92. ;;;----- Redefined error function ----------------------------
  93.  
  94. (defun proj-err (s)
  95.   (if (/= s "Function cancelled")
  96.       (princ (strcat "\n┐∙╗~: " s))
  97.   )
  98.   (setq *error* olderr)
  99.   (setvar "ucsicon" icon)
  100.   (if (and reject-set
  101.            (eq (type reject-set) 'pickset)
  102.            (not (zerop (sslength reject-set))))
  103.       (redraw-rej reject-set 1)
  104.   )
  105.   (setq copy-set nil
  106.         entset nil
  107.         entities nil
  108.         reject-set nil
  109.         err-set nil
  110.   )
  111.   (moder)
  112.   (princ)
  113. )
  114.  
  115. ;;;----- Superfulous translation counter ---------------------
  116.  
  117. (defun call ()
  118.   (princ (strcat (chr 008) (chr 008) (chr 008)))
  119.   (if (= numctr 1) (princ "  |"))
  120.   (if (= numctr 2) (princ "  /"))
  121.   (if (= numctr 3) (princ "  -"))
  122.   (if (= numctr 4) (princ "  \\"))
  123.   (setq numctr (+ 1 numctr))
  124.   (if (= numctr 5) (setq numctr 1))
  125. )
  126.  
  127. ;;;----- Mode Save -- Saves system variables in a list -------
  128.  
  129. (defun MODES (a)
  130.   (setq MLST '())
  131.   (repeat (length a)
  132.     (setq MLST (append MLST (list (list (car a) (getvar (car a))))))
  133.     (setq a (cdr a))
  134.   )
  135. )
  136.  
  137. ;;;----- Mode Reset -- Resets system variables ---------------
  138.  
  139. (defun MODER ()
  140.   (repeat (length MLST)
  141.     (setvar (caar MLST) (cadar MLST))
  142.     (setq MLST (cdr MLST))
  143.   )
  144. )
  145.  
  146. ;;;----- Converts radians to degrees -------------------------
  147.  
  148. (defun rtd (r)
  149.   (* 180 (/ r pi))
  150. )
  151.  
  152. ;;;----- Find current entity color ---------------------------
  153.  
  154. (defun getcolor (/ max ctr ccolor)
  155.   (setq ncolor nil)
  156.   (setq ccolor (getvar "cecolor"))
  157.   (setq ctr 1)
  158.   (setq max (strlen ccolor))
  159.   (while (< ctr max)
  160.     (if (= (substr ccolor ctr 1) " ")
  161.       (progn
  162.          (setq ncolor (substr ccolor 1 (- ctr 1)))
  163.          (setq ctr max)
  164.       )
  165.       (setq ctr (1+ ctr))
  166.     )
  167.   )
  168.   (if (not ncolor) (setq ncolor ccolor))
  169. )
  170.  
  171. ;;;----- Redraw rejected entities ----------------------------
  172.  
  173. (defun redraw-rej (ss tp / r-ctr)
  174.   (if (not proj2)
  175.     (progn
  176.       (setq r-ctr 0)
  177.       (while (> n-of-ents r-ctr)
  178.         (redraw (ssname ss r-ctr) tp)
  179.         (setq r-ctr (1+ r-ctr))
  180.       )
  181.     )
  182.   )
  183. )
  184.  
  185. ;;;----- "Please wait ..." function --------------------------
  186.  
  187. (defun prmpt ()
  188.   (prompt "\n╢iªµíuºδ╝vív . . .     ╜╨╡y¡╘ \n")
  189. )
  190.  
  191. ;;;----- UCS parallel check ----------------------------------
  192.  
  193. (defun ucsp (edir udir / arbval dx dy dz)
  194.   (setq dx     (- (car edir) (car udir))
  195.         dy     (- (cadr edir) (cadr udir))
  196.         dz     (- (caddr edir) (caddr udir))
  197.         arbval (/ 1.0 64.0)
  198.   )
  199.   (if (< (+ (* dx dx) (* dy dy) (* dz dz)) 1E-20)
  200.     (equal (and (< (abs (car edir)) arbval) (< (abs (cadr edir))))
  201.            (and (< (abs (car udir)) arbval) (< (abs (cadr udir))))
  202.     )
  203.     nil
  204.   )
  205. )
  206.  
  207. ;;;----- Select projection plane (for use with "PROJECT2") ---
  208.  
  209. (defun getplane (/ 1st 2nd 3rd)
  210.   (setq ucs-a "$$PLANE-A")
  211.   (command "_.UCS" "_S" ucs-a)
  212.   (setq ucs-b
  213.     (getstring "\níuUCS ªW║┘ív⌐╬½÷ <Return> ┐∩╛▄ 3 ┬I: ")
  214.   )
  215.   (while (and (not (tblsearch "UCS" ucs-b))
  216.               (/= ucs-b "")
  217.          )
  218.     (prompt "\nUCS ñúªsªb ")
  219.     (setq ucs-b
  220.       (getstring "\níuUCS ªW║┘ív⌐╬½÷ <Return> ┐∩╛▄ 3 ┬I: ")
  221.     )
  222.   )
  223.   (if (= ucs-b "")                    ;if you hit <RETURN>
  224.     (progn                            ;then select new UCS
  225.       (setq 1st (getpoint "\n¡∞┬I: "))
  226.       (setq 2nd (getpoint 1st "\n┬IÑXíuÑ┐ X ╢bívñΦªV: "))
  227.       (setq 3rd
  228.        (getpoint 1st "\n┬IÑXíuUCS X-Y Ñ¡¡▒ív¬║Ñ┐ªV: ")
  229.       )
  230.       (command "_.UCS" "3" 1st 2nd 3rd)
  231.       (setq ucs-b "$$PLANE-B")
  232.       (command "_.UCS" "_S" ucs-b)
  233.     )
  234.     (command "_.UCS" "_R" ucs-b)         ;else restore named UCS
  235.   )
  236.   (setq udir (trans '(0 0 1) 1 0 T))
  237.   (command "_.UCS" "_P")
  238. )
  239.  
  240. ;;;----- Set projection layer --------------------------------
  241.  
  242. (defun slayer (/ clay laynam)
  243.  (setq clay (getvar "CLAYER"))
  244.  (setq laynam (getstring (strcat "\n╝hªW <" clay ">: ")))
  245.  (if (not (= laynam ""))
  246.    (progn
  247.      (while (not (tblsearch "LAYER" laynam))
  248.        (prompt (strcat "\nºΣñú¿∞íu╣╧╝h " laynam "ív"))
  249.        (setq laynam (getstring (strcat "\n╝hªW <" clay ">: ")))
  250.        (if (= laynam "") (setq laynam clay))
  251.      )
  252.      (if (not (= laynam clay))
  253.        (command "_.LAYER" "_S" laynam "")
  254.      )
  255.    )
  256.  )
  257. )
  258.  
  259. ;;;----- Make BLOCK from projected entities ------------------
  260.  
  261. (defun make-blk (ss / blknam blkflg ip)
  262.  (while (= (setq blknam (getstring "\n╣╧╕sªW║┘: ")) "")
  263.         (prompt "\nÑ╝½ⁿ⌐wíu╣╧╕sªW║┘íví╨ ╜╨ªA╕╒!")
  264.  )
  265.  (setq blkflg "")  ;init flag to redefine exist block
  266.  (if (tblsearch "BLOCK" blknam)
  267.    (while
  268.      (and (tblsearch "BLOCK" blknam) (not (eq blkflg "Yes")))
  269.      (prompt (strcat "\n╣╧╕síu" blknam "ívñwªsªbíC"))
  270.      (initget "Yes No")
  271.      (setq blkflg (getkword "\n¼Oº_¡½╖sñ⌐ÑH⌐w╕q? <N>: "))
  272.      (if (/= blkflg "Yes")
  273.          (setq blknam (getstring "\╣╧╕sªW║┘: "))
  274.      )
  275.    )
  276.  )
  277.  (setq ip (getpoint "\n┤íñ▐┬I <UCS 0,0,0>: "))
  278.  (if (not ip) (setq ip '(0 0 0)))
  279.  (command "_.BLOCK" blknam ip ss "")
  280.  (command "_.REGENALL")
  281. )
  282.  
  283. ;;;----- Write projected entities to disk as DWG file --------
  284.  
  285. (defun write-blk (ss / flname dwgflg filept ip)
  286.   (while (= (setq flname (getstring "\n└╔ªW: ")) "")
  287.          (prompt "\nÑ╝½ⁿ⌐w└╔ªW í╨ ╜╨ªA╕╒!")
  288.   )
  289.   (setq dwgflg "")                    ;initialize flag to redefine exist file
  290.   (if                                 ;file of same name?
  291.     (setq filept (open (strcat flname ".DWG") "r"))
  292.     (progn
  293.       (setq filept (close filept))  ;close file
  294.       (while
  295.         (and (setq filept (open (strcat flname ".DWG") "r"))
  296.              (not (eq dwgflg "Yes"))
  297.         )
  298.         (prompt (strcat "\n└╔«╫íu" flname "ívñwªsªbíC"))
  299.         (initget "Yes No")
  300.         (setq dwgflg (getkword "\n¼Oº_ñ⌐ÑH¿·ÑN? <N>: "))
  301.         (if (/= dwgflg "Yes")
  302.           (progn
  303.             (setq filept (close filept))
  304.             (setq flname (getstring "\n└╔ªW: "))
  305.           )
  306.           (setq filept (close filept))
  307.         )
  308.       )
  309.     )
  310.   )
  311.   (setq ip (getpoint "\n┤íñ▐┬I <UCS 0,0,0>: "))
  312.   (if (not ip) (setq ip '(0 0 0)))
  313.   (command "_.WBLOCK" flname "" ip ss "")
  314.   (command "_.REGENALL")
  315. )
  316.  
  317. ;;;----- Insert extra vertex for bulges & arcs ---------------
  318. ;;;   This is to allow for exact tangency of silhouette edges
  319. ;;;   on curved enitities that have a thickness
  320. ;;;   sang1 & sang2 are silhouette angles
  321.  
  322. (defun insert-tv (/ p-pt)
  323.   (if (and (>  sang1 (+ st-ang (* p-ctr angmult)))
  324.            (<= sang1 (+ st-ang (* (+ p-ctr 1) angmult)))
  325.       )
  326.     (progn
  327.       (setq p-pt (pro-point (polar center sang1 radius)))
  328.       (setq pntlst (cons (list 'quote p-pt) pntlst))
  329.     )
  330.   )
  331.   (if (and (>  sang2 (+ st-ang (* p-ctr angmult)))
  332.            (<= sang2 (+ st-ang (* (+ p-ctr 1) angmult)))
  333.       )
  334.     (progn
  335.       (setq p-pt (pro-point (polar center sang2 radius)))
  336.       (setq pntlst (cons (list 'quote p-pt) pntlst))
  337.     )
  338.   )
  339. )
  340.  
  341. ;;;---- Increase # of vertices  ------------------------------
  342. ;;;   If silhouette lines need to be drawn then increase the
  343. ;;;   number of vertices in pline that approximates the curve
  344.  
  345. (defun bump-ver ()
  346.   (if (or S1 S2)
  347.     (cond
  348.       ((< incl-ang (/ pi 8)) (setq pt-num 6))
  349.       ((< incl-ang (/ pi 4)) (setq pt-num 8))
  350.       ((< incl-ang (/ pi 2)) (setq pt-num 10))
  351.       ((< incl-ang (/ pi 1.5)) (setq pt-num 12))
  352.       ((< incl-ang pi) (setq pt-num 14))
  353.       (T (setq pt-num 18))
  354.     )
  355.   )
  356.   (if (and S1 S2) (setq pt-num 18))
  357. )
  358.  
  359. ;;;----- Find silhouette edge point of arc or circle ---------
  360.  
  361. (defun s-edge (cntr rad ang / pt c)
  362.   (setq c  (pro-point cntr))
  363.   (setq pt (pro-point (polar cntr (+ ad-ang ang) rad)))
  364.   (setq t-list (cons (list 'quote pt) t-list))
  365. )
  366.  
  367. ;;;---- Draw silhouette lines & edges of thick entities  -----
  368.  
  369. (defun tessilate (t-list / bp tesline ncopy)
  370.   (setq bp (eval (car t-list)))
  371.   (setq t-list (cdr t-list))
  372.   (command "_.LINE" bp (polar bp uvang uvd) "")
  373.   (setq entset (ssadd (entlast) entset))
  374.   (setq tesline (entlast))
  375.   (while (setq ncopy (eval (car t-list)))
  376.     (command "_.COPY" tesline "" bp ncopy)
  377.     (setq entset (ssadd (entlast) entset))
  378.     (setq t-list (cdr t-list))
  379.   )
  380. )
  381.  
  382. ;;;----- Project LINE ----------------------------------------
  383.  
  384. (defun lines-pro (/ stpt endpt pntlst t-list)
  385.   (setq stpt  (cdr (assoc 10 elist))
  386.         endpt (cdr (assoc 11 elist))
  387.   )
  388.   (setq stpt  (pro-point stpt))
  389.   (setq endpt (pro-point endpt))
  390.   (setq pntlst (list (list 'quote stpt)
  391.                      (list 'quote endpt)
  392.                )
  393.   )
  394.   (eval (append '(command "_.LINE") pntlst '("")))
  395.   (setq entset (ssadd (entlast) entset))
  396.   (if thickness
  397.     (progn
  398.       (setq t-list pntlst)
  399.       (command "_.COPY" (entlast) "" displace "")
  400.       (setq entset (ssadd (entlast) entset))
  401.       (tessilate t-list)
  402.     )
  403.   )
  404. )
  405.  
  406. ;;;-----Project CIRCLE -- projected as curve fit polyline ----
  407. ;;;  derived 0.3926990817 with (/ (* 2 pi) 16)
  408.  
  409. (defun circ-pro (/ planar radius center p-pt pntlst t-list)
  410.   (setq planar T
  411.         radius (cdr (assoc 40 elist))
  412.         center (cdr (assoc 10 elist))
  413.         p-ctr  0
  414.         pntlst '("c")                 ;initialize pt list for PLINE command
  415.         t-list '()
  416.   )
  417.  
  418.   (while (< p-ctr 16)
  419.     (setq p-pt
  420.       (polar center (+ (* p-ctr 0.3926990817) ad-ang) radius)
  421.     )
  422.     (setq p-pt
  423.       (list (car p-pt) (cadr p-pt) (caddr center))
  424.     )
  425.     (setq p-pt (pro-point p-pt))
  426.     (setq pntlst (cons (list 'quote p-pt) pntlst))
  427.     (setq p-ctr (1+ p-ctr))
  428.   )
  429.   (eval (append '(command "_.PLINE") pntlst))
  430.   (command "_.PEDIT" (entlast) "_F" "_X")
  431.  
  432.   (setq entset (ssadd (entlast) entset))
  433.   (if thickness
  434.     (progn
  435.       (command "_.COPY" (entlast) "" displace "")
  436.       (setq entset (ssadd (entlast) entset))
  437.       (s-edge center radius (/ pi 2))
  438.       (s-edge center radius (- 0 (/ pi 2)))
  439.       (tessilate t-list)
  440.     )
  441.   )
  442. )
  443.  
  444. ;;;----- Project ARC -- projected as curve fit polyline ------
  445. ;;;   derive 6.2831853072 with (* 2 pi)
  446.  
  447. (defun arc-pro (/ center radius st-ang end-ang planar
  448.                   pntlst t-list)
  449.   (setq center (cdr (assoc 10 elist))
  450.       radius (cdr (assoc 40 elist))
  451.       st-ang (cdr (assoc 50 elist))
  452.       end-ang (cdr (assoc 51 elist))
  453.       planar T
  454.   )
  455.  
  456.   (arc-draw center radius st-ang end-ang)
  457.  
  458.   (eval (append '(command "_.PLINE") pntlst '("")))
  459.   (command "_.PEDIT" (entlast) "_F" "_X")
  460.   (setq entset (ssadd (entlast) entset))
  461.   (if thickness
  462.     (progn
  463.       (command "_.COPY" (entlast) "" displace "")
  464.       (setq entset (ssadd (entlast) entset))
  465.       (setq t-list (cons (car pntlst) t-list))
  466.       (setq t-list (cons (last pntlst) t-list))
  467.       (tessilate t-list)
  468.     )
  469.   )
  470. )
  471.  
  472. (defun arc-draw (center radius st-ang end-ang / pt-num
  473.                  incl-ang angmult p-ctr edgetest S1 S2 p-pt)
  474.   (setq incl-ang (- end-ang st-ang) p-ctr 0)
  475.   (if (< incl-ang 0)
  476.     (setq incl-ang (+ 6.2831853072 incl-ang))
  477.   )
  478.   (if thickness
  479.     ;;then check if silhoulette lines need to be drawn
  480.     (progn
  481.       (setq end-ang (+ st-ang incl-ang))
  482.       (while (>= end-ang (* 2 pi))
  483.         (setq end-ang (- end-ang  (* 2 pi)))
  484.       )
  485.       (setq edgetest (- end-ang sang1))
  486.       (if (< edgetest 0)
  487.         (setq edgetest (+ edgetest (* 2 pi)))
  488.       )
  489.       (if (> incl-ang edgetest)
  490.         (progn
  491.           (s-edge center radius (/ pi 2))
  492.           (setq S1 T)
  493.         )
  494.       )
  495.       (setq edgetest (- end-ang sang2))
  496.       (if (<= edgetest 0)
  497.         (setq edgetest (+ edgetest (* 2 pi)))
  498.       )
  499.       (if (> incl-ang edgetest)
  500.         (progn
  501.           (s-edge center radius (- 0 (/ pi 2)))
  502.           (setq S2 T)
  503.         )
  504.       )
  505.     )
  506.   )
  507.  
  508.   (setq pt-num (fix (+ 1 (/ incl-ang 0.3927))))
  509.   (if (< pt-num 4) (setq pt-num 4))   ;minimum # of vertex
  510.   (if thickness (bump-ver))
  511.   (setq angmult (/ incl-ang (- pt-num 1)))
  512.   (while (< p-ctr pt-num)
  513.     (setq p-pt
  514.       (polar center (+ st-ang (* p-ctr angmult)) radius)
  515.     )
  516.     (setq p-pt
  517.       (list (car p-pt) (cadr p-pt) (caddr center))
  518.     )
  519.     (setq p-pt (pro-point p-pt))
  520.     (setq pntlst (cons (list 'quote p-pt) pntlst))
  521.     (if thickness
  522.         (if (< p-ctr (1- pt-num)) (insert-tv))
  523.     )
  524.     (setq p-ctr (1+ p-ctr))
  525.   )
  526. )
  527.  
  528. ;;;----- Project PLINE -- projected as polyline(s) -----------
  529.  
  530. (defun pline-pro (/ planar bit-70 close-pt pntlst copy-set t-list)
  531.   (setq planar nil copy-set nil t-list nil)
  532.   (setq copy-set (ssadd))
  533.   (setq bit-70 (cdr (assoc 70 elist)));type of polyline
  534.   (if (= (boole 1 bit-70 1) 1)        ;if closed
  535.     (setq close-pt                    ;save first vertex
  536.       (cdr (assoc 10 (entget (entnext ename))))
  537.     )
  538.     (setq close-pt nil)
  539.   )
  540.   (if (= (boole 1 bit-70 5) 5)        ;closed spline
  541.     (progn
  542.       (setq closure '("c"))
  543.       (setq close-pt nil)
  544.     )
  545.     (setq closure '(""))
  546.   )
  547.  
  548.   (cond
  549.     ((= (boole 1 bit-70 8) 8)         ;space poly
  550.       (setq planar 0) (pline-dr)
  551.     )
  552.     ((= (boole 1 bit-70 16) 16)       ;3D-mesh
  553.       (if proj2 (prompt "\n╡L¬k╣∩íu3D║⌠¡▒ív╢iªµºδ╝v   "))
  554.       (setq reject-set (ssadd ename reject-set))
  555.     )
  556.     ((= (boole 1 bit-70 64) 64)       ;Polyface
  557.       (if proj2 (prompt "\n╡L¬k╣∩íu╗EªX║⌠¡▒ív╢iªµºδ╝v  "))
  558.       (setq reject-set (ssadd ename reject-set))
  559.     )
  560.     (t (setq planar T)                ;then it must be 2D poly
  561.       (if parallel (copy-ent) (pline-dr))
  562.     )
  563.   )
  564. )
  565.  
  566. (defun pline-dr (/ subname sublist sub-etype bulge
  567.                    sp ep ctr firstbpt v-pt b-flag lastbpt)
  568.   (setq subname (entnext ename))
  569.   (setq sublist (entget subname))
  570.   (if (not close-pt) (setq b-flag T)) ;to flag first bulge
  571.   (while                              ;while there is a vertex
  572.     (eq (setq sub-etype (cdr (assoc 0 sublist))) "VERTEX")
  573.     (if                               ;if not spline frame pt
  574.       (/= (logand (cdr (assoc 70 sublist)) 16) 16)
  575.       (progn                          ;then test for bulge, if so
  576.         (if (/= (setq bulge (cdr (assoc 42 sublist))) 0)
  577.           (progn                      ;then
  578.             (d-polyseg)               ;project poly-segment
  579.             (setq sp (cdr (assoc 10 sublist))) ;new stpt for pline
  580.             (if                       ;if end of bulge
  581.               (setq ep (cdr (assoc 10 (entget (entnext subname)))))
  582.               (progn
  583.                 (if b-flag (setq firstbpt sp))
  584.                 (setq b-flag nil)
  585.                 (setq lastbpt ep)
  586.                 (d-bulge)             ;then project polyarc
  587.               )
  588.               (if close-pt            ;else if polyline is closed
  589.                 (progn                ;then project closure of polyarc
  590.                   (setq ep close-pt)
  591.                   (d-bulge)
  592.                   (setq close-pt nil)
  593.                   (setq lastbpt nil)
  594.                 )
  595.               )
  596.             )
  597.           )
  598.           (progn                      ;store vertex in point list
  599.             (setq b-flag nil)
  600.             (setq lastbpt nil)
  601.             (setq v-pt (cdr (assoc 10 sublist)))
  602.             (setq v-pt (pro-point v-pt))
  603.             (setq pntlst (cons (list 'quote v-pt) pntlst))
  604.             (setq t-list (cons (list 'quote v-pt) t-list))
  605.           )
  606.         )
  607.       )
  608.     )
  609.     (setq subname (entnext subname))
  610.     (setq sublist (entget subname))
  611.   )                                   ;end of while loop
  612.  
  613.   (if pntlst (eval (append '(command "_.PLINE") pntlst closure)))
  614.   (setq copy-set (ssadd (entlast) copy-set))
  615.   (setq entset (ssadd (entlast) entset))
  616.  
  617.   (if close-pt                        ;close polyline
  618.     (progn
  619.       (setq lastpt (pro-point close-pt))
  620.       (command "_.PLINE" (cadr (car pntlst)) lastpt "")
  621.       (setq copy-set (ssadd (entlast) copy-set))
  622.       (setq entset (ssadd (entlast) entset))
  623.     )
  624.   )
  625.  
  626.   (if thickness
  627.     (progn
  628.       (if firstbpt
  629.         (progn
  630.           (setq bp (pro-point firstbpt))
  631.           (setq t-list (cons (list 'quote bp) t-list))
  632.         )
  633.       )
  634.       (if lastbpt
  635.         (progn
  636.           (setq lp (pro-point lastbpt))
  637.           (setq t-list (cons (list 'quote lp) t-list))
  638.         )
  639.       )
  640.       (setq ctr 0)
  641.       (setq count (sslength copy-set))
  642.       (while (< ctr count)
  643.          (setq e (ssname copy-set ctr))
  644.          (command "_.COPY" e "" displace "")
  645.          (setq entset (ssadd (entlast) entset))
  646.          (setq ctr (1+ ctr))
  647.       )
  648.       (if (> (length t-list) 0)
  649.           (tessilate t-list)
  650.       )
  651.     )
  652.   )
  653.   (setq copy-set nil)
  654. )
  655.  
  656. (defun d-polyseg ()   ;project polyline segment
  657.   (setq v-pt (cdr (assoc 10 sublist)))
  658.   (setq v-pt (pro-point v-pt))
  659.   (setq pntlst (cons (list 'quote v-pt) pntlst))
  660.   (if (> (length pntlst) 1)
  661.     (progn
  662.       (eval (append '(command "_.PLINE") pntlst closure))
  663.       (setq copy-set (ssadd (entlast) copy-set))
  664.       (setq entset (ssadd (entlast) entset))
  665.       (setq t-list (cons (list 'quote v-pt) t-list))
  666.     )
  667.   )
  668.   (setq pntlst '())
  669. )
  670.  
  671. (defun d-bulge ()     ;project polyline bulge
  672.   (cvtbulge sp ep bulge)
  673.   (setq pntlst '(""))
  674.   (arc-draw center radius st-ang end-ang)
  675.   (eval (append '(command "_.PLINE") pntlst))
  676.   (command "_.PEDIT" (entlast) "_F" "_X")
  677.   (setq copy-set (ssadd (entlast) copy-set))
  678.   (setq entset (ssadd (entlast) entset))
  679.   (setq pntlst '())
  680. )
  681.  
  682. ;;;----- Project 3DFACE -- projected as lines or polyline ----
  683. ;;;    Will project visible edges only as lines.  If SPLFRAME
  684. ;;;    is set to 1, will project all edges as single polyline
  685.  
  686. (defun face-pro (/ bit-70 e1 e2 e3 e4 pt1 pt2 pt3 pt4)
  687.   (setq bit-70 (cdr (assoc 70 elist)))
  688.   (if (= (boole 1 bit-70 1) 1) (setq e1 T))
  689.   (if (= (boole 1 bit-70 2) 2) (setq e2 T))
  690.   (if (= (boole 1 bit-70 4) 4) (setq e3 T))
  691.   (if (= (boole 1 bit-70 8) 8) (setq e4 T))
  692.   (setq pt1 (pro-point (cdr (assoc 10 elist))))
  693.   (setq pt2 (pro-point (cdr (assoc 11 elist))))
  694.   (setq pt3 (pro-point (cdr (assoc 12 elist))))
  695.   (setq pt4 (pro-point (cdr (assoc 13 elist))))
  696.   (if (equal (getvar "splframe") 1)
  697.     (progn
  698.       (command "_.PLINE" pt1 pt2 pt3 pt4 "_C")
  699.       (setq entset (ssadd (entlast) entset))
  700.     )
  701.     (progn
  702.       (if (not e1)
  703.         (progn (command "_.LINE" pt1 pt2 "")
  704.                (setq entset (ssadd (entlast) entset))
  705.         )
  706.       )
  707.       (if (not e2)
  708.         (progn (command "_.LINE" pt2 pt3 "")
  709.                (setq entset (ssadd (entlast) entset))
  710.         )
  711.       )
  712.       (if (not e3)
  713.         (progn (command "_.LINE" pt3 pt4 "")
  714.                (setq entset (ssadd (entlast) entset))
  715.         )
  716.       )
  717.       (if (not e4)
  718.         (progn (command "_.LINE" pt4 pt1 "")
  719.                (setq entset (ssadd (entlast) entset))
  720.         )
  721.       )
  722.     )
  723.   )
  724. )
  725.  
  726. ;;;----- Project SOLID -- projected as single polyline -------
  727.  
  728. (defun solid-pro (/ planar c-type pntlst p-pt)
  729.   (setq planar T)
  730.   (setq pntlst '())     ;initialize point list for solid
  731.   (setq c-type 10) (findcorner)
  732.   (setq c-type 11) (findcorner)
  733.   (setq c-type 13) (findcorner)
  734.   (setq c-type 12) (findcorner)
  735.   (eval (append '(command "_.PLINE") pntlst)) (command "_C")
  736.   (setq entset (ssadd (entlast) entset))
  737.   (if thickness
  738.     (progn
  739.       (setq t-list pntlst)
  740.       (command "_.COPY" (entlast) "" displace "")
  741.       (setq entset (ssadd (entlast) entset))
  742.       (tessilate t-list)
  743.     )
  744.   )
  745. )
  746.  
  747. (defun findcorner (/ corner)
  748.   (setq corner (cdr (assoc c-type elist)))
  749.   (setq p-pt (pro-point corner))
  750.   (setq pntlst (cons (list 'quote p-pt) pntlst))
  751. )
  752.  
  753. ;;;----- Project POINT ---------------------------------------
  754.  
  755. (defun point-pro (/ wpta pt t-list)
  756.   (setq wpta (cdr (assoc 10 elist)))
  757.   (setq pt (pro-point wpta))
  758.   (setq pt (list (car pt) (cadr pt) 0))
  759.   (command "_.POINT" pt)
  760.   (setq entset (ssadd (entlast) entset))
  761.   (if thickness
  762.      (progn
  763.         (setq t-list (list (list 'quote pt)))
  764.         (command "_.COPY" (entlast) "" displace "")
  765.         (setq entset (ssadd (entlast) entset))
  766.         (tessilate t-list)
  767.      )
  768.   )
  769. )
  770.  
  771. ;;;----- Copy entity -----------------------------------------
  772.  
  773. (defun copy-ent (/ fr-pt to-pt)
  774.   (if (not ncolor) (getcolor))
  775.   (if proj2 (command "_.UCS" "_R" ucs-b))
  776.   (setq fr-pt (trans (cdr (assoc 10 elist)) ename 1))
  777.   (setq to-pt (list (car fr-pt) (cadr fr-pt) 0))
  778.   (command "_.COPY" ename "" fr-pt to-pt)
  779.   (command "_.CHPROP" (entlast) ""
  780.            "_C"  ncolor
  781.            "_LA" (getvar "clayer")
  782.            "_T" 0
  783.            ""
  784.   )
  785.   (setq entset (ssadd (entlast) entset))
  786.   (setq parallel nil)
  787. )
  788.  
  789. ;;;--------- Convert bulge information -----------------------
  790. ;;;  AutoLISP function to convert from Polyline "Bulge" representation
  791. ;;;  of an arc to AutoCAD's normal "center, radius, start/end angles"
  792. ;;;  form of arc.     This function applies the bulge between two adjacent
  793. ;;;  vertices.  It assumes that global symbols "sp", "ep", and "bulge"
  794. ;;;  contain the current vertex (start point), next vertex (end point),
  795. ;;;  and bulge, respectively.  It sets the appropriate values in global
  796. ;;;  symbols "center", "radius", "st-ang", and "end-ang".
  797.  
  798. ;;;  subroutine borrowed from
  799. ;;;  Duff Kurland - Autodesk, Inc.
  800. ;;;  July 7, 1986
  801.  
  802. (defun cvtbulge (sp ep bulge / x1 x2 y1 y2 cotbce)
  803.   (setq x1 (car  sp) x2 (car  ep))
  804.   (setq y1 (cadr sp) y2 (cadr ep))
  805.   (setq cotbce (/ (- (/ 1.0 bulge) bulge) 2.0))
  806.   ;;  Compute center point and radius
  807.   (setq center (list (/ (+ x1 x2 (- (* (- y2 y1) cotbce))) 2.0)
  808.                      (/ (+ y1 y2    (* (- x2 x1) cotbce) ) 2.0)
  809.                      (caddr sp)
  810.                )
  811.   )
  812.   (setq radius (distance center sp))
  813.   ;;  Compute start and end angles
  814.   (setq st-ang   (atan (- y1 (cadr center)) (- x1 (car center))))
  815.   (setq end-ang  (atan (- y2 (cadr center)) (- x2 (car center))))
  816.   (if (< st-ang 0.0)                  ;  Eliminate negative angles
  817.     (setq st-ang (+ st-ang (* 2.0 pi)))
  818.   )
  819.   (if (< end-ang 0.0)
  820.     (setq end-ang (+ end-ang (* 2.0 pi)))
  821.   )
  822.   (if (< bulge 0.0)                   ;  Swap angles if clockwise
  823.     (progn
  824.       (setq temp st-ang)
  825.       (setq st-ang end-ang)
  826.       (setq end-ang temp)
  827.     )
  828.   )
  829. )
  830.  
  831. ;;;----- Point projection Subroutine  ------------------------
  832.  
  833. (defun pro-point (pta-w / pta-a pta-b ptb-b ptb-w ptc-a
  834.                           ptc-b ptc-w ptx d1 new-ptb ang-a neg d2)
  835.   (if planar (setq pta-w (trans pta-w ename 0)))
  836.   (if proj2 ;if projecting to a designated plane (ucs-b)
  837.     (progn   ;then
  838.       (if (/= (getvar "ucsname") (strcase ucs-a))
  839.           (progn (command "_.UCS" "_R" ucs-a) (call))
  840.       )
  841.       (setq pta-a (trans pta-w 0 1))
  842.       (setq ptc-a (list (car pta-a) (cadr pta-a) (+ (caddr pta-a) 3)))
  843.       (setq ptc-w (trans ptc-a 1 0))
  844.       (command "_.UCS" "_R" ucs-b) (call)
  845.       (setq pta-b (trans pta-w 0 1))
  846.       (setq ptb-b (list (car pta-b) (cadr pta-b) 0.0))
  847.       (setq ptb-w (trans ptb-b 1 0))
  848.       (setq ptc-b (trans ptc-w 0 1))
  849.       (if          ;test for coincident points
  850.           (or (< (distance pta-b ptb-b) 0.0000000001)
  851.               (< (distance pta-b ptc-b) 0.0000000001)
  852.               (< (distance ptb-b ptc-b) 0.0000000001)
  853.               (equal (list (car ptb-b) (cadr ptb-b) 0)
  854.                      (list (car ptc-b) (cadr ptc-b) 0)
  855.                      0.0000000001
  856.               )
  857.           )
  858.         (progn   ;then no further projection is needed
  859.           (setq ptx ptb-b)
  860.         )
  861.         (progn   ;else do more calculations
  862.           (command "_.UCS" "3" pta-b ptc-b ptb-b) (call)
  863.           (setq d1 (distance pta-b ptb-b))
  864.           (setq new-ptb (trans ptb-w 0 1))
  865.           (setq ang-a (angle (list 0.0 0.0 0.0) new-ptb))
  866.           (if (> ang-a (/ pi 2))
  867.             (progn (setq ang-a (- pi ang-a)) (setq neg T))
  868.           )
  869.           (setq d2 (* (/ 1 (cos ang-a)) d1))
  870.           (if neg (setq d2 (- 0 d2)))
  871.           (setq neg nil)
  872.           (setq ptx (trans (list d2 0.0 0.0) 1 0))
  873.           (command "_.UCS" "_R" ucs-b) (call)
  874.           (setq ptx (trans ptx 0 1))
  875.           (list (car ptx) (cadr ptx) 0.0)
  876.         )
  877.       )
  878.     )
  879.     (progn   ;else project onto the current plane (ucs-a)
  880.       (setq pta-b (trans pta-w 0 1))
  881.       (setq ptb-b (list (car pta-b) (cadr pta-b) 0.0))
  882.     )
  883.   )
  884. )
  885.  
  886.  
  887. ;;;---- Find projected extrusion direction in current UCS ----
  888.  
  889. (defun u-vector (thk xtru / uv uv1 uv2 uv1-w uv2-w)
  890.   (setq uv (trans (list 0 0 thk) xtru 0 T))
  891.   (setq uv1 (pro-point '(0 0 0)))
  892.   (setq uv1-w (trans uv1 1 0))
  893.   (setq uv2 (pro-point uv))
  894.   (setq uv2-w (trans uv2 1 0))
  895.   (setq uvd (distance uv1 uv2))
  896.   (setq uvang (angle uv1 uv2))
  897.   (setq displace (polar '(0 0 0) uvang uvd))
  898.  
  899.  
  900.   (if (or (equal etype "CIRCLE")
  901.           (equal etype "ARC")
  902.           (equal etype "POLYLINE")
  903.       )
  904.     (progn
  905.       (if perpendicular
  906.         (progn
  907.           (setq uv2 (list (car uv2)
  908.                           (cadr uv2)
  909.                           (+ (caddr uv2) 0.000000000001)
  910.                     )
  911.           )
  912.           (setq uv2-w (trans uv2 1 0))
  913.         )
  914.       )
  915.       (e-vector)
  916.     )
  917.   )
  918. )
  919.  
  920. ;;;---- Find ECS angle that is parallel to projected u-dir ---
  921. ;;;    Also find silhouette angles (sang1 & sang2) to later
  922. ;;;    draw silhouette lines  extruded curves
  923.  
  924. (defun e-vector (/ ad-ang1 ad-ang-2)
  925.   (command "_.UCS" "_E" ename)
  926.   (command "_.UCS" "_S" "wtest")
  927.   (setq uv1-e (trans uv1-w 0 1))
  928.   (setq uv2-e (trans uv2-w 0 1))
  929.   (setq ad-ang1 (angle uv2-e uv1-e))
  930.   (setq ad-ang2
  931.       (angle (trans '(0 0 0) ename 1)
  932.              (trans (polar '(0 0 0) 0 1) ename 1)
  933.       )
  934.   )
  935.   (setq ad-ang2 (- (* 2 pi) ad-ang2))
  936.   (setq ad-ang (+ ad-ang1 ad-ang2))
  937.   (if (> ad-ang (* 2 pi)) (setq ad-ang (- ad-ang (* 2 pi))))
  938.   (setq sang1 (+ ad-ang (/ pi 2)))
  939.   (if (>= sang1 (* 2 pi)) (setq sang1 (- sang1 (* 2 pi))))
  940.   (setq sang2 (+ ad-ang (* 3 (/ pi 2))))
  941.   (if (>= sang2 (* 2 pi)) (setq sang2 (- sang2 (* 2 pi))))
  942.   (command "_.UCS" "_P")
  943. )
  944.  
  945. ;;;----- test parallel, thickness, then call *-pro function --
  946.  
  947. (defun proj-ent (/ t-list elist thickness
  948.                    extrusion tp planar uvang uvd ad-ang)
  949.   (setq elist (entget ename) etype (cdr (assoc 0 elist)))
  950.   (if (or (ucsp (trans '(0 0 1)  ename 0 T) udir)
  951.           (ucsp (trans '(0 0 -1) ename 0 T) udir)
  952.       )
  953.     (setq parallel T)
  954.     (setq parallel nil)
  955.   )
  956.  
  957.   (if proj2                           ;  ignore extrusions
  958.     (setq thickness nil ad-ang 0)
  959.     ;; else find thickness & extrusion direction
  960.     (if (setq thickness (cdr (assoc 39 elist)))
  961.       (progn
  962.         (setq extrusion (cdr (assoc 210 elist)))
  963.         (if (equal (distance extrusion udir)
  964.                    (sqrt 2) 0.000000000001
  965.             )
  966.           (setq perpendicular T)
  967.           (setq perpendicular nil)
  968.         )
  969.         (u-vector thickness extrusion)
  970.       )
  971.       (setq thickness nil ad-ang 0)
  972.     )
  973.   )
  974.  
  975.   (cond
  976.     ((eq etype "LINE")       (lines-pro))
  977.     ((eq etype "3DLINE")     (lines-pro))
  978.     ((eq etype "3DFACE")     (face-pro))
  979.     ((eq etype "POINT")      (point-pro))
  980.     ((eq etype "POLYLINE")   (pline-pro))
  981.     ((eq etype "CIRCLE")
  982.       (if parallel (copy-ent) (circ-pro)))
  983.     ((eq etype "ARC")
  984.       (if parallel (copy-ent) (arc-pro)))
  985.     ((eq etype "TRACE")
  986.       (if parallel (copy-ent) (solid-pro)))
  987.     ((eq etype "SOLID")
  988.       (if parallel (copy-ent) (solid-pro)))
  989.     (T
  990.       (if proj2
  991.         (prompt (strcat "\n╡L¬k╣∩íu" etype "ív╢iªµºδ╝v   "))
  992.         (setq reject-set (ssadd ename reject-set))
  993.       )
  994.     )
  995.   )
  996.   (princ (strcat (chr 008) (chr 008) (chr 008)))
  997. )
  998.  
  999. ;;;---- Select entities, find name, call proj-ent function ---
  1000.  
  1001. (defun get-ent (/ ename ptx ctr entities)
  1002.   (setq entities nil)
  1003.   (if proj2                           ;if project to plane
  1004.     (progn                            ;then get a single entity
  1005.       (setq ename (car (entsel "\n┐∩╛▄╣w│╞ºδ╝v¬║íu╣╧ñ╕ív: \n")))
  1006.       (if ename                       ;if found
  1007.         (progn                        ;then turn off icon and project
  1008.           (setvar "ucsicon" 0)
  1009.           (proj-ent)
  1010.         )
  1011.         (prompt "\nºΣñú¿∞╣╧ñ╕ ")
  1012.       )
  1013.       (command "_.UCS" "_R" ucs-a)       ;reset UCS
  1014.       (if ename (setvar "ucsicon" icon)) ;reset ucsicon
  1015.     )
  1016.     (progn                            ;else get a selection set
  1017.       (setq ctr 0)
  1018.       (if (setq entities (ssget))
  1019.         (progn
  1020.           (setq setlength (sslength entities))
  1021.           (prmpt)
  1022.           (while (setq ename (ssname entities ctr))
  1023.             (proj-ent)
  1024.             (setq ctr (+ ctr 1))
  1025.           )
  1026.           (if (> (setq n-of-ents (sslength reject-set)) 0)
  1027.             (progn
  1028.               (princ (strcat "\n" (itoa n-of-ents)
  1029.                              " ¡╙╣╧ñ╕Ñ╝íuºδ╝vív"
  1030.                      )
  1031.               )
  1032.               (setq tp 3)
  1033.               (redraw-rej reject-set tp) ;redraw rejection set
  1034.             )
  1035.           )
  1036.         )
  1037.         (prompt "\nºΣñú¿∞¬½┼Θ")
  1038.       )
  1039.     )
  1040.   )
  1041. )
  1042. ;;;---- Set variables, get projection plane, call (get-ent) -
  1043.  
  1044. (defun project (/ numctr ucs-a ucs-b n-color old-err
  1045.                   entset reject-set entities n-of-ents cudir udir notperp
  1046.                   perpt2 perpang)
  1047.   (modes '("cmdecho" "blipmode" "expert" "flatland"
  1048.            "gridmode" "osmode" "thickness")
  1049.   )
  1050.   (setq icon (getvar "ucsicon"))
  1051.   (mapcar 'setvar
  1052.     '("cmdecho" "blipmode" "expert" "flatland" "gridmode"
  1053.       "osmode" "thickness")
  1054.     '(0 0 4 0 0 0 0)
  1055.   )
  1056.   (setq planar nil numctr 1 neg nil parallel nil)
  1057.   (setq reject-set (ssadd))           ;initialize rejection set
  1058.   (setq entset (ssadd))               ;initialize block set
  1059.   (setq notperp T)
  1060.   (if proj2  ;if using C:PROJECT2
  1061.     (getplane)
  1062.     (setq udir (trans '(0 0 1) 1 0 T))
  1063.   )
  1064.   (setq cudir (trans '(0 0 1) 1 0 T)) ;current extrusion direction
  1065.   (setq u2 (cdr (assoc 210 elist)))
  1066.   (setq u1 (trans '(0 0 1) 1 0 T))
  1067.  
  1068.   (if (and proj2                      ;if UCS' are not parallel
  1069.            (and (not (ucsp cudir udir))
  1070.                 (not (equal (distance udir cudir) 2 0.000001))
  1071.            )
  1072.       )
  1073.     ;;test for perpendicular projection plane
  1074.     (if (equal (distance udir cudir) (sqrt 2) 0.00000000001)
  1075.       (progn
  1076.         (setq notperp nil)
  1077.         (prompt "\nUCS ¼Oíu½½¬╜ív¬║ ")
  1078.         (prompt "\n╡L¬k▒N╣╧ñ╕íuºδ╝vívª▄Ñ¡¡▒íC")
  1079.       )
  1080.       (setq notpert T)
  1081.     )
  1082.   )
  1083.  
  1084.   (if notperp    ;if projection plane is not perpendicular
  1085.     (progn
  1086.       (slayer)     ;get projection layer
  1087.       (get-ent)    ;continue with projection
  1088.       (initget "Yes No")
  1089.       (while       ;continue projecting more entities
  1090.         (eq (getkword "\nºδ╝v¿ΣѪ╣╧ñ╕? Y/N <N>: ") "Yes" )
  1091.         (setq tp 1)
  1092.         (if n-of-ents (redraw-rej reject-set tp))
  1093.         (setq reject-set (ssadd))
  1094.         (get-ent)
  1095.         (initget "Yes No")
  1096.       )
  1097.     )
  1098.   )
  1099.   (setq tp 1)
  1100.   (if n-of-ents (redraw-rej reject-set tp))
  1101.  
  1102.   (if (and (not proj2) (/= (sslength entset) 0))
  1103.     (progn
  1104.       (initget "Yes No")
  1105.       (if (eq (getkword "\n½╪ª¿íu╣╧╕sív? <N>: ") "Yes")
  1106.         (make-blk entset)
  1107.         (progn
  1108.           (initget "Yes No")
  1109.           (if (eq (getkword "\n╝gª¿ DWG └╔«╫? <N>: ") "Yes")
  1110.               (write-blk entset)
  1111.           )
  1112.         )
  1113.       )
  1114.     )
  1115.   )
  1116.  
  1117.   (if proj2     ;if you used C:PROJECT2
  1118.     (progn      ;then delete temporary ucs'
  1119.       (command "_.UCS" "_D" ucs-a)
  1120.       (if (= ucs-b "$$PLANE-B") (command "_.UCS" "_D" ucs-b))
  1121.     )
  1122.   )
  1123.  
  1124.   (moder)
  1125.   (setq ncolor nil)
  1126.   (setvar "ucsicon" icon)
  1127.   (setq *error* olderr)  ;reset error function
  1128.   (princ)
  1129. )
  1130.  
  1131. (defun C:PROJECT1 ()
  1132.   (if (not err-set)
  1133.       (setq olderr *error* *error* proj-err)
  1134.   )
  1135.   (setq proj2 nil)
  1136.   (project)
  1137.   (princ)
  1138. )
  1139.  
  1140. (defun C:PROJECT2 ()
  1141.   (if (not err-set)
  1142.       (setq olderr *error* *error* proj-err)
  1143.   )
  1144.   (setq proj2 T)
  1145.   (project)
  1146.   (princ)
  1147. )
  1148.  
  1149. (defun C:PROJECT (/ choice err-set)
  1150.   (setq olderr *error* *error* proj-err)
  1151.   (setq err-set T)
  1152.   (textscr)
  1153.   (prompt "\n\n\n\n\n\n\n")
  1154.   (prompt "------------------------------ PROJECT.LSP ------------------------\n")
  1155.  
  1156.   (prompt "\n1) PROJECT1")
  1157.   (prompt "\n    ñ╣│\▒Níu╜u║c╝╥½¼ív( ╜u, ⌐╖, ╢Ω, ╗EªX╜u, ╣╧╢⌠, ┬I )")
  1158.   (prompt "\n    ºδ╝vªbíuÑ╪½e UCSívñWíC╣∩⌐≤╣BÑ╬3D╝╥½¼¿╙▓úÑ═ñuº@╣╧º╬")
  1159.   (prompt "\n    ¬║º@╖~ª╙¿Ñ, Ñi»α¼█╖φ╣ΩÑ╬íC\n")
  1160.   (prompt "\n    ºδ╝vñº½ß, Ñ╬ñßÑτÑi▒Nºδ╝vª╙▒o¬║╣╧ñ╕┬α╗sª¿íu╣╧╕sív, ")
  1161.   (prompt "\n    ⌐╬¼OÑHíu╣╧└╔ív¬║º╬ªí╝gªsª▄║╧║╨ñWíC")
  1162.   (prompt "\n    │o¿╟íu╣╧╕sív⌐╬íu╣╧└╔ív( ñ@»δ¼╥¼░: ñW╡°, ½e╡°, ░╝╡°")
  1163.   (prompt "\n    , ╡Ñ¿ñºδ╝v )Ñi⌐≤│µñ@¬║ UCSññªAªµíu┤íñ▐ív, ªP«╔ñ⌐ÑH")
  1164.   (prompt "\n    Ñ[╡∙ª╙¿╙½╪Ñ▀ªh╡°╣╧¬║╣╧¡▒íC\n")
  1165.   (prompt "\n2) PROJECT2")
  1166.   (prompt "\n    ª╣▒`ªíÑi▒N╣╧ñ╕ºδ╝vª▄½½¬╜íuÑ╪½e UCSív¬║╣w⌐wíu½╪║cÑ¡")
  1167.   (prompt "\n    ¡▒ívñW; ª╣Ñ\»α╣∩⌐≤½╪Ñ▀íu3D╜u║c╝╥½¼ívÑi»α¼█╖φ╣ΩÑ╬íC\n")
  1168.   (prompt "\n    ªp¬GÑ╬ñß╖Q▓ñ╣Lª╣┐∩│µ¬║╕▄, ÑiÑH¬╜▒╡ªb½ⁿÑO┤úÑ▄ñU┐ΘñJ")
  1169.   (prompt "\n    PROJECT1 ⌐╬ PROJECT2 íC\n")
  1170.   (if (and (= (substr (getvar "acadver") 1 2) "10")
  1171.            (/= (substr (getvar "acadver") 1 6) "10 c10")
  1172.       )
  1173.     (progn
  1174.       (prompt "\n╣∩⌐≤Ñ╝¿╧Ñ╬íuExtended AutoLISPív¬║ DOS ¬⌐Ñ╬ñߪ╙¿Ñ:")
  1175.       (prompt "\n             *** LISPHEAP  └││]¼░ 35000 ***")
  1176.       (prompt "\n             *** LISPSTACK └││]¼░ 10000 ***")
  1177.     )
  1178.     (prompt"\n\n")
  1179.   )
  1180.  
  1181.   (initget "1 2")
  1182.   (setq choice (getkword "\n┐ΘñJ╣w│╞▒─Ñ╬¬║íuºδ╝v├■½¼ív(1 ⌐╬ 2) <1>: "))
  1183.   (if (or (equal choice "1")
  1184.           (equal choice nil)
  1185.       )
  1186.     (C:PROJECT1)
  1187.     (C:PROJECT2)
  1188.   )
  1189.   (princ)
  1190. )
  1191.  
  1192. (prompt "C:PROJECT")
  1193. (princ)
  1194.  
  1195.