; Introduction of an arbitrary tail-recursive function.
;  Construction based on flat domains in ACL2.
; Copyright (C) 2001  John R. Cowles, University of Wyoming

; This book is free software; you can redistribute it and/or modify
; it under the terms of the GNU General Public License as published by
; the Free Software Foundation; either version 2 of the License, or
; (at your option) any later version.

; This book is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
; GNU General Public License for more details.

; You should have received a copy of the GNU General Public License
; along with this book; if not, write to the Free Software
; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

; Written by:
; John Cowles
; Department of Computer Science
; University of Wyoming
; Laramie, WY 82071-3682 U.S.A.

; Fall 2001.
;  Last modified 20 December 2001.
#|
 To certify (originally in ACL2 Version 2.6):
 (defpkg
     "FLAT" (union-eq
	      *acl2-exports*
	      *common-lisp-symbols-from-main-lisp-package*))

 (certify-book "flat-tail" 1 nil ; compile-flg
	       :defaxioms-okp nil
	       :skip-proofs-okp nil)
|#
(in-package "FLAT")
(include-book "flat")
#|
A construction based on flat domains in ACL2, as introduced in
flat.lisp, of a function f that satisfies the equation in the
following theorem,

(defthm generic-tail-recursive-f
  (equal (f x)
	 (if (test x) (base x) (f (st x))))).

As reported in defpun.lisp, Pete & J give an alternative (and
simpler) construction of such a tail-recursive f.
|#
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Add some basic arithmetic facts:

(local
 (defthm
   commutativity-2-of-+
   (equal (+ x y z)
	  (+ y x z))))

(local
 (defthm
   associate-constants-left-+
   (implies (and (syntaxp (quotep x))
		 (syntaxp (quotep y)))
	    (equal (+ x (+ y z))
		   (+ (+ x y) z)))))

(local
 (defthm
   minus-inverse-+-a
   (implies (acl2-numberp y)
	    (equal (+ (- x) x y)
		   y))))

(local
 (defthm
   minus-inverse-+-b
   (implies (acl2-numberp y)
	    (equal (+ x (- x) y)
		   y))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Proceed with the construction:

(defstub
  test (*) => *)

(defstub
  base (*) => *)

(defstub
  st (*) => *)

(defun
    f-chain (i x)
    (if (zp i)
	($bottom$)
        (if (test x)
	    (base x)
	  (f-chain (- i 1)(st x)))))

(defthm
    base-of-f-chain=$bottom$
    (implies (zp i)
	     (equal (f-chain i x)
		    ($bottom$))))

(defthm
    f-chain-is-$<=$-chain
    (implies (and (integerp i)
		  (>= i 0))
	     ($<=$ (f-chain i x)
		   (f-chain (+ 1 i) x))))

;; Choose an ``index'' for definition of lub of f-chain:

(defchoose
    lub-f-chain-i i (x)
    (not (equal (f-chain i x)
		($bottom$))))

(defthm
    lub-f-chain-i-rewrite
    (implies (equal (f-chain (lub-f-chain-i x) x)
		    ($bottom$))
	     (equal (f-chain i x) ($bottom$)))
    :hints (("Goal"
	     :use lub-f-chain-i)))

;; Make sure the chosen index is a nonneg. integer:

(defun
    lub-f-chain-nat-i (x)
    (nfix (lub-f-chain-i x)))

;; Define the least upper bound of f-chain:

(defun
    lub-f-chain (x)
    (f-chain (lub-f-chain-nat-i x) x))

(in-theory (disable (:executable-counterpart
		     lub-f-chain)))

(defthm
    lub-f-chain-is-upper-bound
    ($<=$ (f-chain i x)
	  (lub-f-chain x))
    :hints (("Goal"
	     :by
	     (:functional-instance
	      lub-$bottom$-based-chain-is-upper-bound
	      ($bottom$-based-chain f-chain)
	      (lub-$bottom$-based-chain lub-f-chain)
	      (lub-$bottom$-based-chain-nat-i lub-f-chain-nat-i)
	      (lub-$bottom$-based-chain-i lub-f-chain-i)))
	    ("Subgoal 2"
	     :use f-chain-is-$<=$-chain)))

(defun
    f (x)
    (lub-f-chain x))

(defun
    g-chain (i x)
    (f-chain (+ 1 i) x))

(defun
    ub-g-chain (x)
    (if (test x)
	(base x)
        (f (st x))))

(defthm
    g-chain-$<=$-ub-g-chain
    (implies (and (integerp i)
		  (>= i 0))
	     ($<=$ (g-chain i x)
		   (ub-g-chain x)))
    :hints (("Subgoal 2"
	     :in-theory (disable lub-f-chain-is-upper-bound)
	     :use (:instance
		   lub-f-chain-is-upper-bound
		   (x (st x))))))

(defun
    Skolem-f (x)
    (lub-f-chain-nat-i (st x)))

(defthm
    ub-g-chain-=-g-chain-Skolem-f
    (equal (ub-g-chain x)
	   (g-chain (Skolem-f x) x)))

(defthm
    lub-f-chain=ub-g-chain
    (equal (lub-f-chain x)(ub-g-chain x))
    :rule-classes nil
    :hints (("Goal"
	     :by
	     (:functional-instance
	      lub-$chain$=ub-shifted-$chain$
	      ($chain$ f-chain)
	      (lub-$chain$ lub-f-chain)
	      (lub-$chain$-i lub-f-chain-i)
	      (lub-$chain$-nat-i lub-f-chain-nat-i)
	      ($f$ Skolem-f)
	      (shifted-$chain$ g-chain)
	      (ub-shifted-$chain$ ub-g-chain)))
	    ("Subgoal 5"
	     :use g-chain-$<=$-ub-g-chain)
	    ("Subgoal 4"
	     :use f-chain-is-$<=$-chain)
	    ))

(defthm
    generic-tail-recursive-f
    (equal (f x)
	   (if (test x)
	       (base x)
	     (f (st x))))
  :hints (("Goal"
	   :use lub-f-chain=ub-g-chain)))
