home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Black Box 4
/
BlackBox.cdr
/
autocad
/
may91.arj
/
SPHEDIT.LSP
< prev
next >
Wrap
Lisp/Scheme
|
1991-05-13
|
5KB
|
158 lines
;SPHEDIT.LSP [Article Figure 4] (c)1991, Phil Kreiker
;--------------------------------------------------------------
; Sphedit.LSP -- COPYRIGHT 1990 BY LOOKING GLASS MICROPRODUCTS
;--------------------------------------------------------------
(setq VERSION "1.0"
WORLD_RADIUS 3950.0 ;miles
DCS 2
UCS 1
WCS 0
FUZZ 1E-6
ORIGIN '(0 0 0)
)
;-----------------------------------------------------------
; Load-time chewing gum
(princ "\n")
(setq BCOUNT 0)
(defun BUMP ()
(setq BCOUNT (1+ BCOUNT))
(princ
(strcat
"\rLoading Sphedit.Lsp v " VERSION " ["
(nth (rem BCOUNT 3) '("." "o" "O"))
"] Copyright 1991 by Looking Glass Microproducts"
)))
;-----------------------------------------------------------
; Error Handler
(BUMP)
(defun SPHEDIT-ERROR (S)
(if (/= S "Function cancelled") (princ S))
(command)
(command)
(command ".undo" "e")
(if UNDOIT
(progn (princ "\nUndoing...") (command ".undo" 1)))
(MODER)
)
;-----------------------------------------------------------
; System variable save
(BUMP)
(defun MODES (A)
(setq MLST nil)
(repeat (length A)
(setq MLST (append MLST
(list (list (car A) (getvar (car A))))
A (cdr A)))
))
;-----------------------------------------------------------
; System variable restore
(BUMP)
(defun MODER ()
(repeat (length MLST)
(setvar (caar MLST) (cadar MLST))
(setq MLST (cdr MLST)))
(setq *error* OLDERROR)
(princ)
)
;-----------------------------------------------------------
; System variable set
(BUMP)
(defun SETVARS (MLST)
(repeat (length MLST)
(setvar (caar MLST) (cadar MLST))
(setq MLST (cdr MLST))
))
;-----------------------------------------------------------
; Square function
(BUMP)(defun SQR (X) (* X X))
;-----------------------------------------------------------
; Map point to surface of sphere
(BUMP)
(defun SURFACE (P / P0 P1 X1 Y1 R)
(if P
(progn
(setq P1 (trans P UCS DCS)
X1 (car P1)
Y1 (cadr P1)
P0 (trans ORIGIN UCS DCS)
R (distance (list X1 Y1)
(list (car P0) (cadr P0))))
(if (<= R WORLD_RADIUS)
(trans
(list X1 Y1
(+ (sqrt (- (SQR WORLD_RADIUS) (SQR R)))
(caddr P0)))
DCS UCS)
))))
;-----------------------------------------------------------
; Get Surface Point
(BUMP)
(defun GETSPOINT (BASE PRMP / AGAIN P PS)
(setq AGAIN t)
(while AGAIN
(setq P (if BASE (getpoint BASE PRMP) (getpoint PRMP)))
(if P
(if (setq PS (SURFACE P))
(progn (setq AGAIN nil) PS)
(prompt "\nInvalid point.\n"))
(setq AGAIN nil)
)))
;-----------------------------------------------------------
; Great Arc Move Routine
(BUMP)
(defun GMOVE (SS P1 P2)
(if (inters P1 ORIGIN P2 ORIGIN)
(progn
(command ".ucs" "3p" ORIGIN P1 P2
".rotate" SS "" ORIGIN (trans P2 WCS UCS)
".ucs" "w")
(setvar "lastpoint" P2))
(prompt "\nInvalid point.")
))
;-----------------------------------------------------------
; Great Arc Rotate Routine
(BUMP)
(defun GROTATE (SS P1)
(prompt "\Rotation angle: ")
(command ".ucs" "za" ORIGIN P1
".ucs" "or" (trans P1 WCS UCS)
".rotate" SS "" ORIGIN pause
".ucs" "w"
))
;-----------------------------------------------------------
; SPHEDIT Main routine
(BUMP)
(defun SPHEDIT (/ SS1 P1 P2 P3 PR)
(command ".ucs" "w")
(if (setq SS1 (ssget))
(progn
(setq P1 (GETSPOINT nil "\nFrom point: ")
P2 (if P1 (GETSPOINT P1 "\nTo point: "))
PR "\nRotation base: ")
(if (and
(if (and P1 P2) (GMOVE SS1 P1 P2) t)
(setq P3
(cond
((GETSPOINT (cond (P2) (P1)) PR))
(P2)
(P1)
)))
(GROTATE SS1 P3)
))))
;-----------------------------------------------------------
; SPHEDIT Command
(BUMP)
(defun C:SPHEDIT (/ OLDERROR UNDOIT)
(MODES '("cmdecho" "osmode" "elevation" "thickness"
"blipmode" "highlight"))
(setq OLDERROR *error* *error* SPHEDIT-ERROR)
(SETVARS '(("cmdecho" 0) ("osmode" 0)
("elevation" 0.0) ("thickness" 0.0)))
(command ".undo" "g")
(SPHEDIT)
(command ".undo" "e")
(MODER)
)
(C:SPHEDIT)