;;; ---------------------------------------------------------------------------
;;; GridSnap.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; PULL EXISTING GEOMETRY ONTO A GRID
;;;
;;; PURPOSE
;;;   Rounds the coordinates of things already drawn to the nearest multiple of
;;;   a spacing you give. Snap mode only helps while you are drawing; this is
;;;   for a drawing that has already gone astray - traced-over scans, imported
;;;   DXF from a package with different tolerances, or work done with snap off
;;;   where everything is a thousandth out and nothing quite meets.
;;;
;;;   Give it 1 and every coordinate becomes a whole number. Give it 25 and
;;;   everything lands on a 25mm grid.
;;;
;;; THE ROUNDING WAS WRONG BELOW ZERO
;;;   The original found the remainder and then either subtracted it or added
;;;   the difference, depending on which half of the step it fell in. That is
;;;   right for positive coordinates and wrong for negative ones, because REM
;;;   returns a negative remainder there. On a step of 5, a coordinate of -8
;;;   should go to -10; the original sent it to 0 - two whole steps out, and in
;;;   the wrong direction.
;;;
;;;   Rounding is now done in one step, by dividing, adding a half toward
;;;   whichever side of zero the number is on, truncating, and multiplying back.
;;;   That behaves the same either side of zero.
;;;
;;; WHAT ELSE WAS FIXED
;;;   - LWPOLYLINE was not handled at all. Only the old heavy POLYLINE was
;;;     recognised, and every polyline AutoCAD has drawn by default since
;;;     Release 14 is an LWPOLYLINE - so the most common object in most drawings
;;;     was silently skipped.
;;;   - Nor were ARC, ELLIPSE, MTEXT, 3DFACE or dimensions.
;;;   - The helper that did the rounding was a global function called SNAC, and
;;;     it worked on a global holding the entity data. Three more variables in
;;;     the block-insert branch were global by omission.
;;;   - CMDECHO was set to 0 and never put back.
;;;   - Blocks were moved with the MOVE command, one command call per block. The
;;;     insertion point is edited directly now, which is both faster and cannot
;;;     be upset by a running object snap.
;;;   - UNDO was set with (command "undo" "mark") - no underscore, so it failed
;;;     on a non-English AutoCAD, and a mark rather than a group.
;;;
;;; A WORD OF WARNING
;;;   This moves real geometry. The largest distance anything shifted is
;;;   reported at the end - if that number is bigger than you expected, U puts
;;;   it all back in one step.
;;;
;;;   GRIDSNAP  - round existing geometry onto a grid
;;; ---------------------------------------------------------------------------

;;; ---------------------------------------------------------------------------
;;; ROUNDING
;;; ---------------------------------------------------------------------------

;;; The nearest multiple of STEP. Adding half a step toward the number's own
;;; side of zero before truncating is what makes this work for negatives, which
;;; is where the original went wrong.
(defun GridSnap:Round ( v step )
    (if (or (null step) (<= step 0.0))
        v
        (* step (float (fix (+ (/ v step) (if (< v 0.0) -0.5 0.5)))))
    )
)

;;; Round every point held under one of CODES, leaving everything else alone.
;;; A group 10 on an LWPOLYLINE has two ordinates and on most other objects
;;; three, so the Z is carried through only when it was there to begin with -
;;; adding one to a lightweight polyline vertex would be rejected.
(defun GridSnap:RoundPoints ( data codes sx sy )
    (mapcar
        '(lambda ( pair )
            (if (and (member (car pair) codes) (listp (cdr pair)))
                (cons (car pair)
                      (if (cdddr pair)
                          (list (GridSnap:Round (cadr pair) sx)
                                (GridSnap:Round (caddr pair) sy)
                                (cadddr pair))
                          (list (GridSnap:Round (cadr pair) sx)
                                (GridSnap:Round (caddr pair) sy))))
                pair))
        data)
)

