(in-package "ACL2")

;; Author: Sandip Ray

;; This book provides a macro defsimulate+ which is an augmentation of
;; defsimulate with function invocation support.  This version only
;; supports partial correctness.

;; Note: This book depends on the existence of an include-book-dir
;; :symbolic that points to the top-level directory containing the
;; books.  For the current version I have: 

;; (add-include-book-dir :symbolic "/u/sandip/Dropbox/research/projects/symbolic/starting-over")

;;; RBK: But I didn't like this, so I moved the include book to the
;;; top of the file.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  Section 1: Basic functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; I include the ordinals and defp books since they are necessary for
;; the functions generated by defsimulate+.

;;; RBK: try different ordinal books, to prevent problems with
;;; arithmetic-5 compatibility.
(include-book "ordinals/limits" :dir :system)
(in-theory (disable o< o+ o- o* o^))
(local (include-book "arithmetic/top-with-meta" :dir :system))
(include-book "misc/defp" :dir :system)
(include-book "extended-partial-correctness")

(defun snoc (x e)
  (cond ((endp x) (list e))
        (t (cons (first x) (snoc (rest x) e)))))

(defun dellast (x)
  (cond ((endp x) nil)
        ((endp (rest x)) nil)
        (t (cons (first x) (dellast (rest x))))))
    

(defun lastval (x)
  (cond ((endp x) nil)
        ((endp (rest x)) (first x))
        (t (lastval (rest x)))))

