;;; ---------------------------------------------------------------------------
;;; BackDrop.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Adds, removes and controls the BACKGROUND MASK on MText, multileaders and
;;; dimensions - all in one dialog, across a whole selection at once.
;;;
;;; A background mask punches the drawing out behind a piece of text so the
;;; text stays readable over hatching or dense linework. AutoCAD offers it, but
;;; through three different places depending on the object type, and only one
;;; object at a time.
;;;
;;; Select any mixture of the three types, set the options once, and every
;;; object takes them.
;;;
;;; THE OPTIONS
;;;   Use Background Mask   on or off
;;;   Mask Offset           how far the mask extends past the text, as a
;;;                         multiple of text height, between 1 and 5. The
;;;                         >> button lets you pick it in the drawing instead.
;;;   Transparent           the mask hides what is behind it without painting
;;;                         a colour - normally what you want, since a coloured
;;;                         mask that matches the screen background will still
;;;                         plot as a solid block
;;;   Fill Color            the mask colour when not transparent
;;;
;;; Settings persist between AutoCAD sessions.
;;;
;;; OFFSET DOES NOT APPLY TO DIMENSIONS. AutoCAD provides no mask offset for
;;; them, so that setting is simply ignored for any dimension in the selection.
;;;
;;; HOW DIMENSIONS DIFFER
;;; MText and multileaders carry their mask settings directly. A dimension does
;;; not - its mask belongs to its dimension STYLE, so masking one dimension
;;; without disturbing others means writing a style OVERRIDE onto that
;;; dimension. That is what the extended-data handling further down does.
;;;
;;; The routine is careful to write an override only where one is actually
;;; needed: if the dimension's own style already specifies the requested mask,
;;; the override is removed instead of added, which keeps the drawing clean.
;;;
;;;   BACKDROP  - control background masks
;;; ---------------------------------------------------------------------------

(vl-load-com)

;; Environment key for the remembered settings.
(setq BackDrop:Key "YZ\\backdrop")

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

