; Standard Utilities Library
;
; Copyright (C) 2020 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")

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

; This file contains macros to generate template functions and theorems
; of the kind processed and generated by DEFMAPPING.
; These templates are useful to construct generic tests
; and to explicate proof generation strategies.

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

; Generate a list of equalities from two equally long lists of terms.

(defun gen-eqs (lefts rights)
  (cond ((or (atom lefts) (atom rights)) nil)
        (t (cons `(equal ,(car lefts) ,(car rights))
                 (gen-eqs (cdr lefts) (cdr rights))))))

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

; Generate theorems of the form generated by DEFMAPPING,
; with the given names, variables, and functions.

(defmacro defthm-alpha-image (&key (name 'alpha-image)
                                   (a1...an '(a))
                                   (b1...bm '(b))
                                   (doma 'doma)
                                   (domb 'domb)
                                   (alpha 'alpha))
  `(defthm ,name
     (implies (,doma ,@a1...an)
              ,(if (= (len b1...bm) 1)
                   `(,domb (,alpha ,@a1...an))
                 `(mv-let ,b1...bm (,alpha ,@a1...an) (,domb ,@b1...bm))))))

(defmacro defthm-beta-image (&key (name 'beta-image)
                                  (a1...an '(a))
                                  (b1...bm '(b))
                                  (doma 'doma)
                                  (domb 'domb)
                                  (beta 'beta))
  `(defthm ,name
     (implies (,domb ,@b1...bm)
              ,(if (= (len a1...an) 1)
                   `(,doma (,beta ,@b1...bm))
                 `(mv-let ,a1...an (,beta ,@b1...bm) (,doma ,@a1...an))))))

(defmacro defthm-beta-of-alpha (&key (name 'beta-of-alpha)
                                     (a1...an '(a))
                                     (b1...bm '(b))
                                     (doma 'doma)
                                     (alpha 'alpha)
                                     (beta 'beta)
                                     aa1...aan
                                     unconditional)
  (let ((core (if (= (len a1...an) 1)
                  (if (= (len b1...bm) 1)
                      `(equal (,beta (,alpha ,(car a1...an)))
                              ,(car a1...an))
                    `(mv-let ,b1...bm
                       (,alpha ,@a1...an)
                       (equal (,beta ,@b1...bm)
                              ,(car a1...an))))
                (if (= (len b1...bm) 1)
                    `(mv-let ,aa1...aan
                       (,beta (,alpha ,@a1...an))
                       (and ,@(gen-eqs aa1...aan a1...an)))
                  `(mv-let ,b1...bm
                     (,alpha ,@a1...an)
                     (mv-let ,aa1...aan
                       (,beta ,@b1...bm)
                       (and ,@(gen-eqs aa1...aan a1...an))))))))
    (if unconditional
        `(defthm ,name
           ,core)
      `(defthm ,name
         (implies (,doma ,@a1...an)
                  ,core)))))

(defmacro defthm-alpha-of-beta (&key (name 'alpha-of-beta)
                                     (a1...an '(a))
                                     (b1...bm '(b))
                                     (domb 'domb)
                                     (alpha 'alpha)
                                     (beta 'beta)
                                     bb1...bbm
                                     unconditional)
  (let ((core (if (= (len b1...bm) 1)
                  (if (= (len a1...an) 1)
                      `(equal (,alpha (,beta ,(car b1...bm)))
                              ,(car b1...bm))
                    `(mv-let ,a1...an
                       (,beta ,@b1...bm)
                       (equal (,alpha ,@a1...an)
                              ,(car b1...bm))))
                (if (= (len a1...an) 1)
                    `(mv-let ,bb1...bbm
                       (,alpha (,beta ,@b1...bm))
                       (and ,@(gen-eqs bb1...bbm b1...bm)))
                  `(mv-let ,a1...an
                     (,beta ,@b1...bm)
                     (mv-let ,bb1...bbm
                       (,alpha ,@a1...an)
                       (and ,@(gen-eqs bb1...bbm b1...bm))))))))
    (if unconditional
        `(defthm ,name
           ,core)
      `(defthm ,name
         (implies (,domb ,@b1...bm)
                  ,core)))))

(defmacro defthm-alpha-injective (&key
                                  (name 'alpha-injective)
                                  (a1...an '(a))
                                  (aa1...aan '(aa))
                                  (doma 'doma)
                                  (alpha 'alpha)
                                  unconditional
                                  hints)
  (let ((core `(equal (equal (,alpha ,@a1...an)
                             (,alpha ,@aa1...aan))
                      ,(if (= (len a1...an) 1)
                           `(equal ,(car a1...an) ,(car aa1...aan))
                         `(and ,@(gen-eqs a1...an aa1...aan))))))
    (if unconditional
        `(defthm ,name
           ,core
           ,@(and hints (list :hints hints)))
      `(defthm ,name
         (implies (and (,doma ,@a1...an)
                       (,doma ,@aa1...aan))
                  ,core)
         ,@(and hints (list :hints hints))))))

(defmacro defthm-beta-injective (&key
                                 (name 'beta-injective)
                                 (b1...bm '(b))
                                 (bb1...bbm '(bb))
                                 (domb 'domb)
                                 (beta 'beta)
                                 unconditional
                                 hints)
  (let ((core `(equal (equal (,beta ,@b1...bm)
                             (,beta ,@bb1...bbm))
                      ,(if (= (len b1...bm) 1)
                           `(equal ,(car b1...bm) ,(car bb1...bbm))
                         `(and ,@(gen-eqs b1...bm bb1...bbm))))))
    (if unconditional
        `(defthm ,name
           ,core
           ,@(and hints (list :hints hints)))
      `(defthm ,name
         (implies (and (,domb ,@b1...bm)
                       (,domb ,@bb1...bbm))
                  ,core)
         ,@(and hints (list :hints hints))))))

(defmacro defthm-doma-guard (&key
                             (name 'doma-guard)
                             (a1...an '(a))
                             (g-doma 'g-doma))
  `(defthm ,name
     (,g-doma ,@a1...an)))

(defmacro defthm-domb-guard (&key
                             (name 'domb-guard)
                             (b1...bm '(b))
                             (g-domb 'g-domb))
  `(defthm ,name
     (,g-domb ,@b1...bm)))

(defmacro defthm-alpha-guard (&key
                              (name 'alpha-guard)
                              (a1...an '(a))
                              (doma 'doma)
                              (g-alpha 'g-alpha))
  `(defthm ,name
     (implies (,doma ,@a1...an)
              (,g-alpha ,@a1...an))))

(defmacro defthm-beta-guard (&key
                             (name 'beta-guard)
                             (b1...bm '(b))
                             (domb 'domb)
                             (g-beta 'g-beta))
  `(defthm ,name
     (implies (,domb ,@b1...bm)
              (,g-beta ,@b1...bm))))

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

; Generate all the DEFMAPPING theorems whose name is not NIL.

(defmacro defthm-all (&key (alpha-image 'alpha-image)
                           (beta-image 'beta-image)
                           (beta-of-alpha 'beta-of-alpha)
                           (alpha-of-beta 'alpha-of-beta)
                           (alpha-injective 'alpha-injective)
                           (beta-injective 'beta-injective)
                           (doma-guard 'doma-guard)
                           (domb-guard 'domb-guard)
                           (alpha-guard 'alpha-guard)
                           (beta-guard 'beta-guard)
                           unconditional
                           (doma 'doma)
                           (domb 'domb)
                           (alpha 'alpha)
                           (beta 'beta)
                           (g-doma 'g-doma)
                           (g-domb 'g-domb)
                           (g-alpha 'g-alpha)
                           (g-beta 'g-beta)
                           (a1...an '(a))
                           (b1...bm '(b))
                           (aa1...aan '(a$))
                           (bb1...bbm '(b$)))
  `(progn
     (defthm-alpha-image
       :name ,alpha-image
       :a1...an ,a1...an
       :b1...bm ,b1...bm
       :doma ,doma
       :domb ,domb
       :alpha ,alpha)
     (defthm-beta-image
       :name ,beta-image
       :a1...an ,a1...an
       :b1...bm ,b1...bm
       :doma ,doma
       :domb ,domb
       :beta ,beta)
     ,@(and beta-of-alpha
            `((defthm-beta-of-alpha
                :name ,beta-of-alpha
                :a1...an ,a1...an
                :b1...bm ,b1...bm
                :doma ,doma
                :alpha ,alpha
                :beta,beta
                :aa1...aan ,aa1...aan
                :unconditional ,unconditional)))
     ,@(and alpha-of-beta
            `((defthm-alpha-of-beta
                :name ,alpha-of-beta
                :a1...an ,a1...an
                :b1...bm ,b1...bm
                :domb ,domb
                :alpha ,alpha
                :beta ,beta
                :bb1...bbm ,bb1...bbm
                :unconditional ,unconditional)))
     ,@(and alpha-injective
            `((defthm-alpha-injective
                :name ,alpha-injective
                :a1...an ,a1...an
                :aa1...aan ,aa1...aan
                :doma ,doma
                :alpha ,alpha
                :unconditional ,unconditional)))
     ,@(and beta-injective
            `((defthm-beta-injective
                :name ,beta-injective
                :b1...bm ,b1...bm
                :bb1...bbm ,bb1...bbm
                :domb ,domb
                :beta ,beta
                :unconditional ,unconditional)))
     ,@(and doma-guard
            `((defthm-doma-guard
                :name ,doma-guard
                :a1...an ,a1...an
                :g-doma ,g-doma)))
     ,@(and domb-guard
            `((defthm-domb-guard
                :name ,domb-guard
                :b1...bm ,b1...bm
                :g-domb ,g-domb)))
     ,@(and alpha-guard
            `((defthm-alpha-guard
                :name ,alpha-guard
                :a1...an ,a1...an
                :doma ,doma
                :g-alpha ,g-alpha)))
     ,@(and beta-guard
            `((defthm-beta-guard
                :name ,beta-guard
                :b1...bm ,b1...bm
                :domb ,domb
                :g-beta ,g-beta)))))

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

; Generate generic domains and conversions with guards, for n = m = 1.

(defmacro definputs-guarded-1-1 ()

  '(encapsulate

     (((doma *) => * :formals (a) :guard (g-doma a))
      ((domb *) => * :formals (b) :guard (g-domb b))
      ((alpha *) => * :formals (a) :guard (g-alpha a))
      ((beta *) => * :formals (b) :guard (g-beta b))
      ((g-doma *) => *) ; guard of DOMA
      ((g-domb *) => *) ; guard of DOMB
      ((g-alpha *) => *) ; guard of ALPHA
      ((g-beta *) => *)) ; guard of BETA

     ;; identity conversion over all values to witness:
     (local (defun doma (a) (declare (ignore a)) t))
     (local (defun domb (b) (declare (ignore b)) t))
     (local (defun alpha (a) a))
     (local (defun beta (b) b))
     (local (defun g-doma (a) (declare (ignore a)) t))
     (local (defun g-domb (b) (declare (ignore b)) t))
     (local (defun g-alpha (a) (doma a)))
     (local (defun g-beta (b) (domb b)))

     ;; applicability conditions:
     (defthm-alpha-image)
     (defthm-beta-image)
     (defthm-beta-of-alpha)
     (defthm-alpha-of-beta)
     (defthm-beta-of-alpha :name beta-of-alpha-uncond :unconditional t)
     (defthm-alpha-of-beta :name alpha-of-beta-uncond :unconditional t)
     (defthm-doma-guard)
     (defthm-domb-guard)
     (defthm-alpha-guard)
     (defthm-beta-guard)

     (in-theory (disable alpha-image
                         beta-image
                         beta-of-alpha
                         alpha-of-beta
                         beta-of-alpha-uncond
                         alpha-of-beta-uncond
                         doma-guard
                         domb-guard
                         alpha-guard
                         beta-guard))))

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

; Generate generic domains and conversions with guards, for n = 2 and m = 1.

(defmacro definputs-guarded-2-1 ()

  '(encapsulate

     (((doma * *) => * :formals (a1 a2) :guard (g-doma a1 a2))
      ((domb *) => * :formals (b) :guard (g-domb b))
      ((alpha * *) => * :formals (a1 a2) :guard (g-alpha a1 a2))
      ((beta *) => (mv * *) :formals (b) :guard (g-beta b))
      ((g-doma * *) => *) ; guard of DOMA
      ((g-domb *) => *) ; guard of DOMB
      ((g-alpha * *) => *) ; guard of ALPHA
      ((g-beta *) => *)) ; guard of BETA

     ;; conversion between pairs of values and single CONSP values to witness:
     (local (defun doma (a1 a2) (declare (ignore a1 a2)) t))
     (local (defun domb (b) (consp b)))
     (local (defun alpha (a1 a2) (cons a1 a2)))
     (local (defun beta (b) (mv (car b) (cdr b))))
     (local (defun g-doma (a1 a2) (declare (ignore a1 a2)) t))
     (local (defun g-domb (b) (declare (ignore b)) t))
     (local (defun g-alpha (a1 a2) (doma a1 a2)))
     (local (defun g-beta (b) (domb b)))

     ;; applicability conditions:
     (defthm-alpha-image :a1...an (a1 a2))
     (defthm-beta-image :a1...an (a1 a2))
     (defthm-beta-of-alpha :a1...an (a1 a2) :aa1...aan (aa1 aa2))
     (defthm-alpha-of-beta :a1...an (a1 a2))
     (defthm-doma-guard :a1...an (a1 a2))
     (defthm-domb-guard)
     (defthm-alpha-guard :a1...an (a1 a2))
     (defthm-beta-guard)

     (in-theory (disable alpha-image
                         beta-image
                         beta-of-alpha
                         alpha-of-beta
                         doma-guard
                         domb-guard
                         alpha-guard
                         beta-guard))))

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

; Generate generic domains and conversions with guards, for n = 1 and m = 2.

(defmacro definputs-guarded-1-2 ()

  '(encapsulate

     (((doma *) => * :formals (a) :guard (g-doma a))
      ((domb * *) => * :formals (b1 b2) :guard (g-domb b1 b2))
      ((alpha *) => (mv * *) :formals (a) :guard (g-alpha a))
      ((beta * *) => * :formals (b1 b2) :guard (g-beta b1 b2))
      ((g-doma *) => *) ; guard of DOMA
      ((g-domb * *) => *) ; guard of DOMB
      ((g-alpha *) => *) ; guard of ALPHA
      ((g-beta * *) => *)) ; guard of BETA

     ;; conversion between single CONSP values and pairs of values to witness:
     (local (defun doma (a) (consp a)))
     (local (defun domb (b1 b2) (declare (ignore b1 b2)) t))
     (local (defun alpha (a) (mv (car a) (cdr a))))
     (local (defun beta (b1 b2) (cons b1 b2)))
     (local (defun g-doma (a) (declare (ignore a)) t))
     (local (defun g-domb (b1 b2) (declare (ignore b1 b2)) t))
     (local (defun g-alpha (a) (doma a)))
     (local (defun g-beta (b1 b2) (domb b1 b2)))

     ;; applicability conditions:
     (defthm-alpha-image :b1...bm (b1 b2))
     (defthm-beta-image :b1...bm (b1 b2))
     (defthm-beta-of-alpha :b1...bm (b1 b2))
     (defthm-alpha-of-beta :b1...bm (b1 b2) :bb1...bbm (bb1 bb2))
     (defthm-doma-guard)
     (defthm-domb-guard :b1...bm (b1 b2))
     (defthm-alpha-guard)
     (defthm-beta-guard :b1...bm (b1 b2))

     (in-theory (disable alpha-image
                         beta-image
                         beta-of-alpha
                         alpha-of-beta
                         doma-guard
                         domb-guard
                         alpha-guard
                         beta-guard))))

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

; Generate generic domains and conversions with guards, for n = m = 2.

(defmacro definputs-guarded-2-2 ()

  '(encapsulate
     (((doma * *) => * :formals (a1 a2) :guard (g-doma a1 a2))
      ((domb * *) => * :formals (b1 b2) :guard (g-domb b1 b2))
      ((alpha * *) => (mv * *) :formals (a1 a2) :guard (g-alpha a1 a2))
      ((beta * *) => (mv * *) :formals (b1 b2) :guard (g-beta b1 b2))
      ((g-doma * *) => *) ; guard of DOMA
      ((g-domb * *) => *) ; guard of DOMB
      ((g-alpha * *) => *) ; guard of ALPHA
      ((g-beta * *) => *)) ; guard of BETA

     ;; identity conversion over all pairs of values to witness:
     (local (defun doma (a1 a2) (declare (ignore a1 a2)) t))
     (local (defun domb (b1 b2) (declare (ignore b1 b2)) t))
     (local (defun alpha (a1 a2) (mv a1 a2)))
     (local (defun beta (b1 b2) (mv b1 b2)))
     (local (defun g-doma (a1 a2) (declare (ignore a1 a2)) t))
     (local (defun g-domb (b1 b2) (declare (ignore b1 b2)) t))
     (local (defun g-alpha (a1 a2) (doma a1 a2)))
     (local (defun g-beta (b1 b2) (domb b1 b2)))

     ;; applicability conditions:
     (defthm-alpha-image :a1...an (a1 a2) :b1...bm (b1 b2))
     (defthm-beta-image :a1...an (a1 a2) :b1...bm (b1 b2))
     (defthm-beta-of-alpha
       :a1...an (a1 a2) :b1...bm (b1 b2) :aa1...aan (aa1 aa2))
     (defthm-alpha-of-beta
       :a1...an (a1 a2) :b1...bm (b1 b2) :bb1...bbm (bb1 bb2))
     (defthm-beta-of-alpha
       :name beta-of-alpha-uncond
       :a1...an (a1 a2)
       :b1...bm (b1 b2)
       :aa1...aan (aa1 aa2)
       :unconditional t)
     (defthm-alpha-of-beta
       :name alpha-of-beta-uncond
       :a1...an (a1 a2)
       :b1...bm (b1 b2)
       :bb1...bbm (bb1 bb2)
       :unconditional t)
     (defthm-doma-guard :a1...an (a1 a2))
     (defthm-domb-guard :b1...bm (b1 b2))
     (defthm-alpha-guard :a1...an (a1 a2))
     (defthm-beta-guard :b1...bm (b1 b2))

     (in-theory (disable alpha-image
                         beta-image
                         beta-of-alpha
                         alpha-of-beta
                         doma-guard
                         domb-guard
                         alpha-guard
                         beta-guard))))

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

; Generate commands to disable the generic theorems.

(defmacro enable-all ()
  `(in-theory (enable alpha-image
                      beta-image
                      beta-of-alpha
                      alpha-of-beta
                      doma-guard
                      domb-guard
                      alpha-guard
                      beta-guard)))

(defmacro enable-all-uncond ()
  `(in-theory (enable alpha-image
                      beta-image
                      beta-of-alpha-uncond
                      alpha-of-beta-uncond
                      doma-guard
                      domb-guard
                      alpha-guard
                      beta-guard)))
