;;; ---------------------------------------------------------------------------
;;; BaseSnap.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Moves a block's base point to a corner or the centre of its own bounding
;;; box - chosen from a nine-point grid, exactly like text justification.
;;;
;;; Blocks inherited from elsewhere routinely have their base point somewhere
;;; arbitrary, so they never snap where you want them. This puts it on a corner
;;; or the middle, for any number of blocks at once.
;;;
;;; TWO METHODS - THE DIFFERENCE MATTERS
;;;
;;;   Retain visual position          every reference is moved to compensate,
;;;                                   so nothing appears to shift. The insertion
;;;                                   coordinates change instead. This is
;;;                                   usually what you want.
;;;
;;;   Retain insertion point position the coordinates stay put and the geometry
;;;                                   swings around them. Use this when blocks
;;;                                   are inserted at meaningful coordinates -
;;;                                   survey points, grid intersections - that
;;;                                   must not change.
;;;
;;; Your choice of justification and method is remembered between sessions.
;;;
;;; WHAT THE BOUNDING BOX MEASURES
;;; Text, MText and attribute definitions are DELIBERATELY EXCLUDED from the
;;; measurement. A block's label often extends well beyond its geometry, and
;;; including it would put the "bottom-left" corner somewhere in empty space
;;; below the drawing. Only real geometry counts.
;;;
;;; Nested blocks are measured properly by recursing into them and transforming
;;; the result by each nesting level's placement.
;;;
;;; Attributed blocks get an ATTSYNC afterwards, so their attributes follow the
;;; new base point instead of drifting away from it.
;;;
;;; ONE CAVEAT: if you UNDO this you will need a REGEN to see the drawing
;;; return to its previous appearance. The change is undone correctly; the
;;; display simply does not refresh on its own.
;;;
;;;   BASESNAP  - justify block base points
;;; ---------------------------------------------------------------------------

(vl-load-com)

;; Environment keys for the remembered settings.
(setq BaseSnap:MethodKey "YZ\\basesnap-method"
      BaseSnap:JustKey   "YZ\\basesnap-just"
)

;; ---------------------------------------------------------------------------
;; BaseSnap:Doc  /  BaseSnap:Blocks  -  cached COM collections
;; ---------------------------------------------------------------------------
(defun BaseSnap:Doc nil
    (eval (list 'defun 'BaseSnap:Doc 'nil
                (vla-get-activedocument (vlax-get-acad-object))
          )
    )
    (BaseSnap:Doc)
)

(defun BaseSnap:Blocks nil
    (eval (list 'defun 'BaseSnap:Blocks 'nil (vla-get-blocks (BaseSnap:Doc))))
    (BaseSnap:Blocks)
)

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

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

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

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

;; Midpoint of two points.
(defun BaseSnap:Mid ( a b )
    (mapcar (function (lambda ( x y ) (/ (+ x y) 2.0))) a b)
)

;; ---------------------------------------------------------------------------
;; BaseSnap:RefGeom
;; ---------------------------------------------------------------------------
;; Returns (matrix vector) describing how a block reference is placed within
;; its parent - the combined extrusion, rotation and scale, plus its insertion
;; displacement.
;;
;; Note the original declared its angle variable twice and omitted the entity
;; data variable entirely, so that leaked into the global namespace on every
;; call. Both are corrected here.
;; ---------------------------------------------------------------------------
(defun BaseSnap:RefGeom ( ent / ang enx mat ocs )
    (setq enx (entget ent)
          ang (cdr (assoc 050 enx))
          ocs (cdr (assoc 210 enx))
    )
    (list
        (setq mat
            (BaseSnap: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))
                )
                (BaseSnap: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)
            (BaseSnap:MxV mat (cdr (assoc 10 (tblsearch "block" (cdr (assoc 2 enx))))))
        )
    )
)

;; ---------------------------------------------------------------------------
;; BaseSnap:EffectiveName
;; ---------------------------------------------------------------------------
;; Returns a block's real name. An anonymous name beginning with "*" belongs to
;; a modified dynamic block; the real name is recovered from the definition's
;; "AcDbBlockRepBTag" extended data, whose group 1005 holds a handle to the
;; original definition.
;; ---------------------------------------------------------------------------
(defun BaseSnap:EffectiveName ( blk / rep )
    (if (and (wcmatch blk "`**")
             (setq rep
                 (cdadr (assoc -3
                     (entget (cdr (assoc 330 (entget (tblobjname "block" blk))))
                            '("AcDbBlockRepBTag")
                     )
                 ))
             )
             (setq rep (handent (cdr (assoc 1005 rep))))
        )
        (cdr (assoc 2 (entget rep)))
        blk
    )
)

