Liren Large Software Subsidy 13/13.iso/p/p065/4.img/3DARRAY.LSP

Text File | 1992-01-08 | 5.0 KB | 188 lines

;******************************** MODES ********************************

; System variable save

(VMON)

(defun MODES (a)
   (setq MLST '())
   (repeat (length a)
      (setq MLST (append MLST (list (list (car a) (getvar (car a))))))
      (setq a (cdr a)))
)

;******************************** MODER ********************************

; System variable restore

(defun MODER ()
   (repeat (length MLST)
      (setvar (caar MLST) (cadar MLST))
      (setq MLST (cdr MLST))
   )
)

;******************************** 3DAERR *******************************

; Standard error function

(defun 3DAERR (st)                    ; If an error (such as CTRL-C) occurs
                                      ; while this command is active...
  (if (/= st "Function cancelled")
      (princ (strcat "\nError: " s))
  )
  (command "UNDO" "E")
  (moder)                             ; Restore system variables
  (setq *error* olderr)               ; Restore old *error* handler
  (princ)
)

;******************************* P-ARRAY *******************************

; Perform polar (circular) array around any axis

(defun P-ARRAY (/ n af yn cen c ra)

   ; Define number of items in array
   (setq n 0)
   (while (<= n 1)
          (initget (+ 1 2 4))
          (setq n (getint "\n╩Σ╚δ╧ε╩²: "))
          (if (= n 1)
              (prompt "\n╧ε╩²▒╪╨δ┤≤╙┌ 1")
          )
   )

   ; Define angle to fill
   (initget 2)
   (setq af (getreal "\n╒≤┴╨╔·│╔╖╢╬º╜╟╢╚ <360>: "))
   (if (= af nil) (setq af 360))

   ; Are objects to be rotated?
   (initget "Yes No")
   (setq yn (getkword "\n╒≤┴╨╔·│╔╩▒╨²╫¬╩╡╠σ┬≡ <Y>: "))
   (if (null yn)
      (setq yn "Y")
   )

   ; Define center point of array
   (initget 17)
   (setq cen (getpoint "\n╘░╨─: "))
   (setq c (trans cen 1 0))

   ; Define rotational axis
   (initget 17)
   (setq ra (getpoint cen "\n╨²╫¬╓ß╡─╡┌╢■╡π: "))
   (while (equal ra cen)
      (princ "\nInvalid point. Second point cannot equal center point.")
      (initget 17)
      (setq ra (getpoint cen "\nPlease try again: "))
   )
   (setvar "UCSFOLLOW" 0)
   (setvar "GRIDMODE" 0)
   (command "UCS" "ZAXIS" cen ra)
   (setq cen (trans c 0 1))

   ; Draw polar array
   (command "ARRAY" ss "" "P" cen n af yn)
   (command "UCS" "p")
)

;******************************* R-ARRAY *******************************

; Perform rectangular array

(defun R-ARRAY (/ nr nc nl flag x y z c el en ss2 e)

   ; Set array parameters
   (while (or (= nr nc nl nil) (= nr nc nl 1))
      (setq nr 1 nc 1)
      (initget (+ 2 4))
      (setq nl (getint "\n▓π╩² (...) <1>: "))
      (if (null nl) (setq nl 1))
      (if (= nr nc nl 1)
         (princ "\nOne-element array, nothing to do.\nPlease try again")
      )
   )
   (setvar "ORTHOMODE" 1)
   (setvar "HIGHLIGHT" 0)
   (setq flag 0)                      ; Command style flag
   (cond ((/= nr 1)
          (initget (+ 1 2))
          (setq y (getdist "\n╨╨╝Σ╛α└δ (---): "))
          (setq flag 1)
         )
   )
   (cond ((/= nc 1)
          (initget (+ 1 2))
          (setq x (getdist "\n┴╨╝Σ╛α└δ (|||): "))
          (setq flag (+ flag 2))
         )
   )
   (cond  ((/= nl 1)
           (initget (+ 1 2))
           (setq z (getdist "\n▓π╕▀ (...): "))
          )
   )
   (setvar "BLIPMODE" 0)

   (setq c 1)
   (setq el (entlast))                ; Reference entity
   (setq en (entnext el))
   (while (not (null en))
       (setq el en)
       (setq en (entnext el))
   )

   ; Copy the selected entities one level at a time
   (while (< c nl)
          (command "COPY" ss ""
                          "0,0,0"
                          (append (list 0 0) (list (* c z)))
          )
          (setq c (1+ c))
   )

;  (setq ss2 (ssadd))                 ; create a new selection set
;  (setq e (entnext el))              ; of all the new entities since
;  (while e                           ; the reference entity.
;      (ssadd e ss2)
;      (setq e (entnext e))
;  )

   ; Array original selection set and copied entities
   (cond
     ((= flag 1) (command "ARRAY" ss ss2 "" "R" nr "1" y))
     ((= flag 2) (command "ARRAY" ss ss2 "" "R" "1" nc x))
     ((= flag 3) (command "ARRAY" ss ss2 "" "R" nr nc y x))
   )
)

;***************************** MAIN PROGRAM ****************************

(defun C:3DARRAY (/ olderr ss xx)

   (setq olderr *error*
         *error* 3daerr)
   (modes '("cmdecho" "blipmode" "highlight" "orthomode"
            "ucsfollow" "gridmode"))
   (setvar "CMDECHO" 0)
   (command "UNDO" "GROUP")
   (graphscr)

   (setq ss nil)
   (while  (null ss)                  ; Ensure selection of entities
           (setq ss (ssget))
   )

   (initget 1 "Rectangular Polar Circular")
   (setq xx "Rectangular")
   (cond ((eq xx "Rectangular") (r-array))
         (T (p-array))
   )
   (command "UNDO" "E")
   (moder)                            ; Restore system variables
   (setq *error* olderr)              ; Restore old *error* handler
   (princ)
)