;;; ---------------------------------------------------------------------------
;;; BalloonTag.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; DETAIL AND ITEM BALLOONS WITH LEADERS
;;;
;;; PURPOSE
;;;   Places a numbered balloon on a leader - the round or hexagonal callout used
;;;   to key a part on an assembly drawing to a line on the parts list, or a
;;;   detail on a sheet to the detail that draws it.
;;;
;;;   The balloon can be divided into one, two, three or four compartments, which
;;;   is how detail keys are normally written: detail number over sheet number,
;;;   or a four-way split carrying item, quantity, detail and sheet.
;;;
;;; HOW IT WORKS
;;;   1. You pick the arrow point - what the balloon is pointing AT - then the
;;;      balloon centre. The leader is drawn between them and automatically
;;;      stopped at the balloon's edge rather than running under it, worked out
;;;      by stepping back one radius along the leader angle from the centre.
;;;
;;;   2. A solid arrowhead is drawn at the arrow point, sized from DIMASZ times
;;;      DIMSCALE so it matches the arrowheads on the drawing's dimensions.
;;;
;;;   3. The balloon body is drawn, then its divider lines as true chords of the
;;;      circle, then the text in each compartment.
;;;
;;;   4. Text is placed middle-centre in each compartment, so it is genuinely
;;;      centred rather than approximately centred by nudging a baseline.
;;;
;;;   5. AUTO-INCREMENT: when the text you type is a whole number, the next
;;;      balloon offers the number after it as its default. Ballooning twenty
;;;      parts in sequence is then pick, pick, Enter, twenty times.
;;;
;;; SIZE
;;;   The balloon radius is DIMSCALE times 0.1563 - a shade under a 5/16 inch
;;;   diameter balloon on the plotted sheet - unless you override it, in which
;;;   case your size is remembered for the rest of the session. Everything else
;;;   is proportional to that radius, so the whole callout scales together.
;;;
;;;   BALLOONTAG  - place detail balloons on leaders, repeating until Enter
;;; ---------------------------------------------------------------------------

;;; ---------------------------------------------------------------------------
;;; SESSION MEMORY
;;; ---------------------------------------------------------------------------

(if (null *BalloonTag:Prefs*)
    (setq *BalloonTag:Prefs*
        (list (cons "DIVS"  1)          ; compartments, 1 to 4
              (cons "SHAPE" "Circle")   ; "Circle" or "Hexagon"
              (cons "RAD"   nil)        ; nil means derive from DIMSCALE
              (cons "NEXT"  nil)        ; next auto-increment number, if any
        )
    )
)

(defun BalloonTag:Get ( key ) (cdr (assoc key *BalloonTag:Prefs*)))

