;;; ---------------------------------------------------------------------------
;;; PlainSpeak.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; DRIVING AUTOCAD BY TYPING ENGLISH
;;;
;;; PURPOSE
;;;   Type what you want in ordinary words and watch AutoCAD do it:
;;;
;;;       draw three circles
;;;       hide the lines
;;;       show the arcs
;;;       count the circles
;;;       erase the lines
;;;       that will do, quit
;;;
;;;   It is a demonstration rather than a tool, but the thing it demonstrates is
;;;   worth understanding, because the same machinery is useful anywhere a
;;;   routine has to make sense of text it did not write.
;;;
;;; HOW THE MATCHING WORKS
;;;   The sentence is broken into a list of words and tested against a set of
;;;   patterns. A pattern is a list of words with three wildcards mixed in:
;;;
;;;       $ONE$    matches any single word, and throws it away
;;;       $MANY$   matches any run of one or more words, and throws them away
;;;       $SAVE$   matches any single word and KEEPS it
;;;
;;;   So the pattern ("DRAW" "$SAVE$" "$SAVE$") matches "draw three circles" and
;;;   hands back ("THREE" "CIRCLES"), while ("$MANY$" "QUIT") matches "that will
;;;   do quit" and hands back nothing. The matcher is recursive: $MANY$ works by
;;;   trying to match the rest of the pattern here, and if that fails, swallowing
;;;   one more word and trying again. Six lines of code for something that reads
;;;   like it should be much harder.
;;;
;;; WHAT WAS FIXED
;;;   - Every variable was global, including two called Exit and S, which is a
;;;     poor thing to leave lying about in a session.
;;;   - The helper functions were global too, and one was called LAYERS - a name
;;;     almost guaranteed to collide with something else eventually.
;;;   - $SAVE$ built its results with (cons word (if (null Extracted) nil (list
;;;     Extracted))), which nests the captures one inside another instead of
;;;     listing them side by side. The caller then had to dig them out with
;;;     (caadr ext). Captures now come back as a flat list, in order.
;;;   - It created four layers on startup whether or not you drew anything, and
;;;     one of those, TEMP, existed only because AutoCAD will not freeze the
;;;     current layer. Switching to layer 0 before freezing does the same job
;;;     without leaving a layer behind.
;;;   - CMDECHO, BLIPMODE and the current layer were changed and never restored.
;;;   - The vocabulary stopped at five. It now reaches twenty, and any actual
;;;     numeral is read directly, so "draw 12 circles" works.
;;;
;;;   PLAINSPEAK  - type instructions in English
;;; ---------------------------------------------------------------------------

;;; ---------------------------------------------------------------------------
;;; THE PATTERN MATCHER
;;;
;;; Returns nil if the words do not fit the pattern. On a match it returns a list
;;; whose first element is T and whose remaining elements are whatever $SAVE$
;;; captured, in the order they appeared. The leading T is what lets a match with
;;; no captures be told apart from no match at all.
;;; ---------------------------------------------------------------------------

(defun PlainSpeak:Match ( pat words / rest )
    (cond
        ;; Both ran out together - a clean match.
        ((and (null pat) (null words)) (list t))

        ;; One ran out before the other.
        ((or (null pat) (null words)) nil)

        ;; A literal word that agrees, or the throwaway single wildcard.
        ((or (= "$ONE$" (car pat)) (= (car pat) (car words)))
         (PlainSpeak:Match (cdr pat) (cdr words)))

        ;; Keep this word, provided the rest of the pattern still fits.
        ((= "$SAVE$" (car pat))
         (if (setq rest (PlainSpeak:Match (cdr pat) (cdr words)))
             (cons t (cons (car words) (cdr rest)))))

        ;; Any run of words. Try matching the rest of the pattern starting after
        ;; this word; failing that, swallow another word and try again.
        ((= "$MANY$" (car pat))
         (cond ((PlainSpeak:Match (cdr pat) (cdr words)))
               ((PlainSpeak:Match pat (cdr words)))))
    )
)

;;; Break a sentence into upper-case words, dropping punctuation and the filler
;;; words that carry no meaning here.
(defun PlainSpeak:Words ( s / i ch word out )
    (setq i 0 word "" out nil)
    (while (< i (strlen s))
        (setq i (1+ i) ch (substr s i 1))
        (cond
            ;; Punctuation simply vanishes.
            ((member ch '("." "," "!" "?" ";" ":" "'" "\"")))
            ;; Whitespace ends the word in hand.
            ((= ch " ")
             (if (/= "" word) (setq out (cons word out) word "")))
            (t (setq word (strcat word (strcase ch))))))
    (if (/= "" word) (setq out (cons word out)))
    (vl-remove-if '(lambda ( w ) (member w '("PLEASE" "SOME" "ME" "WOULD" "YOU")))
                  (reverse out))
)

;;; ---------------------------------------------------------------------------
;;; VOCABULARY
;;; ---------------------------------------------------------------------------