;; ---------------------------------------------------------------------------
;; BaseSnap:PointsToBox
;; ---------------------------------------------------------------------------
;; Reduces a list of points to the four corners of their bounding rectangle,
;; anticlockwise from the lower left.
;; ---------------------------------------------------------------------------
(defun BaseSnap:PointsToBox ( lst )
    (   (lambda ( l )
            (mapcar
                (function
                    (lambda ( a ) (mapcar (function (lambda ( b ) ((eval b) l))) a))
                )
               '(
                    (caar   cadar  caddar)
                    (caadr  cadar  caddar)
                    (caadr cadadr  caddar)
                    (caar  cadadr  caddar)
                )
            )
        )
        (mapcar (function (lambda ( f ) (apply 'mapcar (cons f lst)))) '(min max))
    )
)

;; ---------------------------------------------------------------------------
;; BaseSnap:ReferenceBox
;; ---------------------------------------------------------------------------
;; Returns the bounding box of a nested block reference, transformed into its
;; parent's coordinates - which is how a nested block contributes correctly to
;; the outer block's measurement.
;; ---------------------------------------------------------------------------
(defun BaseSnap:ReferenceBox ( ref )
    (   (lambda ( lst )
            (apply
                (function
                    (lambda ( m v )
                        (mapcar (function (lambda ( p ) (mapcar '+ (BaseSnap:MxV m p) v))) lst)
                    )
                )
                (BaseSnap:RefGeom (vlax-vla-object->ename ref))
            )
        )
        (BaseSnap:DefinitionBox (vla-item (BaseSnap:Blocks) (vla-get-name ref)))
    )
)

;; ---------------------------------------------------------------------------
;; BaseSnap:DefinitionBox
;; ---------------------------------------------------------------------------
;; Returns the four corners of a block definition's bounding box.
;;
;; Three cases per object:
;;   invisible          skipped entirely
;;   nested block       measured recursively and transformed into place
;;   anything else      its own bounding box is taken, UNLESS it is text or an
;;                      attribute definition - see the note in the header
;;
;; Objects that cannot report a bounding box are skipped rather than aborting
;; the measurement.
;; ---------------------------------------------------------------------------
(defun BaseSnap:DefinitionBox ( def / llp lst urp )
    (vlax-for obj def
        (cond
            (   (= :vlax-false (vla-get-visible obj)))

            (   (= "AcDbBlockReference" (vla-get-objectname obj))
                (setq lst (append lst (BaseSnap:ReferenceBox obj)))
            )

            (   (and (not (wcmatch (vla-get-objectname obj) "AcDbAttributeDefinition,AcDb*Text"))
                     (vlax-method-applicable-p obj 'getboundingbox)
                     (not (vl-catch-all-error-p
                              (vl-catch-all-apply 'vla-getboundingbox (list obj 'llp 'urp))
                          )
                     )
                )
                (setq lst (vl-list* (vlax-safearray->list llp) (vlax-safearray->list urp) lst))
            )
        )
    )
    (BaseSnap:PointsToBox lst)
)

;; ---------------------------------------------------------------------------
;; BaseSnap:Ssget
;; ---------------------------------------------------------------------------
(defun BaseSnap: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)
)

;;; ---------------------------------------------------------------------------
;;; THE JUSTIFICATION PICKER
;;;
;;; DCL has no grid-of-buttons control, so the nine-point picker is drawn as a
;;; single image and the click position decoded back into which cell was hit.
;;; ---------------------------------------------------------------------------

;; ---------------------------------------------------------------------------
;; BaseSnap:PixelToJust
;; ---------------------------------------------------------------------------
;; Returns which justification cell a click landed in, or nil.
;;
;; Each entry is the lower-left pixel of a 16 x 16 hot zone; a click counts if
;; it falls inside one. The zones are laid out on an 80-pixel horizontal and
;; 58-pixel vertical pitch matching the drawn image.
;; ---------------------------------------------------------------------------
(defun BaseSnap:PixelToJust ( cpx )
    (vl-some
        (function
            (lambda ( a b )
                (if (apply 'and (mapcar '< a cpx (mapcar '+ a '(16 16)))) b)
            )
        )
       '((012 009) (092 009) (172 009)
         (012 067) (092 067) (172 067)
         (012 125) (092 125) (172 125)
        )
       '("TL" "TC" "TR" "ML" "MC" "MR" "BL" "BC" "BR")
    )
)

;; ---------------------------------------------------------------------------
;; BaseSnap:CirclePixels  -  midpoint circle algorithm
;; ---------------------------------------------------------------------------
;; Returns the pixels of a circle outline, used to draw the sample block shape
;; in the picker image.
;;
;; This is Bresenham's midpoint circle: it computes one octant using only
;; integer addition and subtraction, and mirrors those points into the other
;; seven - which is why it needs no trigonometry and no floating point.
;; ---------------------------------------------------------------------------
(defun BaseSnap:CirclePixels ( cx cy r / e l x y )
    (setq e (- r) x r y 0)
    (while (<= y x)
        (setq l (append l (BaseSnap:Plot8 cx cy x y))
              e (+ e y)
              y (1+ y)
              e (+ e y)
        )
        (if (<= 0 e)
            (setq x (1- x) e (- e x) e (- e x))
        )
    )
    l
)

;; Mirrors a point into all eight octants. The diagonal is not mirrored twice.
(defun BaseSnap:Plot8 ( cx cy x y )
    (append (BaseSnap:Plot4 cx cy x y)
            (if (/= x y) (BaseSnap:Plot4 cx cy y x))
    )
)

;; Mirrors a point into four quadrants, skipping duplicates on the axes.
(defun BaseSnap:Plot4 ( cx cy x y )
    (append
        (list (list (+ cx x) (+ cy y)))
        (if (/= x 0) (list (list (- cx x) (+ cy y))))
        (if (/= y 0) (list (list (+ cx x) (- cy y))))
        (if (and (/= x 0) (/= y 0)) (list (list (- cx x) (- cy y))))
    )
)

;; ---------------------------------------------------------------------------
;; BaseSnap:DrawPicker
;; ---------------------------------------------------------------------------
;; Draws the nine-point picker, highlighting the current choice.
;;
;; The image comprises three parts: nine small squares laid out in a grid, a
;; sample shape drawn beside them to show what the justification refers to, and
;; a filled highlight over whichever square is currently chosen.
;;
;; This function rewrites itself on first call, baking the tile dimensions into
;; the replacement - they cannot be read until the tile exists, and reading
;; them on every redraw would be wasted work.
;; ---------------------------------------------------------------------------
(defun BaseSnap:DrawPicker ( key jus )
    (eval
        (list 'defun 'BaseSnap:DrawPicker '( key jus )
           '(start_image key)
            (list 'fill_image 0 0 (dimx_tile key) (dimy_tile key) -15)

            ;; The nine grid squares, drawn as four vectors each.
           '(mapcar 'vector_image
               '(012 028 028 012 028 092 108 108 092 108 172 188 188 172 020 012 028 028 012 020 012 028 028 012
                 100 092 108 108 092 100 092 108 108 092 180 172 188 188 172 180 172 188 188 172 028 108 028 108)
               '(141 141 125 125 133 141 141 125 125 133 141 141 125 125 125 083 083 067 067 067 025 025 009 009
                 125 083 083 067 067 067 025 025 009 009 125 083 083 067 067 067 025 025 009 009 075 075 017 017)
               '(028 028 012 012 092 108 108 092 092 172 188 188 172 172 020 028 028 012 012 020 028 028 012 012
                 100 108 108 092 092 100 108 108 092 092 180 188 188 172 172 180 188 188 172 172 092 172 092 172)
               '(141 125 125 141 133 141 125 125 141 133 141 125 125 141 083 083 067 067 083 025 025 009 009 025
                 083 083 067 067 083 025 025 009 009 025 083 083 067 067 083 025 025 009 009 025 075 075 017 017)
               '(008 008 008 008 008 008 008 008 008 008 008 008 008 008 008 008 008 008 008 008 008 008 008 008
                 008 008 008 008 008 008 008 008 008 008 008 008 008 008 008 008 008 008 008 008 008 008 008 008)
            )

            ;; The sample shape beside the grid.
           '(mapcar 'vector_image
               '(155 155 045 045 042 020 065 144 125 067 086 105 107 045 047 045 045)
               '(107 043 043 107 017 056 056 107 107 107 107 107 067 090 107 071 052)
               '(155 045 045 155 020 065 042 155 155 092 150 155 131 092 111 073 054)
               '(043 043 107 107 056 056 017 096 077 082 043 057 043 043 043 043 043)
               '(086 086 086 086 001 001 001 096 096 096 096 096 096 096 096 096 096)
            )

            ;; A circle in the sample shape. Each pixel is drawn as a
            ;; zero-length vector, which is how a single point is plotted.
            (list 'mapcar ''(lambda ( x ) (apply 'vector_image (append x x '(5))))
                  (list 'quote (BaseSnap:CirclePixels 155 108 25))
            )

            ;; Highlight the chosen cell in red.
           '(apply 'fill_image
                (append
                    (cdr (assoc (strcase jus)
                               '(("TL" 013 010) ("TC" 093 010) ("TR" 173 010)
                                 ("ML" 013 068) ("MC" 093 068) ("MR" 173 068)
                                 ("BL" 013 126) ("BC" 093 126) ("BR" 173 126)
                                )
                         )
                    )
                   '(015 015 001)
                )
            )
           '(end_image)
        )
    )
    (BaseSnap:DrawPicker key jus)
)

