;;; ---------------------------------------------------------------------------
;;; RuleText.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Rules lines through, under or over text - strikethrough and underline for
;;; Text, MText and attributes.
;;;
;;; AutoCAD offers no strikethrough at all, and its underline is an MText
;;; formatting code that plain Text and attributes cannot use. This draws the
;;; rules as real polylines instead, so every text type is supported and the
;;; result plots identically everywhere. It also works in AutoCAD LT.
;;;
;;; COMMANDS - each has a single-pick and a multi-select form
;;;
;;;   RULE1   MRULE1    single strikethrough
;;;   RULE2   MRULE2    double strikethrough
;;;   RULE3   MRULE3    triple strikethrough
;;;   RULEU   MRULEU    underline
;;;   RULEU2  MRULEU2   double underline
;;;   RULEOU  MRULEOU   double overline and underline together
;;;
;;; The single-pick forms keep prompting until you press Enter, so several
;;; items can be ruled in one go. The multi-select forms take a window
;;; selection, and reach attributes inside blocks automatically.
;;;
;;; HOW THE POSITIONS ARE DEFINED
;;; Each rule is described by a pair of factors, both multiples of the text
;;; height:
;;;
;;;     (<vertical offset from centre>  <line width>)
;;;
;;; So (0.0 0.1) is a line straight through the middle at a tenth of the text
;;; height thick, and (-0.8 0.1) sits below the baseline as an underline.
;;; Working in multiples of text height means one definition looks correct at
;;; every text size.
;;;
;;; The rule spans the text's true bounding box and follows its rotation, so
;;; rotated text is ruled along its own axis.
;;;
;;; Edit the factor lists in the command definitions at the foot of this file
;;; to add your own variants.
;;; ---------------------------------------------------------------------------

(vl-load-com)

;; ---------------------------------------------------------------------------
;; RuleText:Midpoint  -  midpoint of two points
;; ---------------------------------------------------------------------------
;; Namespaced; the original defined a bare global called "mid".
;; ---------------------------------------------------------------------------
(defun RuleText:Midpoint ( a b )
    (mapcar (function (lambda ( x y ) (/ (+ x y) 2.0))) a b)
)

;; ---------------------------------------------------------------------------
;; RuleText:MxV  -  matrix multiplied by vector
;; ---------------------------------------------------------------------------
(defun RuleText:MxV ( m v )
    (mapcar (function (lambda ( row ) (apply '+ (mapcar '* row v)))) m)
)

;; ---------------------------------------------------------------------------
;; RuleText:DefaultProps
;; ---------------------------------------------------------------------------
;; Returns common property groups for the entity data, substituting AutoCAD's
;; defaults for any the entity omits - so the rule inherits the layer, colour
;; and linetype of the text it marks.
;; ---------------------------------------------------------------------------
(defun RuleText:DefaultProps ( enx )
    (mapcar (function (lambda ( pair ) (cond ((assoc (car pair) enx)) ( pair ))))
       '(
            (006 . "BYLAYER")
            (008 . "0")
            (039 . 0.0)
            (048 . 1.0)
            (062 . 256)
            (370 . -1)
        )
    )
)