(defun packn+ (x package)
  (declare (xargs :mode :program))
  (let ((ans (coerce (packn1 x) 'string)))
    (intern-in-package-of-symbol ans (pkg-witness package))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  Section 2: The Heart of the functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; This function has a big bunch of parameters, but I think this is
;; manageable.  Most of the parameters are about tweaking function
;; names.

(defun defsimulate+-core 
  (next run

   params 

   subroutine-term insub existsexitpointsub stepstoexitpointsub
   stepstoexitpointsub-tail nextexitpointsub   
   
   premain inmain cutpoint assertion modifymain
   exitsteps exists-next-exitpoint next-exitpoint
   correctness-theorem 

   hints package)

  (declare (xargs :mode :program))

  (let* (
         ;; I have it drilled in my brain that the last parameter of
         ;; the function is the state component, and the first
         ;; parameter is the s0 (pre-state) component.

         (st (lastval params))
         (s0 (first params))

         ;; params includes both s0 and st.  params- does not include
         ;; s0.  Actually params- is used everywhere, --- params is
         ;; used only in assertion.
         
         (params- (rest params))
         (params+i (snoc params- 'i))
         (nextterm (list next st))
         (insubterm (cons insub params-))
         ;; RBK: Hmmm.  I had to comment these out.
         ;;(presubterm (cons '$$$presub params-))
         ;;(nextexitpointsubterm (cons nextexitpointsub params-))
         ;;(modifysubterm (cons '$$$modifysub params-))
         (cutterm (cons cutpoint params-))
         (premainterm (cons premain params-))
         (inmainterm (cons inmain params-))
         (existsexitpointsubterm (cons existsexitpointsub params-))
         (assertterm (cons assertion params))
         (modifyterm (cons modifymain params-))
         (exitsteps-tail (packn+ (list exitsteps '-tail) package))
         )
  `(encapsulate
    ()
    
    (local (deftheory user-theory (current-theory :here)))

    ;; First deal with generic requirements for subroutines.
    (local ,subroutine-term)


    ;; Now some easy theorems about the main program
    (local 
     (defthm $$$pre-implies-assertion
      (implies ,premainterm
               (let ((,s0 ,st))
                 ,assertterm))
      :rule-classes nil))

    (local
     (defthm $$$assertion-main-implies-post
       (implies (and ,assertterm
                     (not ,inmainterm))
                (equal ,st 
                       (let ((,st ,s0))
                         ,modifyterm)))
       :rule-classes nil))

    (local
     (defthm $$$assertion-implies-cutpoint
       (implies ,assertterm
                (or ,cutterm 
                    (not ,inmainterm)))
       :rule-classes nil))

    ;;; RBK: made local
    (local
     (in-theory (theory 'ground-zero)))
    
    (local 
     (defun-sk $$$exists-next-cutpoint ,params-
       (exists n 
               (let* ((,st (,run ,st n)))
                ,cutterm))))


     
    (local 
     (in-theory (union-theories (theory 'user-theory)
                                (list '$$$defp-symsim-theorem))))

    (local
     (defthm $$$assertion-invariant-over-cutpoints
       (implies (and ,assertterm
                     ,inmainterm
                     (let* ((,st (,run ,st n)))
                       (not ,inmainterm)))
                (let* ((,st (,next ,st))
                       (,st ($$$next-cutpoint-main
                             ,@params-)))
                  ,assertterm))
     :rule-classes nil
     :hints ,hints))

    ;;; RBK: made local
    (local
     (in-theory (theory 'ground-zero)))

    (defp ,exitsteps-tail ,params+i
      (if (not ,inmainterm) i
        (let* ((,st ,nextterm))
          (,exitsteps-tail ,@(snoc params- '(1+ i))))))



    (defun ,exitsteps ,params-
      (let* ((steps (,exitsteps-tail
                       ,@(snoc params- 0)))
             (,st (,run ,st steps)))
        (if (not ,inmainterm)
            steps
          (omega))))

    (defun-sk ,exists-next-exitpoint ,params-
      (exists n 
              (let* ((,st (,run ,st n)))
                (not ,inmainterm))))

    (defun ,next-exitpoint ,params-
      (let* ((steps (,exitsteps ,@params-)))
        (,run ,st steps)))
    
    ;;; RBK: Moved to top of file, for ease of use.
    ;;;(local
    ;;; (include-book 
    ;;;  "extended-partial-correctness" :dir :symbolic))

    (local 
     (in-theory (theory 'minimal-theory)))

    (defthm ,correctness-theorem
      (implies (and ,premainterm
                    (,exists-next-exitpoint ,@params-))
               (and (let ((,st (,next-exitpoint ,@params-)))
                      (not ,inmainterm))
                    (equal (,next-exitpoint ,@params-)
                           ,modifyterm)))
  :otf-flg t
  :rule-classes nil
  :hints (("Goal"
           :use ((:instance 
                  (:functional-instance 
                   |epc composite partial correctness|
                   (epc-next (lambda (s) (let ((,st s)) ,nextterm)))
                   (epc-run (lambda (s n) (,run s n)))
                   (exists-epc-next-cutpoint 
                    (lambda (s)
                      (let ((,st s)) 
                        ($$$exists-next-cutpoint ,@params-))))
                   (exists-epc-next-cutpoint-witness 
                    (lambda (s)
                      (let ((,st s))
                          ($$$exists-next-cutpoint-witness ,@params-))))
                   (epc-pre-sub (lambda (s) 
                              (let ((,st s)) ($$$presub ,@params-))))
                   (epc-in-sub (lambda (s) 
                             (let((,st s)) ,insubterm)))
                   (epc-exists-exitpoint-sub 
                    (lambda (s) 
                      (let ((,st s)) ,existsexitpointsubterm)))
                   (epc-exists-exitpoint-sub-witness
                    (lambda (s) 
                      (let ((,st s))
                        (,(packn+ (list existsexitpointsub '-witness)
                                  package)
                         ,@params-))))
                   (epc-steps-to-exitpoint-tail-sub
                    (lambda (s i)
                      (let ((,st s)) (,stepstoexitpointsub-tail ,@params+i))))
                   (epc-modify-sub 
                    (lambda (s) 
                      (let ((,st s))
                        ($$$modifysub ,@params-))))
                   (epc-next-exitpoint-sub 
                    (lambda (s) 
                      (let ((,st s))
                        (,nextexitpointsub  ,@params-))))
                   (epc-steps-to-exitpoint-sub 
                    (lambda (s)
                      (let ((,st s))
                        (,stepstoexitpointsub ,@params-))))

                   (epc-pre-main (lambda (s) 
                               (let ((,st s)) ,premainterm)))
                                 
                   (epc-cutpoint-main 
                    (lambda (s)
                      (let ((,st s)) ,cutterm)))
                   (epc-exists-exitpoint-main 
                    (lambda (s)
                      (let ((,st s))
                        (,exists-next-exitpoint ,@params-))))
                   (epc-exists-exitpoint-main-witness
                    (lambda (s)
                      (let ((,st s))
                        (,(packn+ (list exists-next-exitpoint
                                        '-witness) 
                                  package)
                         ,@params-))))
                   (epc-next-exitpoint-main 
                    (lambda (s) 
                      (let ((,st s))
                        (,next-exitpoint ,@params-))))
                   (epc-exitsteps-main
                    (lambda (s) 
                      (let ((,st s))
                        (,exitsteps ,@params-))))
                   (epc-exitsteps-main-tail
                    (lambda (s i)
                      (let ((,st s))
                        (,exitsteps-tail ,@params+i))))
                   (epc-in-main (lambda (s) 
                              (let ((,st s)) ,inmainterm)))
                                
                   (epc-next-epc-cutpoint-main 
                    (lambda (s) 
                      (let ((,st s))
                        ($$$next-cutpoint-main ,@params-))))
                   (epc-assertion-main 
                    (lambda (s0 s)
                      (let ((,s0 s0)
                            (,st s))
                        ,assertterm)))
                   (epc-modify-main 
                    (lambda (s) 
                      (let ((,st s)) ,modifyterm))))
                  (s ,st))))
                        
          ("Subgoal 22"
           :use ((:instance
                  $$$assertion-invariant-over-cutpoints
                  (,s0 s0)
                  (,st s))))
          ("Subgoal 21"
           :use ((:instance $$$assertion-main-implies-post
                            (,s0 s0)
                            (,st s))))
          ("Subgoal 20"
           :use ((:instance $$$pre-implies-assertion
                            (,st s))))
          ("Subgoal 19"
           :use ((:instance $$$assertion-implies-cutpoint
                            (,s0 s0)
                            (,st s))))
          ("Subgoal 18"
           :use ((:instance  $$$presub-implies-insub
                             (,st s))))
          ("Subgoal 17"
           :use ((:instance $$$in-sub-implies-in-main
                            (,st s))))
          ("Subgoal 16"
           :use ((:instance $$$no-main-cutpoint-in-sub
                            (,st s))))
          ("Subgoal 15"
           :use 
           ((:instance 
             (:definition $$$exists-next-cutpoint)
             (,st s))))
                          
          ("Subgoal 14"
           :use 
           ((:instance $$$exists-next-cutpoint-suff
                       (,st s))))
          ("Subgoal 13"
           :use 
           ((:instance $$$next-cutpoint-main$def
                       (,st s))))
          ("Subgoal 12"
           :use ((:instance $$$correctness-of-sub
                            (,st s))))
          ("Subgoal 11"
           :use ((:instance 
                  ,(packn+ (list stepstoexitpointsub-tail '$def)
                           package)
                  (,st s))))
          ("Subgoal 10"
           :use 
           ((:instance 
             (:definition ,existsexitpointsub)
             (,st s))))
          ("Subgoal 9"
           :use 
           ((:instance 
             ,(packn+ (list existsexitpointsub '-suff) package)
             (,st s))))
          ("Subgoal 8"
           :use 
           ((:instance (:definition ,nextexitpointsub)
                       (,st s))))
          ("Subgoal 7"
           :use 
           ((:instance (:definition ,stepstoexitpointsub)
                       (,st s))))
                        
          ("Subgoal 6"
           :in-theory (enable ,run))

          ("Subgoal 5"
           :use ((:instance (:definition ,next-exitpoint)
                            (,st s))))
          ("Subgoal 4"
           :use ((:instance (:definition ,exitsteps)
                            (,st s))))
          ("Subgoal 3"
           :use ((:instance
                  ,(packn+ (list exitsteps-tail '$def) package)
                  (,st s))))
          ("Subgoal 2"
           :use ((:instance ,(packn+ (list exists-next-exitpoint
                                           '-suff) 
                                     package)
                            (,st s))))
          ("Subgoal 1"
           :use ((:instance (:definition ,exists-next-exitpoint)
                            (,st s)))))))))



;; The following event will be only executed if the insub is provided
;; as nil.  This is because the main theorem does assume that we have
;; proven some correctness of the subroutine.


(defun process-default-subroutines 
  (insub 
   exists-exitpoint-sub 
   steps-to-exitpoint-sub 
   steps-to-exitpoint-sub-tail 
   next-exitpoint-sub
   next run params inmain cutpoint)
  (let ((s (lastval params)))
    `(encapsulate
      ()

      
      (local (deftheory $$$subtheory (current-theory :here)))
      (local (in-theory (theory 'ground-zero)))

      (defun-nx ,insub ,params
         (declare (xargs :normalize nil))
         nil)
      
     (defun-nx $$$presub ,params 
        nil)

      (defun-nx $$$modifysub ,params
        (declare (xargs :normalize nil))
        "Should never see this in a proof")
      
      (defthm $$$no-main-cutpoint-in-sub
        (implies (,insub ,@params)
                 (not (,cutpoint ,@params)))
        :rule-classes nil)
      
      
      (defthm $$$in-sub-implies-in-main
        (implies (,insub ,@params)
                 (,inmain ,@params))
        :rule-classes nil)

      (defthm $$$presub-implies-insub
        (implies ($$$presub ,@params)
                 (,insub ,@params))
        :rule-classes nil)

      
      (defp ,steps-to-exitpoint-sub-tail ,(snoc params 'i)
        (if (not (,insub ,@params))
            i
          (let* ((,s (,next ,s)))
            (,steps-to-exitpoint-sub-tail ,@(snoc params '(1+ i))))))
      
      (defun-nx ,steps-to-exitpoint-sub ,params
        (declare (xargs :normalize nil))
        (let* ((steps (,steps-to-exitpoint-sub-tail ,@(snoc params 0)))
               (,s (,run ,s steps)))
          (if (not (,insub ,@params))
              steps 
            (omega))))
      
      (defun-nx ,next-exitpoint-sub ,params
        (,run ,s (,steps-to-exitpoint-sub ,@params)))
      
      (defun-sk ,exists-exitpoint-sub ,params
        (exists n
                (let* ((,s (,run ,s n)))
                  (not (,insub ,@params))))
        :witness-dcls ((declare (xargs :normalize nil))))
      
      (defthm $$$correctness-of-sub
        (implies (and ($$$presub ,@params)
                      (,exists-exitpoint-sub ,@params))
                 (and (let* ((,s (,next-exitpoint-sub ,@params)))
                        (not (,insub ,@params)))
                      (equal (,next-exitpoint-sub ,@params)
                             ($$$modifysub ,@params))))
        :rule-classes nil)
      
      (local (in-theory (theory 'ground-zero)))
      
      (defp $$$next-cutpoint-main ,params
        (if (or (,cutpoint ,@params)
                (not (,inmain ,@params)))
            ,s
          (let* ((,s (if ($$$presub ,@params)
                         ($$$modifysub ,@params)
                       (,next ,s))))
            ($$$next-cutpoint-main ,@params))))
      
      
      (defthm $$$defp-symsim-theorem
        (equal ($$$next-cutpoint-main ,@params)
               (if (or (,cutpoint ,@params)
                       (not (,inmain ,@params)))
                   ,s
                 ;;; RBK: ???
                 (let* ((,s (,next ,s)))
                   ($$$next-cutpoint-main ,@params))
                 ;;;($$$next-cutpoint-main ,@params)
                 ))
        :hints (("Goal"
                 :in-theory (enable $$$presub $$$modifysub)))))))

;; Now we get to the more non-trivial case, viz., when we actually do
;; have one or more subroutines.  The function
;; process-nontrivial-subroutine assumes that at least one subroutine
;; is present, so it should be called apropriately..

;; First a few auxilliary functions for accessing the different
;; components of subs.

(defun access-presub (sub params)
  (cons (first sub) params))

(defun access-modifysub (sub params)
  (cons (second sub) params))

(defun access-correctness-thm (sub)
  (third sub))

(defun construct-presub-list (subs params)
  (if (endp subs)
      nil
    (cons (access-presub (first subs) params)
          (construct-presub-list (rest subs) params))))

(defun construct-modifysub-list (subs params)
  (if (endp subs)
      nil
    (cons (access-presub (first subs) params)
          (construct-modifysub-list (rest subs) params))))

(defun construct-premodify-list (subs params)
  (if (endp subs)
      nil
    (cons (list (access-presub (first subs) params)
                  (access-modifysub (first subs) params))
            (construct-premodify-list (rest subs) params))))


;; The instance hint will be used in generating :use hint.  Maybe we
;; ought to use :cases hint, --- not decided on that yet.

(defun instance-hint (subs)
  (if (endp subs) nil
    (cons (list :instance (access-correctness-thm (first subs)))
          (instance-hint (rest subs)))))

(defun pre-modify-next-cutpoint (subs params next-cutpoint)
  (if (endp subs) nil
    (cons (list (access-presub (first subs) params)
                (cons next-cutpoint 
                      (snoc (dellast params) 
                            (access-modifysub (first subs) params))))
          (pre-modify-next-cutpoint (rest subs)
                                    params next-cutpoint))))

;; Here is the main function for processing the non-trivial
;; subroutines.

(defun process-nontrivial-subroutines 
  (;; RBK: Hmmm.  run was not being used
   ;; next run params
   next params
   subs insub 
   exists-exitpoint-sub next-exitpoint-sub
   cutpoint inmain)
  (let* ((presublist (construct-presub-list subs params))
         (s (lastval params))
         (pre-modify (construct-premodify-list subs params))
         (pre-modify-nc (pre-modify-next-cutpoint subs params '$$$next-cutpoint-main))
         (instance-hint (instance-hint subs)))

  `(encapsulate
    ()

    (local (deftheory subtheory (current-theory :here)))
    (local (in-theory (theory 'minimal-theory)))

    (defun-nx $$$presub ,params
      (declare (xargs :normalize nil))
      (or ,@presublist))

    (defun-nx $$$modifysub ,params
      (declare (xargs :normalize nil))
      (cond ,@(snoc pre-modify (list t s))))

    (defthm $$$presub-implies-insub
      (implies ($$$presub ,@params)
               (,insub ,@params))
      :hints (("Goal"
               :in-theory (union-theories (theory 'subtheory)
                                          (list '$$$presub '$$$modifysub))))
       :rule-classes nil)
    
    (defthm $$$no-main-cutpoint-in-sub
      (implies (,insub ,@params)
               (not (,cutpoint ,@params)))
      :hints (("Goal"
               :in-theory (union-theories (theory 'subtheory)
                                          (list '$$$presub '$$$modifysub))))
      :rule-classes nil)
  
    (defthm $$$in-sub-implies-in-main
      (implies (,insub ,@params)
               (,inmain ,@params))
      :hints (("Goal"
               :in-theory (union-theories (theory 'subtheory)
                                          (list '$$$presub '$$$modifysub))))
      :rule-classes nil)
    
    ;; One possible optimization is not to generate the subroutine
    ;; correctness theorem if there is only one subroutine (since the
    ;; user has already proven that theorem and I can just use that.
    ;; But we note that this theorem is anyways proven in a very tight
    ;; theory so that optimization is probably not worth it.

    (defthm $$$correctness-of-sub
      (implies (and ($$$presub ,@params)
                    (,exists-exitpoint-sub ,@params))
               (and (let* ((,s (,next-exitpoint-sub ,@params)))
                      (not (,insub ,@params)))
                    (equal (,next-exitpoint-sub ,@params)
                           ($$$modifysub ,@params))))
      :hints (("Goal"
               :in-theory (enable $$$presub $$$modifysub)
               :use ,instance-hint))
      :rule-classes nil)

    (local (in-theory (theory 'ground-zero)))

    (defp $$$next-cutpoint-main ,params
      (if (or (,cutpoint ,@params)
              (not (,inmain ,@params)))
          ,s
        (let* ((,s (if ($$$presub ,@params)
                       ($$$modifysub ,@params)
                     (,next ,s))))
          ($$$next-cutpoint-main ,@params)))
      :rule-classes nil)
  
    (defthm $$$defp-symsim-theorem
      (equal ($$$next-cutpoint-main ,@params)
             (if (or (,cutpoint ,@params)
                     (not (,inmain ,@params)))
                 ,s
               (cond ,@(snoc pre-modify-nc
                             `(t (let* ((,s (,next ,s)))
                                   ($$$next-cutpoint-main ,@params)))))))
      :hints (("Goal"
               :use ((:instance $$$next-cutpoint-main$def)) 
               :in-theory (enable $$$presub $$$modifysub)))))))

;; Now package this all up to a single function. 

(defun defsimulate+-fn
  (next params run 
   subs insub exists-exitpoint-sub 
   steps-to-exitpoint-sub stepstoexitpointsub-tail
   next-exitpoint-sub
   precondition inmain cutpoint assertion modify 
   exitsteps exists-next-exitpoint next-exitpoint
   correctness-theorem 
   hints package)
  (declare (xargs :mode :program))

  (let* ((params- (rest params))
         (subroutine-term
          (if subs
              (process-nontrivial-subroutines 
               ;; RBK:
               ;; next run params- 
               next params-
               subs insub 
               exists-exitpoint-sub next-exitpoint-sub
               cutpoint inmain)
            (process-default-subroutines 
             insub
             exists-exitpoint-sub 
             steps-to-exitpoint-sub 
             stepstoexitpointsub-tail 
             next-exitpoint-sub
             next run params- inmain cutpoint))))
         
          (defsimulate+-core 
            next run

            params 

            subroutine-term insub exists-exitpoint-sub steps-to-exitpoint-sub
            stepstoexitpointsub-tail next-exitpoint-sub   

            precondition inmain cutpoint assertion modify
            exitsteps exists-next-exitpoint next-exitpoint
            correctness-theorem 

            hints package)))

;; And finally write a macro to call that function.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  Section 3: The User Interface
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmacro defsimulate+
  (next          
   &key 
   (assertion-params '(s0 s1))
   (run '$$$run)
   (subs 'nil)
   (insub '$$$insub)
   (exists-exitpoint-sub '$$$exists-exitpoint-sub)
   (steps-to-exitpoint-sub '$$$steps-to-exitpoint-sub)
   (steps-to-exitpoint-sub-tail '$$$steps-to-exitpoint-sub-tail)
   (next-exitpoint-sub '$$$next-exitpoint-sub)
   (precondition '$$$main-precondition)
   (inmain '$$$in-main-program)
   (cutpoint '$$$main-cutpoint)
   (assertion '$$$main-assertion)
   (modify '$$$modify-main)
   (exitsteps '$$$main-steps-to-exitpoint)
   (exists-next-exitpoint '$$$exists-next-exitpoint)
   (next-exitpoint '$$$next-main-exitpoint)
   (correctness-theorem '$$$correctness-of-main)
   (hints 'nil)
   (package '"ACL2"))

  (declare (xargs :guard (and (consp assertion-params)
                              (symbol-listp assertion-params)
                              (>= (len assertion-params) 2)
                              (symbolp run)
                              (symbolp insub)
                              (symbolp exists-exitpoint-sub)
                              (symbolp steps-to-exitpoint-sub)
                              (symbolp steps-to-exitpoint-sub-tail)
                              (symbolp next-exitpoint-sub)
                              (symbolp precondition)
                              (symbolp inmain)
                              (symbolp cutpoint)
                              (symbolp assertion)
                              (symbolp modify)
                              (symbolp exitsteps)
                              (symbolp exists-next-exitpoint)
                              (symbolp next-exitpoint)
                              (symbolp correctness-theorem))))
  (defsimulate+-fn 
    next assertion-params run 
    
    subs insub exists-exitpoint-sub 
    steps-to-exitpoint-sub steps-to-exitpoint-sub-tail
    next-exitpoint-sub
    
    precondition inmain cutpoint assertion modify 

    exitsteps exists-next-exitpoint next-exitpoint
    
    correctness-theorem 

    hints package))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  Section 4: Some testing
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(set-ignore-ok t)
(set-irrelevant-formals-ok t)

;; First one with no subroutine, just stress-testing the default.

(encapsulate
 ()

(local
 (defun try-next (s) s))

(local
 (defun try-run (s n)
   (if (zp n) s
     (try-run (try-next s) (- n 1)))))

(local
 (defun try-precondition (p q r) 
   (declare (ignore p q r))
   nil))

(local
 (defun try-inmain (a b s)
   (declare (ignore a b s))
   t))

(local 
 (defun try-cutpoint (a b s)
   (declare (ignore a b s))
   nil))

(local
(defun try-assertion (p a b s)
  (declare (ignore p a b s))
  nil))

(local
(defun try-modify (a b s)
  (declare (ignore a b s))
  nil))

(local
 (defsimulate+ 
   try-next 
   :assertion-params (a p q st)
   :run try-run 
   :assertion try-assertion
   :cutpoint try-cutpoint
   :precondition try-precondition
   :inmain try-inmain
   :modify try-modify)))

;; Second one, with more test.  Takes a while and can be commented out.

(encapsulate
 ()

 (local
  (defun try-next (s) 
    (declare (xargs :normalize nil))
    s))
 
 (local
  (defun try-run (s n)
    (if (zp n) s
      (try-run (try-next s) (- n 1)))))
 
 
 (local 
  (defun try-insub (p q s)
    t))
 
 (local
  (defun try-sub-precondition (p q s)
    (declare (xargs :normalize nil))
    nil))
 
 (local 
  (defun try-sub-modify (p q s)
    (declare (xargs :normalize nil))
    s))

 (local 
  (defp try-steps-to-exitpoint-tail-sub (p q st i)
    (if (not (try-insub p q st)) 
        i
      (try-steps-to-exitpoint-tail-sub p q (try-next st) (1+ i)))))

 (local 
  (defun try-steps-to-exitpoint-sub (p q st)
    (declare (xargs :normalize nil))
    (let ((steps (try-steps-to-exitpoint-tail-sub p q st 0)))
     (if (not (try-insub p q (try-run st steps)))
         steps 
       (omega)))))


 (local 
  (defun try-next-exitpoint-sub (p q st) 
    (try-run st (try-steps-to-exitpoint-sub p q st))))


 (local 
  (defun-sk try-exists-exitpoint (p q st)
    (exists n (not (try-insub p q (try-run st n))))
    :witness-dcls  ((declare (xargs :normalize nil)))))
  
 (local
  (defthm correctness-of-try
   (implies (and (try-sub-precondition p q st)
                 (try-exists-exitpoint p q st))
            (and (not (try-insub p q (try-next-exitpoint-sub p q st)))
             (equal (try-next-exitpoint-sub p q st)
                   (try-sub-modify p q st))))))

  
 (local
  (defun try-precondition (p q r) 
    (declare (ignore p q r))
    nil))
 
 (local
  (defun try-inmain (a b s)
    (declare (ignore a b s))
   t))
 
 (local 
  (defun try-cutpoint (a b s)
    (declare (ignore a b s))
    nil))
 
 (local
  (defun try-assertion (p a b s)
    (declare (ignore p a b s))
    nil))
 
 (local
  (defun try-modify (a b s)
    (declare (ignore a b s))
    nil))
 
 
 (local
  (encapsulate
   ()
   (local
    (defsimulate+ 
      try-next 
      :assertion-params (a p q st)
      :run try-run 
      :assertion try-assertion
      :cutpoint try-cutpoint
      :precondition try-precondition
      :inmain try-inmain
      :modify try-modify))))

 (local
  (encapsulate
   ()
   (local
    (defsimulate+ 
      try-next 
      :assertion-params (a p q st)
      :subs ((try-sub-precondition try-sub-modify correctness-of-try))
      :run try-run 
      :assertion try-assertion
      :cutpoint try-cutpoint
      :precondition try-precondition
      :inmain try-inmain
      :modify try-modify
      :insub try-insub
      :exists-exitpoint-sub try-exists-exitpoint
      :correctness-theorem correctness-with-one-sub
      :steps-to-exitpoint-sub try-steps-to-exitpoint-sub
      :steps-to-exitpoint-sub-tail try-steps-to-exitpoint-tail-sub
      :next-exitpoint-sub try-next-exitpoint-sub))))

 (local
  (encapsulate
   ()
   (local
    (defsimulate+ 
      try-next 
      :assertion-params (a p q st)
      :subs ((try-sub-precondition try-sub-modify correctness-of-try)
             (try-sub-precondition try-sub-modify correctness-of-try))
      :run try-run 
      :assertion try-assertion
      :cutpoint try-cutpoint
      :precondition try-precondition
      :inmain try-inmain
      :modify try-modify
      :insub try-insub
      :exists-exitpoint-sub try-exists-exitpoint
      :correctness-theorem correctness-with-two-subs
      :steps-to-exitpoint-sub try-steps-to-exitpoint-sub
      :steps-to-exitpoint-sub-tail try-steps-to-exitpoint-tail-sub
      :next-exitpoint-sub try-next-exitpoint-sub))))
 
 )

