;;; ---------------------------------------------------------------------------
;;; LevelTag.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Places elevation/level markers. Prompts repeatedly until you press Enter,
;;; drawing a tapered triangular pointer with the point's UCS Y-coordinate as
;;; the text above it.
;;;
;;;   LEVELTAG  - place elevation markers
;;; ---------------------------------------------------------------------------

(defun c:LEVELTAG ( / *error* vars vals ang hgt len ocs pt1 pt2 pt3 pt4 str sym count )

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

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

    ;; The original handler crashed if msg arrived nil, because strcase cannot
    ;; take nil, and its wildcard list was missing a trailing wildcard on the
    ;; break case. Both fixed here.
    (defun *error* ( msg )
        (LevelTag:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** LEVELTAG 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")

    ;; ocs is the object coordinate system normal for the current UCS; ang is
    ;; the UCS rotation. Together they keep markers upright and correctly
    ;; oriented when the UCS is rotated or the view is not plan.
    (setq hgt   (getvar 'textsize)
          ocs   (trans '(0.0 0.0 1.0) 1 0 t)
          ang   (angle '(0.0 0.0) (trans (getvar 'ucsxdir) 0 ocs t))
          count 0
    )

    (terpri)
    (while (setq pt1 (getpoint "\rSpecify point <exit>: "))
        (setq str (rtos (cadr pt1))
              len (strlen str)
              ;; apex to shoulder: half the marker width times root 3 gives
              ;; the 60-degree taper of an equilateral pointer
              pt2 (list (car pt1) (+ (cadr pt1) (* hgt 0.5 (sqrt 3))))
              pt3 (list (- (car pt1) (* hgt len)) (cadr pt2))
              pt4 (list (- (car pt2) (* hgt 0.5 len)) (+ (cadr pt2) hgt))
        )
        (foreach sym '(pt1 pt2 pt3 pt4)
            (set sym (trans (eval sym) 1 ocs))
        )

        ;; Width tapers from hgt at the apex down to a hairline along the
        ;; shoulder, giving the marker its wedge shape.
        (entmake
            (list
               '(000 . "LWPOLYLINE")
               '(100 . "AcDbEntity")
               '(100 . "AcDbPolyline")
               '(090 . 3)
               '(070 . 0)
                (cons 038 (caddr pt1))
                (cons 010 pt1)
               '(040 . 0.0)
                (cons 041 hgt)
                (cons 010 pt2)
                (cons 040 (* hgt 0.05))
                (cons 041 (* hgt 0.05))
                (cons 010 pt3)
                (cons 210 ocs)
            )
        )
        (entmake
            (list
               '(000 . "TEXT")
                (cons 007 (getvar 'textstyle))
                (cons 001 str)
                (cons 050 ang)
                (cons 040 hgt)
                (cons 010 pt4)
                (cons 011 pt4)
               '(072 . 1)          ; centre horizontally
               '(073 . 2)          ; middle vertically
                (cons 210 ocs)
            )
        )
        (setq count (1+ count))
    )

    (princ (strcat "\n" (itoa count) " marker" (if (= 1 count) "" "s") " placed."))
    (LevelTag:Restore)
    (princ)
)

(princ)