home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Monster Media 1993 #2
/
Image.iso
/
cad
/
may93.zip
/
TUBE.LSP
< prev
Wrap
Text File
|
1993-05-12
|
11KB
|
380 lines
;==========================================================
; TUBE.LSP Copyright 1993 by Looking Glass Microproducts
;==========================================================
; Convert a 3D Polyline to a solid Tube
;=============================================================
(defun C:TUBE (/ ERROR PUSHVARS POPVARS SYSVARS OLD-ERROR
NOTRANS ITEM RTOD GET_VERTS XGETDIST
GET_RADIUS VERTS TUBE FUZZ PNAME)
(setq FUZZ 1E-6)
;==========================================================
; Error Handler
(defun ERROR (S)
(if (not
(member
S
'("Function cancelled" "console break")
)
)
(princ S)
)
(POPVARS)
(princ)
)
;==========================================================
; Set and Save System Variables
(defun PUSHVARS (VLIST)
(foreach PAIR VLIST
(setq
SYSVARS (cons
(cons
(strcase (car PAIR))
(getvar
(car PAIR)
)
)
SYSVARS
)
)
(if (cdr PAIR) (setvar (car PAIR) (cdr PAIR)))
)
)
;==========================================================
; Restore System Variables
(defun POPVARS ()
(foreach PAIR SYSVARS (setvar (car PAIR) (cdr PAIR)))
(setq
*error* OLD-ERROR
)
(setq SYSVARS nil)
)
;==========================================================
; Disallow transparent invocation of routine.
(defun NOTRANS ()
(cond
((zerop (logand (getvar "cmdactive") (+ 1 2 4 8))))
((alert
"This command may not be invoked transparently."
)
)
)
)
;==========================================================
; Item from association list
(defun ITEM (A B) (cdr (assoc A B)))
;==========================================================
; Radians to degrees
(defun RTOD (X) (/ (* 180.0 X) pi))
;==========================================================
; Square of a number
(defun SQR (X) (* X X))
;==========================================================
; Get 3d polyline
(defun GET_3DPOLY (/ AGAIN ENAME ENT)
(setq AGAIN t)
(while AGAIN
(setq
ENAME (car (entsel "\nSelect 3D polyline: "))
)
(cond
((null ENAME) (setq AGAIN nil))
((and
(setq ENT (entget ENAME))
(=
"POLYLINE"
(ITEM 0 ENT)
)
(= 8 (logand (ITEM 70 ENT) (+ 8 16 64)))
)
(setq AGAIN nil)
ENAME
)
(t
(prompt
"Entity selected is not a 3D polyline."
)
)
)
)
)
;==========================================================
; Get Vertices from a 3d Polyline
(defun GET_VERTS (PNAME / ENAME ENT CLOSED VERTS P)
(setq
ENT (entget PNAME)
CLOSED (= 1 (logand (ITEM 70 ENT) 1))
ENAME PNAME
)
(while (progn
(setq
ENAME (entnext ENAME)
ENT (entget ENAME)
P (ITEM 10 ENT)
)
(= "VERTEX" (ITEM 0 ENT))
)
; Ignore spline control points and
; Duplicate points
(if (and
(zerop (logand (ITEM 70 ENT) 16))
(not
(equal P (car VERTS) FUZZ)
)
)
(setq VERTS (cons (ITEM 10 ENT) VERTS))
)
)
(if (and
CLOSED
(> (length VERTS) 2)
(not
(equal (car VERTS) (last VERTS) FUZZ)
)
)
(setq VERTS (cons (last VERTS) VERTS))
)
(if (> (length VERTS) 1) (reverse VERTS))
)
;=======================================================
; Extended get distance
(defun XGETDIST (BASE PRMPT DEFAULT KWORDS)
(setq
PRMPT (if DEFAULT
(strcat
PRMPT
" <"
(rtos DEFAULT)
">: "
)
(strcat PRMPT ": ")
)
)
(initget (if DEFAULT 6 7) KWORDS)
(cond
((if BASE (getdist BASE PRMPT) (getdist PRMPT)))
(DEFAULT
)
)
)
;==========================================================
; Get radius (or diameter)
(defun GET_RADIUS (BASE PRMPT DEFAULT DIAM / RAD)
(setq
RAD (XGETDIST
BASE
(strcat
(if DIAM
"\nDiameter/<radius> "
"\nRadius "
)
PRMPT
)
DEFAULT
(if DIAM "Diameter" "")
)
)
(if (= RAD "Diameter")
(setq
RAD (*
0.5
(XGETDIST
BASE
(strcat "\nDiameter " PRMPT)
(if DEFAULT
(* 2.0 DEFAULT)
)
""
)
)
)
)
RAD
)
;==========================================================
; Get tube radius and elbow radius
(defun GET_RADII ()
(if (not (numberp TUBE_RADIUS)) (setq TUBE_RADIUS nil))
(if (not (numberp ELBOW_RADIUS))
(setq ELBOW_RADIUS nil)
)
(setq
TUBE_RADIUS (GET_RADIUS
(car VERTS)
"of tube"
TUBE_RADIUS
t
)
)
(if (>= TUBE_RADIUS ELBOW_RADIUS)
(setq ELBOW_RADIUS nil)
)
(while (>=
TUBE_RADIUS
(setq
ELBOW_RADIUS (GET_RADIUS
(car VERTS)
"of elbow"
ELBOW_RADIUS
nil
)
)
)
(prompt
"\nElbow radius must be greater than tube radius."
)
(setq ELBOW_RADIUS nil)
)
)
;==========================================================
; Make the tube
(defun MAKE_TUBE (VERTS / P1 P2 P3 PA PB PC PD PE A1 A2 D1
D2 CLOSED SS SKIP_FIRST)
(setq CLOSED (equal (car VERTS) (last VERTS) FUZZ))
(if CLOSED
(setq
VERTS (append
(list (cadr (reverse VERTS)))
VERTS
(list (cadr VERTS))
)
)
)
(setq
SKIP_FIRST CLOSED
SS (ssadd)
P1 (car VERTS)
P2 (cadr VERTS)
P3 (caddr VERTS)
VERTS (cdddr VERTS)
)
(while P2
(cond
((and P3 (inters P1 P2 P2 P3 t))
(command
"_ucs" "3p" P2 P1 P3
)
(setq
A1 (angle '(0 0 0) (trans P3 0 1))
A2 (* 0.5 A1)
D2 (/ ELBOW_RADIUS (sin A2))
D1 (sqrt (- (SQR D2) (SQR ELBOW_RADIUS)))
PA (trans
(setq PD (polar '(0 0 0) 0 D1))
1
0
)
PB (trans (polar '(0 0 0) A1 D1) 1 0)
PC (trans
(setq PE (polar '(0 0 0) A2 D2))
1
0
)
)
(if SKIP_FIRST
; If closed, don't draw the section
(progn
(setq SKIP_FIRST nil)
(command "_ucs" "p")
)
(progn
(command "_ucs" "3p" PD PE "@0,0,1")
(ssadd
(solcyl
(trans P1 0 1)
TUBE_RADIUS
"c"
(trans PA 0 1)
)
SS
)
(command "_circle" '(0 0 0) TUBE_RADIUS)
(ssadd
(solrev
(entlast)
(list ELBOW_RADIUS 0 0)
(list
ELBOW_RADIUS
-1
0
)
(- 180.0 (RTOD A1))
)
SS
)
(command "_ucs" "p")
(command "_ucs" "p")
)
)
(setq
P1 PB
P2 P3
P3 (car VERTS)
VERTS (cdr VERTS)
)
)
(P3
(setq P2 P3 P3 (car VERTS) VERTS (cdr VERTS))
)
(t
(if (not CLOSED)
(ssadd
(SOLCYL P1 TUBE_RADIUS "c" P2)
SS
)
)
(setq P2 nil)
)
)
)
(solunion SS)
(setq SS nil)
)
;==========================================================
; Main Routine
(defun TUBE ()
(cond
((not (member (findfile "ame.exp") (ads)))
(alert
"\nAME must be xloaded to run this command."
)
)
((not (setq PNAME (GET_3DPOLY))))
((not (setq VERTS (GET_VERTS PNAME)))
(alert
"Zero length 3D polyline"
)
)
(t
(PUSHVARS
'(("blipmode" . 0)
("ucsicon" . 0)
("gridmode" . 0)
)
)
(command "_ucs" "w")
(GET_RADII)
(MAKE_TUBE VERTS)
(command "_ucs" "p")
)
)
)
;==========================================================
; Body of c:tube
(if (NOTRANS)
(progn
(setq OLD-ERROR *error* *error* ERROR)
(setvar "cmdecho" 0)
(command "_undo" "mark")
(PUSHVARS '(("osmode" . 0)))
(TUBE)
(POPVARS)
)
)
(princ)
)
(princ
" TUBE.LSP (Copyright 1993 by Looking Glass Microproducts) loaded."
)
(princ)