;; ---------------------------------------------------------------------------
;; BaseSnap:CornerFunction
;; ---------------------------------------------------------------------------
;; Returns a function extracting the requested point from a four-corner
;; bounding box.
;;
;; The corners arrive anticlockwise from lower-left, so the four corner cases
;; are simple accessors and the five edge and centre cases are midpoints of the
;; appropriate pair.
;; ---------------------------------------------------------------------------
(defun BaseSnap:CornerFunction ( jus )
    (eval
        (nth (vl-position jus '("BL" "BR" "TR" "TL" "BC" "MC" "ML" "MR" "TC"))
           '(
                car                                                              ; bottom left
                cadr                                                             ; bottom right
                caddr                                                            ; top right
                cadddr                                                           ; top left
                (lambda ( lst ) (BaseSnap:Mid (car   lst) (cadr   lst)))         ; bottom centre
                (lambda ( lst ) (BaseSnap:Mid (car   lst) (caddr  lst)))         ; middle centre
                (lambda ( lst ) (BaseSnap:Mid (car   lst) (cadddr lst)))         ; middle left
                (lambda ( lst ) (BaseSnap:Mid (cadr  lst) (caddr  lst)))         ; middle right
                (lambda ( lst ) (BaseSnap:Mid (caddr lst) (cadddr lst)))         ; top centre
            )
        )
    )
)

