;;; ---------------------------------------------------------------------------
;;; MlineShift.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Changes the justification of multilines WITHOUT moving them.
;;;
;;; This is the multiline equivalent of the Express Tools TJUST command, which
;;; does the same job for text.
;;;
;;; THE PROBLEM IT SOLVES
;;; An mline's justification says which of its element lines sits on the path
;;; you drew. Change it the obvious way - by editing the property - and the
;;; whole multiline jumps sideways, because the path stays put and the elements
;;; move relative to it. A wall drawn to its centreline suddenly stands off by
;;; half its thickness.
;;;
;;; This routine changes the justification and simultaneously shifts the path
;;; by the exact compensating offset, so the multiline does not appear to move
;;; at all. What changes is which line the geometry is now measured from - which
;;; is what you actually wanted.
;;;
;;; HOW THE OFFSET IS DERIVED
;;; Every mline style defines its element lines as offsets from the path, held
;;; as DXF group 49 values in the style dictionary. The largest is the top
;;; element, the smallest is the bottom. The distance the path must move is the
;;; difference between the old justification's reference offset and the new
;;; one's, multiplied by the mline's own scale factor.
;;;
;;; That shift is then applied along the mitre direction at each vertex rather
;;; than square to the path, which is what keeps mitred corners closed. The
;;; sine term in the calculation is what accounts for the mitre angle.
;;;
;;; Works in any UCS, with any mline style and any mline scale.
;;;
;;;   MLSHIFT  - change multiline justification in place
;;; ---------------------------------------------------------------------------

(vl-load-com)