;;; Which DXF groups hold a position, for each kind of object. Anything not
;;; listed falls back to group 10 alone, which is the insertion or centre point
;;; of almost everything else.
(defun GridSnap:Codes ( kind )
    (cond
        ((= kind "LINE")       '(10 11))
        ((= kind "LWPOLYLINE") '(10))
        ((member kind '("SOLID" "TRACE" "3DFACE")) '(10 11 12 13))
        ((member kind '("TEXT" "ATTDEF" "ATTRIB")) '(10 11))
        ((= kind "DIMENSION")  '(10 13 14))
        (t '(10))
    )
)

;;; ---------------------------------------------------------------------------
;;; MOVING ONE OBJECT
;;;
;;; Returns how far the object's first point travelled, so the command can
;;; report the largest shift it made.
;;; ---------------------------------------------------------------------------

(defun GridSnap:One ( ent sx sy doRadius / data kind before after moved r sub subdata )
    (setq data   (entget ent)
          kind   (cdr (assoc 0 data))
          before (cdr (assoc 10 data))
          moved  0.0)

    (cond
        ;; A heavy polyline keeps its vertices as separate objects following the
        ;; header, so they have to be walked and edited one at a time.
        ((= kind "POLYLINE")
         (setq sub (entnext ent))
         (while (and sub (setq subdata (entget sub))
                     (/= "SEQEND" (cdr (assoc 0 subdata))))
             (if (= "VERTEX" (cdr (assoc 0 subdata)))
                 (progn
                     (setq before (cdr (assoc 10 subdata)))
                     (entmod (GridSnap:RoundPoints subdata '(10) sx sy))
                     (setq after (cdr (assoc 10 (entget sub)))
                           moved (max moved (distance before after)))))
             (setq sub (entnext sub)))
         (entupd ent))

        (t
         (entmod (GridSnap:RoundPoints data (GridSnap:Codes kind) sx sy))

         ;; A circle or arc can have its radius rounded too, but never to zero -
         ;; that would delete it in all but name.
         (if (and doRadius (member kind '("CIRCLE" "ARC")))
             (progn
                 (setq data (entget ent)
                       r    (GridSnap:Round (cdr (assoc 40 data)) sx))
                 (if (<= r 0.0) (setq r sx))
                 (entmod (subst (cons 40 r) (assoc 40 data) data))))

         (setq after (cdr (assoc 10 (entget ent))))
         (if (and before after) (setq moved (distance before after)))
         (entupd ent)))

    moved
)

;;; ---------------------------------------------------------------------------
;;; MAIN COMMAND
;;; ---------------------------------------------------------------------------

(defun c:GRIDSNAP ( / *error* vars vals ss i ent step sx sy doRadius
                      worst d n skipped kind unit v )

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

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

    (setvar "CMDECHO" 0)
    (setvar "BLIPMODE" 0)
    (setvar "HIGHLIGHT" 0)
    ;; AutoCAD 2015 and later refuse (command) inside an *error* handler unless
    ;; the routine says up front that it will use one.
    (vl-catch-all-apply '(lambda ( ) (*push-error-using-command*)) '())
    (command "_.UNDO" "_Begin")

    (princ "\nSelect what to pull onto the grid.")
    (setq ss (ssget))

    (if (null ss)
        (princ "\nNothing selected.")
        (progn
            ;; The current snap spacing is the obvious default, but only if snap
            ;; has been set to something meaningful.
            (setq unit (getvar "SNAPUNIT")
                  sx   (car unit)
                  sy   (cadr unit))
            (if (or (null sx) (<= sx 0.0)) (setq sx 1.0))
            (if (or (null sy) (<= sy 0.0)) (setq sy sx))

            (initget 6)
            (setq step (getdist (strcat "\nGrid spacing <" (rtos sx 2 4) ">: ")))
            (if step (setq sx step sy step))

            (initget "Yes No")
            (if (= "Yes" (getkword (strcat "\nDifferent spacing for Y [Yes/No] <No>: ")))
                (progn
                    (initget 6)
                    (setq v (getdist (strcat "\n  Y spacing <" (rtos sy 2 4) ">: ")))
                    (if v (setq sy v))))

            (initget "Yes No")
            (setq doRadius (= "Yes" (getkword
                "\nRound circle and arc radii as well [Yes/No] <No>: ")))

            ;; --- do it -----------------------------------------------------
            (setq i 0 n 0 skipped 0 worst 0.0)
            (while (< i (sslength ss))
                (setq ent  (ssname ss i)
                      kind (cdr (assoc 0 (entget ent))))
                ;; Objects whose position is derived rather than stored - an
                ;; associative hatch, a leader following its text - would be
                ;; corrupted by moving their points, so they are left alone.
                (if (member kind '("HATCH" "MLINE" "REGION" "SPLINE" "VIEWPORT"))
                    (setq skipped (1+ skipped))
                    (progn
                        (setq d (GridSnap:One ent sx sy doRadius)
                              worst (max worst d))
                        (if (> d 1e-9) (setq n (1+ n)))))
                (setq i (1+ i)))

            (princ (strcat "\n" (itoa n) " object"
                           (if (= n 1) "" "s") " moved onto the grid."))
            (if (> skipped 0)
                (princ (strcat "\n  " (itoa skipped)
                               " left alone - hatches, splines and multilines"
                               " take their shape from other things.")))
            (princ (strcat "\n  Furthest anything moved: " (rtos worst 2 4)))
            (if (> worst (* 1.5 (max sx sy)))
                (princ "\n  ** That is more than the grid spacing - check it"
                       " before going on. U puts it all back. **"))
        )
    )

    (GridSnap:Restore)
    (princ)
)

(princ)