;;; ---------------------------------------------------------------------------
;;; BlockAbsorb.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Adds selected objects INTO an existing block definition, in place.
;;;
;;; Normally, changing a block means opening the block editor, or exploding and
;;; redefining it. This lets you draw the addition where you want it to appear,
;;; pick the block, and have the geometry absorbed into the definition - so it
;;; appears on every reference of that block throughout the drawing.
;;;
;;; The objects land in exactly the position they were drawn, relative to the
;;; block reference you picked.
;;;
;;; WHY THE TRANSFORMATION IS NEEDED
;;; Geometry inside a block definition is stored relative to the block's own
;;; origin, unrotated and unscaled. The objects you have drawn are in world
;;; coordinates, positioned relative to a block reference that may be rotated,
;;; scaled and inserted anywhere.
;;;
;;; So before they can be copied into the definition, they must be transformed
;;; by the INVERSE of the picked reference's placement - undoing its rotation,
;;; its scale and its insertion offset. That is what the reverse geometry
;;; matrix below computes.
;;;
;;; THE SELF-REFERENCE CHECK
;;; A block cannot contain itself, directly or through any chain of nesting.
;;; Before proceeding, the routine maps out which blocks reference which, and
;;; refuses if the target block appears anywhere inside the selection - however
;;; deeply. Without that check, the drawing would end up with a circular
;;; definition, which corrupts it.
;;;
;;; LIMITATIONS, CHECKED AT SELECTION TIME
;;;   - Dynamic blocks are not supported; their definitions are generated per
;;;     reference and have no single stable definition to add to.
;;;   - Non-uniformly scaled references are not supported; the inverse
;;;     transformation would distort the added geometry.
;;;
;;;   BLOCKABSORB  - add objects into an existing block definition
;;; ---------------------------------------------------------------------------

(vl-load-com)

;; ---------------------------------------------------------------------------
;; BlockAbsorb:Doc  -  cached active document
;; ---------------------------------------------------------------------------
(defun BlockAbsorb:Doc nil
    (eval (list 'defun 'BlockAbsorb:Doc 'nil
                (vla-get-activedocument (vlax-get-acad-object))
          )
    )
    (BlockAbsorb:Doc)
)

;;; ---------------------------------------------------------------------------
;;; MATRIX HELPERS - namespaced, because the originals were bare globals named
;;; trp, mxm and mxv, generic enough for another routine to overwrite.
;;; ---------------------------------------------------------------------------

(defun BlockAbsorb:Transpose ( m )
    (apply 'mapcar (cons 'list m))
)

(defun BlockAbsorb:MxV ( m v )
    (mapcar (function (lambda ( row ) (apply '+ (mapcar '* row v)))) m)
)

(defun BlockAbsorb:MxM ( m n )
    (   (lambda ( a ) (mapcar (function (lambda ( row ) (BlockAbsorb:MxV a row))) m))
        (BlockAbsorb:Transpose n)
    )
)

;; ---------------------------------------------------------------------------
;; BlockAbsorb:ReverseGeom
;; ---------------------------------------------------------------------------
;; Returns (matrix vector) that transform world coordinates INTO the block
;; definition's own coordinate system - the inverse of how the block is placed.
;;
;; The three components are applied in reverse order and inverted:
;;   extrusion - world axes expressed in the object's plane
;;   rotation  - by MINUS the insertion angle, which is why the sine terms are
;;               transposed compared with a forward rotation
;;   scale     - by the RECIPROCAL of each scale factor
;;
;; The vector then shifts the result so the block's own base point ends up at
;; the definition origin.
;; ---------------------------------------------------------------------------
(defun BlockAbsorb:ReverseGeom ( ent / ang enx mat ocs )
    (setq enx (entget ent)
          ang (cdr (assoc 050 enx))
          ocs (cdr (assoc 210 enx))
    )
    (list
        (setq mat
            (BlockAbsorb:MxM
                ;; Inverse scale.
                (list (list (/ 1.0 (cdr (assoc 41 enx))) 0.0 0.0)
                      (list 0.0 (/ 1.0 (cdr (assoc 42 enx))) 0.0)
                      (list 0.0 0.0 (/ 1.0 (cdr (assoc 43 enx))))
                )
                (BlockAbsorb:MxM
                    ;; Inverse rotation.
                    (list (list (cos ang)     (sin ang) 0.0)
                          (list (- (sin ang)) (cos ang) 0.0)
                         '(0.0 0.0 1.0)
                    )
                    ;; Inverse extrusion.
                    (mapcar (function (lambda ( v ) (trans v ocs 0 t)))
                           '((1.0 0.0 0.0) (0.0 1.0 0.0) (0.0 0.0 1.0))
                    )
                )
            )
        )
        (mapcar '-
            (cdr (assoc 10 (tblsearch "block" (cdr (assoc 2 enx)))))
            (BlockAbsorb:MxV mat (trans (cdr (assoc 10 enx)) ocs 0))
        )
    )
)