;; Justification codes, matching DXF group 70 and the MLINE command's own
;; ordering: 0 = Top, 1 = Zero, 2 = Bottom.
(setq MlineShift:Options '("Top" "Zero" "Bottom"))

;; ---------------------------------------------------------------------------
;; MlineShift:StyleOffsets
;; ---------------------------------------------------------------------------
;; Returns a list of (styleName maxOffset minOffset) for every mline style
;; defined in the drawing.
;;
;; Element offsets are stored as DXF group 49 entries within each style's entry
;; in the ACAD_MLINESTYLE dictionary. The largest and smallest of them are the
;; outermost elements, which are exactly what the Top and Bottom justifications
;; reference.
;; ---------------------------------------------------------------------------
(defun MlineShift:StyleOffsets ( / dic sty off result )
    (if (setq dic (cdr (assoc -1 (dictsearch (namedobjdict) "acad_mlinestyle"))))
        ;; dictnext walks the dictionary; the (not sty) argument requests the
        ;; first entry on the opening call and the next one thereafter.
        (while (setq sty (dictnext dic (not sty)))
            (setq off (mapcar 'cdr
                              (vl-remove-if-not
                                  (function (lambda ( x ) (= 49 (car x))))
                                  sty
                              )
                      )
            )
            (if off
                (setq result
                    (cons (list (cdr (assoc 2 sty)) (apply 'max off) (apply 'min off))
                          result
                    )
                )
            )
        )
    )
    result
)

;; ---------------------------------------------------------------------------
;; MlineShift:Displacement
;; ---------------------------------------------------------------------------
;; Returns how far the mline path must move, in drawing units, to keep the
;; geometry visually still while the justification changes.
;;
;; Reading the table below: old is the current DXF 70 justification, new is the
;; requested one, hi and lo are the style's outermost element offsets.
;;
;;   to Top (0)     from Zero -> hi          from Bottom -> hi - lo
;;   to Zero (1)    from Top  -> -hi         from Bottom -> -lo
;;   to Bottom (2)  from Zero -> lo          from Top    -> lo - hi
;;
;; The result is scaled by the mline's own scale factor, since the group 49
;; offsets are defined at scale 1.
;;
;; new   - [int] requested justification code
;; old   - [int] current justification code
;; hi/lo - [real] largest and smallest element offsets for this style
;; scale - [real] the mline's scale factor, DXF group 40
;; ---------------------------------------------------------------------------
(defun MlineShift:Displacement ( new old hi lo scale )
    (* scale
        (cond
            ((= 0 new) (if (= 1 old)    hi     (- hi lo)))
            ((= 1 new) (if (= 0 old) (- hi)    (- lo)   ))
            ((= 2 new) (if (= 1 old)    lo     (- lo hi)))
            (t 0.0)
        )
    )
)

;; ---------------------------------------------------------------------------
;; MlineShift:MoveVertices
;; ---------------------------------------------------------------------------
;; Returns a rebuilt entity data list with every vertex displaced by off.
;;
;; Each vertex in an mline carries three vectors:
;;   11 - the vertex position itself
;;   12 - the direction of the segment leaving the vertex
;;   13 - the mitre direction at the vertex
;;
;; The vertex is moved ALONG the mitre direction (13), not perpendicular to the
;; path, because that is the direction in which the element lines actually
;; spread at a corner. Dividing by the sine of the angle between the mitre and
;; the segment direction lengthens the move at sharp corners by exactly the
;; amount needed to keep the joint closed - the same trick a mitred skirting
;; board needs when it meets at anything other than 90 degrees.
;;
;; enx - [list] mline entity data
;; off - [real] displacement
;; ocs - [list] the entity's extrusion vector, group 210
;; ---------------------------------------------------------------------------
(defun MlineShift:MoveVertices ( enx off ocs / itm an1 an2 result )
    (setq result nil)
    (while (setq itm (car enx))
        (if (= 11 (car itm))
            (setq
                ;; Mitre direction and segment direction, both flattened into
                ;; the entity's own plane so the angle between them is measured
                ;; correctly whatever the UCS.
                an1 (angle '(0 0) (trans (cdr (assoc 13 enx)) 0 ocs t))
                an2 (angle '(0 0) (trans (cdr (assoc 12 enx)) 0 ocs t))
                result
                    (cons
                        (cons 11
                            (trans
                                (polar (trans (cdr itm) 0 ocs)
                                       an1
                                       (/ off (sin (- an1 an2)))
                                )
                                ocs 0
                            )
                        )
                        result
                    )
            )
            (setq result (cons itm result))
        )
        (setq enx (cdr enx))
    )
    (reverse result)
)

;; ---------------------------------------------------------------------------
;; c:MLSHIFT  -  main routine
;; ---------------------------------------------------------------------------
(defun c:MLSHIFT ( / *error* vars vals jus sel styles idx ent enx old ocs scale
                     entry off newdata count )

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

    (defun MlineShift:Restore ( )
        (mapcar 'setvar vars vals)
        ;; A while rather than an if: nested undo groups are possible if an
        ;; earlier run was interrupted, and all of them need closing.
        (while (= 8 (logand 8 (getvar 'undoctl)))
            (command "_.UNDO" "_End")
            (vl-catch-all-apply '(lambda ( ) (*pop-error-mode*)) '())
        )
        (princ)
    )

    (defun *error* ( msg )
        (MlineShift:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** MLSHIFT error: " msg " **"))
        )
        (princ)
    )

    (setvar "CMDECHO" 0)

    (initget "Top Zero Bottom")
    (setq jus
        (vl-position
            (cond ((getkword "\nSpecify new justification [Top/Zero/Bottom] <Zero>: "))
                  ("Zero")
            )
            MlineShift:Options
        )
    )

    ;; The (-4 . "<>") (70 . jus) pair excludes mlines that are ALREADY at the
    ;; requested justification - there is nothing to do to those, and including
    ;; them would compute a zero displacement and rewrite them for no reason.
    (if (setq sel (ssget "_:L" (list '(0 . "MLINE") '(-4 . "<>") (cons 70 jus))))
        (progn
            (setq styles (MlineShift:StyleOffsets)
                  count  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")

            (repeat (setq idx (sslength sel))
                (setq idx   (1- idx)
                      ent   (ssname sel idx)
                      enx   (entget ent)
                      old   (cdr (assoc 070 enx))
                      ocs   (cdr (assoc 210 enx))
                      scale (cdr (assoc 040 enx))
                      entry (cdr (assoc (cdr (assoc 2 enx)) styles))
                )

                ;; entry is nil if the mline references a style that is not in
                ;; the dictionary - a corrupt or partially imported drawing.
                ;; Skipped rather than allowed to throw on a nil offset.
                (if entry
                    (progn
                        (setq off (MlineShift:Displacement
                                      jus old (car entry) (cadr entry) scale
                                  )
                              newdata (MlineShift:MoveVertices enx off ocs)
                        )
                        (entmod newdata)
                        ;; The justification property itself is set through
                        ;; ActiveX; entmod alone will not update it reliably.
                        (vla-put-justification
                            (vlax-ename->vla-object (cdr (assoc -1 newdata)))
                            jus
                        )
                        (setq count (1+ count))
                    )
                    (princ "\n  - skipped an mline whose style is missing from the drawing.")
                )
            )

            (princ (strcat "\n" (itoa count)
                           " multiline" (if (= 1 count) "" "s")
                           " re-justified to " (nth jus MlineShift:Options) "."
                   )
            )
        )
        (princ "\nNo multilines selected, or all are already at that justification.")
    )

    (MlineShift:Restore)
    (princ)
)

(princ)