;;; ---------------------------------------------------------------------------
;;; SheetStrip.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; The inverse of SheetEcho: removes matching objects from other layouts.
;;;
;;; Select something on the current sheet and its twin is deleted from every
;;; other sheet too. This is how you retract a preliminary stamp, a revision
;;; cloud or a superseded note that was previously copied across the whole set.
;;;
;;; COMMANDS
;;;   SHEETSTRIP     - remove from chosen layouts
;;;   SHEETSTRIPALL  - remove from every other layout
;;;
;;; Both also delete the originals from the current layout.
;;;
;;; HOW A "MATCHING" OBJECT IS IDENTIFIED
;;; There is no link between copies on different sheets, so matches have to be
;;; recognised by their characteristics. An object matches when ALL of these
;;; agree:
;;;
;;;   object type, layer, colour, linetype, lineweight
;;;   the position of its bounding box corners, to within 1e-6
;;;
;;; The cheap property comparison is done FIRST, and the bounding box is only
;;; computed for objects that pass it. That ordering matters: getting a
;;; bounding box is comparatively expensive, and a large drawing may hold
;;; thousands of candidates.
;;;
;;; READ THIS BEFORE USING IT ON A LIVE SET
;;; Identical geometry on the same layer WILL be treated as a match, even if it
;;; was never a copy of your selection. If two sheets legitimately carry the
;;; same symbol at the same coordinates, both go. Check the reported count.
;;;
;;;   SHEETSTRIP  /  SHEETSTRIPALL
;;; ---------------------------------------------------------------------------

(vl-load-com)

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

