; Copyright (C) 2013, Regents of the University of Texas
; Written by Matt Kaufmann, April, 2013
; License: A 3-clause BSD license.  See the LICENSE file distributed with ACL2.

; Examples illustrating XARGS keyword :SPLIT-TYPES

(in-package "ACL2")

(include-book "misc/eval" :dir :system)

(defun nat-< (x y)
  (declare (xargs :guard t))
  (and (natp x)
       (natp y)
       (< x y)))

; First we have a traditional sort of definition, where :split-types is omitted
; and hence defaults to nil.  Notice that the guard incorporates the type
; declarations.

(defun f1 (x y)
  (declare (xargs :guard (nat-< x y))
           (type (integer -3 *) x)
           (type integer y))
  (assert$ (< x (* 2 y))
           (cons x y)))

(assert-event (equal (guard 'f1 nil (w state))
                     '(IF (NAT-< X Y)
                          (IF (IF (INTEGERP X) (NOT (< X '-3)) 'NIL)
                              (INTEGERP Y)
                              'NIL)
                          'NIL)))

; The next example is the result of adding :split-types t to the code just
; above.  This time, the type is not part of the guard.

(defun f2 (x y)
  (declare (xargs :guard (nat-< x y)
                  :split-types t)
           (type (integer -3 *) x)
           (type integer y))
  (assert$ (< x (* 2 y))
           (cons x y)))

(assert-event (equal (guard 'f2 nil (w state))
                     '(NAT-< X Y)))

; We can use :guard-debug with :split-types t.  The hypothesis of the form
; (EXTRA-INFO '(:GUARD (:TYPE F2-GUARD-DEBUG)) '(INSIST <term>))
; arise from the new guard proof obligation that the explicitly-provided :guard
; implies <term>, which is the conjunction of the terms derived from the type
; declarations.  We use :verify-guards nil so that we can see the proof
; obligation.

(defun f2-guard-debug (x y)
  (declare (xargs :guard (nat-< x y)
                  :split-types t
                  :verify-guards nil)
           (type (integer -3 *) x)
           (type integer y))
  (assert$ (< x (* 2 y))
           (cons x y)))

; Here is what we see printed by the verify-guards form below.

(defconst *f2-guard-debug-expected-proof-obligation*
  '(AND (IMPLIES (AND (EXTRA-INFO '(:GUARD (:TYPE F2-GUARD-DEBUG))
                                  '(INSIST (AND (AND (INTEGERP X) (<= -3 X))
                                                (INTEGERP Y))))
                      (NAT-< X Y))
                 (AND (AND (INTEGERP X) (<= -3 X))
                      (INTEGERP Y)))
        (IMPLIES (AND (EXTRA-INFO '(:GUARD (:BODY F2-GUARD-DEBUG))
                                  '(< X (* 2 Y)))
                      (NAT-< X Y))
                 (RATIONALP X))
        (IMPLIES (AND (EXTRA-INFO '(:GUARD (:BODY F2-GUARD-DEBUG))
                                  '(* 2 Y))
                      (NAT-< X Y))
                 (ACL2-NUMBERP Y))
        (IMPLIES (AND (EXTRA-INFO '(:GUARD (:BODY F2-GUARD-DEBUG))
                                  '(< X (* 2 Y)))
                      (NAT-< X Y))
                 (RATIONALP (* 2 Y)))
        (IMPLIES (AND (EXTRA-INFO '(:GUARD (:BODY F2-GUARD-DEBUG))
                                  '(ILLEGAL 'ASSERT$
                                            "Assertion failed:~%~x0"
                                            '((#\0 ASSERT$ (< X (* 2 Y))
                                                   (CONS X Y)))))
                      (NAT-< X Y))
                 (< X (* 2 Y)))))

; Now we check that the proof obligation is indeed what we have claimed it is,
; above.

(must-eval-to-t
 (mv-let
  (erp val state)
  (guard-obligation 'f2-guard-debug t 'top-level state)
  (value
   (and
    (not erp)
    (equal (prettyify-clause-set (cadr val) nil (w state))
           *f2-guard-debug-expected-proof-obligation*)))))

; Finally, we verify guards for f2-guard-debug.

(verify-guards f2-guard-debug
               :guard-debug t)

; And now we check that the guard really does NOT incorporate the formulas
; generated by the type declarations.

(assert-event (equal (guard 'f2-guard-debug nil (w state))
                     '(NAT-< X Y)))

; It is illegal to specify contradictory values for :split types in the same
; defun form.

(must-fail
 (defun f2-duplicate-keyword (x y)
   (declare (xargs :guard (nat-< x y)
                   :split-types t)
            (type (integer -3 *) x)
            (type integer y))
   (declare (xargs :split-types nil))
   (assert$ (< x (* 2 y))
            (cons x y))))

; However, we can provide :split-types t and :split-types nil to different
; defun forms within a mutual-recursion.

(mutual-recursion
 (defun evenlp (x)
   (declare (type (satisfies true-listp) x))
   (declare (xargs :split-types nil))
   (if (endp x) t (oddlp (cdr x))))
 (defun oddlp (x)
   (declare (xargs :guard (true-listp x)
                   :split-types t))
   (declare (type (or cons null) x))
   (if (endp x) nil (evenlp (cdr x)))))

(assert-event (equal (guard 'evenlp nil (w state))
                     '(TRUE-LISTP X)))
(assert-event (equal (guard 'oddlp nil (w state))
                     '(TRUE-LISTP X)))

; The following example is exactly like the immediately preceding one, except
; this time we leave implicit the declaration that :split-types is nil.

(mutual-recursion
 (defun evenlp2 (x)
   (declare (type (satisfies true-listp) x))
   (if (endp x) t (oddlp2 (cdr x))))
 (defun oddlp2 (x)
   (declare (xargs :guard (true-listp x)
                   :split-types t))
   (declare (type (or cons null) x))
   (if (endp x) nil (evenlp2 (cdr x)))))

(assert-event (equal (guard 'evenlp2 nil (w state))
                     '(TRUE-LISTP X)))
(assert-event (equal (guard 'oddlp2 nil (w state))
                     '(TRUE-LISTP X)))

; The following fails because the explicit :guard does not imply (<= x 10).

(must-fail
 (defun f3 (x y)
   (declare (xargs :guard (and (nat-< x y)
                               (< x 30))))
   (declare (type integer x))
   (declare (type (rational -10 10) x))
   (declare (xargs :split-types t))
   (cons x y)))

; But by changing the type declaration to allow x to go up to 50 instead of 10,
; we succeed.

(defun f3 (x y)
   (declare (xargs :guard (and (nat-< x y)
                               (< x 30))))
   (declare (type integer x))
   (declare (type (rational -10 50) x))
   (declare (xargs :split-types t))
   (cons x y))

; Next we check that if a type is declared, even a trivial one, then by default
; -- i.e., when (default-verify-guards-eagerness (w state)) is 1; see :DOC
; set-verify-guards-eagerness -- that type declaration is enough reason to
; verify guards, even if :split-types t tells us that the type is not part of
; the guard.

(defun f4 (x)
  (declare (xargs :split-types t)
           (type t x))
  x)

(assert-event (equal (symbol-class 'f4 (w state))
                     :common-lisp-compliant))

; The key idea of :split-types is that if its value is t, then the guard does
; not incorporate the type declarations and moreover, for guard verification
; the terms derived from the type declarations must be proved from the guard.
; The next two examples thus fail, since the type is not derivable from the
; (implicit) guard of T.  These two failures differ only in that one has a
; single declare form and the other has two declare forms; that distinction is
; irrelevant.  Finally, we show that the definition admits if :split-types is
; nil.

(must-fail
 (defun my-len-try1 (x)
   (declare (xargs :split-types t)
            (type (satisfies true-listp) x))
   (if (consp x) (1+ (my-len-try1 (cdr x))) 0)))

(must-fail
 (defun my-len-try2 (x)
   (declare (xargs :split-types t))
   (declare (type (satisfies true-listp) x))
   (if (consp x) (1+ (my-len-try2 (cdr x))) 0)))

(defun my-len (x)
  (declare (xargs :split-types nil))
  (declare (type (satisfies true-listp) x))
  (if (consp x) (1+ (my-len (cdr x))) 0))

; Redundancy requires the same :split-types value in each case.

(must-fail
 (defun my-len (x)
   (declare (xargs :split-types t))
   (declare (type (satisfies true-listp) x))
   (if (consp x) (1+ (my-len (cdr x))) 0)))

; Redundancy allows :split-types to be nil in one definition and omitted in the
; other.

(defun my-len (x)
  (declare (type (satisfies true-listp) x))
  (if (consp x) (1+ (my-len (cdr x))) 0))

(defun my-len (x)
  (declare (xargs :split-types nil))
  (declare (type (satisfies true-listp) x))
  (declare (xargs :split-types nil))
  (if (consp x) (1+ (my-len (cdr x))) 0))

; Redundancy checking catches a proposed definition with illegal ambiguity on
; :split-types.

(must-fail
 (defun my-len (x)
   (declare (xargs :split-types nil))
   (declare (type (satisfies true-listp) x))
   (declare (xargs :split-types t))
   (if (consp x) (1+ (my-len (cdr x))) 0)))

; Redundancy checking catches a proposed definition with an illegal value for
; :split-types.

(must-fail
 (defun my-len (x)
   (declare (xargs :split-types 17))
   (declare (type (satisfies true-listp) x))
   (if (consp x) (1+ (my-len (cdr x))) 0)))

(defun f5 (x)
  (declare (xargs :split-types t))
  x)

; Redundant.

(defun f5 (x)
  (declare (xargs :split-types t))
  (declare (xargs :split-types t))
  x)

; Not redundant (and illegal).

(must-fail
 (defun f5 (x)
   (declare (xargs :split-types t))
   (declare (xargs :split-types nil))
   x))

; Presence of :split-types does not trigger guard verification by default (need
; :guard, type, or :stobj declaration).

(defun f6 (x)
  (declare (xargs :split-types t))
  x)

(assert-event (equal (symbol-class 'f6 (w state))
                     :ideal)) ; not guard-verified
