;;; ---------------------------------------------------------------------------
;;; FieldMath.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Builds a LIVE calculation from numbers already in the drawing.
;;;
;;; Pick a piece of text holding a number, choose an operator, pick another,
;;; and keep going. The result is a field that recalculates itself whenever any
;;; of the numbers it references changes.
;;;
;;; The obvious use is a schedule total that must never fall out of step with
;;; the figures above it - or a rate multiplied by a quantity, where both live
;;; elsewhere on the sheet and either might be revised.
;;;
;;; WHAT CAN BE PICKED
;;; Text, MText, attributes, multileaders and dimensions - anything holding a
;;; number. A dimension contributes its MEASUREMENT, so the calculation follows
;;; the geometry rather than any typed override.
;;;
;;; The Constant option lets you type a number in directly, for a rate or a
;;; factor that is not written anywhere on the drawing.
;;;
;;; OPERATORS
;;; Add, Subtract, Multiply and Divide. Undo removes the last term. Result
;;; finishes and places the field.
;;;
;;; The running expression is echoed at the command line as you build it, so
;;; you can see what you have so far.
;;;
;;; NESTED FIELDS
;;; If you pick a piece of text that is ITSELF a field, the default is to
;;; reference that field's underlying expression directly rather than its
;;; displayed text. That matters because the displayed text is FORMATTED - a
;;; value of 12.3456 displayed to two decimals reads 12.35, and calculating
;;; from the rounded figure would compound the error at every step.
;;;
;;; Set FieldMath:UseNested to nil to reference the displayed text instead.
;;;
;;; WHERE THE RESULT GOES
;;; Pick a point for new MText, click a table cell, or choose Object to write
;;; into existing text, an attribute, a block or a multileader.
;;;
;;;   FIELDMATH  - build a live calculation from drawing values
;;; ---------------------------------------------------------------------------

(vl-load-com)

;;; ---------------------------------------------------------------------------
;;; SETTINGS
;;; ---------------------------------------------------------------------------

(setq FieldMath:Format    "%lu6%qf1")  ; formatting for the result, "" for none
(setq FieldMath:UseNested t)           ; reference nested fields directly
(setq FieldMath:Tag       nil)         ; preset target attribute tag

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

;; ---------------------------------------------------------------------------
;; Object ID helpers - see the note in SumField.lsp; the same version handling
;; is needed here.
;; ---------------------------------------------------------------------------
(defun FieldMath:HexToDecimal ( hex / FieldMath:Accumulate FieldMath:Carry )
    (defun FieldMath:Accumulate ( lst rtn )
        (if lst
            (FieldMath:Accumulate (cdr lst) (FieldMath:Carry (- (car lst) (if (< 57 (car lst)) 55 48)) rtn))
            (apply 'strcat (mapcar 'itoa (reverse rtn)))
        )
    )
    (defun FieldMath:Carry ( int lst )
        (if lst
            (if (or (< 0 (setq int (+ (* 16 (car lst)) int))) (cdr lst))
                (cons (rem int 10) (FieldMath:Carry (/ int 10) (cdr lst)))
            )
            (FieldMath:Carry int '(0))
        )
    )
    (FieldMath:Accumulate (vl-string->list (strcase hex)) nil)
)

(defun FieldMath:EnameToID ( ent )
    (FieldMath:HexToDecimal
        (setq ent (vl-string-right-trim ">" (vl-prin1-to-string ent))
              ent (substr ent (+ (vl-string-position 58 ent) 3))
        )
    )
)

