;;; ---------------------------------------------------------------------------
;;; BasePin.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Moves a block definition's BASE POINT - the grip you insert and rotate it
;;; by - without having to redefine the block.
;;;
;;; The usual reason is a block that was created with its base point at some
;;; arbitrary corner, so it never snaps where you want it. Rather than
;;; exploding and rebuilding, this shifts the base point and updates every
;;; reference in the drawing.
;;;
;;; TWO COMMANDS - THE DIFFERENCE MATTERS
;;;
;;;   BASEPIN      Keeps each reference's INSERTION COORDINATES the same. The
;;;                geometry therefore appears to move, swinging around the
;;;                unchanged insertion point.
;;;
;;;                Use this when the block is inserted at meaningful
;;;                coordinates - a survey point, a grid intersection - and
;;;                those coordinates must not change.
;;;
;;;   BASEPINHOLD  Keeps each reference's VISUAL POSITION the same. Every
;;;                reference is moved to compensate, so nothing appears to
;;;                shift; the insertion coordinates change instead.
;;;
;;;                Use this when the drawing looks right and you only want a
;;;                better grip point. This is usually the one you want.
;;;
;;; WHAT ELSE IT HANDLES
;;;   Locked layers are temporarily unlocked and relocked afterwards, so
;;;   references on them are not silently skipped.
;;;
;;;   Attributed blocks get an ATTSYNC afterwards, which repositions their
;;;   attributes relative to the new base point. Without it the attributes stay
;;;   where they were and drift away from the block.
;;;
;;;   Rotated, scaled and mirrored references all work, because the shift is
;;;   transformed through each reference's own placement.
;;;
;;; ONE CAVEAT
;;; If you UNDO this operation you will need a REGEN to see the drawing return
;;; to its previous appearance. The change to the block definition is undone
;;; correctly; the display simply does not refresh on its own.
;;; ---------------------------------------------------------------------------

(vl-load-com)

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

;;; ---------------------------------------------------------------------------
;;; MATRIX HELPERS - namespaced, since the originals were bare globals named
;;; trp, mxm and mxv.
;;; ---------------------------------------------------------------------------

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

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

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

;; ---------------------------------------------------------------------------
;; BasePin:RefGeom
;; ---------------------------------------------------------------------------
;; Returns (matrix vector) describing how a block reference is placed - the
;; combined extrusion, rotation and scale, plus its insertion displacement.
;; ---------------------------------------------------------------------------
(defun BasePin:RefGeom ( ent / ang enx mat ocs )
    (setq enx (entget ent)
          ang (cdr (assoc 050 enx))
          ocs (cdr (assoc 210 enx))
    )
    (list
        (setq mat
            (BasePin:MxM
                (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))
                )
                (BasePin:MxM
                    (list (list (cos ang) (- (sin ang)) 0.0)
                          (list (sin ang) (cos ang)     0.0)
                         '(0.0 0.0 1.0)
                    )
                    (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)
            (BasePin:MxV mat (cdr (assoc 10 (tblsearch "block" (cdr (assoc 2 enx))))))
        )
    )
)

;; ---------------------------------------------------------------------------
;; BasePin:ReverseGeom
;; ---------------------------------------------------------------------------
;; The inverse of the above: transforms world coordinates into the block
;; definition's own coordinate system.
;;
;; Each component is inverted - the reciprocal of each scale factor, rotation
;; by minus the angle (which is why the sine terms are transposed), and the
;; world axes expressed in the object's plane.
;; ---------------------------------------------------------------------------
(defun BasePin:ReverseGeom ( ent / ang enx mat ocs )
    (setq enx (entget ent)
          ang (cdr (assoc 050 enx))
          ocs (cdr (assoc 210 enx))
    )
    (list
        (setq mat
            (BasePin:MxM
                (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))))
                )
                (BasePin:MxM
                    (list (list (cos ang)     (sin ang) 0.0)
                          (list (- (sin ang)) (cos ang) 0.0)
                         '(0.0 0.0 1.0)
                    )
                    (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)))))
            (BasePin:MxV mat (trans (cdr (assoc 10 enx)) ocs 0))
        )
    )
)

