home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Black Box 4
/
BlackBox.cdr
/
autocad
/
may91.arj
/
SPHLINE.LSP
< prev
next >
Wrap
Lisp/Scheme
|
1991-05-13
|
4KB
|
139 lines
; SPHLINE.LSP [Article Figure 3] (c)1991, Phil Kreiker
;--------------------------------------------------------------
; Sphline.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 Sphline.Lsp v " VERSION " ["
(nth (rem BCOUNT 3) '("." "o" "O"))
"] Copyright 1991 by Looking Glass Microproducts"
)))
;-----------------------------------------------------------
; Error Handler
(BUMP)
(defun SPHLINE-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 routine
(BUMP)
(defun GREATARC (P Q)
(if (inters P ORIGIN Q ORIGIN)
(progn
(command
".ucs" "3p" ORIGIN P Q
".arc"
(trans P WCS UCS) "ce" ORIGIN (trans Q WCS UCS)
".ucs" "w")
(setvar "lastpoint" Q))
(prompt "\nInvalid point.")
))
;-----------------------------------------------------------
; SPHLINE Main routine
(BUMP)
(defun SPHLINE (/ P1 P2)
(command ".ucs" "w")
(if (setq P1 (GETSPOINT nil "\nFrom point: "))
(while (setq P2 (GETSPOINT P1 "\nTo point: "))
(if (GREATARC P1 P2) (setq P1 P2))))
)
;-----------------------------------------------------------
; SPHLINE Command
(BUMP)
(defun C:SPHLINE (/ OLDERROR UNDOIT)
(MODES '("cmdecho" "osmode" "elevation" "thickness"
"blipmode" "highlight"))
(setq OLDERROR *error* *error* SPHLINE-ERROR)
(SETVARS '(("cmdecho" 0) ("osmode" 0)
("elevation" 0.0) ("thickness" 0.0)))
(command ".undo" "g")
(SPHLINE)
(command ".undo" "e")
(MODER)
)
(C:SPHLINE)