;;; A counting word, or an actual numeral, as a number. Returns nil if the word
;;; means nothing here, so the caller can say so.
(defun PlainSpeak:HowMany ( w / n pos )
    (setq n '(("A" . 1) ("AN" . 1) ("ONE" . 1) ("TWO" . 2) ("THREE" . 3)
              ("FOUR" . 4) ("FIVE" . 5) ("SIX" . 6) ("SEVEN" . 7)
              ("EIGHT" . 8) ("NINE" . 9) ("TEN" . 10) ("ELEVEN" . 11)
              ("TWELVE" . 12) ("THIRTEEN" . 13) ("FOURTEEN" . 14)
              ("FIFTEEN" . 15) ("SIXTEEN" . 16) ("SEVENTEEN" . 17)
              ("EIGHTEEN" . 18) ("NINETEEN" . 19) ("TWENTY" . 20)))
    (cond
        ((setq pos (assoc w n)) (cdr pos))
        ;; A run of digits is taken at face value.
        ((and (/= "" w) (wcmatch w "#*") (> (atoi w) 0)) (atoi w))
    )
)

;;; What kind of object a word refers to, singular or plural. Returns the DXF
;;; type name, or nil.
(defun PlainSpeak:Object ( w )
    (cond
        ((wcmatch w "CIRCLE,CIRCLES,CIRC*") "CIRCLE")
        ((wcmatch w "ARC,ARCS")             "ARC")
        ((wcmatch w "LINE,LINES")           "LINE")
    )
)