;; ---------------------------------------------------------------------------
;; c:BASESNAP  -  main routine
;; ---------------------------------------------------------------------------
(defun c:BASESNAP ( / *error* vars vals att bln bnl bpt dch dcl def des ent enx
                      fun idx jus lck ret sel count )

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

    (defun BaseSnap:Restore ( )
        (if (= 'file (type des)) (close des))
        (if (and (= 'int (type dch)) (< 0 dch)) (unload_dialog dch))
        (if (and (= 'str (type dcl)) (setq dcl (findfile dcl))) (vl-file-delete dcl))
        ;; Locked layers must be relocked however the routine exits.
        (foreach lay lck (vla-put-lock lay :vlax-true))
        (setq lck nil)
        (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 )
        (BaseSnap:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** BASESNAP error: " msg " **"))
        )
        (princ)
    )

    (setvar "CMDECHO" 0)

    ;; Recover the remembered settings, validating each - a corrupted value
    ;; would otherwise be fed straight into the dialog.
    (if (not (and (setq ret (getenv BaseSnap:MethodKey))
                  (member (setq ret (strcase ret t)) '("rb1" "rb2"))
             )
        )
        (setq ret (setenv BaseSnap:MethodKey "rb1"))
    )
    (if (not (and (setq jus (getenv BaseSnap:JustKey))
                  (wcmatch (setq jus (strcase jus)) "[TMB][LCR]")
             )
        )
        (setq jus (setenv BaseSnap:JustKey "BL"))
    )

    ;; 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 (BaseSnap:Ssget "\nSelect blocks: " '(((0 . "INSERT"))))))
            (princ "\nNothing selected.")
        )

        (   (not
                (and
                    (setq dcl (vl-filename-mktemp "basesnap.dcl"))
                    (setq des (open dcl "w"))
                    (foreach str
                       '(
                            "basesnap : dialog"
                            "{"
                            "    label = \"Justify Block Base Point\";"
                            "    spacer_1;"
                            "    : boxed_column"
                            "    {"
                            "        label = \"Justification\";"
                            "        : image_button"
                            "        {"
                            "            key = \"jus\";"
                            "            width = 33.5; height = 11.62;"
                            "            fixed_width = true; fixed_height = true;"
                            "            alignment = centered;"
                            "            color = dialog_background;"
                            "        }"
                            "        spacer;"
                            "    }"
                            "    : boxed_radio_column"
                            "    {"
                            "        label = \"Method\";"
                            "        : radio_button { key = \"rb1\"; label = \"Retain visual position\"; }"
                            "        : radio_button { key = \"rb2\"; label = \"Retain insertion point position\"; }"
                            "        spacer;"
                            "    }"
                            "    spacer;"
                            "    ok_cancel;"
                            "}"
                        )
                        (write-line str des)
                    )
                    (not (setq des (close des)))
                    (< 0 (setq dch (load_dialog dcl)))
                )
            )
            (princ "\nThe dialog file could not be written.")
        )

        (   (not (new_dialog "basesnap" dch))
            (princ "\nThe dialog could not be displayed.")
        )

        (   (progn
                (BaseSnap:DrawPicker "jus" jus)
                ;; $x and $y are the click position within the image tile.
                (action_tile "jus"
                    (vl-prin1-to-string
                       '(
                            (lambda ( / tmp )
                                (if (setq tmp (BaseSnap:PixelToJust (list $x $y)))
                                    (BaseSnap:DrawPicker $key (setq jus tmp))
                                )
                            )
                        )
                    )
                )
                (set_tile ret "1")
                (foreach key '("rb1" "rb2")
                    (action_tile key "(setq ret $key)")
                )
                (zerop (start_dialog))
            )
            (princ "\n*Cancelled*")
        )

        (   t
            (setenv BaseSnap:MethodKey ret)
            (setenv BaseSnap:JustKey   jus)
            (setq fun (BaseSnap:CornerFunction jus))

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

            ;; ---------------------------------------------------------------
            ;; Move the contents of each distinct block definition, so the
            ;; origin ends up at the requested corner.
            ;;
            ;; Selecting several references of the same block must move its
            ;; definition ONCE, which is what the already-seen list guards -
            ;; moving it twice would displace it by double.
            ;;
            ;; Each block's shift is remembered, because the reference pass
            ;; below needs it.
            ;; ---------------------------------------------------------------
            (repeat (setq idx (sslength sel))
                (setq enx (entget (ssname sel (setq idx (1- idx))))
                      bln (strcase (BaseSnap:EffectiveName (cdr (assoc 2 enx))))
                )
                (if (not (assoc bln bnl))
                    (progn
                        (if (and (setq def (vla-item (BaseSnap:Blocks) bln))
                                 (setq bpt (fun (BaseSnap:DefinitionBox def)))
                            )
                            (vlax-for obj def (vlax-invoke obj 'move bpt '(0.0 0.0 0.0)))
                        )
                        (setq bnl (cons (cons bln bpt) bnl))
                        (if (= 1 (cdr (assoc 66 enx))) (setq att (cons bln att)))
                    )
                )
            )

            ;; ---------------------------------------------------------------
            ;; Retain-visual-position: move EVERY reference of each affected
            ;; block by the compensating amount, transformed through that
            ;; reference's own rotation and scale.
            ;;
            ;; Every reference is visited, not just the selected ones - all of
            ;; them shifted when the definition moved, so all of them need
            ;; correcting. Xref definitions are skipped.
            ;; ---------------------------------------------------------------
            (setq count 0)
            (if (= "rb1" ret)
                (vlax-for blk (BaseSnap:Blocks)
                    (if (= :vlax-false (vla-get-isxref blk))
                        (vlax-for obj blk
                            (if (and (= "AcDbBlockReference" (vla-get-objectname obj))
                                     (setq ent (vlax-vla-object->ename obj))
                                     (setq bpt (cdr (assoc (strcase (BaseSnap:EffectiveName
                                                                        (cdr (assoc 2 (entget ent)))))
                                                           bnl)))
                                     (vlax-write-enabled-p obj)
                                )
                                (progn
                                    (vlax-invoke obj 'move '(0.0 0.0 0.0)
                                        (BaseSnap:MxV (car (BaseSnap:RefGeom ent)) bpt)
                                    )
                                    (setq count (1+ count))
                                )
                            )
                        )
                    )
                )
            )

            ;; Attributed blocks need ATTSYNC, or their attributes stay at
            ;; their old positions relative to the new base point.
            (if att
                (foreach blk att (vl-cmdf "_.attsync" "_N" blk))
            )

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

            (vla-regen (BaseSnap:Doc) acallviewports)

            (princ (strcat "\n" (itoa (length bnl))
                           " block definition" (if (= 1 (length bnl)) "" "s")
                           " re-justified to " jus
                           (if (= "rb1" ret)
                               (strcat "; " (itoa count) " reference"
                                       (if (= 1 count) "" "s") " repositioned.")
                               "."
                           )
                   )
            )
            (princ "\n(A REGEN will be needed if you undo this.)")
        )
    )

    (BaseSnap:Restore)
    (princ)
)

(princ)