;;; ---------------------------------------------------------------------------
;;; BlockPromote.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Pulls a NESTED block out to the top level, correctly positioned.
;;;
;;; Pick a block that lives inside another block, and it is extracted to become
;;; a block reference in its own right - landing in exactly the same place, at
;;; the same scale, rotation and orientation it appeared to have while nested.
;;; It is then removed from the parent definition.
;;;
;;; This is done for EVERY reference of the parent block, so if a detail block
;;; containing a nested north arrow is inserted forty times, all forty north
;;; arrows are promoted and each one lands correctly.
;;;
;;; WHY THIS NEEDS MATRIX MATHS
;;; A nested block's stored position is expressed relative to the block that
;;; contains it, which may itself be nested inside another, and so on. Each
;;; level applies its own rotation, scale and displacement.
;;;
;;; To find where the innermost block actually appears on the drawing, the
;;; transformation of every level has to be combined - walking outwards from the
;;; nested block to the space it is finally drawn in, multiplying the matrices
;;; and accumulating the displacements as it goes. That combined transform is
;;; then applied to a fresh copy of the block placed at the top level.
;;;
;;; LIMITATIONS - REPORTED, NOT HIT LATER
;;;   - Blocks nested inside XREFS cannot be extracted; an xref's contents
;;;     belong to the referenced drawing, not to this one.
;;;   - Blocks nested inside DYNAMIC blocks cannot be extracted; a dynamic
;;;     block's geometry is generated per reference and has no stable
;;;     definition to remove it from.
;;;   - Non-uniformly scaled references are skipped rather than producing a
;;;     distorted result.
;;; All three are checked at selection time and explained, rather than being
;;; allowed to fail part way through.
;;;
;;;   BLOCKPROMOTE  - extract a nested block to the top level
;;; ---------------------------------------------------------------------------

(vl-load-com)

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

;;; ---------------------------------------------------------------------------
;;; MATRIX HELPERS
;;;
;;; Namespaced deliberately. The originals were bare globals named trp, mxm and
;;; mxv - names generic enough that another routine loaded in the same session
;;; could silently replace them, which in a library of a hundred files is a
;;; real hazard rather than a theoretical one.
;;; ---------------------------------------------------------------------------

;; Transpose - flips an n x n matrix about its diagonal.
(defun BlockPromote:Transpose ( m )
    (apply 'mapcar (cons 'list m))
)

;; Matrix multiplied by vector - each row dotted with the vector.
(defun BlockPromote:MxV ( m v )
    (mapcar (function (lambda ( row ) (apply '+ (mapcar '* row v)))) m)
)

;; Matrix multiplied by matrix - each row of m against the transposed n.
(defun BlockPromote:MxM ( m n )
    (   (lambda ( a )
            (mapcar (function (lambda ( row ) (BlockPromote:MxV a row))) m)
        )
        (BlockPromote:Transpose n)
    )
)

;; ---------------------------------------------------------------------------
;; BlockPromote:RefGeom
;; ---------------------------------------------------------------------------
;; Returns (matrix insertionVector) describing how a block reference is placed
;; within its parent - whether that parent is another block, an xref, or a
;; space.
;;
;; The matrix is the product of three transformations, applied in this order:
;;
;;   scale     - DXF 41, 42, 43 down the diagonal
;;   rotation  - DXF 50, as a standard 2D rotation matrix
;;   extrusion - DXF 210, converting from the object's own plane to world
;;
;; The vector is the reference's insertion point, less the transformed base
;; point of the block definition itself - because a block whose base point is
;; not at its own origin is offset by that amount when inserted.
;; ---------------------------------------------------------------------------
(defun BlockPromote:RefGeom ( ent / ang enx mat ocs )
    (setq enx (entget ent)
          ang (cdr (assoc 050 enx))
          ocs (cdr (assoc 210 enx))
    )
    (list
        (setq mat
            (BlockPromote:MxM
                ;; Extrusion: the object's own axes expressed in world terms.
                (mapcar (function (lambda ( v ) (trans v 0 ocs t)))
                       '((1.0 0.0 0.0) (0.0 1.0 0.0) (0.0 0.0 1.0))
                )
                (BlockPromote:MxM
                    ;; Rotation about Z.
                    (list (list (cos ang) (- (sin ang)) 0.0)
                          (list (sin ang) (cos ang)     0.0)
                         '(0.0 0.0 1.0)
                    )
                    ;; Scale.
                    (list (list (cdr (assoc 41 enx)) 0.0 0.0)
                          (list 0.0 (cdr (assoc 42 enx)) 0.0)
                          (list 0.0 0.0 (cdr (assoc 43 enx)))
                    )
                )
            )
        )
        (mapcar '-
            (trans (cdr (assoc 10 enx)) ocs 0)
            (BlockPromote:MxV mat
                (cdr (assoc 10 (tblsearch "block" (cdr (assoc 2 enx)))))
            )
        )
    )
)

