; *******************************************************************
;                          ATTREDEF.LSP
;
; This program allows you to redefine a Block and update the
; Attributes associated with any previous insertions of that Block.
; All new Attributes are added to the old Blocks and given their
; default values. All old Attributes with equal tag values to the new
; Attributes are redefined but retain their old value. And all old
; Attributes not included in the new Block are deleted.
;
; Note that if handles are enabled, new handles will be assigned to
; each redefined block.
;
; Written by Karry Layden - May 1988
; *******************************************************************


; Oldatts sets "old" to the list of old Attributes for each Block.
; The list does not include constant Attributes.

(defun oldatts (/ an e)
   (setq an (entnext b1))
   (setq e (entget an))
   (while (and (= (cdr (assoc 0 e)) "ATTRIB")
               (member (cdr (assoc 70 e)) '(0 1 4 5 8 9 12 13)))
      (if old
         (setq old (cons e old))
         (setq old (list e))
      )
      (setq an (entnext an))
      (if an
         (setq e (entget an))
      )
      (setq count (1+ count))         ; count the number of old atts
   )
)

; Newatts sets "new" to the list of new Attributes in the new Block.
; The list does not include constant Attributes.

(defun newatts (ssetn l / i an e)
   (setq i 0)
   (while (<= i l)
      (setq an (ssname ssetn i))
      (setq e (entget an))
      (if (and (= (cdr (assoc 0 e)) "ATTDEF")
               (member (cdr (assoc 70 e)) '(0 1 4 5 8 9 12 13)))
            (progn
               (if new
                  (setq new (cons e new))
                  (setq new (list e))
               )
               (setq n (1+ n))        ; count the number of new atts
            )
      )
      (setq i (1+ i))
   )
)

; Compare the list of "old" to the list of "new" Attributes and make
; the two lists "same" and "preset". "Same" contains the old values of
; all the Attributes in "old" with equal tag values to some Attribute
; in "new" and the default values of all the other Attributes. "Preset"
; contains the preset Attributes in old with equal tag values to some
; Attribute in new.

(defun compare (/ i j)
   (setq i 0
         j 0
         eds 0
         same nil
         amount 0
         preset nil)
   (while (<= i (1- n))
      (cond ((= (cdr (assoc 2 (nth j old))) (cdr (assoc 2 (nth i new))))
                (if (member (cdr (assoc 70 (nth i new))) '(8 9 12 13))
                   (progn
                      (if preset
                         (setq preset (cons (nth j old) preset))
                         (setq preset (list (nth j old)))
                      )
                      (setq eds (1+ eds)) ; count equal preset atts
                   )
                   (if same
                      (setq same (cons (cdr (assoc 1 (nth j old))) same))
                      (setq same (list (cdr (assoc 1 (nth j old)))))
                   )
                )
                (if (member (cdr (assoc 70 (nth i new))) '(4 5))
                   (setq amount (+ 1 amount))
                )
                (setq i (1+ i))
                (setq j 0)
             )
             ((= j (1- count))
                (if (not (member (cdr (assoc 70 (nth i new))) '(8 9 12 13)))
                   (if same
                      (setq same (cons (cdr (assoc 1 (nth i new))) same))
                      (setq same (list (cdr (assoc 1 (nth i new)))))
                   )
                )
                (if (member (cdr (assoc 70 (nth i new))) '(4 5))
                   (setq amount (+ 1 amount))
                )
                (setq i (1+ i))
                (setq j 0)
             )
             (t
                (setq j (1+ j))
             )
      )
   )
)

; Find the entity for each of the "preset" Attributes in the newly
; inserted Block.

(defun findpt ()
   (setq test T)
   (setq en (entnext e1))
   (setq e (entget en))
   (while test
      (if (and (= (cdr (assoc 0 e)) "ATTRIB") (= (cdr (assoc 2 e)) tag))
         (setq test nil)
         (progn
            (setq ex en)
            (setq en (entnext ex))
            (if e
               (setq e (entget en))
            )
         )
      )
   )
)

; Insert a new Block on top of each old Block and set its new Attributes
; to their values in the list "same". Then replace each of the "preset"
; Attributes with its old value.

(defun redef (/ xsf ysf zsf ls i e1 v)
   (command "ucs" "e" b1)             ; define the block's UCS
   (setq xsf (cdr (assoc 41 (entget b1)))) ; find x scale factor
   (setq ysf (cdr (assoc 42 (entget b1)))) ; find y scale factor
   (setq zsf (cdr (assoc 43 (entget b1)))) ; find z scale factor
   (setq ls (1- (length same)))
   (setq i 0)
   (command "insert" bn "0.0,0.0,0.0" "XYZ" xsf ysf zsf "0.0")
   (while (<= i ls)                   ; set attributes to their values
      (command (nth i same))
      (setq i (1+ i))
   )
   (while (< 0 amount)
      (command "")                    ; at prompts, verify attributes
      (setq amount (1- amount))
   )
   (setq i 0)
   (setq e1 (entlast))
   (while (< 0 eds)                   ; edit each of the "preset" attributes
      (setq tag (cdr (assoc 2 (nth i preset))))
      (setq v (cdr (assoc 1 (nth i preset))))
      (findpt)                        ; find the entity to modify
      (setq e (subst (cons 1 v) (assoc 1 e) e))
      (entmod e)                      ; modify the entity's value
      (setq i (1+ i))
      (setq eds (1- eds))
   )
   (command "ucs" "p")                ; restore the previous UCS
)

; System variable save

(defun modes (a)
   (setq mlst '())
   (repeat (length a)
      (setq mlst (append mlst (list (list (car a) (getvar (car a))))))
      (setq a (cdr a)))
)

; System variable restore

(defun moder ()
   (repeat (length mlst)
      (setvar (caar mlst) (cadar mlst))
      (setq mlst (cdr mlst))
   )
)

; Internal error handler

(defun attrerr (s)                    ; If an error (such as CTRL-C) occurs
                                      ; while this command is active...
   (if (/= s "Function cancelled")
      (princ (strcat "\nError: " s))
   )
   (moder)                            ; restore saved modes
   (setq *error* olderr)              ; restore old *error* handler
   (princ)
)

; Main program

(defun C:ATTREDEF (/ k n olderr bn sseto ssetn pt l new
                     old same presets b1 count amount)
   (setq k 0
         n 0
         test T
         olderr *error*
         *error* attrerr)

   (modes '("CMDECHO" "ATTDIA" "ATTREQ" "GRIDMODE" "UCSFOLLOW"))
   (setvar "cmdecho" 0)               ; turn cmdecho off
   (setvar "attdia" 0)                ; turn attdia off
   (setvar "attreq" 1)                ; turn attreq on
   (setvar "gridmode" 0)              ; turn gridmode off
   (setvar "ucsfollow" 0)             ; turn ucsfollow off

   (while test
      (setq bn (strcase (getstring "\nName of Block you wish to redefine: ")))
      (if (null (setq sseto (ssget "X" (list (cons 2 bn)))))
         (progn
            (princ "\nBlock ")
            (princ bn)
            (princ " is not defined. Please try again.")
         )
         (setq test nil)
      )
   )
   (setq test T)
   (while test
      (princ "\nSelect new Block... ")
      (if (null (setq ssetn (ssget)))
         (princ "\nNo new Block selected. Please try again.")
         (setq test nil)
      )
   )
   (initget 17)
   (setq pt (getpoint "\nInsertion base point of new Block: "))
   (setq l (1- (sslength sseto)))
   (newatts ssetn (1- (sslength ssetn))) ; find the list of new attributes
   (command "block" bn "Y" pt ssetn "")  ; redefine the block
   (while (<= k l)
      (setq b1 (ssname sseto k))      ; For each old block...
      (setq old nil)
      (setq count 0)
      (oldatts)                       ; find the list of old attributes,
      (compare)                       ; compare the old list with the new,
      (redef)                         ; and redefine its attributes.
      (entdel b1)                     ; delete the old block.
      (setq k (1+ k))
   )
   (moder)                            ; restore saved modes
   (command "regenall")
   (setq *error* olderr)              ; restore old *error* handler
   (princ)
)