;; ---------------------------------------------------------------------------
;; BackDrop:GetDefaults  /  BackDrop:SetDefaults
;; ---------------------------------------------------------------------------
;; Settings are stored as a printed list of four items:
;;
;;     (maskOn offsetFactor transparent colourDxf)
;;
;; The stored string is validated on reading - both that it parses as a list
;; and that it has four elements - because a corrupted or older setting would
;; otherwise be unpacked into the wrong variables.
;; ---------------------------------------------------------------------------
(defun BackDrop:GetDefaults ( key / tmp )
    (if (not (and (setq tmp (getenv key))
                  (= 'list (type (setq tmp (read tmp))))
                  (= 4 (length tmp))
             )
        )
        (BackDrop:SetDefaults key '("0" 1.5 "0" ((62 . 1))))
        tmp
    )
)

(defun BackDrop:SetDefaults ( key val )
    ;; Only stored when every element is present, so a cancelled dialog cannot
    ;; write a half-formed setting.
    (if (apply 'and val)
        (setenv key (vl-prin1-to-string val))
    )
    val
)

;; ---------------------------------------------------------------------------
;; BackDrop:Settings
;; ---------------------------------------------------------------------------
;; Displays the settings dialog. Returns the four settings, or nil if
;; cancelled.
;;
;; The dialog name "backdrop" must match between the DCL text and new_dialog.
;;
;; THE LOOP AROUND THE DIALOG
;; The dialog can close with three outcomes: 0 cancelled, 1 accepted, and 2 for
;; the >> button, which means "close, let the user pick an offset in the
;; drawing, then reopen". The while loop is what allows that round trip - it
;; keeps reopening until the result is a plain accept or cancel.
;;
;; arg - [list] the current settings
;; ---------------------------------------------------------------------------
(defun BackDrop:Settings ( arg / col dcf dch dcl des dis fill setcol setmask
                                 img msk off rtn trn tmp )

    (mapcar 'set '(msk off trn col) arg)

    (cond
        (   (not
                (and
                    (setq dcl (vl-filename-mktemp nil nil ".dcl"))
                    (setq des (open dcl "w"))
                    (progn
                        (foreach str
                           '(
                                "imgbox : image_button"
                                "{"
                                "    alignment = centered;"
                                "    height = 1.5;"
                                "    aspect_ratio = 1;"
                                "    fixed_width = true;"
                                "    fixed_height = true;"
                                "    color = 1;"
                                "}"
                                "backdrop : dialog"
                                "{"
                                "    label = \"Background Mask\";"
                                "    spacer;"
                                "    : toggle { label = \"Use Background Mask\"; key = \"msk\"; }"
                                "    spacer;"
                                "    : boxed_column"
                                "    {"
                                "        label = \"Mask Offset\";"
                                "        : row"
                                "        {"
                                "            alignment = centered;"
                                "            : edit_box { key = \"off\"; }"
                                "            : button { label = \">>\"; key = \"pik\"; fixed_width = true; }"
                                "        }"
                                "        spacer;"
                                "    }"
                                "    spacer;"
                                "    : boxed_column"
                                "    {"
                                "        label = \"Fill Color\";"
                                "        : row"
                                "        {"
                                "            alignment = centered;"
                                "            fixed_width = true;"
                                "            : toggle { key = \"trn\"; label = \"Transparent\"; }"
                                "            : imgbox { key = \"col\"; }"
                                "        }"
                                "        spacer;"
                                "    }"
                                "    spacer;"
                                "    ok_cancel;"
                                "}"
                            )
                            (write-line str des)
                        )
                        (setq des (close des))
                        (< 0 (setq dch (load_dialog dcl)))
                    )
                )
            )
            (princ "\nThe mask dialog could not be created.")
        )

        (   (progn
                (while (not (member dcf '(0 1)))
                    (cond
                        (   (null (new_dialog "backdrop" dch))
                            (princ "\nThe mask dialog is not defined.")
                            (setq dcf 0)
                        )
                        (   t
                            ;; Paints a colour swatch into an image tile.
                            (setq img
                                (lambda ( key aci )
                                    (start_image key)
                                    (fill_image 0 0 (dimx_tile key) (dimy_tile key) aci)
                                    (end_image)
                                )
                            )

                            ;; Repaints the colour swatch to reflect the current
                            ;; state: grey when masking is off, black when
                            ;; transparent, otherwise the chosen colour.
                            (   (setq fill
                                    (lambda ( )
                                        (img "col"
                                            (cond
                                                ((= "0" msk) -15)
                                                ((= "1" trn)   0)
                                                ((cdr (assoc 62 col)))
                                                (-15)
                                            )
                                        )
                                    )
                                )
                            )

                            ;; Transparency toggled: repaint, and grey out the
                            ;; colour swatch since it no longer applies.
                            (   (setq setcol
                                    (lambda ( val ) (fill) (mode_tile "col" (atoi val)))
                                )
                                (set_tile "trn" trn)
                            )

                            ;; Masking toggled: enable or grey out everything
                            ;; that only applies when a mask is in use.
                            (   (setq setmask
                                    (lambda ( val )
                                        (setq val (- 1 (atoi val)))
                                        (foreach key '("off" "pik" "trn" "col")
                                            (mode_tile key val)
                                        )
                                        (setcol (if (= "0" msk) "1" trn))
                                    )
                                )
                                (set_tile "msk" msk)
                            )

                            (action_tile "trn" "(setcol (setq trn $value))")
                            (action_tile "msk" "(setmask (setq msk $value))")

                            ;; The offset is validated as it is typed. AutoCAD
                            ;; itself only accepts 1 to 5, so anything outside
                            ;; that is rejected here rather than silently
                            ;; failing when applied.
                            (set_tile "off" (rtos off 2))
                            (action_tile "off"
                                (vl-prin1-to-string
                                   '(if (or (null (setq dis (distof $value)))
                                            (< 5.0 dis)
                                            (< dis 1.0)
                                        )
                                        (progn
                                            (alert "Please provide a value between 1 and 5.")
                                            (set_tile "off" (rtos off 2))
                                            (mode_tile "off" 2)
                                        )
                                        (set_tile "off" (rtos (setq off dis) 2))
                                    )
                                )
                            )

                            ;; The true colour dialog is offered the current
                            ;; colour in whichever form it is held - true
                            ;; colour, colour book, or plain index.
                            (action_tile "col"
                                (vl-prin1-to-string
                                   '(if (setq tmp (acad_truecolordlg
                                                      (vl-some (function (lambda ( x ) (assoc x col)))
                                                              '(430 420 62))
                                                      nil
                                                  )
                                        )
                                        (img "col" (cdr (assoc 62 (setq col tmp))))
                                    )
                                )
                            )

                            ;; Result 2 means "let me pick the offset".
                            (action_tile "pik" "(done_dialog 2)")

                            (setq dcf (start_dialog))
                        )
                    )

                    ;; The >> round trip: pick a distance, then loop back into
                    ;; the dialog with it applied.
                    (if (and (= 2 dcf)
                             (progn
                                 (while (not (or (null (setq dis (getdist (strcat "\nPick mask offset factor <"
                                                                                 (rtos off 2) ">: "))))
                                                 (<= 1.0 dis 5.0)
                                             )
                                        )
                                     (princ "\nThe offset must be between 1 and 5.")
                                 )
                                 dis
                             )
                        )
                        (setq off dis)
                    )
                )
                (zerop dcf)
            )
            (princ "\n*Cancelled*")
        )

        (   (setq rtn (list msk off trn col)))
    )

    (if (and dch (< 0 dch)) (unload_dialog dch))
    (if (and dcl (findfile dcl)) (vl-file-delete dcl))
    rtn
)

