home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p065 / 3.img / 3DARRAY.LSP < prev    next >
Encoding:
Lisp/Scheme  |  1990-10-08  |  6.5 KB  |  236 lines
  1. ;;;*************************************************************************
  2. ;;;                             3DARRAY.LSP
  3. ;;; 
  4. ;;;       By Simon Jones   Autodesk Ltd,London   March 1987
  5. ;;; 
  6. ;;;  Functions included:
  7. ;;;       1) Rectangular ARRAYS (rows, columns & levels)
  8. ;;;       2) Circular ARRAYS around any axis
  9. ;;; 
  10. ;;;  All are loaded by: (load "3darray")
  11. ;;; 
  12. ;;;  And run by:
  13. ;;;       Command: 3darray
  14. ;;;                Select objects:
  15. ;;;                Rectangular or Polar array (R/P): (select type of array)
  16. ;;; 
  17. ;;;  Expanded the circular arrays to revolve around any user
  18. ;;;  specified axis - June 1988
  19. ;;;***********************************************************************
  20. ;;; 
  21. ;;;******************************** MODES ********************************
  22. ;;; 
  23. ;;; System variable save
  24.  
  25. (defun MODES (a)
  26.   (setq MLST '())
  27.   (repeat (length a)
  28.     (setq MLST (append MLST (list (list (car a) (getvar (car a))))))
  29.     (setq a (cdr a))
  30.   )
  31. )
  32.  
  33. ;;;******************************** MODER ********************************
  34. ;;; 
  35. ;;; System variable restore
  36.  
  37. (defun MODER ()
  38.   (repeat (length MLST)
  39.     (setvar (caar MLST) (cadar MLST))
  40.     (setq MLST (cdr MLST))
  41.   )
  42. )
  43.  
  44. ;;;******************************** 3DAERR *******************************
  45. ;;; 
  46. ;;; Standard error function
  47.  
  48. (defun 3DAERR (st)                    ; If an error (such as CTRL-C) occurs
  49.                                       ; while this command is active...
  50.   (if (/= st "Function cancelled")
  51.       (princ (strcat "\nError: " s))
  52.   )
  53.   (command "UNDO" "E")
  54.   (moder)                             ; Restore system variables
  55.   (setq *error* olderr)               ; Restore old *error* handler
  56.   (princ)
  57. )
  58.  
  59. ;;;******************************* P-ARRAY *******************************
  60. ;;; 
  61. ;;; Perform polar (circular) array around any axis
  62.  
  63. (defun P-ARRAY (/ n af yn cen c ra)
  64.  
  65.   ;; Define number of items in array
  66.   (setq n 0)
  67.   (while (<= n 1)
  68.     (initget (+ 1 2 4))
  69.     (setq n (getint "\nNumber of items: "))
  70.     (if (= n 1)
  71.       (prompt "\nNumber of items must be greater than 1")
  72.     )
  73.   )
  74.  
  75.   ;; Define angle to fill
  76.   (initget 2)
  77.   (setq af (getreal "\nAngle to fill <360>: "))
  78.   (if (= af nil) (setq af 360))
  79.  
  80.   ;; Are objects to be rotated?
  81.   (initget "Yes No")
  82.   (setq yn (getkword "\nRotate objects as they are copied? <Y>: "))
  83.   (if (null yn)
  84.     (setq yn "Y")
  85.   )
  86.  
  87.   ;; Define center point of array
  88.   (initget 17)
  89.   (setq cen (getpoint "\nCenter point of array: "))
  90.   (setq c (trans cen 1 0))
  91.  
  92.   ;; Define rotational axis
  93.   (initget 17)
  94.   (setq ra (getpoint cen "\nSecond point on axis of rotation: "))
  95.   (while (equal ra cen)
  96.     (princ "\nInvalid point. Second point cannot equal center point.")
  97.     (initget 17)
  98.     (setq ra (getpoint cen "\nPlease try again: "))
  99.   )
  100.   (setvar "UCSFOLLOW" 0)
  101.   (setvar "GRIDMODE" 0)
  102.   (command "UCS" "ZAXIS" cen ra)
  103.   (setq cen (trans c 0 1))
  104.  
  105.   ;; Draw polar array
  106.   (command "ARRAY" ss "" "P" cen n af yn)
  107.   (command "UCS" "p")
  108. )
  109.  
  110. ;;;******************************* R-ARRAY *******************************
  111. ;;; 
  112. ;;; Perform rectangular array
  113.  
  114. (defun R-ARRAY (/ nr nc nl flag x y z c el en ss2 e)
  115.  
  116.   ;; Set array parameters
  117.   (while (or (= nr nc nl nil) (= nr nc nl 1))
  118.     (setq nr 1)
  119.     (initget (+ 2 4))
  120.     (setq nr (getint "\nNumber of rows (---) <1>: "))
  121.     (if (null nr) (setq nr 1))
  122.     (initget (+ 2 4))
  123.     (setq nc (getint "\nNumber of columns (|||) <1>: "))
  124.     (if (null nc) (setq nc 1))
  125.     (initget (+ 2 4))
  126.     (setq nl (getint "\nNumber of levels (...) <1>: "))
  127.     (if (null nl) (setq nl 1))
  128.     (if (= nr nc nl 1)
  129.       (princ "\nOne-element array, nothing to do.\nPlease try again")
  130.     )
  131.   )
  132.   (setvar "ORTHOMODE" 1)
  133.   (setvar "HIGHLIGHT" 0)
  134.   (setq flag 0)                       ; Command style flag
  135.   (if (/= nr 1)
  136.     (progn
  137.     (initget (+ 1 2))
  138.     (setq y (getdist "\nDistance between rows (---): "))
  139.     (setq flag 1)
  140.     )
  141.   )
  142.   (if (/= nc 1)
  143.     (progn
  144.     (initget (+ 1 2))
  145.     (setq x (getdist "\nDistance between columns (|||): "))
  146.     (setq flag (+ flag 2))
  147.     )
  148.   )
  149.   (if (/= nl 1)
  150.     (progn
  151.     (initget (+ 1 2))
  152.     (setq z (getdist "\nDistance between levels (...): "))
  153.     )
  154.   )
  155.   (setvar "BLIPMODE" 0)
  156.  
  157.   (setq c 1)
  158.   (setq el (entlast))                 ; Reference entity
  159.   (setq en (entnext el))
  160.   (while (not (null en))
  161.     (setq el en)
  162.     (setq en (entnext el))
  163.   )
  164.  
  165.   ;; Copy the selected entities one level at a time
  166.   (while (< c nl)
  167.     (command "COPY" ss "" "0,0,0" (append (list 0 0) (list (* c z)))
  168.     )
  169.     (setq c (1+ c))
  170.   )
  171.  
  172.   (setq ss2 (ssadd))                  ; create a new selection set
  173.   (setq e (entnext el))               ; of all the new entities since
  174.   (while e                            ; the reference entity.
  175.     (ssadd e ss2)
  176.     (setq e (entnext e))
  177.   )
  178.  
  179.   ;; Array original selection set and copied entities
  180.   (cond
  181.     ((= flag 1) (command "ARRAY" ss ss2 "" "R" nr "1" y))
  182.     ((= flag 2) (command "ARRAY" ss ss2 "" "R" "1" nc x))
  183.     ((= flag 3) (command "ARRAY" ss ss2 "" "R" nr nc y x))
  184.   )
  185. )
  186.  
  187. ;;;***************************** MAIN PROGRAM ****************************
  188.  
  189. (defun C:3DARRAY (/ olderr ss xx)
  190.   (if (and (= (getvar "cvport") 1) (= (getvar "tilemode") 0))
  191.     (progn
  192.       (prompt "\n *** Command not allowed in Paper space ***\n")
  193.       (princ)
  194.     )
  195.     (progn
  196.       (setq olderr *error*
  197.             *error* 3daerr
  198.       )
  199.       (modes '("cmdecho" "blipmode" "highlight" "orthomode" 
  200.                "ucsfollow" "gridmode")
  201.       )
  202.       (setvar "CMDECHO" 0)
  203.       (command "UNDO" "GROUP")
  204.       (graphscr)
  205.  
  206.       (setq ss nil)
  207.       (while  (null ss)               ; Ensure selection of entities
  208.         (setq ss (ssget))
  209.       )
  210.     
  211.       (initget 1 "Rectangular Polar Circular")
  212.       (setq xx (getkword "\nRectangular or Polar array (R/P): "))
  213.       (cond 
  214.         ((eq xx "Rectangular") 
  215.           (r-array)
  216.         )
  217.         (T 
  218.           (p-array)
  219.         )
  220.       )
  221.       (command "UNDO" "E")
  222.       (moder)                         ; Restore system variables
  223.       (setq *error* olderr)           ; Restore old *error* handler
  224.       (princ)
  225.     )
  226.   )
  227. )
  228. ;;; If loading this from LLoad, then print this string.  However, if we
  229. ;;; are loading from the menu, then load it silently.  I_LIST is set in
  230. ;;; the module that loads files in LLoad.lsp.
  231.  
  232. (if I_LIST 
  233.    (princ "\n\tC:3DARRAY loaded.  Start interactive command with 3DARRAY.")
  234. )
  235. (if I_LIST (princ))
  236.