; ABNF (Augmented Backus-Naur Form) Library
;
; Copyright (C) 2026 Kestrel Institute (http://www.kestrel.edu)
;
; License: A 3-clause BSD license. See the LICENSE file distributed with ACL2.
;
; Author: Alessandro Coglio (www.alessandrocoglio.info)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package "ABNF")

(include-book "../grammar-parser/executable")
(include-book "../grammar-printer/executable")
(include-book "../notation/syntax-abstraction")
(include-book "../operations/closure")
(include-book "../operations/well-formedness")
(include-book "../operations/numeric-range-retrieval")
(include-book "../operations/character-value-retrieval")

(include-book "kestrel/event-macros/cw-event" :dir :system)
(include-book "kestrel/event-macros/input-processing" :dir :system)
(include-book "kestrel/event-macros/make-event-terse" :dir :system)
(include-book "kestrel/event-macros/restore-output" :dir :system)
(include-book "kestrel/fty/symbol-pseudoeventform-alist" :dir :system)
(include-book "std/system/constant-namep" :dir :system)
(include-book "std/system/constant-value" :dir :system)
(include-book "std/system/table-alist-plus" :dir :system)
(include-book "kestrel/utilities/er-soft-plus" :dir :system)
(include-book "kestrel/utilities/true-list-listp-theorems" :dir :system)
(include-book "std/alists/assoc" :dir :system)
(include-book "std/typed-alists/string-symbol-alistp" :dir :system)
(include-book "std/typed-alists/string-symbollist-alistp" :dir :system)
(include-book "std/typed-lists/nat-listp" :dir :system)
(include-book "std/util/error-value-tuples" :dir :system)

