; System Utilities -- Named Formulas
;
; Copyright (C) 2017 Kestrel Institute (http://www.kestrel.edu)
;
; License: A 3-clause BSD license. See the LICENSE file distributed with ACL2.
;
; Author: Alessandro Coglio (coglio@kestrel.edu)

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

(in-package "ACL2")

(include-book "../er-soft-plus")
(include-book "event-form-lists")
(include-book "fresh-names")
(include-book "../prove-interface")
(include-book "../symbol-symbol-alists")
(include-book "../symbol-true-list-alists")

(local (set-default-parents named-formulas))

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

(defsection named-formulas
  :parents (kestrel-utilities system-utilities-non-built-in)
  :short "Utilities for named formulas."
  :long
  "<p>
   A <i>named formula</i> is a formula with a name (a symbol).
   </p>
   <p>
   There are utilities to (attempt to) programmatically prove named formulas,
   optionally printing progress messages.
   There are also utilities to turn named formulas into theorem event forms,
   ensuring the freshness and uniqueness of the theorem names.
   </p>")

(define prove-named-formula
  ((name symbolp "Name of the formula to prove.")
   (formula "Formula to prove (an untranslated term).")
   (hints true-listp "Hints to prove the formula.")
   (verbose booleanp "Print progress messages or not.")
   state)
  :returns (mv (success "A @(tsee booleanp).")
               (msg "A @(tsee msgp).")
               state)
  :mode :program
  :short "Try to prove a named formula."
  :long
  "<p>
   Besides returning an indication of success or failure,
   return a structured message (printable with @('~@')).
   When the proof fails, the message is an error message.
   When the proof succeeds, currently the message is empty,
   but future versions of this function
   could return some non-empty message instead.
   </p>
   <p>
   Note that @(tsee prove$) always returns a @('nil') error flag,
   so the code below ignores that result.
   </p>
   <p>
   If the @('verbose') argument is @('t'),
   also print a progress message to indicate that
   the proof of the named formula is being attempted,
   and then to indicate the outcome of the attempt.
   </p>
   <p>
   Parentheses are printed around the progress message
   to ease navigation in an Emacs buffer.
   </p>"
  (b* (((run-when verbose)
        (cw "~%(Proving ~x0:~%~x1~|" name formula))
       ((mv & yes/no state) (prove$ formula :hints hints)))
    (if yes/no
        (b* (((run-when verbose)
              (cw "Done.)~%")))
          (mv t "" state))
      (b* (((run-when verbose)
            (cw "Failed.)~%")))
        (mv nil
            (msg "Unable to prove ~x0:~%~x1~|" name formula)
            state)))))

(define prove-named-formulas
  ((named-formulas symbol-alistp "Named formulas to prove
                                  (an alist from names to untranslated terms).")
   (named-hints symbol-true-list-alistp "Alist from names of formulas
                                         to proof hints
                                         to prove the corresponding formulas.")
   (verbose booleanp "Print progress messages or not.")
   state)
  :returns (mv (success "A @(tsee booleanp).")
               (msg "A @(tsee msgp).")
               state)
  :mode :program
  :short "Try to prove a list of named formulas, one after the other."
  :long
  "<p>
   Besides returning an indication of success or failure,
   return a structured message (printable with @('~@')).
   When the proof of a named formula fails,
   the message is the error message generated by that proof attempt.
   When all the proofs of the named formulas succeed,
   currently the message is empty,
   but future versions of this function
   could return some non-empty message instead.
   </p>
   <p>
   If the @('verbose') argument is @('t'),
   also print progress messages for the named formulas.
   </p>"
  (cond ((endp named-formulas) (mv t "" state))
        (t (b* ((named-formula (car named-formulas))
                (name (car named-formula))
                (formula (cdr named-formula))
                (hints (cdr (assoc-eq name named-hints)))
                ((mv success msg state)
                 (prove-named-formula name formula hints verbose state)))
             (if success
                 (prove-named-formulas
                  (cdr named-formulas) named-hints verbose state)
               (mv nil msg state))))))

(define ensure-named-formulas
  ((named-formulas symbol-alistp "Named formulas to prove
                                  (an alist from names to untranslated terms).")
   (named-hints symbol-true-list-alistp "Alist from names of formulas
                                         to proof hints to prove the formulas.")
   (verbose booleanp "Print progress messages or not.")
   (error-erp "Flag to return in case of error.")
   (error-val "Value to return in case of error.")
   (ctx "Context for errors.")
   state)
  :returns (mv (erp "@('error-erp') or @('nil').")
               (val "@('error-val') or @('nil').")
               state)
  :mode :program
  :short "Cause a soft error if the proof of any named formula fails."
  :long
  "<p>
   Use the message from the named formula proof failure as error message.
   </p>
   <p>
   In case of error, use @(tsee er-soft+)
   with the error flag and value passed as arguments.
   </p>"
  (b* (((mv success msg state)
        (prove-named-formulas named-formulas named-hints verbose state))
       ((unless success) (er-soft+ ctx error-erp error-val "~@0" msg)))
    (value nil)))

(define named-formula-to-thm-event
  ((name symbolp "Name of the formula to turn into a theorem event.")
   (formula "Formula for the theorem event (an untranslated term).")
   (hints true-listp "Hints for the theorem event.")
   (rule-classes "Rule classes for the theorem event.")
   (enabled booleanp "Make the theorem event enabled or not.")
   (local booleanp "Make the theorem event local or not.")
   (names-to-avoid symbol-listp "Avoid these as theorem name.")
   (wrld plist-worldp))
  :returns (mv (thm-event "Theorem event (a @(tsee pseudo-event-formp)).")
               (thm-name "Name of the theorem event (a @(tsee symbolp))."))
  :mode :program
  :short "Turn a named formula into a theorem event."
  :long
  "<p>
   If the name of the formula is not in use and not among the names to avoid,
   it is used as the name of the theorem event.
   Otherwise, it is made fresh by appending @('$') signs.
   If the initial name is a keyword,
   it is interned into the \"ACL2\" package
   before calling @(tsee fresh-name-in-world-with-$s),
   whose guard forbids keywords.
   </p>"
  (b* ((defthm/defthmd (theorem-intro-macro enabled))
       (name (if (keywordp name)
                 (intern (symbol-name name) "ACL2")
               name))
       (thm-name (fresh-name-in-world-with-$s name names-to-avoid wrld))
       (thm-event `(,defthm/defthmd ,thm-name
                     ,formula
                     :hints ,hints
                     :rule-classes ,rule-classes))
       (thm-event (if local
                      `(local ,thm-event)
                    thm-event)))
    (mv thm-event thm-name)))

(define named-formulas-to-thm-events
  ((named-formulas symbol-alistp "Named formulas to turn into theorems
                                  (an alist from names to untranslated terms).")
   (named-hints symbol-true-list-alistp
                "Alist from names of formulas to
                 proof hints for the corresponding theorem events.")
   (named-rule-classes symbol-alistp
                       "Alist from names of formulas to
                        rule classes for the corresponding theorem events.")
   (enableds (or (symbol-listp enableds)
                 (eq enableds t))
             "List of names of formulas whose corresponding theorem events
              must be enabled,
             or @('t') to make all of them enabled.")
   (locals (or (symbol-listp locals)
               (eq locals t))
           "List of names of formulas whose corresponding theorem events
            must be local,
            or @('t') to make all of them local.")
   (names-to-avoid symbol-listp "Avoid these as theorem names.")
   (wrld plist-worldp))
  :returns (mv (thm-events "Theorem events
                            (a @(tsee pseudo-event-form-listp)).")
               (thm-names "A @(tsee symbol-symbol-alistp)
                           from names of formulas
                           to names of the corresponding theorem events."))
  :mode :program
  :short "Turn a list of named formulas into theorem events."
  :long
  "<p>
   Repeatedly call @(tsee named-formula-to-thm-event),
   ensuring that all the theorem names are distinct
   by incrementally adding the generated names to the list of names to avoid.
   </p>"
  (named-formulas-to-thm-events-aux named-formulas
                                    named-hints
                                    named-rule-classes
                                    enableds
                                    locals
                                    names-to-avoid
                                    nil ; REV-THM-EVENTS
                                    nil ; REV-THM-NAMES
                                    wrld)

  :prepwork
  ((define named-formulas-to-thm-events-aux
     ((named-formulas symbol-alistp)
      (named-hints symbol-alistp)
      (named-rule-classes symbol-alistp)
      (enableds (or (symbol-listp enableds)
                    (eq enableds t)))
      (locals (or (symbol-listp locals)
                  (eq locals t)))
      (names-to-avoid symbol-listp)
      (rev-thm-events pseudo-event-form-listp)
      (rev-thm-names symbol-symbol-alistp)
      (wrld plist-worldp))
     :returns (mv thm-events thm-names)
     :parents nil
     :mode :program
     (cond ((endp named-formulas)
            (mv (reverse rev-thm-events) (reverse rev-thm-names)))
           (t (b* ((named-formula (car named-formulas))
                   (name (car named-formula))
                   (formula (cdr named-formula))
                   (hints (cdr (assoc-eq name named-hints)))
                   (rule-classes (cdr (assoc-eq name named-rule-classes)))
                   (enabled (or (eq enableds t)
                                (member-eq name enableds)))
                   (local (or (eq locals t)
                              (member-eq name locals)))
                   ((mv thm-event thm-name)
                    (named-formula-to-thm-event name
                                                formula
                                                hints
                                                rule-classes
                                                enabled
                                                local
                                                names-to-avoid
                                                wrld))
                   (names-to-avoid (cons thm-name names-to-avoid))
                   (rev-thm-names (acons name thm-name rev-thm-names))
                   (rev-thm-events (cons thm-event rev-thm-events)))
                (named-formulas-to-thm-events-aux (cdr named-formulas)
                                                  named-hints
                                                  named-rule-classes
                                                  enabled
                                                  locals
                                                  names-to-avoid
                                                  rev-thm-events
                                                  rev-thm-names
                                                  wrld)))))))
