home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Black Box 4
/
BlackBox.cdr
/
autocad
/
may91f.arj
/
MERCATOR.LSP
next >
Wrap
Text File
|
1991-08-02
|
7KB
|
221 lines
; MERCATOR.LSP [Article Figure 2] (c)1991, Phil Kreiker
;--------------------------------------------------------------
; Mercator.LSP -- COPYRIGHT 1990 BY LOOKING GLASS MICROPRODUCTS
;--------------------------------------------------------------
(setq VERSION "1.1"
WORLD_RADIUS 3950.0 ;miles
RADPERD (/ pi 180.0)
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 Mercator.Lsp v " VERSION " ["
(nth (rem BCOUNT 3) '("." "o" "O"))
"] Copyright 1991 by Looking Glass Microproducts"
)))
;-----------------------------------------------------------
; Item from association list
(BUMP)(defun ITEM (N E) (cdr (assoc N E)))
;-----------------------------------------------------------
; Bit Set
(BUMP)(defun BITSET (A B) (/= (boole 1 A B) 0))
;-----------------------------------------------------------
; Error Handler
(BUMP)
(defun MERCATOR-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))
))
;-----------------------------------------------------------
; Get vertices of pline -- Discard spline frame
(BUMP)
(defun GETVERTS (PNAME / ENT ENAME VERTS CLOSED)
(setq ENT (entget PNAME)
CLOSED (BITSET (ITEM 70 ENT) 1)
ENAME PNAME
VERTS nil)
(while (= "VERTEX"
(ITEM 0 (setq ENAME (entnext ENAME)
ENT (entget ENAME))))
(if (not (BITSET (ITEM 70 ENT) 16))
(progn
(redraw ENAME 3)
(setq VERTS (cons (trans (ITEM 10 ENT) PNAME WCS)
VERTS)))))
(if CLOSED (setq VERTS (cons (last VERTS) VERTS)))
(redraw ENAME)
(reverse VERTS)
)
;-----------------------------------------------------------
; Match the layer, linetype, and color of ENAME1 to ENAME2
(BUMP)
(defun MATCH (ENAME1 ENAME2 / ENT2 LAYER COLOR LTYPE)
(setq ENT2 (entget ENAME2)
LAYER (ITEM 8 ENT2)
LTYPE (ITEM 6 ENT2)
COLOR (ITEM 62 ENT2))
(if (null LTYPE) (setq LTYPE "BYLAYER"))
(if (null COLOR)
(setq COLOR "BYLAYER")
(if (zerop COLOR) (setq COLOR "BYBLOCK")))
(command
".chprop" ENAME1 "" "la" LAYER "lt" LTYPE "c" COLOR "")
ENAME1
)
;-----------------------------------------------------------
; Expand one line or polyline into a list of vertices
(BUMP)
(defun EXPAND-ONE (ENAME / ENT ETYPE MESH)
(setq ENT (entget ENAME) ETYPE (ITEM 0 ENT))
(cond
((= "LINE" ETYPE)
(list (trans (ITEM 10 ENT) ENAME WCS)
(trans (ITEM 11 ENT) ENAME WCS)))
((= "POLYLINE" ETYPE)
(setq MESH (BITSET (ITEM 70 ENT) (+ 16 64)))
(if (not MESH) (GETVERTS ENAME))
)))
;-----------------------------------------------------------
; Midpoint of 2 points
(BUMP)
(defun MIDPOINT (P1 P2)
(mapcar '(lambda (X1 X2) (* 0.5 (+ X1 X2))) P1 P2))
;-----------------------------------------------------------
; Limit Angles
(BUMP)
(defun LIMIT (P) (mapcar '(lambda (X) (max -179.99 X)) P))
;-----------------------------------------------------------
; Degrees to Radians
(BUMP)(defun DTOR (X) (* X RADPERD))
;-----------------------------------------------------------
; Convert a point from longitute-latitude to xyz
(BUMP)
(defun MAP (P / RXY)
(setq P (mapcar 'DTOR P)
RXY (* WORLD_RADIUS (cos (cadr P))))
(list (* RXY (cos (car P)))
(* RXY (sin (car P)))
(* WORLD_RADIUS (sin (cadr P)))
))
;-----------------------------------------------------------
; Convert one line segment to one arc
(BUMP)
(defun ONE-ARC (P1 P2 / P0M P1M P2M PLIST)
(setq P1M (LIMIT P1)
P2M (LIMIT P2)
P0M (MAP (MIDPOINT P1M P2M)) ;get 3 points on arc
P1M (MAP P1M)
P2M (MAP P2M))
(if (not (or (equal P1M P2M FUZZ)
(equal P1M P0M FUZZ)
(equal P0M P2M FUZZ)))
(progn
(setq PLIST (list P1M P0M P2M))
(command ".ucs" "3p") ;set ucs to arc
(apply 'command
(mapcar '(lambda (P) (trans P WCS UCS)) PLIST))
(command ".arc") ;draw the arc
(apply 'command
(mapcar '(lambda (P) (trans P WCS UCS)) PLIST))
(ssadd (entlast) SS2)
)))
;-----------------------------------------------------------
; Make a block
(BUMP)
(defun BLOCK (SS / BNAME)
(setq BNAME (rtos (getvar "cdate") 2 9)
BNAME (strcat (substr BNAME 1 8) (substr BNAME 10)))
(command
".ucs" "w"
".chprop" SS "" "la" "0" "lt" "byblock" "c" "byblock" ""
".block" BNAME ORIGIN SS ""
".insert" BNAME "@" 1 1 0)
)
;-----------------------------------------------------------
; Project One Entity onto Sphere
(BUMP)
(defun ONE-MERCATOR (ENAME / VLIST SS2)
(setq SS2 (ssadd))
(if (setq VLIST (EXPAND-ONE ENAME))
(progn
(mapcar 'ONE-ARC VLIST (cdr VLIST))
(if (> (sslength SS2) 1) (BLOCK SS2))
(MATCH (entlast) ENAME)
)))
;-----------------------------------------------------------
; Mercator Main Routine
(BUMP)
(defun MERCATOR (/ SS1 J)
(if (setq SS1 (ssget))
(progn
(setq UNDOIT t)
(setvar "highlight" 0)
(setvar "blipmode" 0)
(command ".layer" "thaw" "0" "on" "0" "set" "0" ""
".ucsicon" "all" "off")
(setq J 0)
(repeat (sslength SS1)
(ONE-MERCATOR (ssname SS1 J))
(setq J (1+ J)))
(command ".erase" SS1 "" ".ucs" "w" ".redrawall")
)))
;-----------------------------------------------------------
; MERCATOR Command
(BUMP)
(defun C:MERCATOR (/ OLDERROR UNDOIT)
(MODES '("cmdecho" "osmode" "elevation" "thickness"
"blipmode" "highlight"))
(princ mlst)
(setq OLDERROR *error* *error* MERCATOR-ERROR)
(SETVARS '(("cmdecho" 0) ("osmode" 0)
("elevation" 0.0) ("thickness" 0.0)))
(command ".undo" "g")
(MERCATOR)
(command ".undo" "e")
(MODER)
)
(C:MERCATOR)