;; ---------------------------------------------------------------------------
;; BackDrop:SubstOnce
;; ---------------------------------------------------------------------------
;; Replaces DXF pairs in entity data, using each replacement only once.
;;
;; Consuming each replacement as it is used matters because entity data can
;; repeat a group code with different meanings - substituting every occurrence
;; would corrupt the ones that were not intended.
;; ---------------------------------------------------------------------------
(defun BackDrop:SubstOnce ( enx lst )
    (mapcar
        (function
            (lambda ( dxf / itm )
                (cond
                    (   (setq itm (assoc (car dxf) lst))
                        (setq lst (vl-remove itm lst))
                        itm
                    )
                    (   dxf )
                )
            )
        )
        enx
    )
)

;; ---------------------------------------------------------------------------
;; BackDrop:ToMleaderColour
;; ---------------------------------------------------------------------------
;; Converts a colour to the packed integer a multileader's DXF group 91 needs.
;;
;; Multileaders do not store colour as a plain index. The value is a bit-packed
;; integer whose high bits identify the KIND of colour and whose low bits carry
;; the value, so each case adds a different base:
;;
;;   true colour (420)  -1040187392 plus the RGB value
;;   BYBLOCK (0)        -1056964608
;;   BYLAYER (256)      -1073741824
;;   index 1 to 255     -1023410176 plus the index
;;
;; Get this wrong and the mask comes out an unrelated colour, or not at all.
;; ---------------------------------------------------------------------------
(defun BackDrop:ToMleaderColour ( c / x )
    (cond
        (   (setq x (cdr (assoc 420 c))) (+ -1040187392 x))
        (   (zerop (setq x (cdr (assoc 62 c)))) -1056964608)
        (   (= 256 x) -1073741824)
        (   (< 0 x 256) (+ -1023410176 x))
    )
)

;; ---------------------------------------------------------------------------
;; BackDrop:StyleFill
;; ---------------------------------------------------------------------------
;; Returns a dimension style's own mask settings as ((69 . mode) (70 . colour)),
;; or nil.
;;
;;   69 = 0  no mask,  1 = transparent (uses drawing background),  2 = colour
;;   70 = the colour, when mode is 2
;; ---------------------------------------------------------------------------
(defun BackDrop:StyleFill ( sty / tmp )
    (if (and (setq sty (tblobjname "dimstyle" sty))
             (setq sty (entget sty))
             (setq tmp (assoc 69 sty))
        )
        (list tmp (assoc 70 (member tmp sty)))
    )
)

