home *** CD-ROM | disk | FTP | other *** search
/ Black Box 4 / BlackBox.cdr / autocad / may91.arj / SPHEDIT.LSP < prev    next >
Lisp/Scheme  |  1991-05-13  |  5KB  |  158 lines
  1. ;SPHEDIT.LSP   [Article Figure 4]   (c)1991, Phil Kreiker
  2.  
  3. ;--------------------------------------------------------------
  4. ; Sphedit.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 Sphedit.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 SPHEDIT-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 Move Routine
  103. (BUMP)
  104. (defun GMOVE (SS P1 P2)
  105.    (if (inters P1 ORIGIN P2 ORIGIN)
  106.       (progn
  107.          (command ".ucs" "3p" ORIGIN P1 P2
  108.                   ".rotate" SS "" ORIGIN (trans P2 WCS UCS)
  109.                   ".ucs" "w")
  110.          (setvar "lastpoint" P2))
  111.       (prompt "\nInvalid point.")
  112. ))
  113. ;-----------------------------------------------------------
  114. ; Great Arc Rotate Routine
  115. (BUMP)
  116. (defun GROTATE (SS P1)
  117.    (prompt "\Rotation angle: ")
  118.    (command ".ucs" "za" ORIGIN P1
  119.             ".ucs" "or" (trans P1 WCS UCS)
  120.             ".rotate" SS "" ORIGIN pause
  121.             ".ucs" "w"
  122. ))
  123. ;-----------------------------------------------------------
  124. ; SPHEDIT Main routine
  125. (BUMP)
  126. (defun SPHEDIT (/ SS1 P1 P2 P3 PR)
  127.    (command ".ucs" "w")
  128.    (if (setq SS1 (ssget))
  129.       (progn
  130.          (setq P1 (GETSPOINT nil "\nFrom point: ")
  131.                P2 (if P1 (GETSPOINT P1 "\nTo point: "))
  132.                PR "\nRotation base: ")
  133.          (if (and
  134.                 (if (and P1 P2) (GMOVE SS1 P1 P2) t)
  135.                 (setq P3
  136.                    (cond
  137.                       ((GETSPOINT (cond (P2) (P1)) PR))
  138.                       (P2)
  139.                       (P1)
  140.              )))
  141.              (GROTATE SS1 P3)
  142. ))))
  143. ;-----------------------------------------------------------
  144. ; SPHEDIT Command
  145. (BUMP)
  146. (defun C:SPHEDIT (/ OLDERROR UNDOIT)
  147.    (MODES '("cmdecho" "osmode" "elevation" "thickness"
  148.             "blipmode" "highlight"))
  149.    (setq OLDERROR *error* *error* SPHEDIT-ERROR)
  150.    (SETVARS '(("cmdecho" 0) ("osmode" 0)
  151.               ("elevation" 0.0) ("thickness" 0.0)))
  152.    (command ".undo" "g")
  153.    (SPHEDIT)
  154.    (command ".undo" "e")
  155.    (MODER)
  156. )
  157. (C:SPHEDIT)
  158.