(defun BalloonTag:Put ( key val )
    (setq *BalloonTag:Prefs*
        (cons (cons key val)
              (vl-remove-if '(lambda (p) (= (car p) key)) *BalloonTag:Prefs*)))
    val
)

;;; ---------------------------------------------------------------------------
;;; HELPERS
;;; ---------------------------------------------------------------------------

;;; Point offset from a base by x and y, both expressed as multiples of the
;;; balloon radius. Every text position and divider endpoint is built from this,
;;; which is what keeps the layout proportional at any balloon size.
(defun BalloonTag:Pt ( base rad dx dy )
    (list (+ (car  base) (* rad dx))
          (+ (cadr base) (* rad dy))
          0.0)
)

;;; Is this string a plain whole number? Used to decide whether the next balloon
;;; can offer an incremented default. Rejects anything with a non-digit so that
;;; "12A" or "1.5" are treated as text and simply repeat rather than incrementing
;;; into something meaningless.
(defun BalloonTag:IsInt ( s / i ok )
    (setq ok (> (strlen s) 0) i 1)
    (while (and ok (<= i (strlen s)))
        (if (not (and (>= (ascii (substr s i 1)) 48)
                      (<= (ascii (substr s i 1)) 57)))
            (setq ok nil))
        (setq i (1+ i)))
    ok
)

;;; Ask for one compartment's text, offering a default when there is one.
;;; GETSTRING with a non-nil second argument would allow spaces; a balloon
;;; compartment never wants them, so the plain form is used and Enter means
;;; "take the default".
(defun BalloonTag:AskText ( label default / s )
    (setq s (getstring
                (strcat "\n" label
                        (if (and default (/= default "")) (strcat " <" default ">") "")
                        ": ")))
    (if (= s "") (if default default "") s)
)

;;; Draw the balloon outline.
(defun BalloonTag:Body ( cen rad shape )
    (if (= shape "Hexagon")
        ;; POLYGON circumscribed about nothing - the "Inscribed" option puts the
        ;; vertices on the radius, which keeps the hexagon the same size across
        ;; corners as the circle it replaces.
        (command "_.POLYGON" 6 cen "_I" (BalloonTag:Pt cen rad 0.0 1.0))
        (command "_.CIRCLE" cen rad)
    )
    (princ)
)

;;; ---------------------------------------------------------------------------
;;; COMPARTMENT LAYOUT
;;;
;;; Returns everything needed to fill a balloon with the requested number of
;;; compartments, as a list of:
;;;
;;;   ( (divider-lines...) (compartment...) )
;;;
;;; where each divider is a pair of points and each compartment is
;;;   ( prompt-label  offset-x  offset-y  text-height )
;;; with the offsets and height as multiples of the balloon radius.
;;;
;;; Holding the layout as data rather than four blocks of drawing code means the
;;; four cases cannot drift apart, and a fifth arrangement is one more entry.
;;; ---------------------------------------------------------------------------

(defun BalloonTag:Layout ( cen rad divs )
    (cond
        ;; One compartment: no dividers, one centred line of text.
        ((= divs 1)
         (list nil
               (list (list "Balloon text" 0.0 0.0 0.90))))

        ;; Two: a full-width horizontal chord, text above and below.
        ((= divs 2)
         (list (list (list (BalloonTag:Pt cen rad -1.0 0.0)
                           (BalloonTag:Pt cen rad  1.0 0.0)))
               (list (list "Upper text" 0.0  0.45 0.60)
                     (list "Lower text" 0.0 -0.45 0.60))))

        ;; Three: horizontal chord, plus a vertical from the centre down, giving
        ;; one compartment on top and two beneath.
        ((= divs 3)
         (list (list (list (BalloonTag:Pt cen rad -1.0 0.0)
                           (BalloonTag:Pt cen rad  1.0 0.0))
                     (list cen
                           (BalloonTag:Pt cen rad 0.0 -1.0)))
               (list (list "Upper text"      0.0   0.45 0.60)
                     (list "Lower left text" -0.42 -0.45 0.50)
                     (list "Lower right text" 0.42 -0.45 0.50))))

        ;; Four: both chords full width, four quadrants.
        ((= divs 4)
         (list (list (list (BalloonTag:Pt cen rad -1.0 0.0)
                           (BalloonTag:Pt cen rad  1.0 0.0))
                     (list (BalloonTag:Pt cen rad 0.0  1.0)
                           (BalloonTag:Pt cen rad 0.0 -1.0)))
               (list (list "Upper left text"  -0.42  0.45 0.50)
                     (list "Upper right text"  0.42  0.45 0.50)
                     (list "Lower left text"  -0.42 -0.45 0.50)
                     (list "Lower right text"  0.42 -0.45 0.50))))
    )
)

;;; ---------------------------------------------------------------------------
;;; MAIN COMMAND
;;; ---------------------------------------------------------------------------

(defun c:BALLOONTAG ( / *error* vars vals scl rad divs shape opt
                        p1 cen ang edge arrow a1 a2 layout dividers cells
                        first txt used height loc )

    (setq vars '("CMDECHO" "OSMODE" "ORTHOMODE" "BLIPMODE" "TEXTSTYLE")
          vals (mapcar 'getvar vars))

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

    ;; Balloon size follows DIMSCALE unless the user has set an explicit radius.
    (setq scl (getvar "DIMSCALE"))
    (if (zerop scl) (setq scl 1.0))
    (setq rad (if (BalloonTag:Get "RAD") (BalloonTag:Get "RAD") (* scl 0.1563)))

    ;; Settings first, then straight into placing balloons. Offering the settings
    ;; as one keyword prompt keeps the common case - just place a balloon - to a
    ;; single Enter.
    (initget "Divisions Shape Radius Place")
    (setq opt (getkword
                  (strcat "\nBalloon: " (itoa (BalloonTag:Get "DIVS"))
                          " division(s), " (BalloonTag:Get "SHAPE")
                          ", radius " (rtos rad 2 4)
                          "\n[Divisions/Shape/Radius/Place] <Place>: ")))

    (cond
        ((= opt "Divisions")
         (initget 6)
         (setq divs (getint (strcat "\nCompartments, 1 to 4 <"
                                    (itoa (BalloonTag:Get "DIVS")) ">: ")))
         (if divs
             (if (and (>= divs 1) (<= divs 4))
                 (BalloonTag:Put "DIVS" divs)
                 (princ "\nOut of range - keeping the previous setting."))))

        ((= opt "Shape")
         (initget "Circle Hexagon")
         (setq shape (getkword "\nBalloon shape [Circle/Hexagon]: "))
         (if shape (BalloonTag:Put "SHAPE" shape)))

        ((= opt "Radius")
         (initget 6)
         (setq rad (getdist (strcat "\nBalloon radius <" (rtos rad 2 4) ">: ")))
         (if rad (BalloonTag:Put "RAD" rad)))
    )

    ;; Re-read after any setting change so the placement loop uses the new values.
    (setq rad   (if (BalloonTag:Get "RAD") (BalloonTag:Get "RAD") (* scl 0.1563))
          divs  (BalloonTag:Get "DIVS")
          shape (BalloonTag:Get "SHAPE")
          arrow (* (getvar "DIMASZ") scl))

    ;; An arrowhead of zero length would collapse the SOLID into nothing.
    (if (<= arrow 0.0) (setq arrow (* rad 0.6)))

    (setvar "BLIPMODE" 0)
    (setvar "ORTHOMODE" 0)

    (while (setq p1 (getpoint "\nArrow point - what the balloon points at <Enter to finish>: "))

        ;; Osnaps help land the arrow on geometry but would drag the balloon
        ;; centre onto it too, so they are off for the second pick only.
        (setvar "OSMODE" 0)
        (setq cen (getpoint p1 "\nBalloon centre: "))
        (setvar "OSMODE" (nth (vl-position "OSMODE" vars) vals))

        (if (null cen)
            (princ "\nCancelled - no balloon centre given.")
            (progn
                (setvar "OSMODE" 0)

                ;; Leader stops one radius short of the centre so it meets the
                ;; balloon edge instead of running underneath it.
                (setq ang  (angle p1 cen)
                      edge (polar cen ang (- rad)))
                (command "_.LINE" p1 edge "")

                ;; Solid arrowhead: a narrow triangle opening back along the
                ;; leader. The two barbs sit 0.2 radians either side.
                (setq a1 (polar p1 (+ ang 0.2) arrow)
                      a2 (polar p1 (- ang 0.2) arrow))
                ;; Three points, a blank for the unused fourth corner to make it
                ;; a triangle, then a second blank because SOLID loops asking for
                ;; further triangles until it gets an empty response.
                (command "_.SOLID" p1 a1 a2 "" "")

                (BalloonTag:Body cen rad shape)

                ;; Dividers and compartment text.
                (setq layout    (BalloonTag:Layout cen rad divs)
                      dividers  (car  layout)
                      cells     (cadr layout)
                      first     t)

                (foreach d dividers
                    (command "_.LINE" (car d) (cadr d) ""))

                (foreach cell cells
                    ;; Only the first compartment auto-increments. The others are
                    ;; sheet numbers and quantities, which do not run in sequence.
                    (setq txt (BalloonTag:AskText
                                  (car cell)
                                  (if first (BalloonTag:Get "NEXT") nil)))

                    (if (/= txt "")
                        (progn
                            (setq height (* rad (cadddr cell))
                                  loc    (BalloonTag:Pt cen rad (cadr cell) (caddr cell)))
                            ;; A fixed-height text style supplies its own height
                            ;; and the TEXT command does not ask for one.
                            (if (zerop (cdr (assoc 40 (tblsearch "style" (getvar "TEXTSTYLE")))))
                                (command "_.TEXT" "_J" "_MC" loc height 0 txt)
                                (command "_.TEXT" "_J" "_MC" loc 0 txt))))

                    ;; Remember the successor for the next balloon.
                    (if first
                        (progn
                            (BalloonTag:Put "NEXT"
                                (if (BalloonTag:IsInt txt) (itoa (1+ (atoi txt))) nil))
                            (setq first nil)))
                )

                (setvar "OSMODE" (nth (vl-position "OSMODE" vars) vals))
            )
        )
    )

    (BalloonTag:Restore)
    (princ)
)

(princ)