Liren Large Software Subsidy 13/13.iso/p/p024/5.img/R11SUPP.EXE/PROJECT.LSP

Lisp/Scheme | 1990-09-10 | 36.4 KB | 1,198 lines

;;;  PROJECT.LSP / Release 10 or 11
;;;  Copyright (C) 1990 by Autodesk, Inc.
;;;
;;;   Permission to use, copy, modify, and distribute this software and its
;;;   documentation for any purpose and without fee is hereby granted.
;;;
;;;   THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED WARRANTY.
;;;   ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR PURPOSE AND OF
;;;   MERCHANTABILITY ARE HEREBY DISCLAIMED.
;;;
;;;--------------------------------------------------------------------------
;;; DESCRIPTION
;;;
;;;  This LISP routine allows for two different kinds of
;;;  projection.  The commands are named:
;;;
;;;     PROJECT
;;;     PROJECT1
;;;     PROJECT2
;;;
;;;  An explanation of each command is shown below.
;;;
;;;  (C:PROJECT)
;;;  Calls up a menu with a choice of projections.
;;;
;;;  (C:PROJECT1)
;;;  Allows a "flat" projection of wireframe 3D models (lines,
;;;  arcs, circles, polylines, solids, points) onto the current
;;;  UCS.  This could be a useful aid for generating working
;;;  drawings from a 3D model.  Width information will be
;;;  ignored.   Entities not capable of projection (3Dmesh,
;;;  text, blocks) will be highlighted and tallied.
;;;
;;;  After projection, the user is allowed to make the
;;;  projected entities into a block, or write it out as a
;;;  drawing file.  These blocks or drawing files (typically
;;;  Top, Front, Side, and Iso projections) could be re-
;;;  inserted onto a single UCS and annotated to create a
;;;  multi-view orthographic drawing.  The prompt sequence is:
;;;
;;;    Layer name <current>:
;;;    Select entities:  {do so}
;;;    Project more entities? <N>:  {Y or N}
;;;    Make projected entity(s) into a block? <N>:  {Y or N}
;;;    Write projected entities to disk as DWG file? <N>:  {Y or N}
;;;
;;;
;;;  (C:PROJECT2)
;;;  This routine projects an entity normal from the current
;;;  UCS onto a designated oblique construction plane.  This
;;;  may be useful in the construction of 3D wireframe and
;;;  surface models.
;;;
;;;  The user is prompted to enter the name of the UCS he
;;;  wishes to project onto, or to select 3 points which lie on
;;;  the construction plane.  The prompt sequence is:
;;;
;;;    Layer name <current>:
;;;    UCS namd or <RETURN> to select 3 points:
;;;    Select entities:  {do so}
;;;    Project more entities? <N>:  {Y or N}
;;;
;;;  Lines, arcs, circles, solids, 3d faces, polylines, and
;;;  3d polylines will be projected.  The routine will not
;;;  project text, meshes, or blocks.  Width information will
;;;  be ignored.
;;;
;;;  *** Word of Caution ***
;;;  If you try to project an entity onto a plane that is near
;;;  perpendicular to the current plane, then the entity will
;;;  be projected over a very great distance.  When you do a
;;;  "ZOOM All" your drawing will appear to disappear.
;;;
;;;  Autodesk Training Department
;;;  9/10/90
;;;
;;;-----------------------------------------------------------

(vmon)

;;;  Won't fit in 40K heap unless VMON is enabled
;;;  Extended AutoLISP is highly recommended

;;;----- Redefined error function ----------------------------

(defun proj-err (s)
  (if (/= s "Function cancelled")
      (princ (strcat "\nError: " s))
  )
  (setq *error* olderr)
  (setvar "ucsicon" icon)
  (setq copy-set nil
        entset nil
        entities nil
        reject-set nil
        err-set nil
  )
  (moder)
  (princ)
)

;;;----- Superfulous translation counter ---------------------

(defun call ()
  (princ (strcat (chr 008) (chr 008) (chr 008)))
  (if (= numctr 1) (princ "  |"))
  (if (= numctr 2) (princ "  /"))
  (if (= numctr 3) (princ "  -"))
  (if (= numctr 4) (princ "  \\"))
  (setq numctr (+ 1 numctr))
  (if (= numctr 5) (setq numctr 1))
)

;;;----- Mode Save -- Saves system variables in a list -------

