home *** CD-ROM | disk | FTP | other *** search
/ Black Box 4 / BlackBox.cdr / autocad / may91.arj / SPHLINE.LSP < prev    next >
Lisp/Scheme  |  1991-05-13  |  4KB  |  139 lines
  1. ; SPHLINE.LSP   [Article Figure 3]   (c)1991, Phil Kreiker
  2.  
  3. ;--------------------------------------------------------------
  4. ; Sphline.LSP -- COPYRIGHT 1990 BY LOOKING GLASS MICROPRODUCTS
  5. ;--------------------------------------------------------------
  6. (setq VERSION      "1.0"
  7.       WORLD_RADIUS 3950.0   ;miles
  8.       DCS          2
  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 Sphline.Lsp v " VERSION " ["
  23.          (nth (rem BCOUNT 3) '("." "o" "O"))
  24.          "] Copyright 1991 by Looking Glass Microproducts"
  25. )))
  26. ;-----------------------------------------------------------
  27. ; Error Handler
  28. (BUMP)
  29. (defun SPHLINE-ERROR (S)
  30.    (if (/= S "Function cancelled") (princ S))
  31.    (command)
  32.    (command)
  33.    (command ".undo" "e")
  34.    (if UNDOIT
  35.       (progn (princ "\nUndoing...") (command ".undo" 1)))
  36.    (MODER)
  37. )
  38. ;-----------------------------------------------------------
  39. ; System variable save
  40. (BUMP)
  41. (defun MODES (A)
  42.    (setq MLST nil)
  43.    (repeat (length A)
  44.       (setq MLST (append MLST
  45.                     (list (list (car A) (getvar (car A))))
  46.             A (cdr A)))
  47. ))
  48. ;-----------------------------------------------------------
  49. ; System variable restore
  50. (BUMP)
  51. (defun MODER ()
  52.    (repeat (length MLST)
  53.            (setvar (caar MLST) (cadar MLST))
  54.            (setq MLST (cdr MLST)))
  55.    (setq *error* OLDERROR)
  56.    (princ)
  57. )
  58. ;-----------------------------------------------------------
  59. ; System variable set
  60. (BUMP)
  61. (defun SETVARS (MLST)
  62.    (repeat (length MLST)
  63.            (setvar (caar MLST) (cadar MLST))
  64.            (setq MLST (cdr MLST))
  65. ))
  66. ;-----------------------------------------------------------
  67. ; Square function
  68. (BUMP)(defun SQR (X) (* X X))
  69. ;-----------------------------------------------------------
  70. ; Map point to surface of sphere
  71. (BUMP)
  72. (defun SURFACE (P / P0 P1 X1 Y1 R)
  73.    (if P
  74.       (progn
  75.          (setq P1 (trans P UCS DCS)
  76.                X1 (car P1)
  77.                Y1 (cadr P1)
  78.                P0 (trans ORIGIN UCS DCS)
  79.                R  (distance (list X1 Y1)
  80.                             (list (car P0) (cadr P0))))
  81.          (if (<= R WORLD_RADIUS)
  82.             (trans
  83.                (list X1 Y1
  84.                   (+ (sqrt (- (SQR WORLD_RADIUS) (SQR R)))
  85.                      (caddr P0)))
  86.                DCS UCS)
  87. ))))
  88. ;-----------------------------------------------------------
  89. ; Get Surface Point
  90. (BUMP)
  91. (defun GETSPOINT (BASE PRMP / AGAIN P PS)
  92.    (setq AGAIN t)
  93.    (while AGAIN
  94.       (setq P (if BASE (getpoint BASE PRMP) (getpoint PRMP)))
  95.       (if P
  96.          (if (setq PS (SURFACE P))
  97.             (progn (setq AGAIN nil) PS)
  98.             (prompt "\nInvalid point.\n"))
  99.          (setq AGAIN nil)
  100. )))
  101. ;-----------------------------------------------------------
  102. ; Great Arc routine
  103. (BUMP)
  104. (defun GREATARC (P Q)
  105.    (if (inters P ORIGIN Q ORIGIN)
  106.       (progn
  107.          (command
  108.             ".ucs" "3p" ORIGIN P Q
  109.             ".arc"
  110.                (trans P WCS UCS) "ce" ORIGIN (trans Q WCS UCS)
  111.             ".ucs" "w")
  112.          (setvar "lastpoint" Q))
  113.       (prompt "\nInvalid point.")
  114. ))
  115. ;-----------------------------------------------------------
  116. ; SPHLINE Main routine
  117. (BUMP)
  118. (defun SPHLINE (/ P1 P2)
  119.    (command ".ucs" "w")
  120.    (if (setq P1 (GETSPOINT nil "\nFrom point: "))
  121.       (while (setq P2 (GETSPOINT P1 "\nTo point: "))
  122.          (if (GREATARC P1 P2) (setq P1 P2))))
  123. )
  124. ;-----------------------------------------------------------
  125. ; SPHLINE Command
  126. (BUMP)
  127. (defun C:SPHLINE (/ OLDERROR UNDOIT)
  128.    (MODES '("cmdecho" "osmode" "elevation" "thickness"
  129.             "blipmode" "highlight"))
  130.    (setq OLDERROR *error* *error* SPHLINE-ERROR)
  131.    (SETVARS '(("cmdecho" 0) ("osmode" 0)
  132.               ("elevation" 0.0) ("thickness" 0.0)))
  133.    (command ".undo" "g")
  134.    (SPHLINE)
  135.    (command ".undo" "e")
  136.    (MODER)
  137. )
  138. (C:SPHLINE)
  139.