;; ---------------------------------------------------------------------------
;; BlockAbsorb:BlockTree
;; ---------------------------------------------------------------------------
;; Returns a map of which blocks contain which, as a list of
;; (containerName nestedName nestedName ...).
;;
;; Built once and reused, because walking every block definition is expensive
;; and the answer does not change during the command.
;; ---------------------------------------------------------------------------
(defun BlockAbsorb:BlockTree ( / def ent enx nested tree )
    (while (setq def (tblnext "block" (not def)))
        (setq ent    (tblobjname "block" (cdr (assoc 2 def)))
              nested nil
        )
        (while (setq ent (entnext ent))
            (if (= "INSERT" (cdr (assoc 0 (setq enx (entget ent)))))
                (setq nested (cons (strcase (cdr (assoc 2 enx))) nested))
            )
        )
        (if nested
            (setq tree (cons (cons (strcase (cdr (assoc 2 def))) nested) tree))
        )
    )
    tree
)

;; ---------------------------------------------------------------------------
;; BlockAbsorb:Referenced
;; ---------------------------------------------------------------------------
;; True if block name appears anywhere within the supplied definition list, at
;; any depth of nesting.
;;
;; Recursive: if the name is not directly present, each nested block is looked
;; up in the tree and searched in turn.
;; ---------------------------------------------------------------------------
(defun BlockAbsorb:Referenced ( name def tree )
    (or (member name def)
        (vl-some
            (function
                (lambda ( nst ) (BlockAbsorb:Referenced name (cdr (assoc nst tree)) tree))
            )
            def
        )
    )
)