(defun MODES (a)
  (setq MLST '())
  (repeat (length a)
    (setq MLST (append MLST (list (list (car a) (getvar (car a))))))
    (setq a (cdr a))
  )
)

;;;----- Mode Reset -- Resets system variables ---------------

(defun MODER ()
  (repeat (length MLST)
    (setvar (caar MLST) (cadar MLST))
    (setq MLST (cdr MLST))
  )
)

;;;----- Converts radians to degrees -------------------------

(defun rtd (r)
  (* 180 (/ r pi))
)

;;;----- Find current entity color ---------------------------

(defun getcolor (/ max ctr ccolor)
  (setq ncolor nil)
  (setq ccolor (getvar "cecolor"))
  (setq ctr 1)
  (setq max (strlen ccolor))
  (while (< ctr max)
    (if (= (substr ccolor ctr 1) " ")
      (progn
         (setq ncolor (substr ccolor 1 (- ctr 1)))
         (setq ctr max)
      )
      (setq ctr (1+ ctr))
    )
  )
  (if (not ncolor) (setq ncolor ccolor))
)

;;;----- Redraw rejected entities ----------------------------

(defun redraw-rej (ss tp / r-ctr)
  (if (not proj2)
    (progn
      (setq r-ctr 0)
      (while (> n-of-ents r-ctr)
        (redraw (ssname ss r-ctr) tp)
        (setq r-ctr (1+ r-ctr))
      )
    )
  )
)

;;;----- "Please wait ..." function --------------------------

(defun prmpt ()
  (prompt "\nProjecting . . .     please wait \n")
)

;;;----- UCS parallel check ----------------------------------

(defun ucsp (edir udir / arbval dx dy dz)
  (setq dx     (- (car edir) (car udir))
        dy     (- (cadr edir) (cadr udir))
        dz     (- (caddr edir) (caddr udir))
        arbval (/ 1.0 64.0)
  )
  (if (< (+ (* dx dx) (* dy dy) (* dz dz)) 1E-20)
    (equal (and (< (abs (car edir)) arbval) (< (abs (cadr edir))))
           (and (< (abs (car udir)) arbval) (< (abs (cadr udir))))
    )
    nil
  )
)

;;;----- Select projection plane (for use with "PROJECT2") ---

(defun getplane (/ 1st 2nd 3rd)
  (setq ucs-a "$$PLANE-A")
  (command "ucs" "s" ucs-a)
  (setq ucs-b
    (getstring "\nUCS name or <RETURN> to select 3 points: ")
  )
  (while (and (not (tblsearch "UCS" ucs-b))
              (/= ucs-b "")
         )
    (prompt "\nUCS does not exist ")
    (setq ucs-b
      (getstring "\nUCS name or <RETURN> to select 3 points: ")
    )
  )
  (if (= ucs-b "")                    ;if you hit <RETURN>
    (progn                            ;then select new UCS
      (setq 1st (getpoint "\nOrigin point: "))
      (setq 2nd (getpoint 1st "\nPoint on positive portion of X-axis: "))
      (setq 3rd
       (getpoint 1st "\nPoint on positive portion of the UCS X-Y plane: ")
      )
      (command "ucs" "3" 1st 2nd 3rd)
      (setq ucs-b "$$PLANE-B")
      (command "ucs" "s" ucs-b)
    )
    (command "ucs" "r" ucs-b)         ;else restore named UCS
  )
  (setq udir (trans '(0 0 1) 1 0 T))
  (command "ucs" "p")
)

;;;----- Set projection layer --------------------------------

(defun slayer (/ clay laynam)
 (setq clay (getvar "CLAYER"))
 (setq laynam (getstring (strcat "\nLayer name <" clay ">: ")))
 (if (not (= laynam ""))
   (progn
     (while (not (tblsearch "LAYER" laynam))
       (prompt (strcat "\nCannot find layer " laynam))
       (setq laynam (getstring (strcat "\nLayer name <" clay ">: ")))
       (if (= laynam "") (setq laynam clay))
     )
     (if (not (= laynam clay))
       (command "layer" "s" laynam "")
     )
   )
 )
)

;;;----- Make BLOCK from projected entities ------------------

(defun make-blk (ss / blknam blkflg ip)
 (while (= (setq blknam (getstring "\nBlock name: ")) "")
        (prompt "\nBlock name not specified - Try again!")
 )
 (setq blkflg "")  ;init flag to redefine exist block
 (if (tblsearch "BLOCK" blknam)
   (while
     (and (tblsearch "BLOCK" blknam) (not (eq blkflg "Yes")))
     (prompt (strcat "\nBlock " blknam " already exists. "))
     (initget "Yes No")
     (setq blkflg (getkword "\nRedefine it? <N>: "))
     (if (/= blkflg "Yes")
         (setq blknam (getstring "\Block name: "))
     )
   )
 )
 (setq ip (getpoint "\nInsertion point <UCS 0,0,0>: "))
 (if (not ip) (setq ip '(0 0 0)))
 (command "block" blknam ip ss "")
 (command "regenall")
)

;;;----- Write projected entities to disk as DWG file --------

(defun write-blk (ss / flname dwgflg filept ip)
  (while (= (setq flname (getstring "\nFile name: ")) "")
         (prompt "\nFile name not specified - Try again!")
  )
  (setq dwgflg "")                    ;initialize flag to redefine exist file
  (if                                 ;file of same name?
    (setq filept (open (strcat flname ".DWG") "r"))
    (progn
      (setq filept (close filept))  ;close file
      (while
        (and (setq filept (open (strcat flname ".DWG") "r"))
             (not (eq dwgflg "Yes"))
        )
        (prompt (strcat "\nFile " flname " already exists. "))
        (initget "Yes No")
        (setq dwgflg (getkword "\nOverwrite it? <N>: "))
        (if (/= dwgflg "Yes")
          (progn
            (setq filept (close filept))
            (setq flname (getstring "\File name: "))
          )
          (setq filept (close filept))
        )
      )
    )
  )
  (setq ip (getpoint "\nInsertion point <UCS 0,0,0>: "))
  (if (not ip) (setq ip '(0 0 0)))
  (command "wblock" flname "" ip ss "")
  (command "regenall")
)

;;;----- Insert extra vertex for bulges & arcs ---------------
;;;   This is to allow for exact tangency of silhouette edges
;;;   on curved enitities that have a thickness
;;;   sang1 & sang2 are silhouette angles

(defun insert-tv (/ p-pt)
  (if (and (>  sang1 (+ st-ang (* p-ctr angmult)))
           (<= sang1 (+ st-ang (* (+ p-ctr 1) angmult)))
      )
    (progn
      (setq p-pt (pro-point (polar center sang1 radius)))
      (setq pntlst (cons (list 'quote p-pt) pntlst))
    )
  )
  (if (and (>  sang2 (+ st-ang (* p-ctr angmult)))
           (<= sang2 (+ st-ang (* (+ p-ctr 1) angmult)))
      )
    (progn
      (setq p-pt (pro-point (polar center sang2 radius)))
      (setq pntlst (cons (list 'quote p-pt) pntlst))
    )
  )
)

;;;---- Increase # of vertices  ------------------------------
;;;   If silhouette lines need to be drawn then increase the
;;;   number of vertices in pline that approximates the curve

(defun bump-ver ()
  (if (or S1 S2)
    (cond
      ((< incl-ang (/ pi 8)) (setq pt-num 6))
      ((< incl-ang (/ pi 4)) (setq pt-num 8))
      ((< incl-ang (/ pi 2)) (setq pt-num 10))
      ((< incl-ang (/ pi 1.5)) (setq pt-num 12))
      ((< incl-ang pi) (setq pt-num 14))
      (T (setq pt-num 18))
    )
  )
  (if (and S1 S2) (setq pt-num 18))
)

;;;----- Find silhouette edge point of arc or circle ---------

(defun s-edge (cntr rad ang / pt c)
  (setq c  (pro-point cntr))
  (setq pt (pro-point (polar cntr (+ ad-ang ang) rad)))
  (setq t-list (cons (list 'quote pt) t-list))
)

;;;---- Draw silhouette lines & edges of thick entities  -----

(defun tessilate (t-list / bp tesline ncopy)
  (setq bp (eval (car t-list)))
  (setq t-list (cdr t-list))
  (command "line" bp (polar bp uvang uvd) "")
  (setq entset (ssadd (entlast) entset))
  (setq tesline (entlast))
  (while (setq ncopy (eval (car t-list)))
    (command "copy" tesline "" bp ncopy)
    (setq entset (ssadd (entlast) entset))
    (setq t-list (cdr t-list))
  )
)

;;;----- Project LINE ----------------------------------------

(defun lines-pro (/ stpt endpt pntlst t-list)
  (setq stpt  (cdr (assoc 10 elist))
        endpt (cdr (assoc 11 elist))
  )
  (setq stpt  (pro-point stpt))
  (setq endpt (pro-point endpt))
  (setq pntlst (list (list 'quote stpt)
                     (list 'quote endpt)
               )
  )
  (eval (append '(command "line") pntlst '("")))
  (setq entset (ssadd (entlast) entset))
  (if thickness
    (progn
      (setq t-list pntlst)
      (command "copy" (entlast) "" displace "")
      (setq entset (ssadd (entlast) entset))
      (tessilate t-list)
    )
  )
)

;;;-----Project CIRCLE -- projected as curve fit polyline ----
;;;  derived 0.3926990817 with (/ (* 2 pi) 16)

(defun circ-pro (/ planar radius center p-pt pntlst t-list)
  (setq planar T
        radius (cdr (assoc 40 elist))
        center (cdr (assoc 10 elist))
        p-ctr  0
        pntlst '("c")                 ;initialize pt list for PLINE command
        t-list '()
  )

  (while (< p-ctr 16)
    (setq p-pt
      (polar center (+ (* p-ctr 0.3926990817) ad-ang) radius)
    )
    (setq p-pt
      (list (car p-pt) (cadr p-pt) (caddr center))
    )
    (setq p-pt (pro-point p-pt))
    (setq pntlst (cons (list 'quote p-pt) pntlst))
    (setq p-ctr (1+ p-ctr))
  )
  (eval (append '(command "pline") pntlst))
  (command "pedit" (entlast) "f" "x")

  (setq entset (ssadd (entlast) entset))
  (if thickness
    (progn
      (command "copy" (entlast) "" displace "")
      (setq entset (ssadd (entlast) entset))
      (s-edge center radius (/ pi 2))
      (s-edge center radius (- 0 (/ pi 2)))
      (tessilate t-list)
    )
  )
)

;;;----- Project ARC -- projected as curve fit polyline ------
;;;   derive 6.2831853072 with (* 2 pi)

(defun arc-pro (/ center radius st-ang end-ang planar
                  pntlst t-list)
  (setq center (cdr (assoc 10 elist))
      radius (cdr (assoc 40 elist))
      st-ang (cdr (assoc 50 elist))
      end-ang (cdr (assoc 51 elist))
      planar T
  )

  (arc-draw center radius st-ang end-ang)

  (eval (append '(command "pline") pntlst '("")))
  (command "pedit" (entlast) "f" "x")
  (setq entset (ssadd (entlast) entset))
  (if thickness
    (progn
      (command "copy" (entlast) "" displace "")
      (setq entset (ssadd (entlast) entset))
      (setq t-list (cons (car pntlst) t-list))
      (setq t-list (cons (last pntlst) t-list))
      (tessilate t-list)
    )
  )
)

(defun arc-draw (center radius st-ang end-ang / pt-num
                 incl-ang angmult p-ctr edgetest S1 S2 p-pt)
  (setq incl-ang (- end-ang st-ang) p-ctr 0)
  (if (< incl-ang 0)
    (setq incl-ang (+ 6.2831853072 incl-ang))
  )
  (if thickness
    ;;then check if silhoulette lines need to be drawn
    (progn
      (setq end-ang (+ st-ang incl-ang))
      (while (>= end-ang (* 2 pi))
        (setq end-ang (- end-ang  (* 2 pi)))
      )
      (setq edgetest (- end-ang sang1))
      (if (< edgetest 0)
        (setq edgetest (+ edgetest (* 2 pi)))
      )
      (if (> incl-ang edgetest)
        (progn
          (s-edge center radius (/ pi 2))
          (setq S1 T)
        )
      )
      (setq edgetest (- end-ang sang2))
      (if (<= edgetest 0)
        (setq edgetest (+ edgetest (* 2 pi)))
      )
      (if (> incl-ang edgetest)
        (progn
          (s-edge center radius (- 0 (/ pi 2)))
          (setq S2 T)
        )
      )
    )
  )

  (setq pt-num (fix (+ 1 (/ incl-ang 0.3927))))
  (if (< pt-num 4) (setq pt-num 4))   ;minimum # of vertex
  (if thickness (bump-ver))
  (setq angmult (/ incl-ang (- pt-num 1)))
  (while (< p-ctr pt-num)
    (setq p-pt
      (polar center (+ st-ang (* p-ctr angmult)) radius)
    )
    (setq p-pt
      (list (car p-pt) (cadr p-pt) (caddr center))
    )
    (setq p-pt (pro-point p-pt))
    (setq pntlst (cons (list 'quote p-pt) pntlst))
    (if thickness
        (if (< p-ctr (1- pt-num)) (insert-tv))
    )
    (setq p-ctr (1+ p-ctr))
  )
)

;;;----- Project PLINE -- projected as polyline(s) -----------

(defun pline-pro (/ planar bit-70 close-pt pntlst copy-set t-list)
  (setq planar nil copy-set nil t-list nil)
  (setq copy-set (ssadd))
  (setq bit-70 (cdr (assoc 70 elist)));type of polyline
  (if (= (boole 1 bit-70 1) 1)        ;if closed
    (setq close-pt                    ;save first vertex
      (cdr (assoc 10 (entget (entnext ename))))
    )
    (setq close-pt nil)
  )
  (if (= (boole 1 bit-70 5) 5)        ;closed spline
    (progn
      (setq closure '("c"))
      (setq close-pt nil)
    )
    (setq closure '(""))
  )

  (cond
    ((= (boole 1 bit-70 8) 8)         ;space poly
      (setq planar 0) (pline-dr)
    )
    ((= (boole 1 bit-70 16) 16)       ;3D-mesh
      (if proj2 (prompt "\nCan't project 3DMESH   "))
      (setq reject-set (ssadd ename reject-set))
    )
    ((= (boole 1 bit-70 64) 64)       ;Polyface
      (if proj2 (prompt "\nCan't project Polyface MESH   "))
      (setq reject-set (ssadd ename reject-set))
    )
    (t (setq planar T)                ;then it must be 2D poly
      (if parallel (copy-ent) (pline-dr))
    )
  )
)

(defun pline-dr (/ subname sublist sub-etype bulge
                   sp ep ctr firstbpt v-pt b-flag lastbpt)
  (setq subname (entnext ename))
  (setq sublist (entget subname))
  (if (not close-pt) (setq b-flag T)) ;to flag first bulge
  (while                              ;while there is a vertex
    (eq (setq sub-etype (cdr (assoc 0 sublist))) "VERTEX")
    (if                               ;if not spline frame pt
      (/= (logand (cdr (assoc 70 sublist)) 16) 16)
      (progn                          ;then test for bulge, if so
        (if (/= (setq bulge (cdr (assoc 42 sublist))) 0)
          (progn                      ;then
            (d-polyseg)               ;project poly-segment
            (setq sp (cdr (assoc 10 sublist))) ;new stpt for pline
            (if                       ;if end of bulge
              (setq ep (cdr (assoc 10 (entget (entnext subname)))))
              (progn
                (if b-flag (setq firstbpt sp))
                (setq b-flag nil)
                (setq lastbpt ep)
                (d-bulge)             ;then project polyarc
              )
              (if close-pt            ;else if polyline is closed
                (progn                ;then project closure of polyarc
                  (setq ep close-pt)
                  (d-bulge)
                  (setq close-pt nil)
                  (setq lastbpt nil)
                )
              )
            )
          )
          (progn                      ;store vertex in point list
            (setq b-flag nil)
            (setq lastbpt nil)
            (setq v-pt (cdr (assoc 10 sublist)))
            (setq v-pt (pro-point v-pt))
            (setq pntlst (cons (list 'quote v-pt) pntlst))
            (setq t-list (cons (list 'quote v-pt) t-list))
          )
        )
      )
    )
    (setq subname (entnext subname))
    (setq sublist (entget subname))
  )                                   ;end of while loop

  (if pntlst (eval (append '(command "pline") pntlst closure)))
  (setq copy-set (ssadd (entlast) copy-set))
  (setq entset (ssadd (entlast) entset))

  (if close-pt                        ;close polyline
    (progn
      (setq lastpt (pro-point close-pt))
      (command "pline" (cadr (car pntlst)) lastpt "")
      (setq copy-set (ssadd (entlast) copy-set))
      (setq entset (ssadd (entlast) entset))
    )
  )

  (if thickness
    (progn
      (if firstbpt
        (progn
          (setq bp (pro-point firstbpt))
          (setq t-list (cons (list 'quote bp) t-list))
        )
      )
      (if lastbpt
        (progn
          (setq lp (pro-point lastbpt))
          (setq t-list (cons (list 'quote lp) t-list))
        )
      )
      (setq ctr 0)
      (setq count (sslength copy-set))
      (while (< ctr count)
         (setq e (ssname copy-set ctr))
         (command "copy" e "" displace "")
         (setq entset (ssadd (entlast) entset))
         (setq ctr (1+ ctr))
      )
      (if (> (length t-list) 0)
          (tessilate t-list)
      )
    )
  )
  (setq copy-set nil)
)

(defun d-polyseg ()   ;project polyline segment
  (setq v-pt (cdr (assoc 10 sublist)))
  (setq v-pt (pro-point v-pt))
  (setq pntlst (cons (list 'quote v-pt) pntlst))
  (if (> (length pntlst) 1)
    (progn
      (eval (append '(command "pline") pntlst closure))
      (setq copy-set (ssadd (entlast) copy-set))
      (setq entset (ssadd (entlast) entset))
      (setq t-list (cons (list 'quote v-pt) t-list))
    )
  )
  (setq pntlst '())
)

(defun d-bulge ()     ;project polyline bulge
  (cvtbulge sp ep bulge)
  (setq pntlst '(""))
  (arc-draw center radius st-ang end-ang)
  (eval (append '(command "pline") pntlst))
  (command "pedit" (entlast) "f" "x")
  (setq copy-set (ssadd (entlast) copy-set))
  (setq entset (ssadd (entlast) entset))
  (setq pntlst '())
)

;;;----- Project 3DFACE -- projected as lines or polyline ----
;;;    Will project visible edges only as lines.  If SPLFRAME
;;;    is set to 1, will project all edges as single polyline

(defun face-pro (/ bit-70 e1 e2 e3 e4 pt1 pt2 pt3 pt4)
  (setq bit-70 (cdr (assoc 70 elist)))
  (if (= (boole 1 bit-70 1) 1) (setq e1 T))
  (if (= (boole 1 bit-70 2) 2) (setq e2 T))
  (if (= (boole 1 bit-70 4) 4) (setq e3 T))
  (if (= (boole 1 bit-70 8) 8) (setq e4 T))
  (setq pt1 (pro-point (cdr (assoc 10 elist))))
  (setq pt2 (pro-point (cdr (assoc 11 elist))))
  (setq pt3 (pro-point (cdr (assoc 12 elist))))
  (setq pt4 (pro-point (cdr (assoc 13 elist))))
  (if (equal (getvar "splframe") 1)
    (progn
      (command "pline" pt1 pt2 pt3 pt4 "c")
      (setq entset (ssadd (entlast) entset))
    )
    (progn
      (if (not e1)
        (progn (command "line" pt1 pt2 "")
               (setq entset (ssadd (entlast) entset))
        )
      )
      (if (not e2)
        (progn (command "line" pt2 pt3 "")
               (setq entset (ssadd (entlast) entset))
        )
      )
      (if (not e3)
        (progn (command "line" pt3 pt4 "")
               (setq entset (ssadd (entlast) entset))
        )
      )
      (if (not e4)
        (progn (command "line" pt4 pt1 "")
               (setq entset (ssadd (entlast) entset))
        )
      )
    )
  )
)

;;;----- Project SOLID -- projected as single polyline -------

(defun solid-pro (/ planar c-type pntlst p-pt)
  (setq planar T)
  (setq pntlst '())     ;initialize point list for solid
  (setq c-type 10) (findcorner)
  (setq c-type 11) (findcorner)
  (setq c-type 13) (findcorner)
  (setq c-type 12) (findcorner)
  (eval (append '(command "pline") pntlst)) (command "c")
  (setq entset (ssadd (entlast) entset))
  (if thickness
    (progn
      (setq t-list pntlst)
      (command "copy" (entlast) "" displace "")
      (setq entset (ssadd (entlast) entset))
      (tessilate t-list)
    )
  )
)

(defun findcorner (/ corner)
  (setq corner (cdr (assoc c-type elist)))
  (setq p-pt (pro-point corner))
  (setq pntlst (cons (list 'quote p-pt) pntlst))
)

;;;----- Project POINT ---------------------------------------

(defun point-pro (/ wpta pt t-list)
  (setq wpta (cdr (assoc 10 elist)))
  (setq pt (pro-point wpta))
  (setq pt (list (car pt) (cadr pt) 0))
  (command "point" pt)
  (setq entset (ssadd (entlast) entset))
  (if thickness
     (progn
        (setq t-list (list (list 'quote pt)))
        (command "copy" (entlast) "" displace "")
        (setq entset (ssadd (entlast) entset))
        (tessilate t-list)
     )
  )
)

;;;----- Copy entity -----------------------------------------

(defun copy-ent (/ fr-pt to-pt)
  (if (not ncolor) (getcolor))
  (if proj2 (command "ucs" "r" ucs-b))
  (setq fr-pt (trans (cdr (assoc 10 elist)) ename 1))
  (setq to-pt (list (car fr-pt) (cadr fr-pt) 0))
  (command "copy" ename "" fr-pt to-pt)
  (command "chprop" (entlast) ""
           "c"  ncolor
           "la" (getvar "clayer")
           "t" 0
           ""
  )
  (setq entset (ssadd (entlast) entset))
  (setq parallel nil)
)

;;;--------- Convert bulge information -----------------------
;;;  AutoLISP function to convert from Polyline "Bulge" representation
;;;  of an arc to AutoCAD's normal "center, radius, start/end angles"
;;;  form of arc.     This function applies the bulge between two adjacent
;;;  vertices.  It assumes that global symbols "sp", "ep", and "bulge"
;;;  contain the current vertex (start point), next vertex (end point),
;;;  and bulge, respectively.  It sets the appropriate values in global
;;;  symbols "center", "radius", "st-ang", and "end-ang".

;;;  subroutine borrowed from
;;;  Duff Kurland - Autodesk, Inc.
;;;  July 7, 1986

(defun cvtbulge (sp ep bulge / x1 x2 y1 y2 cotbce)
  (setq x1 (car  sp) x2 (car  ep))
  (setq y1 (cadr sp) y2 (cadr ep))
  (setq cotbce (/ (- (/ 1.0 bulge) bulge) 2.0))
  ;;  Compute center point and radius
  (setq center (list (/ (+ x1 x2 (- (* (- y2 y1) cotbce))) 2.0)
                     (/ (+ y1 y2    (* (- x2 x1) cotbce) ) 2.0)
                     (caddr sp)
               )
  )
  (setq radius (distance center sp))
  ;;  Compute start and end angles
  (setq st-ang   (atan (- y1 (cadr center)) (- x1 (car center))))
  (setq end-ang  (atan (- y2 (cadr center)) (- x2 (car center))))
  (if (< st-ang 0.0)                  ;  Eliminate negative angles
    (setq st-ang (+ st-ang (* 2.0 pi)))
  )
  (if (< end-ang 0.0)
    (setq end-ang (+ end-ang (* 2.0 pi)))
  )
  (if (< bulge 0.0)                   ;  Swap angles if clockwise
    (progn
      (setq temp st-ang)
      (setq st-ang end-ang)
      (setq end-ang temp)
    )
  )
)

;;;----- Point projection Subroutine  ------------------------

(defun pro-point (pta-w / pta-a pta-b ptb-b ptb-w ptc-a
                          ptc-b ptc-w ptx d1 new-ptb ang-a neg d2)
  (if planar (setq pta-w (trans pta-w ename 0)))
  (if proj2 ;if projecting to a designated plane (ucs-b)
    (progn   ;then
      (if (/= (getvar "ucsname") (strcase ucs-a))
          (progn (command "ucs" "r" ucs-a) (call))
      )
      (setq pta-a (trans pta-w 0 1))
      (setq ptc-a (list (car pta-a) (cadr pta-a) (+ (caddr pta-a) 3)))
      (setq ptc-w (trans ptc-a 1 0))
      (command "ucs" "r" ucs-b) (call)
      (setq pta-b (trans pta-w 0 1))
      (setq ptb-b (list (car pta-b) (cadr pta-b) 0.0))
      (setq ptb-w (trans ptb-b 1 0))
      (setq ptc-b (trans ptc-w 0 1))
      (if          ;test for coincident points
          (or (< (distance pta-b ptb-b) 0.0000000001)
              (< (distance pta-b ptc-b) 0.0000000001)
              (< (distance ptb-b ptc-b) 0.0000000001)
              (equal (list (car ptb-b) (cadr ptb-b) 0)
                     (list (car ptc-b) (cadr ptc-b) 0)
                     0.0000000001
              )
          )
        (progn   ;then no further projection is needed
          (setq ptx ptb-b)
        )
        (progn   ;else do more calculations
          (command "ucs" "3" pta-b ptc-b ptb-b) (call)
          (setq d1 (distance pta-b ptb-b))
          (setq new-ptb (trans ptb-w 0 1))
          (setq ang-a (angle (list 0.0 0.0 0.0) new-ptb))
          (if (> ang-a (/ pi 2))
            (progn (setq ang-a (- pi ang-a)) (setq neg T))
          )
          (setq d2 (* (/ 1 (cos ang-a)) d1))
          (if neg (setq d2 (- 0 d2)))
          (setq neg nil)
          (setq ptx (trans (list d2 0.0 0.0) 1 0))
          (command "ucs" "r" ucs-b) (call)
          (setq ptx (trans ptx 0 1))
          (list (car ptx) (cadr ptx) 0.0)
        )
      )
    )
    (progn   ;else project onto the current plane (ucs-a)
      (setq pta-b (trans pta-w 0 1))
      (setq ptb-b (list (car pta-b) (cadr pta-b) 0.0))
    )
  )
)


;;;---- Find projected extrusion direction in current UCS ----

(defun u-vector (thk xtru / uv uv1 uv2 uv1-w uv2-w)
  (setq uv (trans (list 0 0 thk) xtru 0 T))
  (setq uv1 (pro-point '(0 0 0)))
  (setq uv1-w (trans uv1 1 0))
  (setq uv2 (pro-point uv))
  (setq uv2-w (trans uv2 1 0))
  (setq uvd (distance uv1 uv2))
  (setq uvang (angle uv1 uv2))
  (setq displace (polar '(0 0 0) uvang uvd))


  (if (or (equal etype "CIRCLE")
          (equal etype "ARC")
          (equal etype "POLYLINE")
      )
    (progn
      (if perpendicular
        (progn
          (setq uv2 (list (car uv2)
                          (cadr uv2)
                          (+ (caddr uv2) 0.000000000001)
                    )
          )
          (setq uv2-w (trans uv2 1 0))
        )
      )
      (e-vector)
    )
  )
)

;;;---- Find ECS angle that is parallel to projected u-dir ---
;;;    Also find silhouette angles (sang1 & sang2) to later
;;;    draw silhouette lines  extruded curves

(defun e-vector (/ ad-ang1 ad-ang-2)
  (command "ucs" "e" ename)
  (command "ucs" "s" "wtest")
  (setq uv1-e (trans uv1-w 0 1))
  (setq uv2-e (trans uv2-w 0 1))
  (setq ad-ang1 (angle uv2-e uv1-e))
  (setq ad-ang2
      (angle (trans '(0 0 0) ename 1)
             (trans (polar '(0 0 0) 0 1) ename 1)
      )
  )
  (setq ad-ang2 (- (* 2 pi) ad-ang2))
  (setq ad-ang (+ ad-ang1 ad-ang2))
  (if (> ad-ang (* 2 pi)) (setq ad-ang (- ad-ang (* 2 pi))))
  (setq sang1 (+ ad-ang (/ pi 2)))
  (if (>= sang1 (* 2 pi)) (setq sang1 (- sang1 (* 2 pi))))
  (setq sang2 (+ ad-ang (* 3 (/ pi 2))))
  (if (>= sang2 (* 2 pi)) (setq sang2 (- sang2 (* 2 pi))))
  (command "ucs" "p")
)

;;;----- test parallel, thickness, then call *-pro function --

(defun proj-ent (/ t-list elist thickness
                   extrusion tp planar uvang uvd ad-ang)
  (setq elist (entget ename) etype (cdr (assoc 0 elist)))
  (if (or (ucsp (trans '(0 0 1)  ename 0 T) udir)
          (ucsp (trans '(0 0 -1) ename 0 T) udir)
      )
    (setq parallel T)
    (setq parallel nil)
  )

  (if proj2                           ;  ignore extrusions
    (setq thickness nil ad-ang 0)
    ;; else find thickness & extrusion direction
    (if (setq thickness (cdr (assoc 39 elist)))
      (progn
        (setq extrusion (cdr (assoc 210 elist)))
        (if (equal (distance extrusion udir)
                   (sqrt 2) 0.000000000001
            )
          (setq perpendicular T)
          (setq perpendicular nil)
        )
        (u-vector thickness extrusion)
      )
      (setq thickness nil ad-ang 0)
    )
  )

  (cond
    ((eq etype "LINE")       (lines-pro))
    ((eq etype "3DLINE")     (lines-pro))
    ((eq etype "3DFACE")     (face-pro))
    ((eq etype "POINT")      (point-pro))
    ((eq etype "POLYLINE")   (pline-pro))
    ((eq etype "CIRCLE")
      (if parallel (copy-ent) (circ-pro)))
    ((eq etype "ARC")
      (if parallel (copy-ent) (arc-pro)))
    ((eq etype "TRACE")
      (if parallel (copy-ent) (solid-pro)))
    ((eq etype "SOLID")
      (if parallel (copy-ent) (solid-pro)))
    (T
      (if proj2
        (prompt (strcat "\nCan't project " etype "   "))
        (setq reject-set (ssadd ename reject-set))
      )
    )
  )
  (princ (strcat (chr 008) (chr 008) (chr 008)))
)

;;;---- Select entities, find name, call proj-ent function ---

(defun get-ent (/ ename ptx ctr entities)
  (setq entities nil)
  (if proj2                           ;if project to plane
    (progn                            ;then get a single entity
      (setq ename (car (entsel "\nSelect entity to project: \n")))
      (if ename                       ;if found
        (progn                        ;then turn off icon and project
          (setvar "ucsicon" 0)
          (proj-ent)
        )
        (prompt "\nEntity not found ")
      )
      (command "ucs" "r" ucs-a)       ;reset UCS
      (if ename (setvar "ucsicon" icon)) ;reset ucsicon
    )
    (progn                            ;else get a selection set
      (setq ctr 0)
      (if (setq entities (ssget))
        (progn
          (setq setlength (sslength entities))
          (prmpt)
          (while (setq ename (ssname entities ctr))
            (proj-ent)
            (setq ctr (+ ctr 1))
          )
          (if (> (setq n-of-ents (sslength reject-set)) 0)
            (progn
              (princ (strcat "\n" (itoa n-of-ents)
                             " entities not projected"
                     )
              )
              (setq tp 3)
              (redraw-rej reject-set tp) ;redraw rejection set
            )
          )
        )
        (prompt "\nNo entities found")
      )
    )
  )
)
;;;---- Set variables, get projection plane, call (get-ent) -

(defun project (/ numctr ucs-a ucs-b n-color old-err
                  entset reject-set entities n-of-ents cudir udir notperp
                  perpt2 perpang)
  (modes '("cmdecho" "blipmode" "expert" "flatland"
           "gridmode" "osmode" "thickness")
  )
  (setq icon (getvar "ucsicon"))
  (mapcar 'setvar
    '("cmdecho" "blipmode" "expert" "flatland" "gridmode"
      "osmode" "thickness")
    '(0 0 4 0 0 0 0)
  )
  (setq planar nil numctr 1 neg nil parallel nil)
  (setq reject-set (ssadd))           ;initialize rejection set
  (setq entset (ssadd))               ;initialize block set
  (setq notperp T)

  (if proj2  ;if using C:PROJECT2
    (getplane)
    (setq udir (trans '(0 0 1) 1 0 T))
  )

  (setq cudir (trans '(0 0 1) 1 0 T)) ;current extrusion direction
  (setq u2 (cdr (assoc 210 elist)))
  (setq u1 (trans '(0 0 1) 1 0 T))

  (if (and proj2                      ;if UCS' are not parallel
           (and (not (ucsp cudir udir))
                (not (equal (distance udir cudir) 2 0.000001))
           )
      )
    ;;test for perpendicular projection plane
    (if (equal (distance udir cudir) (sqrt 2) 0.00000000001)
      (progn
        (setq notperp nil)
        (prompt "\nUCS is perpendicular ")
        (prompt "\nCan't project entities to plane.")
      )
      (setq notpert T)
    )
  )

  (if notperp    ;if projection plane is not perpendicular
    (progn
      (slayer)     ;get projection layer
      (get-ent)    ;continue with projection
      (initget "Yes No")
      (while       ;continue projecting more entities
        (eq (getkword "\nProject another entity? Y/N <N>: ") "Yes" )
        (setq tp 1)
        (if n-of-ents (redraw-rej reject-set tp))
        (setq reject-set (ssadd))
        (get-ent)
        (initget "Yes No")
      )
    )
  )
  (setq tp 1)
  (if n-of-ents (redraw-rej reject-set tp))

  (if (and (not proj2) (/= (sslength entset) 0))
    (progn
      (initget "Yes No")
      (if (eq (getkword "\nMake into block? <N>: ") "Yes")
        (make-blk entset)
        (progn
          (initget "Yes No")
          (if (eq (getkword "\nWrite to disk as DWG file? <N>: ") "Yes")
              (write-blk entset)
          )
        )
      )
    )
  )

  (if proj2     ;if you used C:PROJECT2
    (progn      ;then delete temporary ucs'
      (command "ucs" "d" ucs-a)
      (if (= ucs-b "$$PLANE-B") (command "ucs" "d" ucs-b))
    )
  )

  (moder)
  (setq ncolor nil)
  (setvar "ucsicon" icon)
  (setq *error* olderr)  ;reset error function
  (princ)
)

(defun C:PROJECT1 ()
  (if (not err-set)
      (setq olderr *error* *error* proj-err)
  )
  (setq proj2 nil)
  (project)
  (princ)
)

(defun C:PROJECT2 ()
  (if (not err-set)
      (setq olderr *error* *error* proj-err)
  )
  (setq proj2 T)
  (project)
  (princ)
)

(defun C:PROJECT (/ choice err-set)
  (setq olderr *error* *error* proj-err)
  (setq err-set T)
  (textscr)
  (prompt "\n\n\n\n\n\n\n")
  (prompt "------------------------------ PROJECT.LSP ------------------------\n")

  (prompt "\n1) PROJECT1")
  (prompt (strcat "\n    Allows a \"flat\" "
                  "projection of wireframe 3D models (lines, arcs,"))
  (prompt
    "\n    circles, polylines, solids, points) onto the current UCS.  This")
  (prompt
    "\n    could be a useful aid for generating working drawings from a 3D")
  (prompt"\n    model.\n")
  (prompt
    "\n    After projection,  the user  is allowed  to make  the projected")
  (prompt
    "\n    entities into  a block,  or write  it out  as a  drawing  file.")
  (prompt
    "\n    These blocks  or drawing files (typically Top, Front, Side, and")
  (prompt
    "\n    Iso projections)  could be  re-inserted onto  a single  UCS and")
  (prompt"\n    annotated to create a multi-view orthographic drawing.\n")

  (prompt"\n2)  PROJECT2")
  (prompt
    "\n    This routine  projects an entity perpendicular from the current")
  (prompt
    "\n    UCS onto  a designated  construction plane.  This may be useful")
  (prompt"\n    in the construction of 3D wireframe models.\n")
  (prompt
    "\nTo avoid  this menu  in the  future the  user can type the commands")
  (prompt "\nPROJECT1 or PROJECT2 at the command prompt.\n")

  (if (and (= (substr (getvar "acadver") 1 2) "10")
           (/= (substr (getvar "acadver") 1 6) "10 c10")
      )
    (progn
      (prompt "\nFor DOS users not using Extended AutoLISP:")
      (prompt "\n             *** LISPHEAP  should be set to 35000 ***")
      (prompt "\n             *** LISPSTACK should be set to 10000 ***")
    )
    (prompt"\n\n")
  )

  (initget "1 2")
  (setq choice (getkword "\nEnter projection type (1 or 2) <1>: "))
  (if (or (equal choice "1")
          (equal choice nil)
      )
    (C:PROJECT1)
    (C:PROJECT2)
  )
  (princ)
)

(prompt "C:PROJECT")
(princ)