;; ---------------------------------------------------------------------------
;; SheetStrip:EscapeWildcards
;; ---------------------------------------------------------------------------
;; Escapes the characters ssget treats as wildcards, by prefixing each with a
;; reverse quote.
;;
;; Essential here because layout and layer names are matched as PATTERNS. A
;; layout genuinely called "Sheet [A]" contains bracket characters that would
;; otherwise be read as a character-set wildcard, and the match would silently
;; fail.
;; ---------------------------------------------------------------------------
(defun SheetStrip:EscapeWildcards ( str )
    (vl-list->string
        (apply 'append
            (mapcar
                (function
                    (lambda ( c )
                        (if (member c '(35 64 46 42 63 126 91 93 45 44))
                            (list 96 c)
                            (list c)
                        )
                    )
                )
                (vl-string->list str)
            )
        )
    )
)

;; ---------------------------------------------------------------------------
;; SheetStrip:Key
;; ---------------------------------------------------------------------------
;; Returns the cheap identity of an object - the five properties compared
;; before any bounding box is computed.
;; ---------------------------------------------------------------------------
(defun SheetStrip:Key ( obj )
    (list (vla-get-objectname obj)
          (vla-get-layer      obj)
          (vla-get-color      obj)
          (vla-get-linetype   obj)
          (vla-get-lineweight obj)
    )
)

;; ---------------------------------------------------------------------------
;; SheetStrip:ListBox
;; ---------------------------------------------------------------------------
;; Multi-select list, returning the chosen strings or nil.
;;
;; The dialog is written at run time and deleted immediately after, keeping
;; this a single self-contained file. The dialog name "sheetstrip" must match
;; between the DCL text and the new_dialog call.
;; ---------------------------------------------------------------------------
(defun SheetStrip:ListBox ( msg lst / dch des tmp rtn )
    (cond
        (   (not
                (and
                    (setq tmp (vl-filename-mktemp nil nil ".dcl"))
                    (setq des (open tmp "w"))
                    (write-line
                        (strcat "sheetstrip:dialog{label=\"" msg "\";spacer;"
                                ":list_box{key=\"list\";multiple_select=true;width=50;height=15;}"
                                "spacer;ok_cancel;}"
                        )
                        des
                    )
                    (not (close des))
                    (< 0 (setq dch (load_dialog tmp)))
                    (new_dialog "sheetstrip" dch)
                )
            )
            (princ "\nThe layout selection dialog could not be created.")
        )
        (   t
            (start_list "list")
            (foreach itm lst (add_list itm))
            (end_list)
            (setq rtn (set_tile "list" "0"))
            (action_tile "list" "(setq rtn $value)")
            (setq rtn
                (if (= 1 (start_dialog))
                    (mapcar (function (lambda ( n ) (nth n lst))) (read (strcat "(" rtn ")")))
                )
            )
        )
    )
    (if (and dch (< 0 dch)) (unload_dialog dch))
    (if (and tmp (setq tmp (findfile tmp))) (vl-file-delete tmp))
    rtn
)

;; ---------------------------------------------------------------------------
;; SheetStrip:Run
;; ---------------------------------------------------------------------------
;; Shared implementation for both commands.
;;
;; all - [boolean] T to strip every other layout without prompting
;; ---------------------------------------------------------------------------
(defun SheetStrip:Run ( all / *error* vars vals current sel1 sel2 idx ent enx obj
                              types layers layouts taborder targets record
                              lower upper key matches count )

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

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

    (setvar "CMDECHO" 0)
    (setq current (strcase (getvar 'ctab)))

    (cond
        (   (/= 1 (getvar 'cvport))
            (princ "\nThis command is only available in paper space.")
        )

        (   (not (cdr (layoutlist)))
            (princ "\nThis drawing has only one layout.")
        )

        (   (not (setq sel1 (ssget "_:L" (list (cons 410 (SheetStrip:EscapeWildcards current))))))
            (princ "\nNothing selected.")
        )

        ;; Choose target layouts, unless stripping all of them.
        (   (and (not all)
                 (progn
                     (vlax-for lyt (vla-get-layouts (SheetStrip:Doc))
                         (cond
                             ((= :vlax-true (vla-get-modeltype lyt)))
                             ((= current (strcase (vla-get-name lyt))))
                             ((setq layouts  (cons (vla-get-name lyt) layouts)
                                    taborder (cons (vla-get-taborder lyt) taborder)
                              )
                             )
                         )
                     )
                     ;; Offered in tab order, which is the order the user sees.
                     (null (setq targets
                               (SheetStrip:ListBox "Select Target Layouts"
                                   (mapcar (function (lambda ( n ) (nth n layouts)))
                                           (vl-sort-i taborder '<)
                                   )
                               )
                           )
                     )
                 )
            )
            (princ "\n*Cancelled* - no target layouts chosen.")
        )

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

                ;; -------------------------------------------------------
                ;; Record the identity of everything selected, then delete
                ;; it from the current layout. The record is what the other
                ;; layouts are then searched against.
                ;; -------------------------------------------------------
                (repeat (setq idx (sslength sel1))
                    (setq idx (1- idx)
                          ent (ssname sel1 idx)
                          enx (entget ent)
                          obj (vlax-ename->vla-object ent)
                    )
                    (vla-getboundingbox obj 'lower 'upper)

                    ;; Collect the distinct types and layers present, to build
                    ;; an efficient search filter below.
                    (if (not (member (cdr (assoc 0 enx)) types))
                        (setq types (cons (cdr (assoc 0 enx)) types))
                    )
                    (if (not (member (cdr (assoc 8 enx)) layers))
                        (setq layers (cons (cdr (assoc 8 enx)) layers))
                    )

                    (setq record
                        (cons (list (SheetStrip:Key obj)
                                    (vlax-safearray->list lower)
                                    (vlax-safearray->list upper)
                              )
                              record
                        )
                    )
                    (vla-delete obj)
                )

                (princ (strcat "\n" (itoa (sslength sel1))
                               " object" (if (= 1 (sslength sel1)) "" "s")
                               " deleted from the current layout."
                       )
                )

                ;; -------------------------------------------------------
                ;; Gather candidates from the target layouts: anything of a
                ;; matching type AND on a matching layer. The layout clause
                ;; is either "not model space and not the current tab", or
                ;; an explicit list of chosen layouts.
                ;; -------------------------------------------------------
                (not (setq sel2
                    (ssget "_X"
                        (append
                           '((-4 . "<OR"))
                            (mapcar (function (lambda ( x ) (cons 0 (SheetStrip:EscapeWildcards x)))) types)
                           '((-4 . "OR>") (-4 . "<OR"))
                            (mapcar (function (lambda ( x ) (cons 8 (SheetStrip:EscapeWildcards x)))) layers)
                           '((-4 . "OR>"))
                            (if all
                                (list '(-4 . "<NOT")
                                          '(-4 . "<OR")
                                              '(410 . "Model")
                                               (cons 410 (getvar 'ctab))
                                          '(-4 . "OR>")
                                      '(-4 . "NOT>")
                                )
                                (append '((-4 . "<OR"))
                                        (mapcar (function (lambda ( x ) (cons 410 (SheetStrip:EscapeWildcards x)))) targets)
                                       '((-4 . "OR>"))
                                )
                            )
                        )
                    )
                ))
            )
            (princ "\nNo matching objects were found in the other layouts.")
        )

        (   t
            ;; -----------------------------------------------------------
            ;; Test each candidate. Cheap property comparison first, and
            ;; only then the bounding box - which is what keeps this usable
            ;; on a drawing with thousands of candidate objects.
            ;; -----------------------------------------------------------
            (setq count 0)
            (repeat (setq idx (sslength sel2))
                (setq matches nil
                      idx     (1- idx)
                      obj     (vlax-ename->vla-object (ssname sel2 idx))
                      key     (SheetStrip:Key obj)
                )

                (foreach itm record
                    (if (equal key (car itm))
                        (setq matches (cons (cdr itm) matches))
                    )
                )

                (cond
                    (   (null matches))
                    (   (progn
                            (vla-getboundingbox obj 'lower 'upper)
                            (setq lower (vlax-safearray->list lower)
                                  upper (vlax-safearray->list upper)
                            )
                            (vl-some
                                (function
                                    (lambda ( bb )
                                        (and (equal lower (car  bb) 1e-6)
                                             (equal upper (cadr bb) 1e-6)
                                        )
                                    )
                                )
                                matches
                            )
                        )
                        (vla-delete obj)
                        (setq count (1+ count))
                    )
                )
            )

            (princ (strcat "\n" (itoa count)
                           " matching object" (if (= 1 count) "" "s")
                           " deleted from other layouts."
                   )
            )
        )
    )

    (SheetStrip:Restore)
    (princ)
)

;; ---------------------------------------------------------------------------
;; Command wrappers
;; ---------------------------------------------------------------------------
(defun c:SHEETSTRIP    nil (SheetStrip:Run nil))   ; chosen layouts
(defun c:SHEETSTRIPALL nil (SheetStrip:Run   t))   ; every layout

(princ)