(defun FieldMath:ObjectID ( obj )
    (eval
        (list 'defun 'FieldMath:ObjectID '( obj )
            (if (wcmatch (getenv "PROCESSOR_ARCHITECTURE") "*64*")
                (if (vlax-method-applicable-p (vla-get-utility (FieldMath:Doc)) 'getobjectidstring)
                    (list 'vla-getobjectidstring
                          (vla-get-utility (FieldMath:Doc)) 'obj ':vlax-false
                    )
                   '(FieldMath:EnameToID (vlax-vla-object->ename obj))
                )
               '(itoa (vla-get-objectid obj))
            )
        )
    )
    (FieldMath:ObjectID obj)
)

(defun FieldMath:IntObjectID ( obj )
    (if (vlax-property-available-p obj 'objectid32)
        (defun FieldMath:IntObjectID ( obj ) (vla-get-objectid32 obj))
        (defun FieldMath:IntObjectID ( obj ) (vla-get-objectid   obj))
    )
    (FieldMath:IntObjectID obj)
)

(defun FieldMath:SetMleaderAttribute ( obj idx str )
    (if (vlax-method-applicable-p obj 'setblockattributevalue32)
        (defun FieldMath:SetMleaderAttribute ( obj idx str ) (vla-setblockattributevalue32 obj idx str))
        (defun FieldMath:SetMleaderAttribute ( obj idx str ) (vla-setblockattributevalue   obj idx str))
    )
    (FieldMath:SetMleaderAttribute obj idx str)
)

;; ---------------------------------------------------------------------------
;; FieldMath:NumToString
;; ---------------------------------------------------------------------------
;; Converts a number to a string without trailing zeros.
;;
;; A whole number returns with no decimal part; anything else is formatted to
;; eight places with DIMZIN 8, which suppresses trailing zeros - so 2.5 reads
;; "2.5" rather than "2.50000000".
;; ---------------------------------------------------------------------------
(defun FieldMath:NumToString ( num / dim rtn )
    (if (equal num (atoi (rtos num 2 0)) 1e-8)
        (rtos num 2 0)
        (progn
            (setq dim (getvar 'dimzin))
            (setvar 'dimzin 8)
            (setq rtn (rtos num 2 8))
            (setvar 'dimzin dim)
            rtn
        )
    )
)

;; ---------------------------------------------------------------------------
;; FieldMath:Evaluate
;; ---------------------------------------------------------------------------
;; Returns the number a field expression currently evaluates to, or nil if it
;; does not produce one.
;;
;; There is no way to ask AutoCAD to evaluate a field expression directly, so
;; the trick is to create a temporary MText holding it - which forces
;; evaluation - read the result, and delete it. The object is removed on every
;; path, including failure, so a malformed expression cannot leave debris.
;;
;; This is what allows the running total to be displayed as you build it, and
;; what rejects text that turns out not to be numeric.
;; ---------------------------------------------------------------------------
(defun FieldMath:Evaluate ( fld / obj rtn )
    (vl-catch-all-apply
       '(lambda nil
            (setq obj (vla-addmtext (vla-get-modelspace (FieldMath:Doc))
                          (vlax-3D-point 0 0) 0.0 fld)
                  rtn (distof (vla-get-textstring obj) 2)
            )
        )
    )
    (if (= 'vla-object (type obj)) (vla-delete obj))
    rtn
)

;; ---------------------------------------------------------------------------
;; FieldMath:StripFormatting
;; ---------------------------------------------------------------------------
;; Removes every formatting code from a field expression, recursively.
;;
;; Necessary when referencing a nested field: the formatting is what rounds the
;; displayed value, and the calculation must use the full precision underneath
;; it. See the note in the header.
;; ---------------------------------------------------------------------------
(defun FieldMath:StripFormatting ( fld / ps1 ps2 )
    (if (and (setq ps1 (vl-string-search " \\f \"" fld))
             (setq ps2 (vl-string-search "\">%" (substr fld (+ 6 ps1))))
        )
        (strcat (substr fld 1 ps1) ">%"
                (FieldMath:StripFormatting (substr fld (+ 9 ps1 ps2)))
        )
        fld
    )
)

;; ---------------------------------------------------------------------------
;; FieldMath:Code
;; ---------------------------------------------------------------------------
;; Returns the fully resolved field expression held by an entity, or nil.
;;
;; A field lives in an ACAD_FIELD dictionary hanging off the object, split
;; across DXF entries when long, and referring to other objects and fields by
;; internal indices. The three nested helpers reassemble it: FieldMath:Assemble stitches
;; the fragments, FieldMath:SwapObjs resolves object references to real IDs, and FieldMath:SwapFlds
;; recurses into nested field dictionaries.
;; ---------------------------------------------------------------------------
(defun FieldMath:Code ( ent / FieldMath:SwapFlds FieldMath:SwapObjs FieldMath:Assemble enx )

    (defun FieldMath:Assemble ( enx / itm )
        (if (setq itm (assoc 3 enx))
            (strcat (cdr itm) (FieldMath:Assemble (cdr (member itm enx))))
            (cond ((cdr (assoc 2 enx))) (""))
        )
    )

    (defun FieldMath:SwapObjs ( str enx / ent pos )
        (if (setq pos (vl-string-search "ObjIdx" str))
            (strcat
                (substr str 1 (+ pos 5)) " "
                (FieldMath:ObjectID
                    (vlax-ename->vla-object (cdr (setq ent (assoc 331 enx))))
                )
                (FieldMath:SwapObjs (substr str (1+ (vl-string-search ">%" str pos)))
                          (cdr (member ent enx))
                )
            )
            str
        )
    )

    (defun FieldMath:SwapFlds ( str enx / ent fld pos )
        (if (setq pos (vl-string-search "\\_FldIdx" (setq str (FieldMath:SwapObjs str enx))))
            (progn
                (setq ent (assoc 360 enx)
                      fld (entget (cdr ent))
                )
                (strcat
                    (substr str 1 pos)
                    (FieldMath:SwapFlds (FieldMath:Assemble fld) fld)
                    (FieldMath:SwapFlds (substr str (1+ (vl-string-search ">%" str pos)))
                              (cdr (member ent enx))
                    )
                )
            )
            str
        )
    )

    (if (and (wcmatch (cdr (assoc 0 (setq enx (entget ent))))
                      "TEXT,MTEXT,ATTRIB,MULTILEADER,*DIMENSION")
             (setq enx (cdr (assoc 360 enx)))
             (setq enx (dictsearch enx "ACAD_FIELD"))
             (setq enx (dictsearch (cdr (assoc -1 enx)) "TEXT"))
        )
        (FieldMath:SwapFlds (FieldMath:Assemble enx) enx)
    )
)

;; ---------------------------------------------------------------------------
;; FieldMath:PickValue
;; ---------------------------------------------------------------------------
;; Prompts for one term of the calculation. Returns (expression displayText),
;; or nil if the user backed out.
;;
;; The two halves are both needed: the expression goes into the field, while
;; the display text is what is echoed at the command line so the user can see
;; the calculation taking shape.
;;
;; bck - [str] the name of the back-out option, "Exit" or "Back"
;; nst - [boolean] reference nested fields directly
;; ---------------------------------------------------------------------------
(defun FieldMath:PickValue ( bck nst / ent fld num rtn sel tmp typ )
    (while
        (not
            (progn
                (setvar 'errno 0)
                (initget (strcat "Constant " bck))
                (setq sel (nentsel (strcat "\nSelect an object with numerical content [Constant/"
                                           bck "] <" bck ">: ")))
                (cond
                    (   (= 7 (getvar 'errno))
                        (princ "\nMissed, try again.")
                    )

                    (   (or (null sel) (= bck sel)))

                    ;; A typed constant. Both halves are the number itself.
                    (   (= "Constant" sel)
                        (initget (strcat "Object " bck))
                        (cond
                            (   (null (setq tmp (getreal (strcat "\nEnter a number [Object/" bck "] <" bck ">: ")))))
                            (   (= bck tmp))
                            (   (= "Object" tmp) nil)
                            (   (setq tmp (FieldMath:NumToString tmp)
                                      rtn (list tmp tmp)
                                )
                            )
                        )
                    )

                    (   (progn
                            ;; A four-element nentsel return means the object is
                            ;; nested; the entity is the last element of the last.
                            (if (= 4 (length sel))
                                (setq ent (last (last sel)))
                                (setq ent (car sel))
                            )
                            (not (wcmatch (setq typ (cdr (assoc 0 (entget ent))))
                                          "TEXT,MTEXT,ATTRIB,MULTILEADER,*DIMENSION"))
                        )
                        (princ "\nSelect text, mtext, an attribute, a multileader or a dimension.")
                    )

                    ;; Build the reference and confirm it evaluates to a number.
                    (   (not
                            (setq num
                                (FieldMath:Evaluate
                                    (setq fld
                                        (cond
                                            ;; The object is itself a field -
                                            ;; reference its expression, stripped
                                            ;; of formatting so full precision is
                                            ;; used.
                                            (   (and nst (setq tmp (FieldMath:Code ent)))
                                                (FieldMath:StripFormatting tmp)
                                            )
                                            ;; Otherwise reference its content. A
                                            ;; dimension gives its Measurement, so
                                            ;; the calculation follows the geometry
                                            ;; rather than any typed override.
                                            (   (strcat
                                                    "%<\\AcObjProp Object(%<\\_ObjId "
                                                    (FieldMath:ObjectID (vlax-ename->vla-object ent))
                                                    ">%)."
                                                    (if (wcmatch typ "*DIMENSION") "Measurement" "TextString")
                                                    ">%"
                                                )
                                            )
                                        )
                                    )
                                )
                            )
                        )
                        (princ "\nThat object does not contain a number.")
                    )

                    (   (setq rtn (list fld (FieldMath:NumToString num))))
                )
            )
        )
    )
    rtn
)

;;; ---------------------------------------------------------------------------
;;; OUTPUT - shared with the other field routines in this library.
;;; ---------------------------------------------------------------------------

(defun FieldMath:ListBox ( msg lst / dch des tmp rtn )
    (cond
        (   (not
                (and
                    (setq tmp (vl-filename-mktemp nil nil ".dcl"))
                    (setq des (open tmp "w"))
                    (write-line
                        (strcat "fieldmath:dialog{label=\"" msg "\";spacer;"
                                ":list_box{key=\"list\";multiple_select=false;width=50;height=15;}"
                                "spacer;ok_cancel;}"
                        )
                        des
                    )
                    (not (close des))
                    (< 0 (setq dch (load_dialog tmp)))
                    (new_dialog "fieldmath" dch)
                )
            )
            (princ "\nThe attribute selection dialog could not be created.")
        )
        (   t
            (start_list "list")
            (foreach itm lst (add_list itm))
            (end_list)
            (setq rtn (set_tile "list" "0"))
            (action_tile "list" "(setq rtn $value)")
            (setq rtn (if (= 1 (start_dialog)) (read (strcat "(" rtn ")"))))
        )
    )
    (if (and dch (< 0 dch)) (unload_dialog dch))
    (if (and tmp (setq tmp (findfile tmp))) (vl-file-delete tmp))
    rtn
)

(defun FieldMath:Tables ( / sel idx result )
    (if (setq sel (ssget "_X"
                       (list '(0 . "ACAD_TABLE")
                              (if (= 1 (getvar 'cvport))
                                  (cons 410 (getvar 'ctab))
                                 '(410 . "Model")
                              )
                       )
                  )
        )
        (repeat (setq idx (sslength sel))
            (setq result (cons (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))) result))
        )
    )
    result
)

(defun FieldMath:HitCell ( tables pnt / dir )
    (setq dir (vlax-3D-point (trans (getvar 'viewdir) 1 0))
          pnt (vlax-3D-point pnt)
    )
    (vl-some
        (function
            (lambda ( tab / row col )
                (if (= :vlax-true (vla-hittest tab pnt dir 'row 'col))
                    (list tab row col)
                )
            )
        )
        tables
    )
)

(defun FieldMath:MleaderAttributes ( mld / rtn )
    (vlax-for obj (vla-item (vla-get-blocks (vla-get-document mld))
                            (vla-get-contentblockname mld))
        (if (and (= "AcDbAttributeDefinition" (vla-get-objectname obj))
                 (= :vlax-false (vla-get-constant obj))
            )
            (setq rtn (cons (cons (strcase (vla-get-tagstring obj)) (FieldMath:IntObjectID obj)) rtn))
        )
    )
    (reverse rtn)
)

;; Clearing first prevents an existing field's evaluated remains being left
;; behind under the new one.
(defun FieldMath:PutText ( obj str )
    (vla-put-textstring obj "")
    (vla-put-textstring obj str)
    t
)

(defun FieldMath:UpdateField ( ent / cmd rtn )
    (setq cmd (getvar 'cmdecho))
    (setvar 'cmdecho 0)
    (setq rtn (vl-cmdf "_.updatefield" ent ""))
    (setvar 'cmdecho cmd)
    rtn
)

;; ---------------------------------------------------------------------------
;; FieldMath:Output
;; ---------------------------------------------------------------------------
;; Places the finished expression - as new MText, into a table cell, or into an
;; existing annotation object. The loop runs until something is written or the
;; user exits; Point and Object switch between the two prompt modes.
;; ---------------------------------------------------------------------------
(defun FieldMath:Output ( tag str / ent enx flg idx obj oid sel tab tmp typ )

    (setq tab (FieldMath:Tables))

    (while
        (not
            (progn
                (if flg
                    (progn
                        (setvar 'errno 0)
                        (initget "Point eXit")
                        (setq sel (nentsel "\nSelect text, mtext, mleader, attribute or attributed block [Point/eXit] <eXit>: "))
                    )
                    (progn
                        (initget "Object eXit")
                        (setq sel (getpoint "\nSpecify point or table cell [Object/eXit] <eXit>: "))
                    )
                )
                (cond
                    (   (= 7 (getvar 'errno)) (princ "\nMissed, try again."))
                    (   (or (null sel) (= "eXit" sel)))
                    (   (= "Point" sel)  (setq flg nil))
                    (   (= "Object" sel) (not (setq flg t)))

                    (   flg
                        (setq ent (car sel)
                              enx (entget ent)
                              typ (cdr (assoc 0 enx))
                              obj (vlax-ename->vla-object ent)
                        )
                        (cond
                            (   (and (= 2 (length sel)) (wcmatch typ "TEXT,MTEXT"))
                                (if (vlax-write-enabled-p obj)
                                    (FieldMath:PutText obj str)
                                    (princ "\nThat text object is on a locked layer.")
                                )
                            )

                            (   (and (= "ATTRIB" typ) (/= 'str (type tag)))
                                (if (vlax-write-enabled-p obj)
                                    (progn
                                        (FieldMath:PutText obj str)
                                        (if (wcmatch (strcase str t) "*%<\\ac*>%*")
                                            (FieldMath:UpdateField ent)
                                        )
                                    )
                                    (princ "\nThat attribute is on a locked layer.")
                                )
                            )

                            (   (and
                                    (or (and (= "ATTRIB" typ) (setq tmp (cdr (assoc 330 enx))))
                                        (and (setq tmp (last (cadddr sel)))
                                             (= "INSERT" (cdr (assoc 0 (entget tmp))))
                                        )
                                    )
                                    (setq tmp (vlax-invoke (vlax-ename->vla-object tmp) 'getattributes))
                                    (or (and (= 'str (type tag))
                                             (setq idx (vl-position (strcase tag) (mapcar 'vla-get-tagstring tmp)))
                                             (setq obj (nth idx tmp))
                                        )
                                        (and (not (cdr tmp)) (setq obj (car tmp)))
                                        (and (setq idx (FieldMath:ListBox "Choose Attribute"
                                                           (mapcar 'vla-get-tagstring tmp)))
                                             (setq obj (nth (car idx) tmp))
                                        )
                                    )
                                )
                                (if (vlax-write-enabled-p obj)
                                    (progn
                                        (FieldMath:PutText obj str)
                                        (if (wcmatch (strcase str t) "*%<\\ac*>%*")
                                            (FieldMath:UpdateField (vlax-vla-object->ename obj))
                                        )
                                    )
                                    (princ "\nThat attribute is on a locked layer.")
                                )
                            )

                            (   (and (= 2 (length sel)) (= "MULTILEADER" typ))
                                (setq typ (cdr (assoc 172 (reverse enx))))
                                (cond
                                    (   (and (<= acblockcontent typ acmtextcontent)
                                             (not (vlax-write-enabled-p obj))
                                        )
                                        (princ "\nThat multileader is on a locked layer.")
                                    )
                                    (   (= acmtextcontent typ)
                                        (FieldMath:PutText obj str)
                                        (if (wcmatch (strcase str t) "*%<\\ac*>%*")
                                            (vla-regen (FieldMath:Doc) acactiveviewport)
                                        )
                                        t
                                    )
                                    (   (and (= acblockcontent typ)
                                             (setq tmp (FieldMath:MleaderAttributes obj))
                                             (or (and (= 'str (type tag))
                                                      (setq oid (cdr (assoc (strcase tag) tmp)))
                                                 )
                                                 (and (not (cdr tmp)) (setq oid (cdar tmp)))
                                                 (and (setq idx (FieldMath:ListBox "Choose Attribute" (mapcar 'car tmp)))
                                                      (setq oid (cdr (nth (car idx) tmp)))
                                                 )
                                             )
                                        )
                                        (FieldMath:SetMleaderAttribute obj oid str)
                                        (if (wcmatch (strcase str t) "*%<\\ac*>%*")
                                            (vla-regen (FieldMath:Doc) acactiveviewport)
                                        )
                                        t
                                    )
                                    (   (princ "\nThat multileader has no editable content."))
                                )
                            )

                            (   (princ "\nThat is not text, mtext, a multileader, an attribute or an attributed block."))
                        )
                    )

                    (   (setq tmp (FieldMath:HitCell tab (trans sel 1 0)))
                        (if (vlax-write-enabled-p (car tmp))
                            (not (vl-catch-all-error-p
                                     (vl-catch-all-apply 'vla-settext (append tmp (list str)))
                                 )
                            )
                            (princ "\nThat table is on a locked layer.")
                        )
                    )

                    (   (vla-addmtext
                            (vlax-get-property (FieldMath:Doc)
                                (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)
                            )
                            (vlax-3D-point (trans sel 1 0))
                            0.0
                            str
                        )
                    )
                )
            )
        )
    )
    (princ)
)

;; ---------------------------------------------------------------------------
;; c:FIELDMATH  -  main routine
;; ---------------------------------------------------------------------------
(defun c:FIELDMATH ( / *error* vars vals ini itm lst msg opr tmp )

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

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

    ;; -----------------------------------------------------------------------
    ;; The expression is built as a flat list holding, in reverse order:
    ;;
    ;;     term, operator, operator, term, operator, operator, term ...
    ;;
    ;; Each entry is a two-element list of (expressionForm displayForm), which
    ;; is why operators appear twice - the same string serves both. That
    ;; uniformity is what lets the whole thing be assembled with one mapcar per
    ;; form, and lets Undo drop a term and its operator with a single cddr.
    ;; -----------------------------------------------------------------------
    (if (car (setq lst (list (FieldMath:PickValue "Exit" FieldMath:UseNested))))
        (progn
            (while
                (progn
                    ;; Echo the calculation so far.
                    (princ (apply 'strcat (cons "\n" (reverse (mapcar 'cadr lst)))))

                    ;; Undo is only offered once there is something to undo.
                    (if (cddr lst)
                        (setq ini "Add Subtract Multiply Divide Undo Result"
                              msg "\nSpecify operator [Add/Subtract/Multiply/Divide] or [Undo/Result] <"
                        )
                        (setq ini "Add Subtract Multiply Divide Result"
                              msg "\nSpecify operator [Add/Subtract/Multiply/Divide] or [Result] <"
                        )
                    )
                    (initget ini)
                    (setq opr (cond ((getkword (strcat msg (cond (opr) ("Exit")) ">: "))) (opr)))

                    (cond
                        (   (or (null opr) (= "Result" opr)) nil)

                        ;; Drop the last term and its operator.
                        (   (= "Undo" opr) (setq lst (cddr lst)))

                        (   (setq itm (FieldMath:PickValue "Back" FieldMath:UseNested))
                            (setq tmp (cdr (assoc opr '(("Add"      . " + ")
                                                        ("Subtract" . " - ")
                                                        ("Multiply" . " * ")
                                                        ("Divide"   . " / ")
                                                       )
                                            )
                                      )
                                  lst (vl-list* itm (list tmp tmp) lst)
                            )
                        )
                    )
                )
            )

            ;; -------------------------------------------------------------
            ;; FieldMath:Assemble. More than one term needs an AcExpr wrapper with the
            ;; whole calculation bracketed; a single term is already a complete
            ;; field expression and only needs formatting spliced in before its
            ;; closing marker - which is what trimming the last two characters
            ;; achieves.
            ;; -------------------------------------------------------------
            (FieldMath:Output FieldMath:Tag
                (if (cddr lst)
                    (strcat "%<\\AcExpr ("
                            (apply 'strcat (reverse (mapcar 'car lst)))
                            ")"
                            (if (= "" FieldMath:Format) "" (strcat " \\f \"" FieldMath:Format "\""))
                            ">%"
                    )
                    (if (= "" FieldMath:Format)
                        (caar lst)
                        (strcat (substr (caar lst) 1 (- (strlen (caar lst)) 2))
                                " \\f \"" FieldMath:Format "\">%"
                        )
                    )
                )
            )
            (princ "\nCalculation field created.")
        )
        (princ "\n*Cancelled*")
    )

    (FieldMath:Restore)
    (princ)
)

(princ)