;;; ---------------------------------------------------------------------------
;;; HatchClear.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Clears hatching from behind text, so buried annotation becomes readable
;;; again.
;;;
;;; Select the text and the offending hatch, and the hatch gains a new island
;;; boundary around each piece of text - genuinely cutting the pattern away
;;; rather than masking it, so it stays correct when plotted.
;;;
;;; This also reaches text INSIDE BLOCKS, including attributes, and blocks
;;; nested inside other blocks to any depth. That is what makes it useful in
;;; practice: it is almost always a block's label that ends up buried.
;;;
;;; HOW NESTED TEXT IS HANDLED - AND THE ONE COST
;;; A hatch boundary cannot reference an object inside a block. So for nested
;;; text, the routine recreates that text temporarily as a normal top-level
;;; object, positioned exactly where the nested original appears, adds the
;;; boundary from it, and then deletes the temporary copy.
;;;
;;; The consequence is unavoidable: adding a boundary from an object that is
;;; then deleted forces the hatch to become NON-ASSOCIATIVE. So if any blocks
;;; are included in the selection, the hatch will no longer follow its original
;;; boundary if that boundary is later edited. Selecting only plain text keeps
;;; the hatch associative.
;;;
;;; Invisible attributes and objects hidden by DXF group 60 are skipped, since
;;; carving a hole for text nobody can see would only put an unexplained gap in
;;; the hatch.
;;;
;;;   HATCHCLEAR  - clear hatch from behind selected text and blocks
;;; ---------------------------------------------------------------------------

(vl-load-com)

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

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

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

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

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

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

;; Assembles a 4x4 transformation from a 3x3 matrix and a displacement vector.
(defun HatchClear:TMatrix ( mat vec )
    (vlax-tmatrix
        (append
            (mapcar (function (lambda ( row v ) (append row (list v)))) mat vec)
           '((0.0 0.0 0.0 1.0))
        )
    )
)

;; ---------------------------------------------------------------------------
;; DXF-pair filtering helpers.
;; ---------------------------------------------------------------------------

;; Removes every pair whose group code is listed.
(defun HatchClear:RemovePairs ( codes lst )
    (vl-remove-if (function (lambda ( x ) (member (car x) codes))) lst)
)

;; Removes only the FIRST occurrence of each listed code - needed for MText,
;; which carries several group 10 and 40 entries with different meanings.
(defun HatchClear:RemoveFirstPairs ( codes lst )
    (vl-remove-if
        (function
            (lambda ( x )
                (if (member (car x) codes)
                    (progn (setq codes (vl-remove (car x) codes)) t)
                )
            )
        )
        lst
    )
)