(local (include-book "std/system/partition-rest-and-keyword-args" :dir :system))
(local (include-book "std/lists/len" :dir :system))
(local (include-book "std/typed-alists/symbol-alistp" :dir :system))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(xdoc::evmac-topic-implementation

 deftreeops

 :items

 (xdoc::*evmac-topic-implementation-item-state*

  xdoc::*evmac-topic-implementation-item-wrld*

  xdoc::*evmac-topic-implementation-item-ctx*

  (xdoc::evmac-topic-implementation-item-input "grammar")

  (xdoc::evmac-topic-implementation-item-input "prefix")

  (xdoc::evmac-topic-implementation-item-input "print"))

 :additional

 ((xdoc::p
   "The generation of the functions and theorems happens in two passes:")
  (xdoc::ol
   (xdoc::li
    "In the first pass, we go through all the rules of the grammar
     and generate
     a @(tsee deftreeops-rulename-info-alist),
     a @(tsee deftreeops-numrange-info-alist), and
     a @(tsee deftreeops-charval-info-alist),
     which mainly contain information about
     the names of the functions and theorems to be generated,
     along with some additional information.")
   (xdoc::li
    "In the second pass, we go through the alists built in the first pass,
     and we generate all the events for the functions and theorems.
     The names and additional information in the alists
     provide the means for the events to reference each other as needed.
     Care is taken to generate the events so that
     there are no forward references, as required in ACL2.
     The generated events are returned as separate sequences,
     in order to put analogous events next to each other."))
  (xdoc::p
   "The alists of information created in the first pass
    are also stored in the @(tsee deftreeops) table,
    via an event generated along with the functions and theorems.
    The table also stores an alist of the generated events as values
    with the names of the events as keys.
    This way, the information about the generated functions and theorems
    can be easily accessed, interactively or programmatically.")
  (xdoc::p
   "In the documentation below,
    we say `defining alternation of a rule name'
    instead of `defining alternation of a rule'.
    In ABNF, a "
   (xdoc::seetopic "well-formedness" "well-formed grammar")
   " may have more than one rule for the same rule name,
    with the rules after the first one being incremental ones.
    Thus, by `defining alternation of a rule name' we mean
    the alternation consisting of all the concatenations in
    the alternations in the rules for the rule name,
    in the order in which they appear in the grammar,
    as returned by @(tsee lookup-rulename).")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defxdoc+ deftreeops-info
  :parents (deftreeops-implementation)
  :short "Information about the events generated by @(tsee deftreeops)."
  :long
  (xdoc::topstring
   (xdoc::p
    "As discussed in @(see deftreeops-implementation),
     this is generated in the first pass.
     The events themselves are generated in the second pass."))
  :order-subtopics t
  :default-parent t)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(fty::defprod deftreeops-rep-info
  :short "Fixtype of @(tsee deftreeops) information about
          a repetition in a concatenation
          in the defining alternation of a rule name."
  :long
  (xdoc::topstring
   (xdoc::p
    "This information consists of:")
   (xdoc::ul
    (xdoc::li
     "The name of the @('<prefix>-<rulename>-conc<i>-rep<j>') function
      described in @(tsee deftreeops).
      This is @('nil') if the function is not generated.")
    (xdoc::li
     "The name of the @('<prefix>-<rulename>-conc<i>-rep<j>-matching') theorem
      described in @(tsee deftreeops).
      This is @('nil') if the theorem is not generated.")
    (xdoc::li
     "The name of the @('<prefix>-<rulename>-conc<i>-rep<j>-len') function
      described in @(tsee deftreeops).
      This is @('nil') if the function is not generated.")
    (xdoc::li
     "The name of the @('<prefix>-<rulename>-conc<i>-rep<j>-elem') function
      described in @(tsee deftreeops).
      This is @('nil') if the function is not generated.")))
  ((get-tree-list-fn acl2::symbolp)
   (matching-thm acl2::symbol)
   (get-len-fn acl2::symbol)
   (get-tree-fn acl2::symbolp))
  :pred deftreeops-rep-infop)

;;;;;;;;;;;;;;;;;;;;

(fty::deflist deftreeops-rep-info-list
  :short "Fixtype of @(tsee deftreeops) information about
          the list of repetitions that form a concatenation
          in the defining alternation of a rule name."
  :elt-type deftreeops-rep-info
  :true-listp t
  :elementp-of-nil nil
  :pred deftreeops-rep-info-listp)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(fty::defprod deftreeops-conc-info
  :short "Fixtype of @(tsee deftreeops) information about a concatenation
          in the defining alternation of a rule name."
  :long
  (xdoc::topstring
   (xdoc::p
    "This information consists of:")
   (xdoc::ul
    (xdoc::li
     "The concatenation.")
    (xdoc::li
     "The discriminant term used in
      the @('<prefix>-<rulename>-conc-equivs') theorem
      described in @(tsee deftreeops).
      This is @('nil') if the rule name is defined by
      an alternation of just one concatenation.")
    (xdoc::li
     "The name of the @('<prefix>-<rulename>-conc?-<i>-iff-match-conc') theorem
      described in @(tsee deftreeops).
      This is @('nil') if the theorem is not generated.")
    (xdoc::li
     "The name of the @('<prefix>-<rulename>-conc<i>') function
      described in @(tsee deftreeops).
      This is @('nil') if the function is not generated.")
    (xdoc::li
     "The name of the @('<prefix>-<rulename>-conc<i>-matching') theorem
      described in @(tsee deftreeops).
      This is @('nil') if the theorem is not generated.")
    (xdoc::li
     "The information about the repetitions that form the concatenation.")))
  ((conc concatenationp)
   (discriminant-term "A term.")
   (check-conc-fn-equiv-thm acl2::symbol)
   (get-tree-list-list-fn acl2::symbol)
   (matching-thm acl2::symbol)
   (rep-infos deftreeops-rep-info-list))
  :pred deftreeops-conc-infop)

;;;;;;;;;;;;;;;;;;;;

(fty::deflist deftreeops-conc-info-list
  :short "Fixtype of @(tsee deftreeops) information about
          the list of concatenations that form
          the defining alternation of a rule name."
  :elt-type deftreeops-conc-info
  :true-listp t
  :elementp-of-nil nil
  :pred deftreeops-conc-info-listp)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(fty::defprod deftreeops-rulename-info
  :short "Fixtype of @(tsee deftreeops) information about a rule name."
  :long
  (xdoc::topstring
   (xdoc::p
    "This information consists of:")
   (xdoc::ul
    (xdoc::li
     "The alternation that defines the rule name.")
    (xdoc::li
     "The name of the @('<prefix>-<rulename>-nonleaf') theorem
      described in @(tsee deftreeops).")
    (xdoc::li
     "The name of the @('<prefix>-<rulename>-rulename') theorem
      described in @(tsee deftreeops).")
    (xdoc::li
     "The name of the @('<prefix>-<rulename>-branches-match-alt') theorem
      described in @(tsee deftreeops).")
    (xdoc::li
     "The name of the @('<prefix>-<rulename>-concs') theorem
      described in @(tsee deftreeops).")
    (xdoc::li
     "The name of the @('<prefix>-<rulename>-conc-equivs') theorem
      described in @(tsee deftreeops).
      This is @('nil') if the theorem is not generated.")
    (xdoc::li
     "If the @('conc-equivs-thm') component is not @('nil'),
      a positive integer indicating the kind of alternation
      among the ones listed as supported in @(tsee deftreeops):
      1 for the first one, 2 for the second one.
      This is 0 if @('conc-equivs-thm') is @('nil').")
    (xdoc::li
     "The name of the @('<prefix>-<rulename>-conc?') function
      described in @(tsee deftreeops).
      This is @('nil') if the function is not generated.")
    (xdoc::li
     "The information about the concatenations that form
      the alternation that defines the rule name.")))
  ((alt alternationp)
   (nonleaf-thm acl2::symbol)
   (rulename-thm acl2::symbol)
   (match-thm acl2::symbol)
   (concs-thm acl2::symbol)
   (conc-equivs-thm acl2::symbol)
   (alt-kind nat)
   (check-conc-fn acl2::symbol)
   (conc-infos deftreeops-conc-info-list))
  :pred deftreeops-rulename-infop)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(fty::defalist deftreeops-rulename-info-alist
  :short "Fixtype of alists from rule names to information about rule names."
  :key-type rulename
  :val-type deftreeops-rulename-info
  :true-listp t
  :keyp-of-nil nil
  :valp-of-nil nil
  :pred deftreeops-rulename-info-alistp
  ///

  (defrule deftreeops-rulename-infop-when-deftreeops-rulename-info-alistp
    (implies (deftreeops-rulename-info-alistp alist)
             (iff (deftreeops-rulename-infop (cdr (assoc-equal key alist)))
                  (cdr (assoc-equal key alist))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(fty::defprod deftreeops-numrange-info
  :short "Fixtype of @(tsee deftreeops) information about numeric ranges."
  :long
  (xdoc::topstring
   (xdoc::p
    "This information consists of:")
   (xdoc::ul
    (xdoc::li
     "The name of the @('<prefix>-%<b><min>-<max>-nat') function
      described in @(tsee deftreeops).")
    (xdoc::li
     "The name of the @('<prefix>-%<b><min>-<max>-nat-bounds') theorem
      described in @(tsee deftreeops).")))
  ((get-nat-fn acl2::symbol)
   (bounds-thm acl2::symbol))
  :pred deftreeops-numrange-infop)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(fty::defalist deftreeops-numrange-info-alist
  :short "Fixtype of alists from numeric ranges to information about them."
  :key-type num-range
  :val-type deftreeops-numrange-info
  :true-listp t
  :keyp-of-nil nil
  :valp-of-nil nil
  :pred deftreeops-numrange-info-alistp)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(fty::defprod deftreeops-charval-info
  :short "Fixtype of @(tsee deftreeops) information about
          character value notation."
  :long
  (xdoc::topstring
   (xdoc::p
    "This information consists of:")
   (xdoc::ul
    (xdoc::li
     "The name of the @('<prefix>-<...>|\"<chars>\"|-leafterm') theorem
      described in @(tsee deftreeops),
      where @('<...>') is @('%i') or @('%s') or nothing.")))
  ((leafterm-thm acl2::symbolp))
  :pred deftreeops-charval-infop)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(fty::defalist deftreeops-charval-info-alist
  :short "Fixtype of alists from character value notations
          to information about them."
  :key-type char-val
  :val-type deftreeops-charval-info
  :true-listp t
  :keyp-of-nil nil
  :valp-of-nil nil
  :pred deftreeops-charval-info-alistp
  ///

  (defrule deftreeops-charval-infop-when-deftreeops-charval-info-alistp
    (implies (deftreeops-charval-info-alistp alist)
             (iff (deftreeops-charval-infop (cdr (assoc-equal key alist)))
                  (cdr (assoc-equal key alist))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defxdoc+ deftreeops-table
  :parents (deftreeops-implementation)
  :short "Table of @(tsee deftreeops) calls."
  :long
  (xdoc::topstring
   (xdoc::p
    "This is for storing information about the generated information and events,
     and also for detecting redundant calls."))
  :order-subtopics t
  :default-parent t)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(fty::defprod deftreeops-table-value
  :short "Fixtype of values of the table of @(tsee deftreeops) calls."
  :long
  (xdoc::topstring
   (xdoc::p
    "A value of this fixtype consists of:")
   (xdoc::ul
    (xdoc::li
     "The alist from rule names to rule name information.")
    (xdoc::li
     "The alist from numeric ranges to numeric range information.")
    (xdoc::li
     "The alist from character value notations
      to character value notation information.")
    (xdoc::li
     "An alist from symbols to events,
      which consists of all the generated events as values,
      with the event names as keys of the alist.")
    (xdoc::li
     "The call of @(tsee deftreeops).")))
  ((rulename-info-alist deftreeops-rulename-info-alist)
   (numrange-info-alist deftreeops-numrange-info-alist)
   (charval-info-alist deftreeops-charval-info-alist)
   (event-alist symbol-pseudoeventform-alist)
   (call pseudo-event-formp))
  :pred deftreeops-table-valuep)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(fty::defoption deftreeops-table-value-option
  deftreeops-table-value
  :short "Fixtype of optional values of the table of @(tsee deftreeops) calls."
  :pred deftreeops-table-value-optionp)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsection deftreeops-table-definition
  :short "Definition of the table of @(tsee deftreeops) calls."
  :long
  (xdoc::topstring
   (xdoc::p
    "We use the grammar constant names as keys."))

  (table deftreeops-table nil nil
    :guard (and (acl2::symbolp acl2::key)
                (deftreeops-table-valuep acl2::val))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-table-lookup ((grammar acl2::symbolp) (wrld plist-worldp))
  :returns (info? deftreeops-table-value-optionp)
  :short "Look up a @(tsee deftreeops) in the table."
  (b* ((info?
        (cdr (assoc-eq grammar (table-alist+ 'deftreeops-table wrld)))))
    (and (deftreeops-table-valuep info?)
         info?)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-table-add ((grammar acl2::symbolp) (info deftreeops-table-valuep))
  :returns (event pseudo-event-formp)
  :short "Event to record a @(tsee deftreeops) in the table."
  `(table deftreeops-table ',grammar ',info))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(xdoc::evmac-topic-input-processing deftreeops)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-process-grammar (grammar
                                    (call pseudo-event-formp)
                                    (wrld plist-worldp))
  :returns (mv erp
               (redundantp booleanp)
               (grammar acl2::symbolp)
               (rules rulelistp))
  :short "Process the @('*grammar*') input."
  :long
  (xdoc::topstring
   (xdoc::p
    "If the @('redundantp') result is @('t'),
     the @('grammar') and @('rules') results are irrelevant."))
  (b* (((reterr) nil nil nil)
       ((unless (constant-namep grammar wrld))
        (reterr (msg "The *GRAMMAR* input ~x0 must be the name of a constant."
                     grammar)))
       (info (deftreeops-table-lookup grammar wrld))
       ((when info)
        (if (equal call (deftreeops-table-value->call info))
            (retok t nil nil)
          (reterr (msg "DEFTREEOPS has been already called on ~x0, ~
                        but the previous call ~x1 differs ~
                        from the new call ~x2, ~
                        which is therefore not redundant."
                       grammar (deftreeops-table-value->call info) call))))
       (rules (constant-value grammar wrld))
       ((unless (and (rulelistp rules)
                     (consp rules)))
        (reterr (msg "The *GRAMMAR* input is the name of a constant, ~
                      but its value ~x0 is not a non-empty ABNF grammar."
                     rules)))
       ((unless (rulelist-wfp rules))
        (reterr (msg "The *GRAMMAR* input denotes and ABNF grammar, ~
                      but the grammar is not well-formed
                      (see :DOC ABNF::WELL-FORMEDNESS).")))
       ((unless (rulelist-closedp rules))
        (reterr (msg "The *GRAMMAR* input denotes an ABNF grammar, ~
                      but the grammar is not closed
                      (see :DOC ABNF::CLOSURE)."))))
    (retok nil grammar rules)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-process-prefix (prefix)
  :returns (mv erp (prefix acl2::symbolp))
  :short "Process the @(':prefix') input."
  (b* (((reterr) nil)
       ((unless (acl2::symbolp prefix))
        (reterr (msg "The :PREFIX input ~x0 must be a symbol." prefix))))
    (retok prefix)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-process-print (print)
  :returns (mv erp (print evmac-input-print-p))
  :short "Process the @(':print') input."
  (b* (((reterr) :error)
       ((unless (and print
                     (evmac-input-print-p print)))
        (reterr (msg "The :PRINT input ~x0 must be ~
                      :ERROR, :RESULT, :INFO, or :ALL."
                     print))))
    (retok print)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defval *deftreeops-allowed-options*
  :short "Keyword options accepted by @(tsee deftreeops)."
  '(:prefix
    :print)
  ///
  (assert-event (keyword-listp *deftreeops-allowed-options*))
  (assert-event (no-duplicatesp-eq *deftreeops-allowed-options*)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-process-inputs ((args true-listp)
                                   (call pseudo-event-formp)
                                   (wrld plist-worldp))
  :returns (mv erp
               (redundantp booleanp)
               (grammar acl2::symbolp)
               (rules rulelistp)
               (prefix acl2::symbolp)
               (print evmac-input-print-p))
  :short "Process all the inputs."
  :long
  (xdoc::topstring
   (xdoc::p
    "If the @('redundantp') result is @('t'),
     the @('grammar'), @('rules'), and @('prefix') results are irrelevant."))
  (b* (((reterr) nil nil nil nil :error)
       ((mv erp grammar options)
        (partition-rest-and-keyword-args args *deftreeops-allowed-options*))
       ((when (or erp
                  (not (consp grammar))
                  (not (endp (cdr grammar)))))
        (reterr (msg "The inputs must be the constant name for the grammar ~
                      followed by the options ~&0."
                     *deftreeops-allowed-options*)))
       (grammar (car grammar))
       ((erp redundantp grammar rules)
        (deftreeops-process-grammar grammar call wrld))
       ((when redundantp) (retok t nil nil nil :error))
       (prefix-option (assoc-eq :prefix options))
       ((unless (consp prefix-option))
        (reterr (msg "The :PREFIX input must be supplied.")))
       (prefix (cdr prefix-option))
       ((erp prefix) (deftreeops-process-prefix prefix))
       (print-option (assoc-eq :print options))
       (print (if print-option
                  (cdr print-option)
                :result))
       ((erp print) (deftreeops-process-print print)))
    (retok nil grammar rules prefix print))
  :guard-hints (("Goal" :in-theory (enable acl2::alistp-when-symbol-alistp))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(xdoc::evmac-topic-event-generation deftreeops)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-match-pred ((prefix acl2::symbolp))
  :returns (pred acl2::symbolp)
  :short "Name of the @('<prefix>-matchp') predicate."
  (add-suffix-to-fn prefix "-MATCHP"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-elem-match-pred ((prefix acl2::symbolp))
  :returns (pred acl2::symbolp)
  :short "Name of the @('<prefix>-list-elem-matchp') predicate."
  (add-suffix-to-fn prefix "-LIST-ELEM-MATCHP"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-rep-match-pred ((prefix acl2::symbolp))
  :returns (pred acl2::symbolp)
  :short "Name of the @('<prefix>-list-rep-matchp') predicate."
  (add-suffix-to-fn prefix "-LIST-REP-MATCHP"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-conc-match-pred ((prefix acl2::symbolp))
  :returns (pred acl2::symbolp)
  :short "Name of the @('<prefix>-list-list-conc-matchp') predicate."
  (add-suffix-to-fn prefix "-LIST-LIST-CONC-MATCHP"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-alt-match-pred ((prefix acl2::symbolp))
  :returns (pred acl2::symbolp)
  :short "Name of the @('<prefix>-list-list-alt-matchp') predicate."
  (add-suffix-to-fn prefix "-LIST-LIST-ALT-MATCHP"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-cst-match ((grammar acl2::symbolp)
                                  (prefix acl2::symbolp)
                                  (print evmac-input-print-p))
  :returns (mv (events pseudo-event-form-listp)
               (event-alist symbol-pseudoeventform-alistp))
  :short "Generate the first of the specialized matching predicates."
  (b* ((cst-matchp (deftreeops-match-pred prefix))
       (cst-matchp$ (add-suffix-to-fn cst-matchp "$"))
       (cst-matchp$-event
        `(define ,cst-matchp$ ((tree treep) (elem elementp))
           :returns (yes/no booleanp)
           (and (tree-terminatedp tree)
                (tree-match-element-p tree elem ,grammar))
           :hooks (:fix)))
       (cst-matchp-event
        `(defmacro ,cst-matchp (tree elem)
           (declare (xargs :guard (acl2::stringp elem)))
           (b* (((mv err elem rest)
                 (parse-element (string=>nats elem)))
                ((when err) (er hard ',cst-matchp "~@0" err))
                ((when (consp rest))
                 (er hard ',cst-matchp
                     "Extra: ~s0" (nats=>string rest)))
                (elem (abstract-element elem)))
             `(,',cst-matchp$ ,tree ',elem))))
       (table-event
        `(table acl2::macro-aliases-table
           ',cst-matchp
           ',cst-matchp$))
       (print-event?
        (and (evmac-input-print->= print :result)
             `((cw-event "Function ~x0 and macro ~x1.~%"
                         ',cst-matchp$
                         ',cst-matchp)))))
    (mv (list* cst-matchp$-event
               cst-matchp-event
               table-event
               print-event?)
        (list (cons cst-matchp$ cst-matchp$-event)
              (cons cst-matchp cst-matchp-event)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-cst-list-elem-match ((grammar acl2::symbolp)
                                            (prefix acl2::symbolp)
                                            (print evmac-input-print-p))
  :returns (mv (events pseudo-event-form-listp)
               (event-alist symbol-pseudoeventform-alistp))
  :short "Generate the second of the specialized matching predicates."
  (b* ((cst-list-elem-matchp (deftreeops-elem-match-pred prefix))
       (cst-list-elem-matchp$ (add-suffix-to-fn cst-list-elem-matchp "$"))
       (cst-list-elem-matchp$-event
        `(define ,cst-list-elem-matchp$ ((trees tree-listp) (elem elementp))
           :returns (yes/no booleanp)
           (and (tree-list-terminatedp trees)
                (tree-list-match-element-p trees elem ,grammar))
           :hooks (:fix)))
       (cst-list-elem-matchp-event
        `(defmacro ,cst-list-elem-matchp (trees elem)
           (declare (xargs :guard (acl2::stringp elem)))
           (b* (((mv err elem rest)
                 (parse-element (string=>nats elem)))
                ((when err) (er hard ',cst-list-elem-matchp "~@0" err))
                ((when (consp rest))
                 (er hard ',cst-list-elem-matchp
                     "Extra: ~s0" (nats=>string rest)))
                (elem (abstract-element elem)))
             `(,',cst-list-elem-matchp$ ,trees ',elem))))
       (table-event
        `(table acl2::macro-aliases-table
           ',cst-list-elem-matchp
           ',cst-list-elem-matchp$))
       (print-event?
        (and (evmac-input-print->= print :result)
             `((cw-event "Function ~x0 and macro ~x1.~%"
                         ',cst-list-elem-matchp$
                         ',cst-list-elem-matchp)))))
    (mv (list* cst-list-elem-matchp$-event
               cst-list-elem-matchp-event
               table-event
               print-event?)
        (list (cons cst-list-elem-matchp$ cst-list-elem-matchp$-event)
              (cons cst-list-elem-matchp cst-list-elem-matchp-event)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-cst-list-rep-match ((grammar acl2::symbolp)
                                           (prefix acl2::symbolp)
                                           (print evmac-input-print-p))
  :returns (mv (events pseudo-event-form-listp)
               (event-alist symbol-pseudoeventform-alistp))
  :short "Generate the third of the specialized matching predicates."
  (b* ((cst-list-rep-matchp (deftreeops-rep-match-pred prefix))
       (cst-list-rep-matchp$ (add-suffix-to-fn cst-list-rep-matchp "$"))
       (cst-list-rep-matchp$-event
        `(define ,cst-list-rep-matchp$ ((trees tree-listp) (rep repetitionp))
           :returns (yes/no booleanp)
           (and (tree-list-terminatedp trees)
                (tree-list-match-repetition-p trees rep ,grammar))
           :hooks (:fix)))
       (cst-list-rep-matchp-event
        `(defmacro ,cst-list-rep-matchp (trees rep)
           (declare (xargs :guard (acl2::stringp rep)))
           (b* (((mv err rep rest)
                 (parse-repetition (string=>nats rep)))
                ((when err) (er hard ',cst-list-rep-matchp "~@0" err))
                ((when (consp rest))
                 (er hard ',cst-list-rep-matchp
                     "Extra: ~s0" (nats=>string rest)))
                (rep (abstract-repetition rep)))
             `(,',cst-list-rep-matchp$ ,trees ',rep))))
       (table-event
        `(table acl2::macro-aliases-table
           ',cst-list-rep-matchp
           ',cst-list-rep-matchp$))
       (print-event?
        (and (evmac-input-print->= print :result)
             `((cw-event "Function ~x0 and macro ~x1.~%"
                         ',cst-list-rep-matchp$
                         ',cst-list-rep-matchp)))))
    (mv (list* cst-list-rep-matchp$-event
               cst-list-rep-matchp-event
               table-event
               print-event?)
        (list (cons cst-list-rep-matchp$ cst-list-rep-matchp$-event)
              (cons cst-list-rep-matchp cst-list-rep-matchp-event)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-cst-list-list-conc-match ((grammar acl2::symbolp)
                                                 (prefix acl2::symbolp)
                                                 (print evmac-input-print-p))
  :returns (mv (events pseudo-event-form-listp)
               (event-alist symbol-pseudoeventform-alistp))
  :short "Generate the fourth of the specialized matching predicates."
  (b* ((cst-list-list-conc-matchp (deftreeops-conc-match-pred prefix))
       (cst-list-list-conc-matchp$
        (add-suffix-to-fn cst-list-list-conc-matchp "$"))
       (cst-list-list-conc-matchp$-event
        `(define ,cst-list-list-conc-matchp$ ((treess tree-list-listp)
                                              (conc concatenationp))
           :returns (yes/no booleanp)
           (and (tree-list-list-terminatedp treess)
                (tree-list-list-match-concatenation-p treess conc ,grammar))
           :hooks (:fix)))
       (cst-list-list-conc-matchp-event
        `(defmacro ,cst-list-list-conc-matchp (treess conc)
           (declare (xargs :guard (acl2::stringp conc)))
           (b* (((mv err conc rest)
                 (parse-concatenation (string=>nats conc)))
                ((when err) (er hard ',cst-list-list-conc-matchp "~@0" err))
                ((when (consp rest))
                 (er hard ',cst-list-list-conc-matchp
                     "Extra: ~s0" (nats=>string rest)))
                (conc (abstract-concatenation conc)))
             `(,',cst-list-list-conc-matchp$ ,treess ',conc))))
       (table-event
        `(table acl2::macro-aliases-table
           ',cst-list-list-conc-matchp
           ',cst-list-list-conc-matchp$))
       (print-event?
        (and (evmac-input-print->= print :result)
             `((cw-event "Function ~x0 and macro ~x1.~%"
                         ',cst-list-list-conc-matchp$
                         ',cst-list-list-conc-matchp)))))
    (mv (list* cst-list-list-conc-matchp$-event
               cst-list-list-conc-matchp-event
               table-event
               print-event?)
        (list
         (cons cst-list-list-conc-matchp$ cst-list-list-conc-matchp$-event)
         (cons cst-list-list-conc-matchp cst-list-list-conc-matchp-event)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-cst-list-list-alt-match ((grammar acl2::symbolp)
                                                (prefix acl2::symbolp)
                                                (print evmac-input-print-p))
  :returns (mv (events pseudo-event-form-listp)
               (event-alist symbol-pseudoeventform-alistp))
  :short "Generate the fifth of the specialized matching predicates."
  (b* ((cst-list-list-alt-matchp (deftreeops-alt-match-pred prefix))
       (cst-list-list-alt-matchp$
        (add-suffix-to-fn cst-list-list-alt-matchp "$"))
       (cst-list-list-alt-matchp$-event
        `(define ,cst-list-list-alt-matchp$ ((treess tree-list-listp)
                                             (alt alternationp))
           :returns (yes/no booleanp)
           (and (tree-list-list-terminatedp treess)
                (tree-list-list-match-alternation-p treess alt ,grammar))
           :hooks (:fix)))
       (cst-list-list-alt-matchp-event
        `(defmacro ,cst-list-list-alt-matchp (treess alt)
           (declare (xargs :guard (acl2::stringp alt)))
           (b* (((mv err alt rest)
                 (parse-alternation (string=>nats alt)))
                ((when err) (er hard ',cst-list-list-alt-matchp "~@0" err))
                ((when (consp rest))
                 (er hard ',cst-list-list-alt-matchp
                     "Extra: ~s0" (nats=>string rest)))
                (alt (abstract-alternation alt)))
             `(,',cst-list-list-alt-matchp$ ,treess ',alt))))
       (table-event
        `(table acl2::macro-aliases-table
           ',cst-list-list-alt-matchp
           ',cst-list-list-alt-matchp$))
       (print-event?
        (and (evmac-input-print->= print :result)
             `((cw-event "Function ~x0 and macro ~x1.~%"
                         ',cst-list-list-alt-matchp$
                         ',cst-list-list-alt-matchp)))))
    (mv (list* cst-list-list-alt-matchp$-event
               cst-list-list-alt-matchp-event
               table-event
               print-event?)
        (list (cons cst-list-list-alt-matchp$ cst-list-list-alt-matchp$-event)
              (cons cst-list-list-alt-matchp cst-list-list-alt-matchp-event)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-matchers ((grammar acl2::symbolp)
                                 (prefix acl2::symbolp)
                                 (print evmac-input-print-p))
  :returns (mv (events pseudo-event-form-listp)
               (event-alist symbol-pseudoeventform-alistp))
  :short "Generate the specialized matching predicates."
  (b* (((mv cst-match-events
            cst-match-event-alist)
        (deftreeops-gen-cst-match grammar prefix print))
       ((mv cst-list-elem-match-events
            cst-list-elem-match-event-alist)
        (deftreeops-gen-cst-list-elem-match grammar prefix print))
       ((mv cst-list-rep-match-events
            cst-list-rep-match-event-alist)
        (deftreeops-gen-cst-list-rep-match grammar prefix print))
       ((mv cst-list-list-conc-match-events
            cst-list-list-conc-match-event-alist)
        (deftreeops-gen-cst-list-list-conc-match grammar prefix print))
       ((mv cst-list-list-alt-match-events
            cst-list-list-alt-match-event-alist)
        (deftreeops-gen-cst-list-list-alt-match grammar prefix print)))
    (mv (append cst-match-events
                cst-list-elem-match-events
                cst-list-rep-match-events
                cst-list-list-conc-match-events
                cst-list-list-alt-match-events)
        (append cst-match-event-alist
                cst-list-elem-match-event-alist
                cst-list-rep-match-event-alist
                cst-list-list-conc-match-event-alist
                cst-list-list-alt-match-event-alist))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-discriminant-terms ((alt alternationp))
  :returns (mv (terms true-listp) (alt-kind natp))
  :short "Generate the terms to discriminate among
          two or more concatenations that form
          the alternation that defines a rule name."
  :long
  (xdoc::topstring
   (xdoc::p
    "These are the terms used in
     the @('<prefix>-<rulename>-conc-equivs') theorem
     described in @(tsee deftreeops).")
   (xdoc::p
    "For now we only support alternations of the forms
     listed in the description of @('<prefix>-<rulename>-conc-equivs')
     in @(tsee deftreeops).
     The @('alt-kind') result of this function indicates which one,
     as a positive integer in the same order as listed,
     or it is 0 if the alternation is a singleton
     or does not have a supported form,
     i.e. if there is no need to indicate the supported form.")
   (xdoc::p
    "If the alternation does not have a supported form,
     we return @('nil') as the @('terms') result;
     otherwise, we return a list of terms,
     of the same length as the alternation.
     Recall that @(tsee deftreeops) requires the grammar to be well-formed,
     and that well-formed grammars have non-empty alternations:
     so the @('terms') result cannot be @('nil')
     if the alternation is supported.")
   (xdoc::p
    "If the alternation is a singleton,
     we return a singleton list consisting of the term @('t'),
     which makes sense since the concatenation must be always that only one.
     Otherwise, we check for different forms of the two or more alternatives:")
   (xdoc::ul
    (xdoc::li
     "If the alternation consists of two or more concatenations
      each of which is a singleton,
      each consisting of a repetition with range 1
      whose element is a rule name:
      then we return two or more terms,
      each of which checks whether the one subtree
      has the corresponding rule name as root.")
    (xdoc::li
     "If the alternation consists of exactly two concatenations,
      one of which is a singleton of a repetition with range 1
      whose element is numeric or character value notation,
      and the other is a singleton of a repetition with range 1
      whose element is a rule name:
      then we return two terms,
      one that checks whether the one subtree is a terminal leaf
      (for the numeric or character value notation case),
      and the other that checks whether the one subtree is a non-leaf
      (for the other case).")))
  (b* (((when (endp alt)) (mv nil 0)) ; never happens
       ((when (endp (cdr alt))) (mv (list t) 0))
       (terms? (deftreeops-gen-discriminant-terms-aux1 alt))
       ((when terms?) (mv terms? 1))
       (terms? (deftreeops-gen-discriminant-terms-aux2 alt))
       ((when terms?) (mv terms? 2)))
    (mv nil 0))

  :prepwork

  ((define deftreeops-gen-discriminant-terms-aux1 ((alt alternationp))
     :guard (consp alt)
     :returns (terms true-listp)
     :parents nil
     (b* ((conc (car alt))
          ((unless (and (consp conc)
                        (endp (cdr conc))))
           nil)
          (rep (car conc))
          ((unless (equal (repetition->range rep)
                          (make-repeat-range :min 1
                                             :max (nati-finite 1))))
           nil)
          (elem (repetition->element rep))
          ((unless (element-case elem :rulename))
           nil)
          (rulename (element-rulename->get elem))
          (term `(equal (tree-nonleaf->rulename?
                         (nth 0 (nth 0 (tree-nonleaf->branches cst))))
                        (rulename ,(rulename->get rulename))))
          (alt (cdr alt))
          ((when (endp alt)) (list term))
          (terms (deftreeops-gen-discriminant-terms-aux1 alt))
          ((unless terms) nil))
       (cons term terms))
     ///

     (defret len-of-deftreeops-gen-discriminant-terms-aux1
       (implies terms
                (equal (len terms)
                       (len alt)))))

   (define deftreeops-gen-discriminant-terms-aux2 ((alt alternationp))
     :guard (and (consp alt)
                 (consp (cdr alt)))
     :returns (terms true-listp)
     :parents nil
     (b* (((unless (endp (cddr alt))) nil)
          (conc1 (car alt))
          (conc2 (cadr alt))
          ((unless (and (consp conc1)
                        (consp conc2)
                        (endp (cdr conc1))
                        (endp (cdr conc2))))
           nil)
          (rep1 (car conc1))
          (rep2 (car conc2))
          ((unless (and (equal (repetition->range rep1)
                               (make-repeat-range :min 1
                                                  :max (nati-finite 1)))
                        (equal (repetition->range rep2)
                               (make-repeat-range :min 1
                                                  :max (nati-finite 1)))))
           nil)
          (elem1 (repetition->element rep1))
          (elem2 (repetition->element rep2)))
       (cond ((and (element-case elem1 :rulename)
                   (element-case elem2 :char-val))
              (list `(tree-case
                      (nth 0 (nth 0 (tree-nonleaf->branches cst)))
                      :nonleaf)
                    `(tree-case
                      (nth 0 (nth 0 (tree-nonleaf->branches cst)))
                      :leafterm)))
             ((and (element-case elem1 :char-val)
                   (element-case elem2 :rulename))
              (list `(tree-case
                      (nth 0 (nth 0 (tree-nonleaf->branches cst)))
                      :leafterm)
                    `(tree-case
                      (nth 0 (nth 0 (tree-nonleaf->branches cst)))
                      :nonleaf)))
             (t nil)))
     ///

     (defret len-of-deftreeops-gen-discriminant-terms-aux2
       (implies terms
                (equal (len terms)
                       (len alt))))))

  ///

  (defret len-of-deftreeops-gen-discriminant-terms
    (implies terms
             (equal (len terms)
                    (len alt)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-rep-info
  ((rep repetitionp)
   (i posp "Indentifies the concatenation that this repetition is part of,
            starting from 1.")
   (check-conc-fn acl2::symbolp
                  "The @('check-conc-fn') component of
                   @(tsee deftreeops-rulename-info).")
   (alt-singletonp booleanp "Whether the alternation that defines the rule name
                             consists of a single concatenation or not.")
   (rulename-upstring acl2::stringp "Rule name normalized in uppercase.")
   (prefix acl2::symbolp))
  :returns (info deftreeops-rep-infop)
  :short "Generate the information for
          a repetition in a concatenation in
          the alternation that defines a rule name."
  (b* ((matching-thm
        (and (equal (repetition->range rep)
                    (make-repeat-range :min 1 :max (nati-finite 1)))
             (if alt-singletonp
                 (packn-pos (list prefix
                                  '-
                                  rulename-upstring
                                  '-conc-rep-matching)
                            prefix)
               (packn-pos (list prefix
                                '-
                                rulename-upstring
                                '-conc
                                i
                                '-rep-matching)
                          prefix))))
       (get-tree-list-fn
        (and (equal (repetition->range rep)
                    (make-repeat-range :min 1 :max (nati-finite 1)))
             (if alt-singletonp
                 (packn-pos (list prefix
                                  '-
                                  rulename-upstring
                                  '-conc-rep)
                            prefix)
               (and check-conc-fn
                    (packn-pos (list prefix
                                     '-
                                     rulename-upstring
                                     '-conc
                                     i
                                     '-rep)
                               prefix)))))
       (get-tree-fn
        (and get-tree-list-fn
             (or alt-singletonp
                 (element-case (repetition->element rep) :rulename))
             (packn-pos (list get-tree-list-fn '-elem) get-tree-list-fn))))
    (make-deftreeops-rep-info :get-tree-list-fn get-tree-list-fn
                              :matching-thm matching-thm
                              :get-len-fn nil
                              :get-tree-fn get-tree-fn)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-rep-info-list
  ((conc concatenationp)
   (i posp)
   (check-conc-fn acl2::symbolp
                  "The @('check-conc-fn') component of
                   @(tsee deftreeops-rulename-info).")
   (alt-singletonp booleanp)
   (rulename-upstring acl2::stringp)
   (prefix acl2::symbolp))
  :returns (infos deftreeops-rep-info-listp)
  :short "Lift @(tsee deftreeops-gen-rep-info) to
          lists of repetitions, i.e. to concatenations."
  (b* (((when (endp conc)) nil)
       (info (deftreeops-gen-rep-info
               (car conc) i check-conc-fn alt-singletonp
               rulename-upstring prefix))
       (more-info (deftreeops-gen-rep-info-list
                    (cdr conc) i check-conc-fn alt-singletonp
                    rulename-upstring prefix)))
    (cons info more-info)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-conc-info
  ((conc concatenationp)
   (i posp "Indentifies the concatenation, starting from 1.")
   (discriminant-term "The discriminant term for the concatenation.")
   (check-conc-fn acl2::symbolp
                  "The @('check-conc-fn') component of
                   @(tsee deftreeops-rulename-info).")
   (alt-singletonp booleanp "Whether the alternation that defines the rule name
                             consists of a single concatenation or not.")
   (rulename-upstring acl2::stringp "Rule name normalized in uppercase.")
   (prefix acl2::symbolp))
  :returns (info deftreeops-conc-infop)
  :short "Generate the information for a concatenation in
          the alternation that defines a rule name."
  (b* ((conc-singletonp (and (consp conc)
                             (not (consp (cdr conc)))))
       (matching-thm
        (and conc-singletonp
             (if alt-singletonp
                 (packn-pos (list prefix '- rulename-upstring '-conc-matching)
                            prefix)
               (packn-pos (list prefix '- rulename-upstring '-conc i '-matching)
                          prefix))))
       (check-conc-fn-equiv-thm
        (and check-conc-fn
             (packn-pos (list check-conc-fn '- i '-iff-match-conc)
                        check-conc-fn)))
       (get-tree-list-list-fn
        (if alt-singletonp
            (packn-pos (list prefix '- rulename-upstring '-conc)
                       prefix)
          (and check-conc-fn
               (packn-pos (list prefix '- rulename-upstring '-conc i)
                          prefix))))
       (rep-infos
        (and conc-singletonp
             (deftreeops-gen-rep-info-list
               conc i check-conc-fn alt-singletonp rulename-upstring prefix)))
       (info (make-deftreeops-conc-info
              :conc conc
              :discriminant-term discriminant-term
              :check-conc-fn-equiv-thm check-conc-fn-equiv-thm
              :get-tree-list-list-fn get-tree-list-list-fn
              :matching-thm matching-thm
              :rep-infos rep-infos)))
    info))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-conc-info-list
  ((alt alternationp)
   (discriminant-terms-or-nils "A list of terms.")
   (check-conc-fn acl2::symbolp
                  "The @('check-conc-fn') component of
                   @(tsee deftreeops-rulename-info).")
   (alt-singletonp booleanp "Whether the alternation that defines the rule name
                             consists of a single concatenation or not.")
   (rulename-upstring acl2::stringp)
   (prefix acl2::symbolp))
  :guard (equal (len discriminant-terms-or-nils) (len alt))
  :returns (infos deftreeops-conc-info-listp)
  :short "Lift @(tsee deftreeops-gen-conc-info)
          to lists of concatenations, i.e. to alternations."
  (deftreeops-gen-conc-info-list-aux
    alt 1 discriminant-terms-or-nils check-conc-fn alt-singletonp
    rulename-upstring prefix)

  :prepwork
  ((define deftreeops-gen-conc-info-list-aux
     ((alt alternationp)
      (i posp)
      (discriminant-terms-or-nils "A list of terms.")
      (check-conc-fn acl2::symbolp)
      (alt-singletonp booleanp)
      (rulename-upstring acl2::stringp)
      (prefix acl2::symbolp))
     :guard (equal (len discriminant-terms-or-nils) (len alt))
     :returns (infos deftreeops-conc-info-listp)
     :parents nil
     (b* (((when (endp alt)) nil)
          (info
           (deftreeops-gen-conc-info
             (car alt)
             i
             (car discriminant-terms-or-nils)
             check-conc-fn
             alt-singletonp
             rulename-upstring
             prefix))
          (more-info
           (deftreeops-gen-conc-info-list-aux
             (cdr alt)
             (1+ i)
             (cdr discriminant-terms-or-nils)
             check-conc-fn
             alt-singletonp
             rulename-upstring
             prefix)))
       (cons info more-info)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-rulename-info
  ((rulename rulenamep)
   (alt alternationp "The alternation that define @('rulename').")
   (prefix acl2::symbolp))
  :returns (info deftreeops-rulename-infop)
  :short "Generate the information for a rule name."
  (b* ((rulename-string (rulename->get rulename))
       (rulename-upstring (str::upcase-string rulename-string))
       (nonleaf-thm
        (packn-pos (list prefix '- rulename-upstring '-nonleaf)
                   prefix))
       (rulename-thm
        (packn-pos (list prefix '- rulename-upstring '-rulename)
                   prefix))
       (match-thm
        (packn-pos (list prefix '- rulename-upstring '-branches-match-alt)
                   prefix))
       (concs-thm
        (packn-pos (list prefix '- rulename-upstring '-concs)
                   prefix))
       ((mv terms alt-kind) (deftreeops-gen-discriminant-terms alt))
       (terms-or-nils (or terms
                          (repeat (len alt) nil)))
       (alt-singletonp (and (consp alt)
                            (endp (cdr alt))))
       (conc-equivs-thm
        (and (not alt-singletonp)
             terms
             (packn-pos (list prefix '- rulename-upstring '-conc-equivs)
                        prefix)))
       (check-conc-fn
        (and (not alt-singletonp)
             terms
             (= alt-kind 1) ; temporary
             (packn-pos (list prefix '- rulename-upstring '-conc?)
                        prefix)))
       (conc-infos (deftreeops-gen-conc-info-list
                     alt terms-or-nils check-conc-fn alt-singletonp
                     rulename-upstring prefix))
       (info (make-deftreeops-rulename-info
              :alt alt
              :nonleaf-thm nonleaf-thm
              :rulename-thm rulename-thm
              :match-thm match-thm
              :concs-thm concs-thm
              :conc-equivs-thm conc-equivs-thm
              :alt-kind alt-kind
              :check-conc-fn check-conc-fn
              :conc-infos conc-infos)))
    info))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-rulename-info-alist
  ((rules rulelistp)
   (prefix acl2::symbolp))
  :returns (info deftreeops-rulename-info-alistp)
  :short "Generate the alist from rule names to rule name information,
          from a list of rules."
  :long
  (xdoc::topstring
   (xdoc::p
    "Note that we generate an alist entry for each rule name, not rule:
     each rule name may be defined by multiple rules
     (the ones after the first incremental ones, in well-formed grammars),
     so we keep track of which rule names we have encountered already,
     so we can skip them when encountered again;
     when encountered the first time,
     we obtain its defining alternation (via @(tsee lookup-rulename))
     and use it to generate the alist entry.")
   (xdoc::p
    "The generated alist has unique keys."))
  (deftreeops-gen-rulename-info-alist-aux rules nil prefix)

  :prepwork
  ((define deftreeops-gen-rulename-info-alist-aux
     ((rules rulelistp)
      (done rulename-listp)
      (prefix acl2::symbolp))
     :returns (info deftreeops-rulename-info-alistp)
     :parents nil
     (b* (((when (endp rules)) nil)
          (rule (car rules))
          (rulename (rule->name rule))
          ((when (member-equal rulename done))
           (deftreeops-gen-rulename-info-alist-aux (cdr rules) done prefix))
          (alt (lookup-rulename rulename rules))
          (info (deftreeops-gen-rulename-info rulename alt prefix))
          (more-info (deftreeops-gen-rulename-info-alist-aux
                       (cdr rules) (cons rulename done) prefix)))
       (acons rulename info more-info))
     :verify-guards :after-returns)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-numrange-info ((range num-range-p)
                                      (prefix acl2::symbolp))
  :returns (info deftreeops-numrange-infop)
  :short "Generate the information for a numeric range."
  (b* (((num-range range) range)
       (range-part-of-name
        (num-base-case
         range.base
         :dec (str::cat "%D"
                        (str::nat-to-dec-string range.min)
                        "-"
                        (str::nat-to-dec-string range.max))
         :hex (str::cat "%X"
                        (str::nat-to-hex-string range.min)
                        "-"
                        (str::nat-to-hex-string range.max))
         :bin (str::cat "%B"
                        (str::nat-to-bin-string range.min)
                        "-"
                        (str::nat-to-bin-string range.max))))
       (get-nat-fn (packn-pos (list prefix '- range-part-of-name '-nat)
                              prefix))
       (bounds-thm (packn-pos (list get-nat-fn '-bounds)
                              prefix)))
    (make-deftreeops-numrange-info
     :get-nat-fn get-nat-fn
     :bounds-thm bounds-thm)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-numrange-info-alist ((rules rulelistp)
                                            (prefix acl2::symbolp))
  :returns (infos deftreeops-numrange-info-alistp)
  :short "Generate the alist from numeric ranges to numeric range information,
          from a list of rules."
  :long
  (xdoc::topstring
   (xdoc::p
    "We obtain the set of numeric ranges from the rules,
     and then we generate an alist from the set."))
  (deftreeops-gen-numrange-info-alist-aux
    (rulelist-num-ranges rules) prefix)

  :prepwork
  ((define deftreeops-gen-numrange-info-alist-aux ((ranges num-range-setp)
                                                   (prefix acl2::symbolp))
     :returns (infos deftreeops-numrange-info-alistp
                     :hyp (num-range-setp ranges))
     :parents nil
     (b* (((when (set::emptyp ranges)) nil)
          (range (set::head ranges))
          (info (deftreeops-gen-numrange-info range prefix))
          (infos (deftreeops-gen-numrange-info-alist-aux
                   (set::tail ranges) prefix)))
       (acons range info infos))
     :verify-guards :after-returns)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-charval-info ((charval char-val-p)
                                     (prefix acl2::symbolp))
  :returns (info deftreeops-charval-infop)
  :short "Generate the information for a character value notation."
  (b* ((leafterm-thm (packn-pos (list prefix
                                      '-
                                      (pretty-print-char-val charval)
                                      '-leafterm)
                                prefix)))
    (make-deftreeops-charval-info
     :leafterm-thm leafterm-thm)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-charval-info-alist ((rules rulelistp)
                                           (prefix acl2::symbolp))
  :returns (infos deftreeops-charval-info-alistp)
  :short "Generate the alist from character value notation
          to character value notation information
          from a list of rules."
  :long
  (xdoc::topstring
   (xdoc::p
    "We obtain the set of character value notations from the rules,
     and then we generate an alist from the set."))
  (deftreeops-gen-charval-info-alist-aux
    (rulelist-char-vals rules) prefix)

  :prepwork
  ((define deftreeops-gen-charval-info-alist-aux ((charvals char-val-setp)
                                                  (prefix acl2::symbolp))
     :returns (info deftreeops-charval-info-alistp
                    :hyp (char-val-setp charvals))
     :parents nil
     (b* (((when (set::emptyp charvals)) nil)
          (charval (set::head charvals))
          (info (deftreeops-gen-charval-info charval prefix))
          (infos (deftreeops-gen-charval-info-alist-aux
                   (set::tail charvals) prefix)))
       (acons charval info infos))
     :verify-guards :after-returns)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-rep-events
  ((rep repetitionp)
   (info deftreeops-rep-infop)
   (i posp "Index of the concatenation that this repetition is part of.")
   (get-tree-list-list-fn acl2::symbolp
                          "The function @('<prefix>-<rulename>-conc')
                           or @('<prefix>-<rulename>-conc<i>')
                           described in @(tsee deftreeops).")
   (get-tree-list-list-fn-match-thm acl2::symbolp
                                    "The theorem saying that
                                     @('get-tree-list-list-fn'))
                                     matches the concatenation.")
   (conc-matching-thm acl2::symbolp)
   (check-conc-fn acl2::symbolp)
   (rulename rulenamep)
   (prefix acl2::symbolp)
   (print evmac-input-print-p))
  :returns (mv (matching-thm-events pseudo-event-form-listp)
               (get-tree-list-fn-events pseudo-event-form-listp)
               (get-tree-fn-events pseudo-event-form-listp)
               (event-alist symbol-pseudoeventform-alistp))
  :short "Generate the functions and theorems for
          a repetition in a concatenation in
          the alternation that defines a rule name."
  (b* (((deftreeops-rep-info info) info)
       (matchp (deftreeops-match-pred prefix))
       (rep-matchp (deftreeops-rep-match-pred prefix))
       (rulename-string (rulename->get rulename))
       (elem (repetition->element rep))
       (matching-thm-event?
        (and info.matching-thm
             `((defruled ,info.matching-thm
                 (implies (,rep-matchp csts
                                       ,(pretty-print-repetition rep))
                          (and (equal (len csts) 1)
                               (,matchp (nth 0 csts)
                                        ,(pretty-print-element elem))))
                 :in-theory
                 '(,rep-matchp
                   ,matchp
                   tree-list-match-repetition-p-of-1-repetition
                   tree-terminatedp-of-car-when-tree-list-terminatedp
                   (:e nati-finite)
                   (:e repeat-range)
                   (:e repetition->element)
                   (:e repetition->range)
                   nth
                   (:e zp)
                   len)))))
       (matching-thm-events
        (and matching-thm-event?
             (append matching-thm-event?
                     (and (evmac-input-print->= print :result)
                          `((cw-event "Theorem ~x0.~%"
                                      ',info.matching-thm))))))
       (get-tree-list-fn-match-thm
        (packn-pos (list info.get-tree-list-fn '-match)
                   info.get-tree-list-fn))
       (get-tree-list-fn-event?
        (and
         info.get-tree-list-fn
         `((define ,info.get-tree-list-fn ((cst treep))
             :guard ,(if check-conc-fn
                         `(and (,matchp cst ,rulename-string)
                               (equal (,check-conc-fn cst) ,i))
                       `(,matchp cst ,rulename-string))
             :returns (csts tree-listp
                            :hints
                            (("Goal"
                              :in-theory
                              '(,info.get-tree-list-fn
                                return-type-of-tree-list-fix.newx))))
             (tree-list-fix (nth 0 (,get-tree-list-list-fn cst)))
             :prepwork ((local (in-theory nil)))
             :guard-hints
             (("Goal"
               :in-theory
               '((:e elementp)
                 (:t ,get-tree-list-list-fn)
                 tree-listp-of-nth-when-tree-list-listp
                 ,(packn-pos (list 'tree-list-listp-of-
                                   get-tree-list-list-fn)
                             get-tree-list-list-fn)
                 (:e nfix))
               :use (,get-tree-list-list-fn-match-thm
                     (:instance ,conc-matching-thm
                                (cstss (,get-tree-list-list-fn cst))))))
             ///
             (more-returns
              (csts (,rep-matchp csts
                                 ,(pretty-print-repetition rep))
                    :hyp ,(if check-conc-fn
                              `(and (,matchp cst ,rulename-string)
                                    (equal (,check-conc-fn cst) ,i))
                            `(,matchp cst ,rulename-string))
                    :name ,get-tree-list-fn-match-thm
                    :hints
                    (("Goal"
                      :in-theory '(,info.get-tree-list-fn
                                   tree-list-fix-when-tree-listp
                                   tree-listp-of-nth-when-tree-list-listp
                                   (:e nfix)
                                   ,(packn-pos (list 'tree-list-listp-of-
                                                     get-tree-list-list-fn)
                                               get-tree-list-list-fn))
                      :use ((:instance ,get-tree-list-list-fn-match-thm
                                       (cst cst))
                            (:instance ,conc-matching-thm
                                       (cstss
                                        (,get-tree-list-list-fn cst))))))))
             (fty::deffixequiv ,info.get-tree-list-fn
               :hints (("Goal"
                        :in-theory '(,info.get-tree-list-fn
                                     ,(packn-pos (list get-tree-list-list-fn
                                                       '-of-tree-fix-cst)
                                                 get-tree-list-list-fn)))))))))
       (get-tree-list-fn-events
        (and get-tree-list-fn-event?
             (append get-tree-list-fn-event?
                     (and (evmac-input-print->= print :result)
                          `((cw-event "Function ~x0.~%"
                                      ',info.get-tree-list-fn))))))
       (get-tree-fn-event?
        (and
         info.get-tree-fn
         `((define ,info.get-tree-fn ((cst treep))
             :guard ,(if check-conc-fn
                         `(and (,matchp cst ,rulename-string)
                               (equal (,check-conc-fn cst) ,i))
                       `(,matchp cst ,rulename-string))
             :returns (cst1 treep
                            :hints
                            (("Goal"
                              :in-theory
                              '(,info.get-tree-fn
                                return-type-of-tree-fix.new-x))))
             (tree-fix (nth 0 (,info.get-tree-list-fn cst)))
             :prepwork ((local (in-theory nil)))
             :guard-hints
             (("Goal"
               :in-theory '((:e elementp)
                            (:t ,info.get-tree-list-fn)
                            treep-of-nth-when-tree-listp
                            ,(packn-pos (list 'tree-listp-of-
                                              info.get-tree-list-fn)
                                        info.get-tree-list-fn)
                            (:e nfix))
               :use (,get-tree-list-fn-match-thm
                     (:instance ,info.matching-thm
                                (csts (,info.get-tree-list-fn cst))))))
             ///
             (more-returns
              (cst1 (,matchp cst1 ,(pretty-print-element elem))
                    :hyp ,(if check-conc-fn
                              `(and (,matchp cst ,rulename-string)
                                    (equal (,check-conc-fn cst) ,i))
                            `(,matchp cst ,rulename-string))
                    :name ,(packn-pos (list info.get-tree-fn '-match)
                                      info.get-tree-fn)
                    :hints
                    (("Goal"
                      :in-theory '(,info.get-tree-fn
                                   tree-fix-when-treep
                                   treep-of-nth-when-tree-listp
                                   (:e nfix)
                                   ,(packn-pos (list 'tree-listp-of-
                                                     info.get-tree-list-fn)
                                               info.get-tree-list-fn))
                      :use (,get-tree-list-fn-match-thm
                            (:instance ,info.matching-thm
                                       (csts (,info.get-tree-list-fn cst))))))))
             (fty::deffixequiv ,info.get-tree-fn
               :hints (("Goal"
                        :in-theory '(,info.get-tree-fn
                                     ,(packn-pos (list info.get-tree-list-fn
                                                       '-of-tree-fix-cst)
                                                 info.get-tree-list-fn)))))))))
       (get-tree-fn-events
        (and get-tree-fn-event?
             (append get-tree-fn-event?
                     (and (evmac-input-print->= print :result)
                          `((cw-event "Function ~x0.~%"
                                      ',info.get-tree-fn)))))))
    (mv matching-thm-events
        get-tree-list-fn-events
        get-tree-fn-events
        (append (and matching-thm-event?
                     (list (cons info.matching-thm
                                 (car matching-thm-event?))))
                (and get-tree-list-fn-event?
                     (list (cons info.get-tree-list-fn
                                 (car get-tree-list-fn-event?))))
                (and get-tree-fn-event?
                     (list (cons info.get-tree-fn
                                 (car get-tree-fn-event?))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-rep-list-events
  ((conc concatenationp)
   (infos deftreeops-rep-info-listp)
   (i posp "Index of the concatenation that this repetition is part of.")
   (get-tree-list-list-fn acl2::symbolp
                          "The function @('<prefix>-<rulename>-conc')
                           or @('<prefix>-<rulename>-conc<i>')
                           described in @(tsee deftreeops).")
   (get-tree-list-list-fn-match-thm acl2::symbolp
                                    "The theorem saying that
                                     @('get-tree-list-list-fn'))
                                     matches the concatenation.")
   (conc-matching-thm acl2::symbolp)
   (check-conc-fn acl2::symbolp)
   (rulename rulenamep)
   (prefix acl2::symbolp)
   (print evmac-input-print-p))
  :guard (equal (len infos) (len conc))
  :returns (mv (matching-thm-events pseudo-event-form-listp)
               (get-tree-list-fn-events pseudo-event-form-listp)
               (get-tree-fn-events pseudo-event-form-listp)
               (event-alist symbol-pseudoeventform-alistp))
  :short "Lift @(tsee deftreeops-gen-rep-events) to lists."
  (b* (((when (endp conc)) (mv nil nil nil nil))
       ((mv matching-thm-events
            get-tree-list-fn-events
            get-tree-fn-events
            event-alist)
        (deftreeops-gen-rep-events
          (car conc)
          (car infos)
          i
          get-tree-list-list-fn
          get-tree-list-list-fn-match-thm
          conc-matching-thm
          check-conc-fn
          rulename
          prefix
          print))
       ((mv more-matching-thm-events
            more-get-tree-list-fn-events
            more-get-tree-fn-events
            more-event-alist)
        (deftreeops-gen-rep-list-events
          (cdr conc)
          (cdr infos)
          i
          get-tree-list-list-fn
          get-tree-list-list-fn-match-thm
          conc-matching-thm
          check-conc-fn
          rulename
          prefix
          print)))
    (mv (append matching-thm-events more-matching-thm-events)
        (append get-tree-list-fn-events more-get-tree-list-fn-events)
        (append get-tree-fn-events more-get-tree-fn-events)
        (append event-alist more-event-alist))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-conc-events ((conc concatenationp)
                                    (info deftreeops-conc-infop)
                                    (i posp)
                                    (conc-equivs-thm acl2::symbolp)
                                    (check-conc-fn acl2::symbolp)
                                    (nonleaf-thm acl2::symbolp)
                                    (alt-match-thm acl2::symbolp)
                                    (alt-singletonp booleanp)
                                    (rulename rulenamep)
                                    (prefix acl2::symbolp)
                                    (print evmac-input-print-p))
  :returns (mv (matching-thm-events pseudo-event-form-listp)
               (check-conc-fn-equiv-thm-events pseudo-event-form-listp)
               (get-tree-list-list-fn-events pseudo-event-form-listp)
               (rep-matching-thm-events pseudo-event-form-listp)
               (get-tree-list-fn-events pseudo-event-form-listp)
               (get-tree-fn-events pseudo-event-form-listp)
               (event-alist symbol-pseudoeventform-alistp))
  :short "Generate the functions and theorems for a concatenation in
          the alternation that defines a rule name."
  (b* (((deftreeops-conc-info info) info)
       (matchp (deftreeops-match-pred prefix))
       (alt-matchp (deftreeops-alt-match-pred prefix))
       (conc-matchp (deftreeops-conc-match-pred prefix))
       (rep-matchp (deftreeops-rep-match-pred prefix))
       (rulename-string (rulename->get rulename))
       (matching-thm-event?
        (and
         info.matching-thm
         (b* (((unless (consp conc))
               (raise "Internal error: empty concatenation."))
              (rep (car conc)))
           `((defruled ,info.matching-thm
               (implies (,conc-matchp cstss
                                      ,(pretty-print-concatenation conc))
                        (and (equal (len cstss) 1)
                             (,rep-matchp (nth 0 cstss)
                                          ,(pretty-print-repetition rep))))
               :in-theory
               '(,conc-matchp
                 ,rep-matchp
                 tree-list-list-match-concatenation-p-when-atom-concatenation
                 tree-list-list-match-concatenation-p-of-cons-concatenation
                 tree-list-terminatedp-of-car-when-tree-list-list-terminatedp
                 nth
                 (:e zp)
                 len))))))
       (matching-thm-events
        (and matching-thm-event?
             (append matching-thm-event?
                     (and (evmac-input-print->= print :result)
                          `((cw-event "Theorem ~x0.~%"
                                      ',info.matching-thm))))))
       (check-conc-fn-equiv-thm-event?
        (and
         info.check-conc-fn-equiv-thm
         `((defruled ,info.check-conc-fn-equiv-thm
             (implies (,matchp cst ,rulename-string)
                      (iff (equal (,check-conc-fn cst) ,i)
                           (,conc-matchp
                            (tree-nonleaf->branches cst)
                            ,(pretty-print-concatenation info.conc))))
             :in-theory
             '(,(packn-pos (list check-conc-fn '-tree-equiv-congruence-on-cst)
                           check-conc-fn)
               ,(packn-pos (list matchp '$-tree-equiv-congruence-on-tree)
                           matchp)
               tree-nonleaf->branches$inline-tree-equiv-congruence-on-x
               return-type-of-tree-fix.new-x
               tree-fix-under-tree-equiv)
             :use (:instance lemma (cst (tree-fix cst)))
             :prep-lemmas
             ((defrule lemma
                (implies (and (treep cst)
                              (,matchp cst ,rulename-string))
                         (iff (equal (,check-conc-fn cst) ,i)
                              (,conc-matchp
                               (tree-nonleaf->branches cst)
                               ,(pretty-print-concatenation info.conc))))
                :in-theory '(,check-conc-fn
                             ,conc-equivs-thm
                             (:e rulename))
                :use (:guard-theorem ,check-conc-fn)))))))
       (check-conc-fn-equiv-thm-events
        (and check-conc-fn-equiv-thm-event?
             (append check-conc-fn-equiv-thm-event?
                     (and (evmac-input-print->= print :result)
                          `((cw-event "Theorem ~x0.~%"
                                      ',info.check-conc-fn-equiv-thm))))))
       (get-tree-list-list-fn-match-thm
        (packn-pos (list info.get-tree-list-list-fn '-match)
                   info.get-tree-list-list-fn))
       (get-tree-list-list-fn-event?
        (and
         (or alt-singletonp
             check-conc-fn)
         `((define ,info.get-tree-list-list-fn ((cst treep))
             :guard ,(if check-conc-fn
                         `(and (,matchp cst ,rulename-string)
                               (equal (,check-conc-fn cst) ,i))
                       `(,matchp cst ,rulename-string))
             :returns (cstss tree-list-listp
                             :hints
                             (("Goal"
                               :in-theory
                               '(,info.get-tree-list-list-fn
                                 tree-list-listp-of-tree-nonleaf->branches))))
             (tree-nonleaf->branches cst)
             :prepwork ((local (in-theory nil)))
             :guard-hints (("Goal" :in-theory '((:e elementp)
                                                ,nonleaf-thm)))
             ///
             (more-returns
              (cstss
               (,conc-matchp cstss
                             ,(pretty-print-concatenation info.conc))
               :hyp ,(if check-conc-fn
                         `(and (,matchp cst ,rulename-string)
                               (equal (,check-conc-fn cst) ,i))
                       `(,matchp cst ,rulename-string))
               :name ,get-tree-list-list-fn-match-thm
               :hints
               ,(if check-conc-fn
                    `(("Goal"
                       :in-theory
                       '(,info.get-tree-list-list-fn
                         ,info.check-conc-fn-equiv-thm)))
                  `(("Goal"
                     :in-theory
                     '(,info.get-tree-list-list-fn
                       ,alt-matchp
                       ,conc-matchp
                       tree-list-list-match-alternation-p-when-atom-alternation
                       tree-list-list-match-alternation-p-of-cons-alternation)
                     :use ,alt-match-thm)))))
             (fty::deffixequiv ,info.get-tree-list-list-fn
               :hints
               (("Goal"
                 :in-theory
                 '(,info.get-tree-list-list-fn
                   tree-nonleaf->branches$inline-tree-equiv-congruence-on-x
                   tree-fix-under-tree-equiv))))))))
       (get-tree-list-list-fn-events
        (and get-tree-list-list-fn-event?
             (append get-tree-list-list-fn-event?
                     (and (evmac-input-print->= print :result)
                          `((cw-event "Function ~x0.~%"
                                      ',info.get-tree-list-list-fn))))))
       (conc-singletonp (and (consp conc)
                             (not (consp (cdr conc)))))
       ((unless (or (not conc-singletonp)
                    (= (len info.rep-infos) (len conc))))
        (raise "Internal error: length of ~x0 differs from length of ~x1."
               info.rep-infos conc)
        (mv nil nil nil nil nil nil nil))
       ((mv rep-matching-thm-events
            get-tree-list-fn-events
            get-tree-fn-events
            event-alist)
        (if conc-singletonp
            (deftreeops-gen-rep-list-events
              conc
              info.rep-infos
              i
              info.get-tree-list-list-fn
              get-tree-list-list-fn-match-thm
              info.matching-thm
              check-conc-fn
              rulename
              prefix
              print)
          (mv nil nil nil nil))))
    (mv matching-thm-events
        check-conc-fn-equiv-thm-events
        get-tree-list-list-fn-events
        rep-matching-thm-events
        get-tree-list-fn-events
        get-tree-fn-events
        (append event-alist
                (and matching-thm-event?
                     (list (cons info.matching-thm
                                 (car matching-thm-event?))))
                (and check-conc-fn-equiv-thm-event?
                     (list (cons info.check-conc-fn-equiv-thm
                                 (car check-conc-fn-equiv-thm-event?))))
                (and get-tree-list-list-fn-event?
                     (list (cons info.get-tree-list-list-fn
                                 (car get-tree-list-list-fn-event?))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-conc-list-events ((alt alternationp)
                                         (infos deftreeops-conc-info-listp)
                                         (conc-equivs-thm acl2::symbolp)
                                         (check-conc-fn acl2::symbolp)
                                         (nonleaf-thm acl2::symbolp)
                                         (alt-match-thm acl2::symbolp)
                                         (alt-singletonp booleanp)
                                         (rulename rulenamep)
                                         (prefix acl2::symbolp)
                                         (print evmac-input-print-p))
  :guard (equal (len infos) (len alt))
  :returns (mv (matching-thm-events pseudo-event-form-listp)
               (check-conc-fn-equiv-thm-events pseudo-event-form-listp)
               (get-tree-list-list-fn-events pseudo-event-form-listp)
               (rep-matching-thmevents pseudo-event-form-listp)
               (get-tree-list-fn-events pseudo-event-form-listp)
               (get-tree-fn-events pseudo-event-form-listp)
               (event-alist symbol-pseudoeventform-alistp))
  :short "Lift @(tsee deftreeops-gen-conc-events) to lists."
  (deftreeops-gen-conc-list-events-aux
    alt infos 1
    conc-equivs-thm check-conc-fn nonleaf-thm alt-match-thm
    alt-singletonp rulename prefix print)

  :prepwork
  ((define deftreeops-gen-conc-list-events-aux
     ((alt alternationp)
      (infos deftreeops-conc-info-listp)
      (i posp)
      (conc-equivs-thm acl2::symbolp)
      (check-conc-fn acl2::symbolp)
      (nonleaf-thm acl2::symbolp)
      (alt-match-thm acl2::symbolp)
      (alt-singletonp booleanp)
      (rulename rulenamep)
      (prefix acl2::symbolp)
      (print evmac-input-print-p))
     :guard (equal (len infos) (len alt))
     :returns (mv (matching-thm-events pseudo-event-form-listp)
                  (check-conc-fn-equiv-thm-events pseudo-event-form-listp)
                  (get-tree-list-list-fn-events pseudo-event-form-listp)
                  (rep-matching-thmevents pseudo-event-form-listp)
                  (get-tree-list-fn-events pseudo-event-form-listp)
                  (get-tree-fn-events pseudo-event-form-listp)
                  (event-alist symbol-pseudoeventform-alistp))
     :parents nil
     (b* (((when (endp alt)) (mv nil nil nil nil nil nil nil))
          ((mv matching-thm-event?
               check-conc-fn-equiv-thm-event?
               get-tree-list-list-fn-event?
               rep-matching-thm-events
               get-tree-list-fn-events
               get-tree-fn-events
               event-alist)
           (deftreeops-gen-conc-events
             (car alt) (car infos) i
             conc-equivs-thm check-conc-fn nonleaf-thm alt-match-thm
             alt-singletonp rulename prefix print))
          ((mv more-matching-thm-events
               more-check-conc-fn-equiv-thm-events
               more-get-tree-list-list-fn-events
               more-rep-matching-thm-events
               more-get-tree-list-fn-events
               more-get-tree-fn-events
               more-event-alist)
           (deftreeops-gen-conc-list-events-aux
             (cdr alt) (cdr infos) (1+ i)
             conc-equivs-thm check-conc-fn nonleaf-thm alt-match-thm
             alt-singletonp rulename prefix print)))
       (mv (append matching-thm-event?
                   more-matching-thm-events)
           (append check-conc-fn-equiv-thm-event?
                   more-check-conc-fn-equiv-thm-events)
           (append get-tree-list-list-fn-event?
                   more-get-tree-list-list-fn-events)
           (append rep-matching-thm-events
                   more-rep-matching-thm-events)
           (append get-tree-list-fn-events
                   more-get-tree-list-fn-events)
           (append get-tree-fn-events
                   more-get-tree-fn-events)
           (append event-alist
                   more-event-alist))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-rulename-events
  ((rulename rulenamep)
   (alt alternationp)
   (info deftreeops-rulename-infop)
   (prefix acl2::symbolp)
   (rulename-infos deftreeops-rulename-info-alistp
                   "Information about all the rule names.")
   (charval-infos deftreeops-charval-info-alistp
                  "Information about all the character value notations.")
   (print evmac-input-print-p))
  :returns (mv (nonleaf-thm-events pseudo-event-form-listp)
               (rulename-thm-events pseudo-event-form-listp)
               (match-thm-events pseudo-event-form-listp)
               (concs-thm-events pseudo-event-form-listp)
               (conc-equivs-thm-events pseudo-event-form-listp)
               (check-conc-fn-events pseudo-event-form-listp)
               (get-tree-list-list-fn-events pseudo-event-form-listp)
               (conc-matching-thm-events pseudo-event-form-listp)
               (rep-matching-thm-events pseudo-event-form-listp)
               (get-tree-list-fn-events pseudo-event-form-listp)
               (get-tree-fn-events pseudo-event-form-listp)
               (event-alist symbol-pseudoeventform-alistp))
  :short "Generate the events for a rule name."
  (b* (((deftreeops-rulename-info info) info)
       (rulename-string (rulename->get rulename))
       (alt-string (pretty-print-alternation alt))
       (matchp (deftreeops-match-pred prefix))
       (alt-matchp (deftreeops-alt-match-pred prefix))
       (conc-matchp (deftreeops-conc-match-pred prefix))
       ((unless (equal (len info.conc-infos) (len alt)))
        (raise "Internal error: ~x0 and ~x1 have different lengths."
               info.conc-infos alt)
        (mv nil nil nil nil nil nil nil nil nil nil nil nil))
       (alt-singletonp (and (consp alt)
                            (endp (cdr alt))))
       ((mv conc-matching-thm-events
            check-conc-fn-equiv-thm-events
            get-tree-list-list-fn-events
            rep-matching-thm-events
            get-tree-list-fn-events
            get-tree-fn-events
            event-alist)
        (deftreeops-gen-conc-list-events
          alt
          info.conc-infos
          info.conc-equivs-thm
          info.check-conc-fn
          info.nonleaf-thm
          info.match-thm
          alt-singletonp
          rulename
          prefix
          print))
       (nonleaf-thm-event
        `(defruled ,info.nonleaf-thm
           (implies (,matchp cst ,rulename-string)
                    (equal (tree-kind cst) :nonleaf))
           :in-theory '(,matchp
                        tree-nonleaf-when-match-rulename/group/option
                        (:e element-kind)
                        (:e member-equal))))
       (nonleaf-thm-events
        (cons nonleaf-thm-event
              (and (evmac-input-print->= print :result)
                   `((cw-event "Theorem ~x0.~%" ',info.nonleaf-thm)))))
       (rulename-thm-event
        `(defruled ,info.rulename-thm
           (implies (,matchp cst ,rulename-string)
                    (equal (tree-nonleaf->rulename? cst)
                           (rulename ,rulename-string)))
           :in-theory '(,matchp
                        tree-rulename-when-match-rulename
                        (:e element-kind)
                        (:e element-rulename->get)
                        (:e rulename))))
       (rulename-thm-events
        (cons rulename-thm-event
              (and (evmac-input-print->= print :result)
                   `((cw-event "Theorem ~x0.~%" ',info.rulename-thm)))))
       (match-thm-event
        `(defruled ,info.match-thm
           (implies (,matchp cst ,rulename-string)
                    (,alt-matchp
                     (tree-nonleaf->branches cst) ,alt-string))
           :in-theory '(,matchp
                        ,alt-matchp
                        tree-branches-match-alt-when-match-rulename
                        tree-terminatedp
                        (:e element-kind)
                        (:e element-rulename->get)
                        (:e lookup-rulename))
           :use ,info.nonleaf-thm))
       (match-thm-events
        (cons match-thm-event
              (and (evmac-input-print->= print :result)
                   `((cw-event "Theorem ~x0.~%" ',info.match-thm)))))
       (concs-thm-event
        `(defruled ,info.concs-thm
           (implies (,alt-matchp cstss ,alt-string)
                    (or ,@(deftreeops-gen-rulename-events-aux1
                            alt conc-matchp)))
           :do-not '(preprocess)
           :in-theory
           '(,alt-matchp
             ,conc-matchp
             tree-list-list-match-alternation-p-when-atom-alternation
             tree-list-list-match-alternation-p-of-cons-alternation)))
       (concs-thm-events
        (cons concs-thm-event
              (and (evmac-input-print->= print :result)
                   `((cw-event "Theorem ~x0.~%" ',info.concs-thm)))))
       (conc-equivs-thm-event?
        (and
         info.conc-equivs-thm
         (b* (((mv conjuncts rules lemma-instances)
               (deftreeops-gen-rulename-events-aux2
                 alt
                 info.alt-kind
                 info.conc-infos
                 rulename-infos
                 charval-infos
                 conc-matchp)))
           `((defruled ,info.conc-equivs-thm
               (implies (,matchp cst ,rulename-string)
                        (and ,@conjuncts))
               :in-theory '(,@(if (= info.alt-kind 1)
                                  '((:e rulename))
                                nil)
                            ,info.match-thm
                            ,@rules)
               :use ((:instance ,info.concs-thm
                                (cstss (tree-nonleaf->branches cst)))
                     ,@lemma-instances))))))
       (conc-equivs-thm-events
        (and conc-equivs-thm-event?
             (append conc-equivs-thm-event?
                     (and (evmac-input-print->= print :result)
                          `((cw-event "Theorem ~x0.~%"
                                      ',info.conc-equivs-thm))))))
       (check-conc-fn-event?
        (and
         info.check-conc-fn
         (b* (((mv cond-arms disjuncts rules)
               (deftreeops-gen-rulename-events-aux3
                 alt info.conc-infos 1 rulename-infos)))
           `((define ,info.check-conc-fn ((cst treep))
               :guard (,matchp cst ,rulename-string)
               :returns (number posp
                                :hints (("Goal" :in-theory '(,info.check-conc-fn
                                                             (:e posp)))))
               (cond ,@cond-arms
                     (t (prog2$ (acl2::impossible) 1)))
               :guard-hints
               (("Goal"
                 :in-theory
                 '(acl2::true-listp-of-nth-when-true-list-listp
                   (:t tree-nonleaf->branches)
                   abnf::true-list-listp-of-tree-nonleaf->branches
                   abnf::treep-of-nth-when-tree-listp
                   abnf::tree-listp-of-nth-when-tree-list-listp
                   abnf::tree-list-listp-of-tree-nonleaf->branches
                   (:e abnf::rulename)
                   (:e nfix)
                   ,info.nonleaf-thm
                   ,info.match-thm
                   ,@rules)
                 :use
                 ((:instance ,info.concs-thm
                             (cstss (tree-nonleaf->branches cst))))))
               ///
               (more-returns
                (number (or ,@disjuncts)
                        :name ,(packn-pos (list info.check-conc-fn
                                                '-possibilities)
                                          info.check-conc-fn)
                        :rule-classes
                        ((:forward-chaining
                          :trigger-terms ((,info.check-conc-fn cst))))
                        :hints (("Goal" :in-theory '(,info.check-conc-fn)))))
               (fty::deffixequiv ,info.check-conc-fn
                 :hints
                 (("Goal"
                   :in-theory
                   '(,info.check-conc-fn
                     tree-nonleaf->branches$inline-tree-equiv-congruence-on-x
                     tree-fix-under-tree-equiv))))
               ,@check-conc-fn-equiv-thm-events)))))
       (check-conc-fn-events
        (and check-conc-fn-event?
             (append check-conc-fn-event?
                     (and (evmac-input-print->= print :result)
                          `((cw-event "Theorem ~x0.~%"
                                      ',info.check-conc-fn)))))))
    (mv nonleaf-thm-events
        rulename-thm-events
        match-thm-events
        concs-thm-events
        conc-equivs-thm-events
        check-conc-fn-events
        get-tree-list-list-fn-events
        conc-matching-thm-events
        rep-matching-thm-events
        get-tree-list-fn-events
        get-tree-fn-events
        (append event-alist
                (list (cons info.nonleaf-thm
                            nonleaf-thm-event))
                (list (cons info.rulename-thm
                            rulename-thm-event))
                (list (cons info.match-thm
                            match-thm-event))
                (list (cons info.concs-thm
                            concs-thm-event))
                (and conc-equivs-thm-event?
                     (list (cons info.conc-equivs-thm
                                 (car conc-equivs-thm-event?))))
                (and check-conc-fn-event?
                     (list (cons info.check-conc-fn
                                 (car check-conc-fn-event?)))))))

  :prepwork

  ((define deftreeops-gen-rulename-events-aux1 ((alt alternationp)
                                               (conc-matchp acl2::symbolp))
     :returns (disjuncts true-listp)
     :parents nil
     (cond ((endp alt) nil)
           (t (cons `(,conc-matchp cstss
                                   ,(pretty-print-concatenation (car alt)))
                    (deftreeops-gen-rulename-events-aux1
                      (cdr alt) conc-matchp)))))

   (define deftreeops-gen-rulename-events-aux2
     ((alt alternationp)
      (alt-kind natp)
      (conc-infos deftreeops-conc-info-listp)
      (rulename-infos deftreeops-rulename-info-alistp)
      (charval-infos deftreeops-charval-info-alistp)
      (conc-matchp acl2::symbolp))
     :guard (equal (len conc-infos) (len alt))
     :returns (mv (conjuncts true-listp)
                  (rules symbol-listp)
                  (lemma-instances true-listp))
     :parents nil
     (b* (((when (endp alt)) (mv nil nil nil))
          (conc (car alt))
          ((deftreeops-conc-info conc-info) (car conc-infos))
          ((unless (and (consp conc)
                        (endp (cdr conc))))
           (raise "Internal error: non-singleton concatenation ~x0." conc)
           (mv nil nil nil))
          (rep (car conc))
          ((unless (equal (repetition->range rep)
                          (make-repeat-range :min 1
                                             :max (nati-finite 1))))
           (raise "Internal error: non-singleton repetition ~x0." rep)
           (mv nil nil nil))
          (elem (repetition->element rep))
          (conjunct
           `(iff (,conc-matchp (tree-nonleaf->branches cst)
                               ,(pretty-print-element elem))
                 ,conc-info.discriminant-term))
          ((unless (and (consp conc-info.rep-infos)
                        (endp (cdr conc-info.rep-infos))))
           (raise "Internal error:
                   non-singleton list of repetition information ~x0."
                  conc-info.rep-infos)
           (mv nil nil nil))
          ((deftreeops-rep-info rep-info) (car conc-info.rep-infos))
          (rules (list conc-info.matching-thm
                       rep-info.matching-thm))
          (lemma-instance
           (cond
            ((element-case elem :rulename)
             (b* ((rulename (element-rulename->get elem))
                  (rulename-info (cdr (assoc-equal rulename rulename-infos)))
                  ((unless rulename-info)
                   (raise "Internal error: no information for rule name ~x0."
                          rulename)))
               (if (= alt-kind 1)
                   `(:instance
                     ,(deftreeops-rulename-info->rulename-thm rulename-info)
                     (cst (nth 0 (nth 0 (tree-nonleaf->branches cst)))))
                 `(:instance
                   ,(deftreeops-rulename-info->nonleaf-thm rulename-info)
                   (cst (nth 0 (nth 0 (tree-nonleaf->branches cst))))))))
            ((element-case elem :char-val)
             (b* ((charval (element-char-val->get elem))
                  (charval-info (cdr (assoc-equal charval charval-infos)))
                  ((unless charval-info)
                   (raise "Internal error: no information for ~
                           character value notation ~x0."
                          charval)))
               `(:instance
                 ,(deftreeops-charval-info->leafterm-thm charval-info)
                 (cst (nth 0 (nth 0 (tree-nonleaf->branches cst)))))))
            (t
             (raise "Internal error: found element ~x0." elem))))
          ((mv more-conjuncts more-rules more-lemma-instances)
           (deftreeops-gen-rulename-events-aux2
             (cdr alt)
             alt-kind
             (cdr conc-infos)
             rulename-infos
             charval-infos
             conc-matchp)))
       (mv (cons conjunct more-conjuncts)
           (append rules more-rules)
           (cons lemma-instance more-lemma-instances))))

   (define deftreeops-gen-rulename-events-aux3
     ((alt alternationp)
      (conc-infos deftreeops-conc-info-listp)
      (i posp)
      (rulename-infos deftreeops-rulename-info-alistp))
     :guard (equal (len conc-infos) (len alt))
     :returns (mv (cond-arms true-listp)
                  (disjuncts true-listp)
                  (rules symbol-listp))
     :parents nil
     (b* (((when (endp alt)) (mv nil nil nil))
          (conc (car alt))
          ((deftreeops-conc-info conc-info) (car conc-infos))
          ((unless (and (consp conc)
                        (endp (cdr conc))))
           (raise "Internal error: non-singleton concatenation ~x0." conc)
           (mv nil nil nil))
          (rep (car conc))
          ((unless (equal (repetition->range rep)
                          (make-repeat-range :min 1
                                             :max (nati-finite 1))))
           (raise "Internal error: non-singleton repetition ~x0." rep)
           (mv nil nil nil))
          (elem (repetition->element rep))
          ((unless (element-case elem :rulename))
           (raise "Internal error: element ~x0 is not a rule name." elem)
           (mv nil nil nil))
          (rulename (element-rulename->get elem))
          (cond-arm `(,conc-info.discriminant-term ,i))
          (disjunct `(equal number ,i))
          (rep-infos (deftreeops-conc-info->rep-infos conc-info))
          ((unless (and (consp rep-infos)
                        (endp (cdr rep-infos))))
           (raise "Internal error:
                   non-singleton list of repetition information ~x0."
                  rep-infos)
           (mv nil nil nil))
          ((deftreeops-rep-info rep-info) (car rep-infos))
          (rulename-info (cdr (assoc-equal rulename rulename-infos)))
          ((unless rulename-info)
           (raise "Internal error: no information for rule name ~x0." rulename)
           (mv nil nil nil))
          (rules (list (deftreeops-rulename-info->nonleaf-thm rulename-info)
                       (deftreeops-rulename-info->rulename-thm rulename-info)
                       conc-info.matching-thm
                       rep-info.matching-thm))
          ((mv more-cond-arms
               more-disjuncts
               more-rules)
           (deftreeops-gen-rulename-events-aux3
             (cdr alt) (cdr conc-infos) (1+ i) rulename-infos)))
       (mv (cons cond-arm more-cond-arms)
           (cons disjunct more-disjuncts)
           (append rules more-rules))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-rulename-alist-events
  ((rulename-infos deftreeops-rulename-info-alistp)
   (charval-infos deftreeops-charval-info-alistp)
   (prefix acl2::symbolp)
   (print evmac-input-print-p))
  :returns (mv (nonleaf-thm-events pseudo-event-form-listp)
               (rulename-thm-events pseudo-event-form-listp)
               (match-thm-events pseudo-event-form-listp)
               (concs-thm-events pseudo-event-form-listp)
               (conc-equivs-thm-events pseudo-event-form-listp)
               (check-conc-fn-events pseudo-event-form-listp)
               (get-tree-list-list-fn-events pseudo-event-form-listp)
               (conc-matching-thm-events pseudo-event-form-listp)
               (rep-matching-thm-events pseudo-event-form-listp)
               (get-tree-list-fn-events pseudo-event-form-listp)
               (get-tree-fn-events pseudo-event-form-listp)
               (event-alist symbol-pseudoeventform-alistp))
  :short "Generate the events for all the rule names in the alist."
  (deftreeops-gen-rulename-alist-events-aux
    rulename-infos prefix rulename-infos charval-infos print)

  :prepwork
  ((define deftreeops-gen-rulename-alist-events-aux
     ((rest-rulename-infos deftreeops-rulename-info-alistp)
      (prefix acl2::symbolp)
      (all-rulename-infos deftreeops-rulename-info-alistp)
      (charval-infos deftreeops-charval-info-alistp)
      (print evmac-input-print-p))
     :returns (mv (nonleaf-thm-events pseudo-event-form-listp)
                  (rulename-thm-events pseudo-event-form-listp)
                  (match-thm-events pseudo-event-form-listp)
                  (concs-thm-events pseudo-event-form-listp)
                  (conc-equivs-thm-events pseudo-event-form-listp)
                  (check-conc-fn-events pseudo-event-form-listp)
                  (get-tree-list-list-fn-events pseudo-event-form-listp)
                  (conc-matching-thm-events pseudo-event-form-listp)
                  (rep-matching-thm-events pseudo-event-form-listp)
                  (get-tree-list-fn-events pseudo-event-form-listp)
                  (get-tree-fn-events pseudo-event-form-listp)
                  (event-alist symbol-pseudoeventform-alistp))
     :parents nil
     (b* (((when (endp rest-rulename-infos))
           (mv nil nil nil nil nil nil nil nil nil nil nil nil))
          ((cons rulename info) (car rest-rulename-infos))
          (alt (deftreeops-rulename-info->alt info))
          ((mv nonleaf-thm-events
               rulename-thm-events
               match-thm-events
               concs-thm-events
               conc-equivs-thm-events
               check-conc-fn-events
               get-tree-list-list-fn-events
               conc-matching-thm-events
               rep-matching-thm-events
               get-tree-list-fn-events
               get-tree-fn-events
               event-alist)
           (deftreeops-gen-rulename-events
             rulename alt info prefix all-rulename-infos charval-infos print))
          ((mv more-nonleaf-thm-events
               more-rulename-thm-events
               more-match-thm-events
               more-concs-thm-events
               more-conc-equivs-thm-events
               more-check-conc-fn-events
               more-get-tree-list-list-fn-events
               more-conc-matching-thm-events
               more-rep-matching-thm-events
               more-get-tree-list-fn-events
               more-get-tree-fn-events
               more-event-alist)
           (deftreeops-gen-rulename-alist-events-aux
             (cdr rest-rulename-infos)
             prefix
             all-rulename-infos
             charval-infos
             print)))
       (mv (append nonleaf-thm-events more-nonleaf-thm-events)
           (append rulename-thm-events more-rulename-thm-events)
           (append match-thm-events more-match-thm-events)
           (append concs-thm-events more-concs-thm-events)
           (append conc-equivs-thm-events more-conc-equivs-thm-events)
           (append check-conc-fn-events more-check-conc-fn-events)
           (append get-tree-list-list-fn-events
                   more-get-tree-list-list-fn-events)
           (append conc-matching-thm-events more-conc-matching-thm-events)
           (append rep-matching-thm-events more-rep-matching-thm-events)
           (append get-tree-list-fn-events more-get-tree-list-fn-events)
           (append get-tree-fn-events more-get-tree-fn-events)
           (append event-alist more-event-alist))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-all-rulename-infos+events
  ((rules rulelistp)
   (charval-infos deftreeops-charval-info-alistp)
   (prefix acl2::symbolp)
   (print evmac-input-print-p))
  :returns (mv (rulename-infos deftreeops-rulename-info-alistp)
               (rulename-events pseudo-event-form-listp)
               (event-alist symbol-pseudoeventform-alistp))
  :short "Generate the information and events
          for all the rulenames in a grammar."
  :long
  (xdoc::topstring
   (xdoc::p
    "We generate the events in an order that
     keeps analogous events together
     and avoids forward references."))
  (b* ((infos (deftreeops-gen-rulename-info-alist rules prefix))
       ((mv nonleaf-thm-events
            rulename-thm-events
            match-thm-events
            concs-thm-events
            conc-equivs-thm-events
            check-conc-fn-events
            get-tree-list-list-fn-events
            conc-matching-thm-events
            rep-matching-thm-events
            get-tree-list-fn-events
            get-tree-fn-events
            event-alist)
        (deftreeops-gen-rulename-alist-events infos charval-infos prefix print))
       (events (append nonleaf-thm-events
                       rulename-thm-events
                       match-thm-events
                       concs-thm-events
                       conc-matching-thm-events
                       rep-matching-thm-events
                       conc-equivs-thm-events
                       check-conc-fn-events
                       get-tree-list-list-fn-events
                       get-tree-list-fn-events
                       get-tree-fn-events)))
    (mv infos events event-alist)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-numrange-events ((range num-range-p)
                                        (info deftreeops-numrange-infop)
                                        (prefix acl2::symbolp)
                                        (print evmac-input-print-p))
  :returns (mv (get-nat-fn-events pseudo-event-form-listp
                                  "The function
                                  @('<prefix>-%<b><min>-<max>-nat')
                                  described in @(tsee deftreeops).")
               (bounds-thm-events pseudo-event-form-listp
                                  "The theorem
                                  @('<prefix>-%<b><min>-<max>-nat-bounds')
                                  described in @(tsee deftreeops).")
               (event-alist symbol-pseudoeventform-alistp))
  :short "Generate the function and theorem for a numeric range."
  (b* (((num-range range) range)
       ((deftreeops-numrange-info info) info)
       (matchp (deftreeops-match-pred prefix))
       (matchp$ (packn-pos (list matchp "$") matchp))
       (range-desc (pretty-print-num-val-range range.min range.max range.base))
       (get-nat-fn-event
        `(define ,info.get-nat-fn ((cst treep))
           :guard (,matchp cst ,range-desc)
           :returns (nat natp :hints (("Goal" :in-theory '(,info.get-nat-fn
                                                           lnfix
                                                           nfix
                                                           natp))))
           (lnfix (nth 0 (tree-leafterm->get cst)))
           :guard-hints
           (("Goal" :in-theory '(,matchp$
                                 tree-match-element-p
                                 tree-match-num-val-p
                                 nat-listp-of-tree-leafterm->get
                                 acl2::natp-of-nth-when-nat-listp
                                 (:e element-kind)
                                 (:e element-num-val->get)
                                 (:e num-val-kind)
                                 (:e num-val-range->max)
                                 (:e num-val-range->min)
                                 (:e nfix)
                                 (:t tree-leafterm->get))))
           ///
           (fty::deffixequiv ,info.get-nat-fn
             :hints (("Goal"
                      :in-theory '(,info.get-nat-fn
                                   tree-leafterm->get$inline-of-tree-fix-x))))))
       (get-nat-fn-events
        (cons get-nat-fn-event
              (and (evmac-input-print->= print :result)
                   `((cw-event "Function ~x0.~%" ',info.get-nat-fn)))))
       (bounds-thm-event
        `(defrule ,info.bounds-thm
           (implies (,matchp cst ,range-desc)
                    (and (<= ,range.min (,info.get-nat-fn cst))
                         (<= (,info.get-nat-fn cst) ,range.max)))
           :rule-classes :linear
           :hints (("Goal" :in-theory '(,info.get-nat-fn
                                        ,matchp$
                                        tree-match-element-p
                                        tree-match-num-val-p
                                        lnfix
                                        nfix
                                        nth
                                        acl2::integerp-of-car-when-nat-listp
                                        nat-listp-of-tree-leafterm->get
                                        (:e element-kind)
                                        (:e element-num-val->get)
                                        (:e num-val-kind)
                                        (:e num-val-range->max)
                                        (:e num-val-range->min)
                                        (:e zp))))))
       (bounds-thm-events
        (cons bounds-thm-event
              (and (evmac-input-print->= print :result)
                   `((cw-event "Theorem ~x0.~%" ',info.bounds-thm))))))
    (mv get-nat-fn-events
        bounds-thm-events
        (list (cons info.get-nat-fn
                    get-nat-fn-event)
              (cons info.bounds-thm
                    bounds-thm-event)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-numrange-alist-events
  ((range-infos deftreeops-numrange-info-alistp)
   (prefix acl2::symbolp)
   (print evmac-input-print-p))
  :returns (mv (get-nat-fn-events pseudo-event-form-listp)
               (bounds-thm-events pseudo-event-form-listp)
               (event-alist symbol-pseudoeventform-alistp))
  :short "Generate the events for all the numeric ranges in the alist."
  (b* (((when (endp range-infos)) (mv nil nil nil))
       ((cons range info) (car range-infos))
       ((mv get-nat-fn-events
            bounds-thm-events
            event-alist)
        (deftreeops-gen-numrange-events range info prefix print))
       ((mv more-get-nat-fn-events
            more-bounds-thm-events
            more-event-alist)
        (deftreeops-gen-numrange-alist-events (cdr range-infos) prefix print)))
    (mv (append get-nat-fn-events
              more-get-nat-fn-events)
        (append bounds-thm-events
              more-bounds-thm-events)
        (append event-alist
                more-event-alist))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-all-numrange-infos+events ((rules rulelistp)
                                                  (prefix acl2::symbolp)
                                                  (print evmac-input-print-p))
  :returns (mv (numrange-infos deftreeops-numrange-info-alistp)
               (numrange-events pseudo-event-form-listp)
               (event-alist symbol-pseudoeventform-alistp))
  :short "Generate the information and events
          for all the numeric ranges in a grammar."
  (b* ((infos (deftreeops-gen-numrange-info-alist rules prefix))
       ((mv get-nat-fn-events
            bounds-thm-events
            event-alist)
        (deftreeops-gen-numrange-alist-events infos prefix print))
       (events (append get-nat-fn-events
                       bounds-thm-events)))
    (mv infos events event-alist)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-charval-events ((charval char-val-p)
                                       (info deftreeops-charval-infop)
                                       (prefix acl2::symbolp)
                                       (print evmac-input-print-p))
  :returns (mv (leafterm-thm-events pseudo-event-form-listp
                                   "The theorem
                                    @('<prefix>-<...>|\"<chars>\"|-leafterm')
                                    described in @(tsee deftreeops).")
               (event-alist symbol-pseudoeventform-alistp))
  :short "Generate the theorem for a character value notation."
  (b* (((deftreeops-charval-info info) info)
       (matchp (deftreeops-match-pred prefix))
       (matchp$ (packn-pos (list matchp "$") matchp))
       (charval-desc (pretty-print-char-val charval))
       (leafterm-thm-event
        `(defruled ,info.leafterm-thm
           (implies (,matchp cst ,charval-desc)
                    (equal (tree-kind cst) :leafterm))
           :hints (("Goal" :in-theory '(,matchp$
                                        tree-leafterm-when-match-numval/charval
                                        (:e element-kind)
                                        (:e member-equal))))))
       (leafterm-thm-events
        (cons leafterm-thm-event
              (and (evmac-input-print->= print :result)
                   `((cw-event "Theorem ~x0.~%" ',info.leafterm-thm))))))
    (mv leafterm-thm-events
        (list (cons info.leafterm-thm
                    leafterm-thm-event)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-charval-alist-events
  ((charval-infos deftreeops-charval-info-alistp)
   (prefix acl2::symbolp)
   (print evmac-input-print-p))
  :returns (mv (leafterm-thm-events pseudo-event-form-listp)
               (event-alist symbol-pseudoeventform-alistp))
  :short "Generate the events for all the character value notations
          in the alist."
  (b* (((when (endp charval-infos)) (mv nil nil))
       ((cons charval info) (car charval-infos))
       ((mv leafterm-thm-events
            event-alist)
        (deftreeops-gen-charval-events charval info prefix print))
       ((mv more-leafterm-thm-events
            more-event-alist)
        (deftreeops-gen-charval-alist-events (cdr charval-infos) prefix print)))
    (mv (append leafterm-thm-events
                more-leafterm-thm-events)
        (append event-alist
                more-event-alist))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-all-charval-infos+events ((rules rulelistp)
                                                 (prefix acl2::symbolp)
                                                 (print evmac-input-print-p))
  :returns (mv (charval-infos deftreeops-charval-info-alistp)
               (charval-events pseudo-event-form-listp)
               (event-alist symbol-pseudoeventform-alistp))
  :short "Generate the information and events
          for all the character value notations in a grammar."
  (b* ((infos (deftreeops-gen-charval-info-alist rules prefix))
       ((mv leafterm-thm-events
            event-alist)
        (deftreeops-gen-charval-alist-events infos prefix print))
       (events leafterm-thm-events))
    (mv infos events event-alist)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-gen-everything ((grammar acl2::symbolp)
                                   (rules rulelistp)
                                   (prefix acl2::symbolp)
                                   (print evmac-input-print-p)
                                   (call pseudo-event-formp))
  :returns (event pseudo-event-formp)
  :short "Generate all the events."
  :long
  (xdoc::topstring
   (xdoc::p
    "If the @(':print') input is @(':all'),
     we use @(tsee restore-output?) to restore all the output,
     which @(tsee make-event-terse) otherwise suppresses."))
  (b* (((mv matchers
            matchers-event-alist)
        (deftreeops-gen-matchers grammar prefix print))
       ((mv numrange-infos
            numrange-events
            numrange-event-alist)
        (deftreeops-gen-all-numrange-infos+events rules prefix print))
       ((mv charval-infos
            charval-events
            charval-event-alist)
        (deftreeops-gen-all-charval-infos+events rules prefix print))
       ((mv rulename-infos
            rulename-events
            rulename-event-alist)
        (deftreeops-gen-all-rulename-infos+events
          rules charval-infos prefix print))
       (event-alist (append matchers-event-alist
                            numrange-event-alist
                            charval-event-alist
                            rulename-event-alist))
       (table-value (make-deftreeops-table-value
                     :rulename-info-alist rulename-infos
                     :numrange-info-alist numrange-infos
                     :charval-info-alist charval-infos
                     :event-alist event-alist
                     :call call))
       (event `(defsection ,(add-suffix grammar "-TREE-OPERATIONS")
                 :parents (,grammar)
                 :short ,(str::cat
                          "Tree operations specialized to @(tsee "
                          (str::downcase-string (symbol-name grammar))
                          ").")
                 ,@matchers
                 ,@numrange-events
                 ,@charval-events
                 ,@rulename-events
                 ,(deftreeops-table-add grammar table-value)))
       (event (restore-output? (eq print :all) event)))
    event))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-process-inputs-and-gen-everything ((args true-listp)
                                                      (call pseudo-event-formp)
                                                      (wrld plist-worldp))
  :returns (mv erp (event pseudo-event-formp))
  :parents (deftreeops-implementation)
  :short "Process the inputs and generate the events."
  (b* (((reterr) '(_))
       ((erp redundantp grammar rules prefix print)
        (deftreeops-process-inputs args call wrld))
       ((when redundantp) (retok '(value-triple :redundant))))
    (retok (deftreeops-gen-everything grammar rules prefix print call))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define deftreeops-fn ((args true-listp)
                       (call pseudo-event-formp)
                       (ctx ctxp)
                       state)
  :returns (mv erp (event pseudo-event-formp) state)
  :parents (deftreeops-implementation)
  :short "Event expansion of @(tsee deftreeops)."
  (b* (((mv erp event)
        (deftreeops-process-inputs-and-gen-everything args call (w state)))
       ((when erp) (er-soft+ ctx t '(_) "~@0" erp)))
    (value event)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsection deftreeops-macro-definition
  :parents (deftreeops-implementation)
  :short "Definition of @(tsee deftreeops)."
  (defmacro deftreeops (&whole call &rest args)
    `(make-event-terse (deftreeops-fn ',args ',call 'deftreeops state))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsection deftreeops-show-info
  :parents (deftreeops)
  :short "Show the information from the @(tsee deftreeops) table
          associated to a given grammar constant name."
  :long
  (xdoc::topstring
   (xdoc::p
    "If there is no information in the table
     for the given grammar constant name,
     we print a message saying so.")
   (xdoc::@def "deftreeops-show-info"))

  (define deftreeops-show-info-fn ((grammar acl2::symbolp)
                                   (wrld plist-worldp))
    :returns (event pseudo-event-formp)
    :parents nil
    (b* ((info (deftreeops-table-lookup grammar wrld))
         ((unless info)
          (cw "~%No entry in DEFTREEOPS table for grammar ~x0.~%" grammar)
          '(value-triple :invisible))
         (- (cw "~%~x0.~%" info)))
      '(value-triple :invisible)))

  (defmacro deftreeops-show-info (grammar)
    (declare (xargs :guard (acl2::symbolp grammar)))
    `(make-event-terse (deftreeops-show-info-fn ',grammar (w state)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsection deftreeops-show-event
  :parents (deftreeops)
  :short "Show the event with a given name from the @(tsee deftreeops) table
          associated to a given grammar constant name."
  :long
  (xdoc::topstring
   (xdoc::p
    "If there is no information in the table
     for the given grammar constant name,
     or if there is no event with the given name,
     we print a message saying so.")
   (xdoc::@def "deftreeops-show-event"))

  (define deftreeops-show-event-fn ((grammar acl2::symbolp)
                                    (name acl2::symbolp)
                                    (wrld plist-worldp))
    :returns (event pseudo-event-formp)
    :parents nil
    (b* ((info (deftreeops-table-lookup grammar wrld))
         ((unless info)
          (cw "~%No entry in DEFTREEOPS table for grammar ~x0.~%" grammar)
          '(value-triple :invisible))
         (event-alist (deftreeops-table-value->event-alist info))
         (name+event (assoc-eq name event-alist))
         ((unless name+event)
          (cw "~%No event with name ~x0 ~
               in DEFTREEOPS table entry for grammar ~x1.~%"
              name grammar)
          '(value-triple :invisible))
         (- (cw "~%~x0~%" (cdr name+event))))
      '(value-triple :invisible)))

  (defmacro deftreeops-show-event (grammar name)
    (declare (xargs :guard (and (acl2::symbolp grammar) (acl2::symbolp name))))
    `(make-event-terse (deftreeops-show-event-fn ',grammar ',name (w state)))))