;; ---------------------------------------------------------------------------
;; BlockAbsorb:Ssget
;; ---------------------------------------------------------------------------
;; ssget with a custom prompt. NOMUTT is restored to its captured value rather
;; than to a hard-coded zero.
;; ---------------------------------------------------------------------------
(defun BlockAbsorb:Ssget ( msg arg / mutt sel )
    (princ msg)
    (setq mutt (getvar 'nomutt))
    (setvar 'nomutt 1)
    (setq sel (vl-catch-all-apply 'ssget arg))
    (setvar 'nomutt mutt)
    (if (not (vl-catch-all-error-p sel)) sel)
)

;; ---------------------------------------------------------------------------
;; c:BLOCKABSORB  -  main routine
;; ---------------------------------------------------------------------------
(defun c:BLOCKABSORB ( / *error* vars vals sel idx ent enx objects blocknames
                         tree ent target name reachable )

    (setq vars '("CMDECHO")
          vals (mapcar 'getvar vars)
    )

    (defun BlockAbsorb:Restore ( )
        (mapcar 'setvar vars vals)
        (while (= 8 (logand 8 (getvar 'undoctl)))
            (command "_.UNDO" "_End")
            (vl-catch-all-apply '(lambda ( ) (*pop-error-mode*)) '())
        )
        (princ)
    )

    (defun *error* ( msg )
        (BlockAbsorb:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** BLOCKABSORB error: " msg " **"))
        )
        (princ)
    )

    (setvar "CMDECHO" 0)
    ;; AutoCAD 2015 and later refuse (command) inside an *error* handler
    ;; unless the routine says up front that it will use one. Restore does,
    ;; to close this undo group. The declaring call is absent on older
    ;; releases, so it is wrapped rather than tested for.
    (vl-catch-all-apply '(lambda ( ) (*push-error-using-command*)) '())
    (command "_.UNDO" "_Begin")

    (cond
        (   (not (setq sel (BlockAbsorb:Ssget "\nSelect objects to add to a block: " '("_:L"))))
            (princ "\nNothing selected.")
        )

        (   (progn
                ;; Collect the objects, and note every block name among them -
                ;; needed for the self-reference check.
                (repeat (setq idx (sslength sel))
                    (setq idx     (1- idx)
                          ent     (ssname sel idx)
                          enx     (entget ent)
                          objects (cons (vlax-ename->vla-object ent) objects)
                    )
                    (if (and (= "INSERT" (cdr (assoc 0 enx)))
                             (not (member (setq name (strcase (cdr (assoc 2 enx)))) blocknames))
                        )
                        (setq blocknames (cons name blocknames))
                    )
                )

                (setq tree (BlockAbsorb:BlockTree))

                ;; Re-prompt for the target block until a usable one is picked.
                (while
                    (progn
                        (setvar 'errno 0)
                        (setq target (car (entsel "\nSelect the block to add them to: ")))
                        (cond
                            (   (= 7 (getvar 'errno))
                                (princ "\nMissed, try again.")
                            )
                            (   (null target) nil)

                            (   (/= "INSERT" (cdr (assoc 0 (setq enx (entget target)))))
                                (princ "\nThat object is not a block.")
                            )

                            (   (not (and (equal (abs (cdr (assoc 41 enx))) (abs (cdr (assoc 42 enx))) 1e-8)
                                          (equal (abs (cdr (assoc 41 enx))) (abs (cdr (assoc 43 enx))) 1e-8)
                                     )
                                )
                                (princ "\nNon-uniformly scaled blocks are not supported.")
                            )

                            (   (= :vlax-true (vla-get-isdynamicblock (vlax-ename->vla-object target)))
                                (princ "\nDynamic blocks are not supported.")
                            )

                            ;; Self-reference check: build the set of blocks
                            ;; that would end up containing the target, and
                            ;; refuse if any of them is in the selection.
                            (   (vl-some
                                    (function (lambda ( n ) (member n blocknames)))
                                    (   (lambda ( / reachable )
                                            (setq name (strcase (cdr (assoc 2 enx))))
                                            (foreach def tree
                                                (cond
                                                    ((= name (car def)))
                                                    ((member (car def) reachable))
                                                    ((BlockAbsorb:Referenced name (cdr def) tree)
                                                     (setq reachable (cons (car def) reachable))
                                                    )
                                                )
                                            )
                                            (cons name reachable)
                                        )
                                    )
                                )
                                (princ "\nThat block is referenced by a block in the selection - it cannot contain itself.")
                            )
                        )
                    )
                )
                target
            )

            ;; ---------------------------------------------------------------
            ;; Transform the objects into the block's coordinate system, copy
            ;; them into the definition, then remove the originals from the
            ;; drawing - they now live inside the block and will reappear
            ;; through every reference of it.
            ;; ---------------------------------------------------------------
            (   (lambda ( mat )
                    (foreach obj objects (vla-transformby obj mat))
                    (vla-copyobjects (BlockAbsorb:Doc)
                        (vlax-make-variant
                            (vlax-safearray-fill
                                (vlax-make-safearray vlax-vbobject (cons 0 (1- (length objects))))
                                objects
                            )
                        )
                        (vla-item (vla-get-blocks (BlockAbsorb:Doc))
                                  (cdr (assoc 2 (entget target)))
                        )
                    )
                    (foreach obj objects (vla-delete obj))
                    (vla-regen (BlockAbsorb:Doc) acallviewports)
                    (princ (strcat "\n" (itoa (length objects))
                                   " object" (if (= 1 (length objects)) "" "s")
                                   " added to block \""
                                   (cdr (assoc 2 (entget target))) "\"."
                           )
                    )
                )
                ;; Assemble the 4x4 transformation from the 3x3 matrix and the
                ;; displacement vector.
                (apply
                    (function
                        (lambda ( mat vec )
                            (vlax-tmatrix
                                (append
                                    (mapcar (function (lambda ( row v ) (append row (list v))))
                                            mat vec
                                    )
                                   '((0.0 0.0 0.0 1.0))
                                )
                            )
                        )
                    )
                    (BlockAbsorb:ReverseGeom target)
                )
            )
        )

        (   t
            (princ "\n*Cancelled*")
        )
    )

    (BlockAbsorb:Restore)
    (princ)
)

(princ)