;; ---------------------------------------------------------------------------
;; BlockPromote:Copy
;; ---------------------------------------------------------------------------
;; Copies an entity into the same owner as another entity, returning the copy.
;;
;; The 32-bit and 64-bit forms of the ownership lookup differ, so the test is
;; performed once and this function then replaces itself with whichever version
;; applies on this machine.
;; ---------------------------------------------------------------------------
(defun BlockPromote:Copy ( ent par )
    (eval
        (list 'defun 'BlockPromote:Copy '( ent par )
            (list 'car
                (list 'vlax-invoke (BlockPromote:Doc) ''copyobjects
                     '(list (vlax-ename->vla-object ent))
                    (if (vlax-method-applicable-p (BlockPromote:Doc) 'objectidtoobject32)
                        (list 'vla-objectidtoobject32 (BlockPromote:Doc)
                             '(vla-get-ownerid32 (vlax-ename->vla-object par)))
                        (list 'vla-objectidtoobject   (BlockPromote:Doc)
                             '(vla-get-ownerid   (vlax-ename->vla-object par)))
                    )
                )
            )
        )
    )
    (BlockPromote:Copy ent par)
)

;; ---------------------------------------------------------------------------
;; BlockPromote:References
;; ---------------------------------------------------------------------------
;; Returns every path by which the named block is referenced, as a list of
;; entity chains running from the innermost reference outwards to the space it
;; is finally drawn in.
;;
;; The walk goes: block table record -> its owner dictionary -> the DXF 331
;; entries listing each reference of it. For each reference, the owner is
;; examined; if that owner is a space (*MODEL_SPACE or *PAPER_SPACE) the chain
;; ends there, otherwise the function recurses to find how THAT block is itself
;; referenced.
;;
;; This is what makes the routine work at any nesting depth.
;; ---------------------------------------------------------------------------
(defun BlockPromote:References ( blk / ent enx lst )
    (if (setq ent (tblobjname "block" blk))
        (foreach dxf (entget (cdr (assoc 330 (entget ent))))
            (if (and (= 331 (car dxf))
                     (setq ent (cdr dxf))
                     (setq enx (entget ent))
                     ;; Reading the owner from the REVERSED data avoids picking
                     ;; up a DXF 330 belonging to an attached reactor - which is
                     ;; the crash that version 1.2 of the original was released
                     ;; to fix, triggered by associative dimensions.
                     (setq enx (entget (cdr (assoc 330 (reverse enx)))))
                )
                (if (wcmatch (strcase (setq blk (cdr (assoc 2 enx)))) "`**_SPACE")
                    (setq lst (cons (list ent) lst))
                    (setq lst
                        (append
                            (mapcar (function (lambda ( l ) (cons ent l)))
                                    (BlockPromote:References blk)
                            )
                            lst
                        )
                    )
                )
            )
        )
    )
    lst
)

;; True if the entity is a reference to an xref.
(defun BlockPromote:IsXref ( ent )
    (= 4 (logand 4 (cdr (assoc 70 (tblsearch "block" (cdr (assoc 2 (entget ent))))))))
)

;; True if the entity is a dynamic block reference.
(defun BlockPromote:IsDynamic ( ent / obj )
    (and (vlax-property-available-p (setq obj (vlax-ename->vla-object ent)) 'isdynamicblock)
         (= :vlax-true (vla-get-isdynamicblock obj))
    )
)

;; ---------------------------------------------------------------------------
;; c:BLOCKPROMOTE  -  main routine
;; ---------------------------------------------------------------------------
(defun c:BLOCKPROMOTE ( / *error* vars vals sel count )

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

    (defun BlockPromote: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 )
        (BlockPromote:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** BLOCKPROMOTE error: " msg " **"))
        )
        (princ)
    )

    (setvar "CMDECHO" 0)

    ;; Re-prompt until something valid is picked. Each rejection explains
    ;; itself, so the user is never left guessing why a pick was refused.
    (while
        (progn
            (setvar 'errno 0)
            (setq sel (nentselp "\nSelect nested block: "))
            (cond
                (   (= 7 (getvar 'errno))
                    (princ "\nMissed, try again.")
                )
                (   (null sel) nil)

                ;; nentselp returns the containing chain as its last element;
                ;; if that has no second item, the object was not nested.
                (   (null (cadr (setq sel (last sel))))
                    (princ "\nThat object is not a nested block.")
                )

                (   (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" (cdr (assoc 8 (entget (car sel)))))))))
                    (princ "\nThat block is on a locked layer.")
                )

                (   (vl-some 'BlockPromote:IsXref (cdr sel))
                    (princ "\nBlocks nested inside xrefs cannot be extracted.")
                )

                (   (vl-some 'BlockPromote:IsDynamic (cdr sel))
                    (princ "\nBlocks nested inside dynamic blocks cannot be extracted.")
                )
            )
        )
    )

    (if sel
        (progn
            ;; 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")
            (setq count 0)

            ;; One pass per reference path found.
            (foreach chain (BlockPromote:References (cdr (assoc 2 (entget (cadr sel)))))
                (apply
                    (function
                        (lambda ( mat vec / obj )
                            ;; Walk outwards through the chain, combining each
                            ;; level's transform into the running total.
                            (foreach ent (cdr (reverse chain))
                                (apply
                                    (function
                                        (lambda ( m v )
                                            (setq vec (mapcar '+ vec (BlockPromote:MxV mat v))
                                                  mat (BlockPromote:MxM mat m)
                                            )
                                        )
                                    )
                                    (BlockPromote:RefGeom ent)
                                )
                            )

                            ;; Place a copy at the top level and apply the
                            ;; combined transform, as a 4x4 matrix with the
                            ;; displacement in its final column.
                            ;;
                            ;; A non-uniformly scaled reference makes TransformBy
                            ;; throw; that copy is deleted so no distorted block
                            ;; is left behind.
                            (if (vl-catch-all-error-p
                                    (vl-catch-all-apply 'vla-transformby
                                        (list (setq obj (BlockPromote:Copy (car sel) (last chain)))
                                              (vlax-tmatrix
                                                  (append
                                                      (mapcar (function (lambda ( m v ) (append m (list v))))
                                                              mat vec
                                                      )
                                                     '((0.0 0.0 0.0 1.0))
                                                  )
                                              )
                                        )
                                    )
                                )
                                (vla-delete obj)
                                (setq count (1+ count))
                            )
                        )
                    )
                    (BlockPromote:RefGeom (last chain))
                )
            )

            ;; Remove the block from the parent definition now every reference
            ;; has been promoted.
            (vla-delete (vlax-ename->vla-object (car sel)))
            (vla-regen  (BlockPromote:Doc) acactiveviewport)

            (princ (strcat "\n" (itoa count)
                           " reference" (if (= 1 count) "" "s") " promoted to the top level."
                   )
            )
        )
        (princ "\n*Cancelled*")
    )

    (BlockPromote:Restore)
    (princ)
)

(princ)