home *** CD-ROM | disk | FTP | other *** search
/ Black Box 4 / BlackBox.cdr / autocad / may91.arj / MERCATOR.LSP < prev    next >
Lisp/Scheme  |  1991-05-13  |  7KB  |  220 lines
  1. ; MERCATOR.LSP   [Article Figure 2]   (c)1991, Phil Kreiker
  2.  
  3. ;--------------------------------------------------------------
  4. ; Mercator.LSP -- COPYRIGHT 1990 BY LOOKING GLASS MICROPRODUCTS
  5. ;--------------------------------------------------------------
  6. (setq VERSION      "1.0"
  7.       WORLD_RADIUS 3950.0   ;miles
  8.       RADPERD      (/ pi 180.0)
  9.       UCS          1
  10.       WCS          0
  11.       FUZZ         1E-6
  12.       ORIGIN       '(0 0 0)
  13. )
  14. ;-----------------------------------------------------------
  15. ; Load-time chewing gum
  16. (princ "\n")
  17. (setq BCOUNT 0)
  18. (defun BUMP ()
  19.    (setq BCOUNT (1+ BCOUNT))
  20.    (princ
  21.       (strcat
  22.          "\rLoading Mercator.Lsp v " VERSION " ["
  23.          (nth (rem BCOUNT 3) '("." "o" "O"))
  24.          "] Copyright 1991 by Looking Glass Microproducts"
  25. )))
  26. ;-----------------------------------------------------------
  27. ; Item from association list
  28. (BUMP)(defun ITEM (N E) (cdr (assoc N E)))
  29. ;-----------------------------------------------------------
  30. ; Bit Set
  31. (BUMP)(defun BITSET (A B) (/= (boole 1 A B) 0))
  32. ;-----------------------------------------------------------
  33. ; Error Handler
  34. (BUMP)
  35. (defun MERCATOR-ERROR (S)
  36.    (if (/= S "Function cancelled") (princ S))
  37.    (command)
  38.    (command)
  39.    (command ".undo" "e")
  40.    (if UNDOIT
  41.       (progn (princ "\nUndoing...") (command ".undo" 1)))
  42.    (MODER)
  43. )
  44. ;-----------------------------------------------------------
  45. ; System variable save
  46. (BUMP)
  47. (defun MODES (A)
  48.    (setq MLST nil)
  49.    (repeat (length A)
  50.       (setq MLST (append MLST
  51.                     (list (list (car A) (getvar (car A))))
  52.             A (cdr A)))
  53. ))
  54. ;-----------------------------------------------------------
  55. ; System variable restore
  56. (BUMP)
  57. (defun MODER ()
  58.    (repeat (length MLST)
  59.            (setvar (caar MLST) (cadar MLST))
  60.            (setq MLST (cdr MLST)))
  61.    (setq *error* OLDERROR)
  62.    (princ)
  63. )
  64. ;-----------------------------------------------------------
  65. ; System variable set
  66. (BUMP)
  67. (defun SETVARS (MLST)
  68.    (repeat (length MLST)
  69.            (setvar (caar MLST) (cadar MLST))
  70.            (setq MLST (cdr MLST))
  71. ))
  72. ;-----------------------------------------------------------
  73. ; Get vertices of pline -- Discard spline frame
  74. (BUMP)
  75. (defun GETVERTS (PNAME / ENT ENAME VERTS CLOSED)
  76.    (setq ENT    (entget PNAME)
  77.          CLOSED (BITSET (ITEM 70 ENT) 1)
  78.          ENAME  PNAME
  79.          VERTS  nil)
  80.    (while (= "VERTEX"
  81.              (ITEM 0 (setq ENAME (entnext ENAME)
  82.                            ENT   (entget ENAME))))
  83.       (if (not (BITSET (ITEM 70 ENT) 16))
  84.          (progn
  85.             (redraw ENAME 3)
  86.             (setq VERTS (cons (trans (ITEM 10 ENT) PNAME WCS)
  87.                            VERTS)))))
  88.    (if CLOSED (setq VERTS (cons (last VERTS) VERTS)))
  89.    (redraw ENAME)
  90.    (reverse VERTS)
  91. )
  92. ;-----------------------------------------------------------
  93. ; Match the layer, linetype, and color of ENAME1 to ENAME2
  94. (BUMP)
  95. (defun MATCH (ENAME1 ENAME2 / ENT2 LAYER COLOR LTYPE)
  96.    (setq ENT2  (entget ENAME2)
  97.          LAYER (ITEM 8 ENT2)
  98.          LTYPE (ITEM 6 ENT2)
  99.          COLOR (ITEM 62 ENT2))
  100.    (if (null LTYPE) (setq LTYPE "BYLAYER"))
  101.    (if (null COLOR)
  102.       (setq COLOR "BYLAYER")
  103.       (if (zerop COLOR) (setq COLOR "BYBLOCK")))
  104.    (command
  105.       ".chprop" ENAME1 "" "la" LAYER "lt" LTYPE "c" COLOR "")
  106.    ENAME1
  107. )
  108. ;-----------------------------------------------------------
  109. ; Expand one line or polyline into a list of vertices
  110. (BUMP)
  111. (defun EXPAND-ONE (ENAME / ENT ETYPE MESH)
  112.    (setq ENT (entget ENAME) ETYPE (ITEM 0 ENT))
  113.    (cond
  114.       ((= "LINE" ETYPE)
  115.          (list (trans (ITEM 10 ENT) ENAME WCS)
  116.                (trans (ITEM 11 ENT) ENAME WCS)))
  117.       ((= "POLYLINE" ETYPE)
  118.          (setq MESH (BITSET (ITEM 70 ENT) (+ 16 64)))
  119.          (if (not MESH) (GETVERTS ENAME))
  120. )))
  121. ;-----------------------------------------------------------
  122. ; Midpoint of 2 points
  123. (BUMP)
  124. (defun MIDPOINT (P1 P2)
  125.    (mapcar '(lambda (X1 X2) (* 0.5 (+ X1 X2))) P1 P2))
  126. ;-----------------------------------------------------------
  127. ; Limit Angles
  128. (BUMP)
  129. (defun LIMIT (P) (mapcar '(lambda (X) (max -179.99 X)) P))
  130. ;-----------------------------------------------------------
  131. ; Degrees to Radians
  132. (BUMP)(defun DTOR (X) (* X RADPERD))
  133. ;-----------------------------------------------------------
  134. ; Convert a point from longitute-latitude to xyz
  135. (BUMP)
  136. (defun MAP (P / RXY)
  137.    (setq P (mapcar 'DTOR P)
  138.          RXY (* WORLD_RADIUS (cos (cadr P))))
  139.    (list (* RXY (cos (car P)))
  140.          (* RXY (sin (car P)))
  141.          (* WORLD_RADIUS (sin (cadr P)))
  142. ))
  143. ;-----------------------------------------------------------
  144. ; Convert one line segment to one arc
  145. (BUMP)
  146. (defun ONE-ARC (P1 P2 / P0M P1M P2M PLIST)
  147.    (setq P1M (LIMIT P1)
  148.          P2M (LIMIT P2)
  149.          P0M (MAP (MIDPOINT P1M P2M))   ;get 3 points on arc
  150.          P1M (MAP P1M)
  151.          P2M (MAP P2M))
  152.    (if (not (or (equal P1M P2M FUZZ)
  153.                 (equal P1M P0M FUZZ)
  154.                 (equal P0M P2M FUZZ)))
  155.       (progn
  156.          (setq PLIST (list P1M P0M P2M))
  157.          (command ".ucs" "3p")            ;set ucs to arc
  158.          (apply 'command
  159.             (mapcar '(lambda (P) (trans P WCS UCS)) PLIST))
  160.          (command ".arc")                 ;draw the arc
  161.          (apply 'command
  162.             (mapcar '(lambda (P) (trans P WCS UCS)) PLIST))
  163.          (ssadd (entlast) SS2)
  164. )))
  165. ;-----------------------------------------------------------
  166. ; Make a block
  167. (BUMP)
  168. (defun BLOCK (SS / BNAME)
  169.    (setq BNAME (rtos (getvar "cdate") 2 9)
  170.          BNAME (strcat (substr BNAME 1 8) (substr BNAME 10)))
  171.    (command
  172.       ".ucs" "w"
  173.       ".chprop" SS "" "la" "0" "lt" "byblock" "c" "byblock" ""
  174.       ".block" BNAME ORIGIN SS ""
  175.       ".insert" BNAME "@" 1 1 0)
  176. )
  177. ;-----------------------------------------------------------
  178. ; Project One Entity onto Sphere
  179. (BUMP)
  180. (defun ONE-MERCATOR (ENAME / VLIST SS2)
  181.    (setq SS2 (ssadd))
  182.    (if (setq VLIST (EXPAND-ONE ENAME))
  183.       (progn
  184.          (mapcar 'ONE-ARC VLIST (cdr VLIST))
  185.          (if (> (sslength SS2) 1) (BLOCK SS2))
  186.          (MATCH (entlast) ENAME)
  187. )))
  188. ;-----------------------------------------------------------
  189. ; Mercator Main Routine
  190. (BUMP)
  191. (defun MERCATOR (/ SS1 J)
  192.    (if (setq SS1 (ssget))
  193.       (progn
  194.          (setq UNDOIT t)
  195.          (setvar "highlight" 0)
  196.          (setvar "blipmode" 0)
  197.          (command ".layer" "thaw" "0" "on" "0" "set" "0" ""
  198.                   ".ucsicon" "all" "off")
  199.          (setq J 0)
  200.          (repeat (sslength SS1)
  201.                  (ONE-MERCATOR (ssname SS1 J))
  202.                  (setq J (1+ J)))
  203.          (command ".erase" SS1 "" ".ucs" "w" ".redrawall")
  204. )))
  205. ;-----------------------------------------------------------
  206. ; MERCATOR Command
  207. (BUMP)
  208. (defun C:MERCATOR (/ OLDERROR UNDOIT)
  209.    (MODES '("cmdecho" "osmode" "elevation" "thickness"
  210.             "blipmode" "highlight"))
  211.    (setq OLDERROR *error* *error* MERCATOR-ERROR)
  212.    (SETVARS '(("cmdecho" 0) ("osmode" 0)
  213.               ("elevation" 0.0) ("thickness" 0.0)))
  214.    (command ".undo" "g")
  215.    (MERCATOR)
  216.    (command ".undo" "e")
  217.    (MODER)
  218. )
  219. (C:MERCATOR)
  220.