;; ---------------------------------------------------------------------------
;; BasePin:BlockName
;; ---------------------------------------------------------------------------
;; Returns a block reference's effective name - the name the user knows it by,
;; rather than the anonymous "*U27" style name a modified dynamic block is
;; stored under.
;; ---------------------------------------------------------------------------
(defun BasePin:BlockName ( obj )
    (if (vlax-property-available-p obj 'effectivename)
        (defun BasePin:BlockName ( obj ) (vla-get-effectivename obj))
        (defun BasePin:BlockName ( obj ) (vla-get-name obj))
    )
    (BasePin:BlockName obj)
)

;; ---------------------------------------------------------------------------
;; BasePin:Run
;; ---------------------------------------------------------------------------
;; Shared implementation for both commands.
;;
;; hold - [boolean] T to keep each reference's visual position (BASEPINHOLD),
;;        nil to keep its insertion coordinates (BASEPIN)
;; ---------------------------------------------------------------------------
(defun BasePin:Run ( hold / *error* vars vals ent newpt mat vec name locked count )

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

    (defun BasePin:Restore ( )
        ;; Locked layers must be relocked on every exit path, or an interrupted
        ;; run leaves the drawing's layer locks quietly changed.
        (foreach lay locked (vla-put-lock lay :vlax-true))
        (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 )
        (BasePin:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** BASEPIN error: " msg " **"))
        )
        (princ)
    )

    (setvar "CMDECHO" 0)

    ;; Re-prompt until a block is picked, or the user gives up.
    (while
        (progn
            (setvar 'errno 0)
            (setq ent (car (entsel "\nSelect a block: ")))
            (cond
                (   (= 7 (getvar 'errno))
                    (princ "\nMissed, try again.")
                )
                (   (= 'ename (type ent))
                    (if (/= "INSERT" (cdr (assoc 0 (entget ent))))
                        (princ "\nThat object is not a block.")
                    )
                )
            )
        )
    )

    (if (and (= 'ename (type ent))
             (setq newpt (getpoint "\nSpecify the new base point: "))
        )
        (progn
            ;; ---------------------------------------------------------------
            ;; Work out the shift, expressed in the block DEFINITION's own
            ;; coordinates. The picked point and the reference's insertion
            ;; point are both taken to world coordinates, the difference is the
            ;; shift in world terms, and the reverse matrix converts that into
            ;; definition terms - undoing the reference's rotation and scale.
            ;; ---------------------------------------------------------------
            (setq mat  (car (BasePin:ReverseGeom ent))
                  vec  (BasePin:MxV mat
                           (mapcar '- (trans newpt 1 0)
                                      (trans (cdr (assoc 10 (entget ent))) ent 0)
                           )
                       )
                  name (BasePin:BlockName (vlax-ename->vla-object ent))
            )

            ;; 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")

            ;; Unlock every locked layer, remembering which.
            (vlax-for lay (vla-get-layers (BasePin:Doc))
                (if (= :vlax-true (vla-get-lock lay))
                    (progn
                        (vla-put-lock lay :vlax-false)
                        (setq locked (cons lay locked))
                    )
                )
            )

            ;; ---------------------------------------------------------------
            ;; Move all the geometry INSIDE the definition by the shift. This
            ;; is what actually relocates the base point: the origin stays put
            ;; and the contents move relative to it.
            ;; ---------------------------------------------------------------
            (vlax-for obj (vla-item (vla-get-blocks (BasePin:Doc)) name)
                (vlax-invoke obj 'move vec '(0.0 0.0 0.0))
            )

            ;; ---------------------------------------------------------------
            ;; For BASEPINHOLD, move every reference by the equal and opposite
            ;; amount so nothing appears to have shifted. The vector is
            ;; transformed through each reference's OWN placement, so rotated
            ;; and scaled references each move by the right amount in their own
            ;; direction.
            ;;
            ;; Xref definitions are skipped - their contents belong to the
            ;; referenced drawing.
            ;; ---------------------------------------------------------------
            (setq count 0)
            (if hold
                (vlax-for blk (vla-get-blocks (BasePin:Doc))
                    (if (= :vlax-false (vla-get-isxref blk))
                        (vlax-for obj blk
                            (if (and (= "AcDbBlockReference" (vla-get-objectname obj))
                                     (= name (BasePin:BlockName obj))
                                     (vlax-write-enabled-p obj)
                                )
                                (progn
                                    (vlax-invoke obj 'move '(0.0 0.0 0.0)
                                        (BasePin:MxV
                                            (car (BasePin:RefGeom (vlax-vla-object->ename obj)))
                                            vec
                                        )
                                    )
                                    (setq count (1+ count))
                                )
                            )
                        )
                    )
                )
            )

            ;; ---------------------------------------------------------------
            ;; Attributed blocks need ATTSYNC, or their attributes stay at
            ;; their old positions relative to the new base point.
            ;; ---------------------------------------------------------------
            (if (= 1 (cdr (assoc 66 (entget ent))))
                (vl-cmdf "_.attsync" "_N" name)
            )

            (foreach lay locked (vla-put-lock lay :vlax-true))
            (setq locked nil)

            (vla-regen (BasePin:Doc) acallviewports)

            (princ (strcat "\nBase point of block \"" name "\" changed"
                           (if hold
                               (strcat "; " (itoa count) " reference"
                                       (if (= 1 count) "" "s") " repositioned."
                               )
                               "."
                           )
                   )
            )
            (princ "\n(A REGEN will be needed if you undo this.)")
        )
        (princ "\n*Cancelled*")
    )

    (BasePin:Restore)
    (princ)
)

;; ---------------------------------------------------------------------------
;; Command wrappers
;; ---------------------------------------------------------------------------
(defun c:BASEPIN     nil (BasePin:Run nil))   ; keep insertion coordinates
(defun c:BASEPINHOLD nil (BasePin:Run   t))   ; keep visual position

(princ)