;; ---------------------------------------------------------------------------
;; HatchClear:MakeTemp
;; ---------------------------------------------------------------------------
;; Creates a temporary top-level copy of a text object from its DXF data.
;;
;; Two categories are stripped before creation:
;;
;;   Handle, layer, linetype, colour, thickness, lineweight and reactor groups
;;   are removed and replaced with neutral values - the copy exists only to
;;   define a boundary and is deleted immediately, so it must not inherit
;;   anything that could tie it to the original.
;;
;;   Any pair whose VALUE is an entity name is removed, because those point at
;;   objects inside the block that will not exist at the top level and would
;;   make entmakex fail.
;; ---------------------------------------------------------------------------
(defun HatchClear:MakeTemp ( enx )
    (entmakex
        (append
            (vl-remove-if
                (function
                    (lambda ( x )
                        (or (member (car x) '(005 006 008 039 048 062 102 370))
                            (= 'ename (type (cdr x)))
                        )
                    )
                )
                enx
            )
           '(
                (006 . "CONTINUOUS")
                (008 . "0")
                (039 . 0.0)
                (048 . 1.0)
                (062 . 7)
                (370 . 0)
            )
        )
    )
)

;; ---------------------------------------------------------------------------
;; HatchClear:Attributes
;; ---------------------------------------------------------------------------
;; Creates temporary copies of a block reference's visible attributes, and
;; returns their entity names.
;;
;; Bit 1 of DXF group 70 marks an attribute invisible; those are skipped.
;;
;; A multi-line attribute is identified by the "Embedded Object" marker and is
;; recreated as MTEXT; a single-line one becomes TEXT. In the TEXT case group
;; 74 is substituted into group 73, because vertical justification is stored
;; under different codes on the two entity types.
;; ---------------------------------------------------------------------------
(defun HatchClear:Attributes ( ent / att atx lst tmp )
    (setq att (entnext ent)
          atx (entget  att)
    )
    (while (= "ATTRIB" (cdr (assoc 0 atx)))
        (if (and (zerop (logand 1 (cdr (assoc 70 atx))))
                 (setq tmp
                     (HatchClear:MakeTemp
                         (if (member '(101 . "Embedded Object") atx)
                             (append '((0 . "MTEXT") (100 . "AcDbEntity") (100 . "AcDbMText"))
                                 (HatchClear:RemoveFirstPairs '(001 007 010 011 040 041 050 071 072 073 210)
                                     (HatchClear:RemovePairs  '(000 002 042 043 051 070 074 100 101 102 280 330 360)
                                                              atx
                                     )
                                 )
                             )
                             (append '((0 . "TEXT"))
                                 (HatchClear:RemovePairs '(000 002 070 074 100 280)
                                     (subst (cons 73 (cdr (assoc 74 atx))) (assoc 74 atx) atx)
                                 )
                             )
                         )
                     )
                 )
            )
            (setq lst (cons tmp lst))
        )
        (setq att (entnext att)
              atx (entget  att)
        )
    )
    lst
)

;; ---------------------------------------------------------------------------
;; HatchClear:ProcessBlock
;; ---------------------------------------------------------------------------
;; Walks a block definition, creating temporary top-level copies of every text
;; object found within it - recursing into nested blocks - and transforms them
;; all into position by the supplied matrix.
;;
;; Because the recursion transforms each level's results before returning them,
;; each nested object ends up transformed once per level of nesting, which
;; correctly composes into its true position on the drawing.
;;
;; mat - [variant] transformation for this level
;; blk - [str] block definition name
;; ---------------------------------------------------------------------------
(defun HatchClear:ProcessBlock ( mat blk / ent enx lst tmp )
    (if (setq ent (tblobjname "block" blk))
        (while (setq ent (entnext ent))
            (setq enx (entget ent))
            (cond
                ;; DXF 60 set to 1 means the object is hidden.
                (   (= 1 (cdr (assoc 60 enx))))

                (   (wcmatch (cdr (assoc 0 enx)) "TEXT,MTEXT")
                    (if (setq tmp (HatchClear:MakeTemp enx))
                        (setq lst (cons tmp lst))
                    )
                )

                (   (= "INSERT" (cdr (assoc 0 enx)))
                    (if (= 1 (cdr (assoc 66 enx)))
                        (setq lst (append lst (HatchClear:Attributes ent)))
                    )
                    (setq lst
                        (append lst
                            (HatchClear:ProcessBlock
                                (apply 'HatchClear:TMatrix (HatchClear:RefGeom ent))
                                (cdr (assoc 2 enx))
                            )
                        )
                    )
                )
            )
        )
    )
    (foreach ent lst
        (vla-transformby (vlax-ename->vla-object ent) mat)
    )
    lst
)

;; ---------------------------------------------------------------------------
;; HatchClear:Ssget
;; ---------------------------------------------------------------------------
;; ssget with a custom prompt, restoring NOMUTT to its captured value.
;; ---------------------------------------------------------------------------
(defun HatchClear: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)
)

;; ---------------------------------------------------------------------------
;; c:HATCHCLEAR  -  main routine
;; ---------------------------------------------------------------------------
;; Note that the original defined its error handler without declaring it local,
;; leaving it installed globally after the command finished. It is localised
;; here, as are the temporary entity lists it relies on.
;; ---------------------------------------------------------------------------
(defun c:HATCHCLEAR ( / *error* vars vals sel hat idx ent enx direct temps )

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

    ;; The temporary objects must be removed on EVERY exit path, or an
    ;; interrupted run leaves stray text scattered across the drawing.
    (defun HatchClear:Restore ( )
        (foreach ent temps
            (if (entget ent) (entdel ent))
        )
        (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 )
        (HatchClear:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** HATCHCLEAR error: " msg " **"))
        )
        (princ)
    )

    (setvar "CMDECHO" 0)
    ;; 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
        ;; Temporary objects are created on layer 0, so it must be unlocked.
        (   (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" "0")))))
            (princ "\nLayer \"0\" is locked - unlock it before running this.")
        )

        (   (and
                (setq sel (HatchClear:Ssget "\nSelect text and blocks to clear: "
                                           '(((0 . "INSERT,TEXT,MTEXT")))))
                (setq hat (HatchClear:Ssget "\nSelect the hatch to modify: "
                                           '("_+.:E:S:L" ((0 . "HATCH")))))
            )
            ;; Sort the selection: plain text can be used as a boundary
            ;; directly, blocks need temporary copies of their contents.
            (repeat (setq idx (sslength sel))
                (setq ent (ssname sel (setq idx (1- idx)))
                      enx (entget ent)
                )
                (if (wcmatch (cdr (assoc 0 enx)) "*TEXT")
                    (setq direct (cons ent direct))
                    (progn
                        (setq temps
                            (append temps
                                (HatchClear:ProcessBlock
                                    (apply 'HatchClear:TMatrix (HatchClear:RefGeom ent))
                                    (cdr (assoc 2 enx))
                                )
                            )
                        )
                        (if (= 1 (cdr (assoc 66 enx)))
                            (setq temps (append temps (HatchClear:Attributes ent)))
                        )
                    )
                )
            )

            (if (or direct temps)
                (progn
                    ;; Associativity must be dropped first when temporary
                    ;; objects are involved - see the note in the header.
                    (if temps
                        (command "_.-hatchedit" (ssname hat 0) "_DI")
                    )
                    (command "_.-hatchedit" (ssname hat 0) "_AD" "_S")
                    (apply 'command (append direct temps))
                    (command "" "")

                    (princ (strcat "\nHatch cleared from behind "
                                   (itoa (+ (length direct) (length temps)))
                                   " text object"
                                   (if (= 1 (+ (length direct) (length temps))) "" "s")
                                   "."
                           )
                    )
                    (if temps
                        (princ "\nNote: the hatch is now non-associative, because blocks were included.")
                    )
                )
                (princ "\nNo text was found in the selection.")
            )
        )

        (   t
            (princ "\n*Cancelled*")
        )
    )

    (HatchClear:Restore)
    (princ)
)

(princ)