;; ---------------------------------------------------------------------------
;; BackDrop:GetOverrides
;; ---------------------------------------------------------------------------
;; Returns a dimension's existing style overrides, as a list of pairs.
;;
;; Overrides live in the dimension's extended data under the "ACAD"
;; application, inside a DSTYLE group delimited by "{" and "}". The values are
;; stored flat - code, value, code, value - so they are re-paired as they are
;; read.
;; ---------------------------------------------------------------------------
(defun BackDrop:GetOverrides ( dim / lst ovr )
    (setq lst (cddr (member '(1000 . "DSTYLE") (cdadr (assoc -3 (entget dim '("acad")))))))
    (while (and lst (not (equal '(1002 . "}") (car lst))))
        (setq ovr (cons (list (car lst) (cadr lst)) ovr)
              lst (cddr lst)
        )
    )
    (reverse ovr)
)

;; ---------------------------------------------------------------------------
;; BackDrop:SetOverrides
;; ---------------------------------------------------------------------------
;; Writes a dimension's style overrides, replacing any that were there.
;;
;; Three cases, because extended data may be absent entirely, present with a
;; DSTYLE section, or present without one:
;;
;;   1. No ACAD extended data at all - register the application and write it.
;;   2. A DSTYLE section exists - splice the new overrides in place of it,
;;      preserving anything before and after, since other applications may keep
;;      their own data in the same place.
;;   3. Extended data exists but no DSTYLE - append.
;;
;; Case 2's preservation is what stops this routine destroying unrelated
;; extended data, which is the crash version 1.4 of the original fixed.
;; ---------------------------------------------------------------------------
(defun BackDrop:SetOverrides ( dim ovr / lst tmp )
    (if ovr
        (setq ovr (append '((1000 . "DSTYLE") (1002 . "{"))
                          (apply 'append ovr)
                         '((1002 . "}"))
                  )
        )
    )
    (cond
        (   (not (setq lst (cdadr (assoc -3 (entget dim '("acad"))))))
            (regapp "acad")
            (entmod (append (entget dim) (list (list -3 (cons "acad" ovr)))))
        )
        (   (setq tmp (member '(1000 . "DSTYLE") lst))
            (entmod
                (append (entget dim)
                    (list (list -3
                              (cons "acad"
                                  (append
                                      (reverse (cdr (member '(1000 . "DSTYLE") (reverse lst))))
                                      ovr
                                      (cdr (member '(1002 . "}") tmp))
                                  )
                              )
                          )
                    )
                )
            )
        )
        (   (entmod (append (entget dim) (list (list -3 (cons "acad" (append lst ovr)))))))
    )
)

;; ---------------------------------------------------------------------------
;; BackDrop:Apply
;; ---------------------------------------------------------------------------
;; Applies the mask settings to one object.
;;
;; ent - [ename] the object
;; msk - [boolean] use a mask
;; off - [real] offset factor
;; trn - [boolean] transparent
;; col - [list] colour DXF pairs
;; ---------------------------------------------------------------------------
(defun BackDrop:Apply ( ent msk off trn col / enx typ sty ovr )
    (setq enx (entget ent)
          typ (cdr (assoc 0 enx))
    )
    (cond

        ;; -------------------------------------------------------------------
        ;; MTEXT - the mask groups are stripped and rewritten:
        ;;   90  fill type: 1 = colour, 3 = drawing background
        ;;   63  the colour when type 1
        ;;   45  the offset factor
        ;;   441 transparency, always 0 here
        ;;
        ;; The colour codes are incremented by one because the colour dialog
        ;; returns entity codes (62, 420, 430) while MText's mask expects the
        ;; next code along (63, 421, 431).
        ;; -------------------------------------------------------------------
        (   (= "MTEXT" typ)
            (if msk
                (entmod
                    (append
                        (vl-remove-if (function (lambda ( x ) (member (car x) '(45 63 90 421 431 441)))) enx)
                        (if trn
                           '((90 . 3) (63 . 256))
                            (cons '(90 . 1)
                                  (mapcar (function (lambda ( x ) (cons (1+ (car x)) (cdr x)))) col)
                            )
                        )
                        (list (cons 45 off) '(441 . 0))
                    )
                )
                (vla-put-backgroundfill (vlax-ename->vla-object (cdr (assoc -1 enx))) :vlax-false)
            )
        )

        ;; -------------------------------------------------------------------
        ;; MULTILEADER
        ;;   91  mask colour, packed
        ;;   141 offset
        ;;   291 transparent flag
        ;;   292 mask on flag
        ;; -------------------------------------------------------------------
        (   (= "MULTILEADER" typ)
            (entmod
                (BackDrop:SubstOnce enx
                    (if msk
                        (list (cons 091 (BackDrop:ToMleaderColour (if trn '((62 . 256)) col)))
                              (cons 141 off)
                              (if trn '(291 . 1) '(291 . 0))
                             '(292 . 1)
                        )
                       '((292 . 0))
                    )
                )
            )
            ;; Working round an AutoCAD bug: modifying a multileader's mask
            ;; silently resets its text line spacing factor, so the original
            ;; value is read from the pre-edit data and written straight back.
            (vla-put-textlinespacingfactor
                (vlax-ename->vla-object ent)
                (cdr (assoc 045 enx))
            )
        )

        ;; -------------------------------------------------------------------
        ;; DIMENSION - handled through style overrides, as explained in the
        ;; header. Existing mask overrides (codes 69 and 70) are stripped from
        ;; whatever is already there, then the right ones added back.
        ;;
        ;; Each branch checks whether an override is actually NEEDED: if the
        ;; dimension's own style already gives the requested result, no
        ;; override is written, which keeps the drawing free of redundant ones.
        ;; -------------------------------------------------------------------
        (   (wcmatch typ "*DIMENSION")
            (setq sty (BackDrop:StyleFill (cdr (assoc 3 enx)))
                  ovr (vl-remove-if (function (lambda ( x ) (< 68 (cdar x) 71)))
                                    (BackDrop:GetOverrides ent)
                      )
            )
            (cond
                ;; Mask off. An explicit override is only needed if the style
                ;; itself specifies a mask that must be countermanded.
                (   (not msk)
                    (if (assoc 69 sty)
                        (BackDrop:SetOverrides ent
                            (append ovr '(((1070 . 70) (1070 . 0)) ((1070 . 69) (1070 . 0))))
                        )
                        (BackDrop:SetOverrides ent ovr)
                    )
                )
                ;; Transparent - style mode 1.
                (   trn
                    (if (= 1 (cdr (assoc 69 sty)))
                        (BackDrop:SetOverrides ent ovr)
                        (BackDrop:SetOverrides ent (append ovr '(((1070 . 69) (1070 . 1)))))
                    )
                )
                ;; Coloured, and the style already gives that exact colour.
                (   (and (= 2 (cdr (assoc 69 sty)))
                         (= (cdr (assoc 62 col)) (cdr (assoc 70 sty)))
                    )
                    (BackDrop:SetOverrides ent ovr)
                )
                ;; Coloured, override required.
                (   (BackDrop:SetOverrides ent
                        (append ovr
                            (list (list '(1070 . 70) (cons 1070 (cdr (assoc 62 col))))
                                 '((1070 . 69) (1070 . 2))
                            )
                        )
                    )
                )
            )
        )
    )
    (princ)
)

;; ---------------------------------------------------------------------------
;; BackDrop:ApplyToSelection
;; ---------------------------------------------------------------------------
;; Applies the settings across a selection. Exposed separately so it can be
;; driven from your own routines, bypassing the dialog.
;; ---------------------------------------------------------------------------
(defun BackDrop:ApplyToSelection ( sel msk off trn col / idx )
    (if (= 'pickset (type sel))
        (repeat (setq idx (sslength sel))
            (BackDrop:Apply (ssname sel (setq idx (1- idx))) msk off trn col)
        )
    )
    (princ)
)

;; ---------------------------------------------------------------------------
;; BackDrop:Ssget
;; ---------------------------------------------------------------------------
;; ssget with a custom prompt, restoring NOMUTT to its captured value.
;; ---------------------------------------------------------------------------
(defun BackDrop: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:BACKDROP  -  main routine
;; ---------------------------------------------------------------------------
;; Note the original never opened an undo group at all - it closed one in its
;; error handler that nothing had started - so the edits could not be reversed
;; in a single step. One is opened properly here.
;; ---------------------------------------------------------------------------
(defun c:BACKDROP ( / *error* vars vals sel settings )

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

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

    (setvar "CMDECHO" 0)

    (if (and (setq sel (BackDrop:Ssget "\nSelect mtext, multileaders or dimensions: "
                                      '("_:L" ((0 . "*DIMENSION,MTEXT,MULTILEADER")))))
             (setq settings (BackDrop:Settings (BackDrop:GetDefaults BackDrop:Key)))
        )
        (progn
            (BackDrop:SetDefaults BackDrop:Key settings)
            ;; 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")
            ;; The two flags are stored as dialog strings and converted here.
            (BackDrop:ApplyToSelection sel
                (= "1" (nth 0 settings))     ; mask on
                (nth 1 settings)             ; offset
                (= "1" (nth 2 settings))     ; transparent
                (nth 3 settings)             ; colour
            )
            (princ (strcat "\nBackground mask "
                           (if (= "1" (nth 0 settings)) "applied to " "removed from ")
                           (itoa (sslength sel))
                           " object" (if (= 1 (sslength sel)) "" "s") "."
                   )
            )
        )
        (princ "\n*Cancelled*")
    )

    (BackDrop:Restore)
    (princ)
)

(princ)