;;; The layer each kind of object lives on. "ALL" and "EVERYTHING" give all three.
(defun PlainSpeak:Layers ( w )
    (cond
        ((null w) nil)
        ((wcmatch w "ALL,EVERYTHING,EVERY*") '("LINES" "ARCS" "CIRCLES"))
        ((wcmatch w "CIRCLE,CIRCLES,CIRC*")  '("CIRCLES"))
        ((wcmatch w "ARC,ARCS")              '("ARCS"))
        ((wcmatch w "LINE,LINES")            '("LINES"))
    )
)

;;; Make a layer if it is not there already, and leave it visible.
(defun PlainSpeak:EnsureLayer ( name )
    (if (not (tblsearch "LAYER" name))
        (command "_.LAYER" "_Make" name ""))
    (command "_.LAYER" "_Thaw" name "_On" name "")
)

(defun PlainSpeak:Help ( )
    (princ "\n  Things it understands:")
    (princ "\n    draw three circles       draw a line      draw 12 arcs")
    (princ "\n    show the lines           hide the arcs    show everything")
    (princ "\n    count the circles        erase the lines")
    (princ "\n    quit                     (or anything ending in quit)")
    (princ)
)

;;; ---------------------------------------------------------------------------
;;; DRAWING
;;;
;;; Each kind of object asks for what it needs and is put on its own layer, so
;;; that "hide the arcs" has something to act on.
;;; ---------------------------------------------------------------------------

(defun PlainSpeak:DrawOne ( kind / p1 p2 p3 r )
    (cond
        ((= kind "LINE")
         (if (and (setq p1 (getpoint "\n  Start of the line: "))
                  (setq p2 (getpoint p1 "\n  End of the line: ")))
             (progn (PlainSpeak:EnsureLayer "LINES")
                    (setvar "CLAYER" "LINES")
                    (command "_.LINE" p1 p2 "")
                    t)))

        ((= kind "ARC")
         (if (and (setq p1 (getpoint "\n  Centre of the arc: "))
                  (setq p2 (getpoint p1 "\n  Start of the arc: "))
                  (setq p3 (getpoint p1 "\n  End of the arc: ")))
             (progn (PlainSpeak:EnsureLayer "ARCS")
                    (setvar "CLAYER" "ARCS")
                    (command "_.ARC" p2 "_C" p1 p3)
                    t)))

        ((= kind "CIRCLE")
         (if (and (setq p1 (getpoint "\n  Centre of the circle: "))
                  (progn (initget 6) (setq r (getdist p1 "\n  Radius: "))))
             (progn (PlainSpeak:EnsureLayer "CIRCLES")
                    (setvar "CLAYER" "CIRCLES")
                    (command "_.CIRCLE" p1 r)
                    t)))
    )
)

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

(defun c:PLAINSPEAK ( / *error* vars vals patterns said words done hit
                        count kind ss n )

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

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

    (setvar "CMDECHO" 0)
    (setvar "BLIPMODE" 0)
    ;; AutoCAD 2015 and later refuse (command) inside an *error* handler unless
    ;; the routine says up front that it will use one.
    (vl-catch-all-apply '(lambda ( ) (*push-error-using-command*)) '())
    (command "_.UNDO" "_Begin")

    ;; Order matters. The longer, more specific patterns are tried first, so
    ;; "draw three circles" is not caught by the one-word DRAW pattern with
    ;; "three" mistaken for the object.
    (setq patterns
        (list
            (cons 'quit  '("$MANY$" "QUIT"))
            (cons 'quit  '("$MANY$" "QUIT" "$MANY$"))
            (cons 'quit  '("QUIT"))
            (cons 'quit  '("$MANY$" "STOP"))
            (cons 'quit  '("$MANY$" "BYE"))
            (cons 'help  '("HELP"))
            (cons 'help  '("$MANY$" "HELP" "$MANY$"))
            (cons 'draw  '("DRAW" "$SAVE$" "$SAVE$"))
            (cons 'draw1 '("DRAW" "$SAVE$"))
            (cons 'show  '("SHOW" "THE" "$SAVE$"))
            (cons 'show  '("SHOW" "$SAVE$"))
            (cons 'show  '("DISPLAY" "THE" "$SAVE$"))
            (cons 'show  '("DISPLAY" "$SAVE$"))
            (cons 'hide  '("HIDE" "THE" "$SAVE$"))
            (cons 'hide  '("HIDE" "$SAVE$"))
            (cons 'count '("COUNT" "THE" "$SAVE$"))
            (cons 'count '("COUNT" "$SAVE$"))
            (cons 'wipe  '("ERASE" "THE" "$SAVE$"))
            (cons 'wipe  '("ERASE" "$SAVE$"))
            (cons 'wipe  '("DELETE" "THE" "$SAVE$"))))

    (princ "\nType what you want in plain words.")
    (PlainSpeak:Help)

    (setq done nil)
    (while (not done)
        (setq said  (getstring t "\n> ")
              words (PlainSpeak:Words said)
              hit   nil)

        ;; Find the first pattern that fits, and remember what it captured.
        (foreach p patterns
            (if (and (null hit) (setq n (PlainSpeak:Match (cdr p) words)))
                (setq hit (cons (car p) (cdr n)))))

        (cond
            ((null words))                    ; empty line, ask again

            ((null hit)
             (princ "\n  Sorry - I do not follow that one.")
             (PlainSpeak:Help))

            ((eq 'quit (car hit))
             (princ "\n  Right you are.")
             (setq done t))

            ((eq 'help (car hit)) (PlainSpeak:Help))

            ;; "draw three circles" - a count and an object.
            ((eq 'draw (car hit))
             (setq count (PlainSpeak:HowMany (cadr hit))
                   kind  (PlainSpeak:Object  (caddr hit)))
             (cond
                 ((null kind)
                  (princ (strcat "\n  I do not know what a " (caddr hit) " is.")))
                 ((null count)
                  (princ (strcat "\n  " (cadr hit)
                                 " is not a number I recognise.")))
                 (t (while (and (> count 0) (PlainSpeak:DrawOne kind))
                        (setq count (1- count))))))

            ;; "draw a line" with no count word.
            ((eq 'draw1 (car hit))
             (if (setq kind (PlainSpeak:Object (cadr hit)))
                 (PlainSpeak:DrawOne kind)
                 (princ (strcat "\n  I do not know what a " (cadr hit) " is."))))

            ((member (car hit) '(show hide))
             (if (setq n (PlainSpeak:Layers (cadr hit)))
                 (progn
                     ;; AutoCAD will not freeze the layer you are working on, so
                     ;; step off it first.
                     (setvar "CLAYER" "0")
                     (foreach lay n
                         (if (tblsearch "LAYER" lay)
                             (if (eq 'show (car hit))
                                 (command "_.LAYER" "_Thaw" lay "_On" lay "")
                                 (command "_.LAYER" "_Freeze" lay ""))))
                     (princ (strcat "\n  " (if (eq 'show (car hit))
                                               "Showing " "Hiding ")
                                    (cadr hit) ".")))
                 (princ (strcat "\n  I have nothing called " (cadr hit) "."))))

            ((eq 'count (car hit))
             (if (setq n (PlainSpeak:Layers (cadr hit)))
                 (foreach lay n
                     (setq ss (ssget "_X" (list (cons 8 lay))))
                     (princ (strcat "\n  " (itoa (if ss (sslength ss) 0))
                                    " on layer " lay ".")))
                 (princ (strcat "\n  I have nothing called " (cadr hit) "."))))

            ((eq 'wipe (car hit))
             (if (setq n (PlainSpeak:Layers (cadr hit)))
                 (foreach lay n
                     (if (setq ss (ssget "_X" (list (cons 8 lay))))
                         (progn
                             (setq count (sslength ss))
                             (command "_.ERASE" ss "")
                             (princ (strcat "\n  Erased " (itoa count)
                                            " from layer " lay ".")))
                         (princ (strcat "\n  Nothing on layer " lay "."))))
                 (princ (strcat "\n  I have nothing called " (cadr hit) "."))))
        )
    )

    (PlainSpeak:Restore)
    (princ)
)

(princ)