;; ---------------------------------------------------------------------------
;; RuleText:TextBox
;; ---------------------------------------------------------------------------
;; Returns the four corners of a text object's bounding box, in order.
;;
;; Three cases:
;;
;;   Multi-line ATTRIB - identified by the "Embedded Object" marker. Its MText
;;                       data follows that marker, so the function re-enters
;;                       itself with that portion relabelled as MTEXT.
;;
;;   TEXT and ATTRIB   - the built-in textbox function gives two opposite
;;                       corners; the other two are assembled from them.
;;
;;   MTEXT             - has no textbox equivalent, so the box comes from its
;;                       stored width (42) and height (43), with the origin
;;                       derived from the attachment point (71). An MText
;;                       attached middle-centre sits half its width left and
;;                       half its height below its insertion point; one
;;                       attached top-left sits exactly on it. The two cond
;;                       expressions decode that 1-9 grid.
;;
;; The corners are finally rotated by the text rotation and translated onto the
;; base point.
;; ---------------------------------------------------------------------------
(defun RuleText:TextBox ( enx / bpt hgt jus lst ocs org rot wid )
    (cond
        (   (and (= "ATTRIB" (cdr (assoc 000 enx)))
                 (= "Embedded Object" (cdr (assoc 101 enx)))
            )
            (RuleText:TextBox
                (cons '(000 . "MTEXT") (member '(101 . "Embedded Object") enx))
            )
        )
        (   (cond
                (   (wcmatch (cdr (assoc 000 enx)) "ATTRIB,TEXT")
                    (setq bpt (cdr (assoc 010 enx))
                          rot (cdr (assoc 050 enx))
                          lst (textbox enx)
                          lst (list (car lst)
                                    (list (caadr lst) (cadar  lst))
                                    (cadr lst)
                                    (list (caar  lst) (cadadr lst))
                              )
                    )
                )
                (   (= "MTEXT" (cdr (assoc 000 enx)))
                    (setq ocs (cdr (assoc 210 enx))
                          bpt (trans (cdr (assoc 010 enx)) 0 ocs)
                          rot (angle '(0.0 0.0) (trans (cdr (assoc 011 enx)) 0 ocs))
                          wid (cdr (assoc 042 enx))
                          hgt (cdr (assoc 043 enx))
                          jus (cdr (assoc 071 enx))
                          org (list
                                  (cond ((member jus '(2 5 8)) (/ wid -2.0))
                                        ((member jus '(3 6 9)) (- wid))
                                        (0.0)
                                  )
                                  (cond ((member jus '(1 2 3)) (- hgt))
                                        ((member jus '(4 5 6)) (/ hgt -2.0))
                                        (0.0)
                                  )
                              )
                          lst (list org
                                    (mapcar '+ org (list wid 0))
                                    (mapcar '+ org (list wid hgt))
                                    (mapcar '+ org (list 0 hgt))
                              )
                    )
                )
            )
            (   (lambda ( m )
                    (mapcar (function (lambda ( p ) (mapcar '+ (RuleText:MxV m p) bpt))) lst)
                )
                (list (list (cos rot) (sin (- rot)) 0.0)
                      (list (sin rot) (cos rot)     0.0)
                     '(0.0 0.0 1.0)
                )
            )
        )
    )
)

;; ---------------------------------------------------------------------------
;; RuleText:Draw
;; ---------------------------------------------------------------------------
;; Draws the rules through one text object and returns the polylines created.
;;
;; The two midpoints - of the left edge and of the right edge - define the line
;; that runs through the middle of the text. Each rule is that line displaced
;; perpendicular by its offset factor.
;;
;; DXF group 43 sets a constant width for the whole polyline, which is how the
;; rule gets its thickness; group 38 sets the elevation so it sits in the same
;; plane as the text.
;;
;; ent - [ename] text, mtext or attribute
;; par - [list] list of (offsetFactor widthFactor) pairs
;; ---------------------------------------------------------------------------
(defun RuleText:Draw ( ent par / ang enx hgt lst mid1 mid2 rtn )
    (if (setq lst (RuleText:TextBox (setq enx (entget ent))))
        (progn
            (setq hgt  (cdr (assoc 40 enx))
                  mid1 (RuleText:Midpoint (car  lst) (last  lst))
                  mid2 (RuleText:Midpoint (cadr lst) (caddr lst))
                  ang  (angle (car lst) (last lst))
            )
            (foreach itm par
                (setq rtn
                    (cons
                        (entmakex
                            (append
                               '(  (000 . "LWPOLYLINE")
                                   (100 . "AcDbEntity")
                                   (100 . "AcDbPolyline")
                                   (090 . 2)
                                   (070 . 0)
                                )
                                (RuleText:DefaultProps enx)
                                (list
                                    (cons  043 (* (cadr itm) hgt))
                                    (cons  038 (caddar lst))
                                    (cons  010 (polar mid1 ang (* (car itm) hgt)))
                                    (cons  010 (polar mid2 ang (* (car itm) hgt)))
                                    (assoc 210 enx)
                                )
                            )
                        )
                        rtn
                    )
                )
            )
        )
    )
    rtn
)

;; ---------------------------------------------------------------------------
;; RuleText:Restore
;; ---------------------------------------------------------------------------
(defun RuleText:Restore ( vars vals )
    (mapcar 'setvar vars vals)
    (while (= 8 (logand 8 (getvar 'undoctl)))
        (command "_.UNDO" "_End")
        (vl-catch-all-apply '(lambda ( ) (*pop-error-mode*)) '())
    )
    (princ)
)

;; ---------------------------------------------------------------------------
;; RuleText:Single
;; ---------------------------------------------------------------------------
;; Prompts repeatedly for a single text object and rules each one, until the
;; user presses Enter.
;;
;; par - [list] rule definitions
;; ---------------------------------------------------------------------------
(defun RuleText:Single ( par / *error* vars vals sel count )

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

    (defun *error* ( msg )
        (RuleText:Restore vars vals)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** RuleText 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")
    (setq count 0)

    (while
        (progn
            (setvar 'errno 0)
            (setq sel (nentselp "\nSelect text, mtext or attribute <exit>: "))
            (cond
                (   (= 7 (getvar 'errno))
                    (princ "\nMissed, try again.")
                )
                (   (null sel) nil)

                ;; A two-element return means the object is at the top level.
                ;; Nested objects are not offered here, because a rule drawn at
                ;; the top level would not line up with text inside a block.
                (   (and (= 2 (length sel))
                         (wcmatch (cdr (assoc 0 (entget (car sel)))) "TEXT,MTEXT,ATTRIB")
                    )
                    (RuleText:Draw (car sel) par)
                    (setq count (1+ count))
                    t
                )
                (   (princ "\nThat is not a top-level text object - try again.")
                    t
                )
            )
        )
    )

    (princ (strcat "\n" (itoa count) " object" (if (= 1 count) "" "s") " ruled."))
    (RuleText:Restore vars vals)
    (princ)
)

;; ---------------------------------------------------------------------------
;; RuleText:Selection
;; ---------------------------------------------------------------------------
;; Rules every text object in a window selection, reaching into attributed
;; blocks to rule their attributes too.
;;
;; par - [list] rule definitions
;; ---------------------------------------------------------------------------
(defun RuleText:Selection ( par / *error* vars vals sel idx ent att atx count )

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

    (defun *error* ( msg )
        (RuleText:Restore vars vals)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** RuleText 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")
    (setq count 0)

    (princ "\nSelect text, mtext or attributed blocks: ")
    (if (setq sel (ssget '((-4 . "<OR")
                              (0 . "TEXT,MTEXT")
                              (-4 . "<AND") (0 . "INSERT") (66 . 1) (-4 . "AND>")
                          (-4 . "OR>"))))
        (progn
            (repeat (setq idx (sslength sel))
                (setq ent (ssname sel (setq idx (1- idx))))
                (if (= "INSERT" (cdr (assoc 0 (entget ent))))
                    ;; Attributes follow their block reference as sub-entities,
                    ;; so walking forward with entnext visits each in turn.
                    (progn
                        (setq att (entnext ent)
                              atx (entget  att)
                        )
                        (while (= "ATTRIB" (cdr (assoc 0 atx)))
                            (RuleText:Draw att par)
                            (setq count (1+ count)
                                  att   (entnext att)
                                  atx   (entget  att)
                            )
                        )
                    )
                    (progn
                        (RuleText:Draw ent par)
                        (setq count (1+ count))
                    )
                )
            )
            (princ (strcat "\n" (itoa count) " object" (if (= 1 count) "" "s") " ruled."))
        )
        (princ "\nNothing selected.")
    )

    (RuleText:Restore vars vals)
    (princ)
)

;;; ---------------------------------------------------------------------------
;;; COMMAND DEFINITIONS
;;;
;;; Each pair of factors is (verticalOffset lineWidth), both as multiples of
;;; the text height. Edit these, or add your own commands following the same
;;; pattern.
;;; ---------------------------------------------------------------------------

;; Single strikethrough - straight through the centre.
(defun c:RULE1  nil (RuleText:Single    '((0.0 0.1))))
(defun c:MRULE1 nil (RuleText:Selection '((0.0 0.1))))

;; Double strikethrough - a pair either side of the centre.
(defun c:RULE2  nil (RuleText:Single    '((0.15 0.1) (-0.15 0.1))))
(defun c:MRULE2 nil (RuleText:Selection '((0.15 0.1) (-0.15 0.1))))

;; Triple strikethrough.
(defun c:RULE3  nil (RuleText:Single    '((0.2 0.1) (0.0 0.1) (-0.2 0.1))))
(defun c:MRULE3 nil (RuleText:Selection '((0.2 0.1) (0.0 0.1) (-0.2 0.1))))

;; Underline - below the baseline.
(defun c:RULEU  nil (RuleText:Single    '((-0.8 0.1))))
(defun c:MRULEU nil (RuleText:Selection '((-0.8 0.1))))

;; Double underline - thinner, since there are two of them.
(defun c:RULEU2  nil (RuleText:Single    '((-0.8 0.05) (-1.0 0.05))))
(defun c:MRULEU2 nil (RuleText:Selection '((-0.8 0.05) (-1.0 0.05))))

;; Double overline and underline - the accountancy total treatment.
(defun c:RULEOU  nil (RuleText:Single    '((1.0 0.05) (0.8 0.05) (-0.8 0.05) (-1.0 0.05))))
(defun c:MRULEOU nil (RuleText:Selection '((1.0 0.05) (0.8 0.05) (-0.8 0.05) (-1.0 0.05))))

(princ)