; APT (Automated Program Transformations) Library
;
; Copyright (C) 2024 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 "ACL2")

(include-book "kestrel/soft/defequal" :dir :system)
(include-book "kestrel/soft/defunvar" :dir :system)
(include-book "kestrel/soft/defun2" :dir :system)
(include-book "kestrel/soft/defun-sk2" :dir :system)

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

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

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

; Generate a function variable.

(defmacro gen-funvar (&key name arity)
  `(defunvar ,name ,(repeat arity '*) => *))

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

; Generate a function stub.

(defmacro gen-stub (&key name arity)
  `(defstub ,name ,(repeat arity '*) => *))

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

; Generate the function OLD described in the user documentation.

(defmacro gen-old (&key (name 'old)
                        (?f '?f)
                        (iorel 'iorel)
                        (x 'x)
                        x1...
                        ...xn
                        a1...
                        ...am)
  (let ((x-x1...xn (append x1... (list x) ...xn))
        (x-a1...am (append a1... (list x) ...am)))
    `(defun-sk2 ,name ()
       (declare (xargs :guard t :verify-guards t))
       (forall ,x-x1...xn (,iorel ,@x-x1...xn (,?f ,@x-a1...am))))))

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

; Generate the function ALGO[?F1]...[?FP] described in the user documentation.

(defmacro gen-algo-divconq-list-0-1 (&key (name 'algo[?g][?h])
                                          (?g '?g)
                                          (?h '?h)
                                          (x 'x)
                                          z1...
                                          ...zm
                                          hints
                                          guard-hints)
  (let ((x-z1...zm (append z1... (list x) ...zm)))
    `(defun2 ,name ,x-z1...zm
       (declare (xargs
                 :measure (acl2-count ,x)
                 ,@(and hints (list :hints hints))
                 :guard t
                 :verify-guards t
                 :guard-hints ,guard-hints))
       (cond ((atom ,x) (,?g ,@x-z1...zm))
             (t (,?h ,@z1...
                     (car ,x)
                     ,@...zm
                     (,name ,@z1... (cdr ,x) ,@...zm)))))))

(defmacro gen-algo-divconq-list-0-1-2 (&key (name 'algo[?g0][?g1][?h])
                                            (?g0 '?g0)
                                            (?g1 '?g1)
                                            (?h '?h)
                                            (x 'x)
                                            z1...
                                            ...zm
                                            hints
                                            guard-hints)
  (let ((x-z1...zm (append z1... (list x) ...zm)))
    `(defun2 ,name ,x-z1...zm
       (declare (xargs
                 :measure (acl2-count ,x)
                 ,@(and hints (list :hints hints))
                 :guard t
                 :verify-guards t
                 :guard-hints ,guard-hints))
       (cond ((atom ,x) (,?g0 ,@x-z1...zm))
             ((atom (cdr ,x)) (,?g1 ,@z1... (car ,x) (cdr ,x) ,@...zm))
             (t (,?h ,@z1...
                     (car ,x)
                     ,@...zm
                     (,name ,@z1... (cddr ,x) ,@...zm)))))))

(defmacro gen-algo-divconq-oset-0-1 (&key (name 'algo[?g][?h])
                                          (?g '?g)
                                          (?h '?h)
                                          (x 'x)
                                          z1...
                                          ...zm
                                          hints
                                          guard-hints)
  (let ((x-z1...zm (append z1... (list x) ...zm)))
    `(defun2 ,name ,x-z1...zm
       (declare (xargs
                 :measure (acl2-count ,x)
                 ,@(and hints (list :hints hints))
                 :guard t
                 :verify-guards t
                 :guard-hints ,guard-hints))
       (cond ((or (not (set::setp ,x))
                  (set::emptyp ,x))
              (,?g ,@x-z1...zm))
             (t (,?h ,@z1...
                     (set::head ,x)
                     ,@...zm
                     (,name ,@z1... (set::tail ,x) ,@...zm)))))))

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

; Generate the function SPEC-0[?G] or SPEC-0[?G0]
; described in the user documentation.

(defmacro gen-spec-0-divconq-list-0-1 (&key (name 'spec-0[?g])
                                            (?g '?g)
                                            (x 'x)
                                            x1...
                                            ...xn
                                            a1...
                                            ...am
                                            (iorel 'iorel)
                                            guard-hints)
  (let ((x-x1...xn (append x1... (list x) ...xn))
        (x-a1...am (append a1... (list x) ...am)))
    `(defun-sk2 ,name  ()
       (declare (xargs :guard t
                       :verify-guards t
                       :guard-hints ,guard-hints))
       (forall ,x-x1...xn
               (impliez (atom ,x)
                        (,iorel ,@x-x1...xn (,?g ,@x-a1...am)))))))

(defmacro gen-spec-0-divconq-list-0-1-2 (&key (name 'spec-0[?g0])
                                              (?g0 '?g0)
                                              (x 'x)
                                              x1...
                                              ...xn
                                              a1...
                                              ...am
                                              (iorel 'iorel)
                                              guard-hints)
  (let ((x-x1...xn (append x1... (list x) ...xn))
        (x-a1...am (append a1... (list x) ...am)))
    `(defun-sk2 ,name  ()
       (declare (xargs :guard t
                       :verify-guards t
                       :guard-hints ,guard-hints))
       (forall ,x-x1...xn
               (impliez (atom ,x)
                        (,iorel ,@x-x1...xn (,?g0 ,@x-a1...am)))))))

(defmacro gen-spec-0-divconq-oset-0-1 (&key (name 'spec-0[?g])
                                            (?g '?g)
                                            (x 'x)
                                            x1...
                                            ...xn
                                            a1...
                                            ...am
                                            (iorel 'iorel)
                                            guard-hints)
  (let ((x-x1...xn (append x1... (list x) ...xn))
        (x-a1...am (append a1... (list x) ...am)))
    `(defun-sk2 ,name  ()
       (declare (xargs :guard t
                       :verify-guards t
                       :guard-hints ,guard-hints))
       (forall ,x-x1...xn
               (impliez (or (not (set::setp ,x))
                            (set::emptyp ,x))
                        (,iorel ,@x-x1...xn (,?g ,@x-a1...am)))))))

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

; Generate the function SPEC-1[?H] or SPEC-1[?G1]
; described in the user documentation.

(defmacro gen-spec-1-divconq-list-0-1 (&key (name 'spec-1[?h])
                                            (?h '?h)
                                            (x 'x)
                                            (y 'y)
                                            x1...
                                            ...xn
                                            a1...
                                            ...am
                                            (iorel 'iorel)
                                            guard-hints)
  (let ((x-x1...xn (append x1... (list x) ...xn)))
    `(defun-sk2 ,name ()
       (declare (xargs :guard t
                       :verify-guards t
                       :guard-hints ,guard-hints))
       (forall (,@x-x1...xn ,y)
               (impliez (and (consp ,x)
                             (,iorel ,@x1... (cdr ,x) ,@...xn ,y))
                        (iorel ,@x-x1...xn
                               (,?h ,@a1... (car ,x) ,@...am ,y)))))))

(defmacro gen-spec-1-divconq-list-0-1-2 (&key (name 'spec-1[?g1])
                                              (?g1 '?g1)
                                              (x 'x)
                                              x1...
                                              ...xn
                                              a1...
                                              ...am
                                              (iorel 'iorel)
                                              guard-hints)
  (let ((x-x1...xn (append x1... (list x) ...xn)))
    `(defun-sk2 ,name ()
       (declare (xargs :guard t
                       :verify-guards t
                       :guard-hints ,guard-hints))
       (forall (,@x-x1...xn)
               (impliez (and (consp ,x)
                             (atom (cdr ,x)))
                        (,iorel
                         ,@x-x1...xn
                         (,?g1 ,@a1... (car ,x) (cdr ,x) ,@...am)))))))

(defmacro gen-spec-1-divconq-oset-0-1 (&key (name 'spec-1[?h])
                                            (?h '?h)
                                            (x 'x)
                                            (y 'y)
                                            x1...
                                            ...xn
                                            a1...
                                            ...am
                                            (iorel 'iorel)
                                            guard-hints)
  (let ((x-x1...xn (append x1... (list x) ...xn)))
    `(defun-sk2 ,name ()
       (declare (xargs :guard t
                       :verify-guards t
                       :guard-hints ,guard-hints))
       (forall (,@x-x1...xn ,y)
               (impliez (and (set::setp ,x)
                             (not (set::emptyp ,x))
                             (,iorel ,@x1... (set::tail ,x) ,@...xn ,y))
                        (iorel ,@x-x1...xn
                               (,?h ,@a1... (set::head ,x) ,@...am ,y)))))))

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

; Generate the function SPEC-2[?H] described in the user documentation.

(defmacro gen-spec-2-divconq-list-0-1-2 (&key (name 'spec-2[?h])
                                              (?h '?h)
                                              (x 'x)
                                              (y 'y)
                                              x1...
                                              ...xn
                                              a1...
                                              ...am
                                              (iorel 'iorel)
                                              guard-hints)
  (let ((x-x1...xn (append x1... (list x) ...xn)))
    `(defun-sk2 ,name ()
       (declare (xargs :guard t
                       :verify-guards t
                       :guard-hints ,guard-hints))
       (forall (,@x-x1...xn ,y)
               (impliez (and (consp ,x)
                             (consp (cdr ,x))
                             (,iorel ,@x1... (cddr ,x) ,@...xn ,y))
                        (iorel ,@x-x1...xn
                               (,?h ,@a1... (car ,x) ,@...am ,y)))))))

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

; Generate the function EQUAL[?F][ALGO[?F1]...[?FP]]
; described in the user documentation.

(defmacro gen-equal-algo-divconq-list-0-1 (&key (name 'equal[?f][algo[?g][?h]])
                                                (?f '?f)
                                                (algo 'algo[?g][?h])
                                                (x 'x)
                                                z1...
                                                ...zm)
  (let ((x-z1...zm (append z1... (list x) ...zm)))
    `(defequal ,name
       :left ,?f
       :right ,algo
       :vars ,x-z1...zm)))

(defmacro gen-equal-algo-divconq-list-0-1-2
    (&key (name 'equal[?f][algo[?g0][?g1][?h]])
          (?f '?f)
          (algo 'algo[?g0][?g1][?h])
          (x 'x)
          z1...
          ...zm)
  (let ((x-z1...zm (append z1... (list x) ...zm)))
    `(defequal ,name
       :left ,?f
       :right ,algo
       :vars ,x-z1...zm)))

(defmacro gen-equal-algo-divconq-oset-0-1 (&key (name 'equal[?f][algo[?g][?h]])
                                                (?f '?f)
                                                (algo 'algo[?g][?h])
                                                (x 'x)
                                                z1...
                                                ...zm)
  (let ((x-z1...zm (append z1... (list x) ...zm)))
    `(defequal ,name
       :left ,?f
       :right ,algo
       :vars ,x-z1...zm)))

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

; Generate the function NEW described in the user documentation.

(defmacro gen-new-divconq-list-0-1 (&key (name 'new)
                                         (equal-algo 'equal[?f][algo[?g][?h]])
                                         (spec-0 'spec-0[?g])
                                         (spec-1 'spec-1[?h])
                                         guard-hints)
  `(defun2 ,name ()
     (declare (xargs :guard t :verify-guards t :guard-hints ,guard-hints))
     (and (,equal-algo)
          (,spec-0)
          (,spec-1))))

(defmacro gen-new-divconq-list-0-1-2
    (&key (name 'new)
          (equal-algo 'equal[?f][algo[?g0][?g1][?h]])
          (spec-0 'spec-0[?g0])
          (spec-1 'spec-1[?g1])
          (spec-2 'spec-2[?h])
          guard-hints)
  `(defun2 ,name ()
     (declare (xargs :guard t :verify-guards t :guard-hints ,guard-hints))
     (and (,equal-algo)
          (,spec-0)
          (,spec-1)
          (,spec-2))))

(defmacro gen-new-divconq-oset-0-1 (&key (name 'new)
                                         (equal-algo 'equal[?f][algo[?g][?h]])
                                         (spec-0 'spec-0[?g])
                                         (spec-1 'spec-1[?h])
                                         guard-hints)
  `(defun2 ,name ()
     (declare (xargs :guard t :verify-guards t :guard-hints ,guard-hints))
     (and (,equal-algo)
          (,spec-0)
          (,spec-1))))

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

; Generate the internal theorem ALGO-CORRECT
; (not described in the user documentation).

(defmacro gen-algo-correct-divconq-list-0-1 (&key (name 'algo-correct)
                                                  (spec-0 'spec-0[?g])
                                                  (spec-1 'spec-1[?h])
                                                  (algo 'algo[?g][?h])
                                                  (x 'x)
                                                  x1...
                                                  ...xn
                                                  a1...
                                                  ...am
                                                  (iorel 'iorel)
                                                  hints)
  (let ((x-x1...xn (append x1... (list x) ...xn))
        (x-a1...am (append a1... (list x) ...am)))
    `(defthm ,name
       (implies (and (,spec-0)
                     (,spec-1))
                (,iorel ,@x-x1...xn (,algo ,@x-a1...am)))
       :hints ,hints)))

(defmacro gen-algo-correct-divconq-list-0-1-2 (&key (name 'algo-correct)
                                                    (spec-0 'spec-0[?g0])
                                                    (spec-1 'spec-1[?g1])
                                                    (spec-2 'spec-2[?h])
                                                    (algo 'algo[?g0][?g1][?h])
                                                    (x 'x)
                                                    x1...
                                                    ...xn
                                                    a1...
                                                    ...am
                                                    (iorel 'iorel)
                                                    hints)
  (let ((x-x1...xn (append x1... (list x) ...xn))
        (x-a1...am (append a1... (list x) ...am)))
    `(defthm ,name
       (implies (and (,spec-0)
                     (,spec-1)
                     (,spec-2))
                (,iorel ,@x-x1...xn (,algo ,@x-a1...am)))
       :hints ,hints)))

(defmacro gen-algo-correct-divconq-oset-0-1 (&key (name 'algo-correct)
                                                  (spec-0 'spec-0[?g])
                                                  (spec-1 'spec-1[?h])
                                                  (algo 'algo[?g][?h])
                                                  (x 'x)
                                                  x1...
                                                  ...xn
                                                  a1...
                                                  ...am
                                                  (iorel 'iorel)
                                                  hints)
  (let ((x-x1...xn (append x1... (list x) ...xn))
        (x-a1...am (append a1... (list x) ...am)))
    `(defthm ,name
       (implies (and (,spec-0)
                     (,spec-1))
                (,iorel ,@x-x1...xn (,algo ,@x-a1...am)))
       :hints ,hints)))

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

; Generate the theorem OLD-IF-NEW described in the user documentation.

(defmacro gen-old-if-new (&key (name 'old-if-new)
                               (old 'old)
                               (new 'new)
                               hints)
  `(defthm ,name
     (implies (,new)
              (,old))
     :hints ,hints))

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

; Generate generic inputs of the transformation,
; for different values of n and m and
; different positions npos and mpos within 1,...,n and 1,...m
; (both npos and mpos are 0-based).

; generate list of variables X1, ..., Xn:
(defun gen-x1...xn (n)
  (cond ((zp n) nil)
        (t (append (gen-x1...xn (1- n)) (list (packn (list 'x n)))))))

; generate list of terms (A1 X1 ... Xn), ..., (Am X1 ... Xn):
(defun gen-a1...am (m x1...xn)
  (cond ((zp m) nil)
        (t (append (gen-a1...am (1- m) x1...xn)
                   (list `(,(packn (list 'a m)) ,@x1...xn))))))

; generate stubs for A1, ..., Am:
(defun gen-a1...am-stubs (m n)
  (cond ((zp m) nil)
        (t (append (gen-a1...am-stubs (1- m) n)
                   (list `(gen-stub :name ,(packn (list 'a m)) :arity ,n))))))

; generate generic inputs:
(defmacro gen-inputs (n npos m mpos)
  (let* ((x1...xn (gen-x1...xn n))
         (a1...am (gen-a1...am m x1...xn)))
    `(encapsulate ()
       (gen-funvar :name ?f :arity ,(1+ m))
       (gen-stub :name iorel :arity ,(+ 2 n))
       ,@(gen-a1...am-stubs m n)
       (gen-old :x1... ,(take npos x1...xn)
                :...xn ,(nthcdr npos x1...xn)
                :a1... ,(take mpos a1...am)
                :...am ,(nthcdr mpos a1...am)))))
