(*
    Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      VcgEx.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2004-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

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

This library 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
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

section \<open>Examples using Statespaces\<close>

theory VcgExSP imports "../HeapList" "../Vcg" begin

subsection \<open>State Spaces\<close>

text \<open>
 First of all we provide a store of program variables that
 occur in the programs considered later.  Slightly unexpected
 things may happen when attempting to work with undeclared variables.
\<close>

hoarestate state_space =
  A :: nat
  I :: nat
  M :: nat
  N :: nat
  R :: nat
  S :: nat
  B :: bool
  Abr:: string

lemma (in state_space)"\<Gamma>\<turnstile> \<lbrace>\<acute>N = n\<rbrace> LOC \<acute>N :== 10;; \<acute>N :== \<acute>N + 2 COL \<lbrace>\<acute>N = n\<rbrace>"
  by vcg

text \<open>Internally we decorate the state components in the statespace with the
suffix \<open>_'\<close>,
to avoid cluttering the namespace with the simple names that could no longer
be used for logical variables otherwise.
\<close>

text \<open>We will first consider programs without procedures, later on
we will regard procedures without global variables and finally we
will get the full pictures: mutually recursive procedures with global
variables (including heap).
\<close>

subsection \<open>Basic Examples\<close>

text \<open>
 We look at few trivialities involving assignment and sequential
 composition, in order to get an idea of how to work with our
 formulation of Hoare Logic.
\<close>

text \<open>
 Using the basic rule directly is a bit cumbersome.
\<close>

lemma (in state_space) "\<Gamma>\<turnstile> {|\<acute>N = 5|} \<acute>N :== 2 * \<acute>N {|\<acute>N = 10|}"
  apply (rule HoarePartial.Basic)
  apply simp
  done

lemma (in state_space) "\<Gamma>\<turnstile> \<lbrace>True\<rbrace> \<acute>N :== 10 \<lbrace>\<acute>N = 10\<rbrace>"
  by vcg

lemma (in state_space) "\<Gamma>\<turnstile> \<lbrace>2 * \<acute>N = 10\<rbrace> \<acute>N :== 2 * \<acute>N \<lbrace>\<acute>N = 10\<rbrace>"
  by vcg

lemma (in state_space) "\<Gamma>\<turnstile> \<lbrace>\<acute>N = 5\<rbrace> \<acute>N :== 2 * \<acute>N \<lbrace>\<acute>N = 10\<rbrace>"
  apply vcg
  apply simp
  done

lemma (in state_space) "\<Gamma>\<turnstile> \<lbrace>\<acute>N + 1 = a + 1\<rbrace> \<acute>N :== \<acute>N + 1 \<lbrace>\<acute>N = a + 1\<rbrace>"
  by vcg

lemma (in state_space) "\<Gamma>\<turnstile> \<lbrace>\<acute>N = a\<rbrace> \<acute>N :== \<acute>N + 1 \<lbrace>\<acute>N = a + 1\<rbrace>"
  apply vcg
  apply simp
  done

lemma (in state_space)
  shows "\<Gamma>\<turnstile> \<lbrace>a = a \<and> b = b\<rbrace> \<acute>M :== a;; \<acute>N :== b \<lbrace>\<acute>M = a \<and> \<acute>N = b\<rbrace>"
  by vcg

lemma (in state_space)
  shows "\<Gamma>\<turnstile> \<lbrace>True\<rbrace> \<acute>M :== a;; \<acute>N :== b \<lbrace>\<acute>M = a \<and> \<acute>N = b\<rbrace>"
  by vcg

lemma (in state_space)
  shows "\<Gamma>\<turnstile> \<lbrace>\<acute>M = a \<and> \<acute>N = b\<rbrace>
                \<acute>I :== \<acute>M;; \<acute>M :== \<acute>N;; \<acute>N :== \<acute>I
              \<lbrace>\<acute>M = b \<and> \<acute>N = a\<rbrace>"
  apply vcg
  apply simp
  done

text \<open>
We can also perform verification conditions generation step by step by using
the \<open>vcg_step\<close> method.
\<close>

lemma (in state_space)
  shows "\<Gamma>\<turnstile> \<lbrace>\<acute>M = a \<and> \<acute>N = b\<rbrace>
               \<acute>I :== \<acute>M;; \<acute>M :== \<acute>N;; \<acute>N :== \<acute>I
              \<lbrace>\<acute>M = b \<and> \<acute>N = a\<rbrace>"
  apply vcg_step
  apply vcg_step
  apply vcg_step
  apply vcg_step
  apply simp
  done

text \<open>
 In the following assignments we make use of the consequence rule in
 order to achieve the intended precondition.  Certainly, the
 \<open>vcg\<close> method is able to handle this case, too.
\<close>

lemma (in state_space)
  shows "\<Gamma>\<turnstile> \<lbrace>\<acute>M = \<acute>N\<rbrace> \<acute>M :== \<acute>M + 1 \<lbrace>\<acute>M \<noteq> \<acute>N\<rbrace>"
proof -
  have "\<lbrace>\<acute>M = \<acute>N\<rbrace> \<subseteq> \<lbrace>\<acute>M + 1 \<noteq> \<acute>N\<rbrace>"
    by auto
  also have "\<Gamma>\<turnstile> \<dots> \<acute>M :== \<acute>M + 1 \<lbrace>\<acute>M \<noteq> \<acute>N\<rbrace>"
    by vcg
  finally show ?thesis .
qed

lemma (in state_space)
  shows "\<Gamma>\<turnstile> \<lbrace>\<acute>M = \<acute>N\<rbrace> \<acute>M :== \<acute>M + 1 \<lbrace>\<acute>M \<noteq> \<acute>N\<rbrace>"
proof -
  have "\<And>m n::nat. m = n \<longrightarrow> m + 1 \<noteq> n"
      \<comment> \<open>inclusion of assertions expressed in ``pure'' logic,\<close>
      \<comment> \<open>without mentioning the state space\<close>
    by simp
  also have "\<Gamma>\<turnstile> \<lbrace>\<acute>M + 1 \<noteq> \<acute>N\<rbrace> \<acute>M :== \<acute>M + 1 \<lbrace>\<acute>M \<noteq> \<acute>N\<rbrace>"
    by vcg
  finally show ?thesis .
qed

lemma (in state_space)
  shows "\<Gamma>\<turnstile> \<lbrace>\<acute>M = \<acute>N\<rbrace> \<acute>M :== \<acute>M + 1 \<lbrace>\<acute>M \<noteq> \<acute>N\<rbrace>"
  apply vcg
  apply simp
  done

subsection \<open>Multiplication by Addition\<close>

text \<open>
 We now do some basic examples of actual \texttt{WHILE} programs.
 This one is a loop for calculating the product of two natural
 numbers, by iterated addition.  We first give detailed structured
 proof based on single-step Hoare rules.
\<close>

lemma (in state_space)
  shows "\<Gamma>\<turnstile> \<lbrace>\<acute>M = 0 \<and> \<acute>S = 0\<rbrace>
      WHILE \<acute>M \<noteq> a
      DO \<acute>S :== \<acute>S + b;; \<acute>M :== \<acute>M + 1 OD
      \<lbrace>\<acute>S = a * b\<rbrace>"
proof -
  let "\<Gamma>\<turnstile> _ ?while _" = ?thesis
  let "\<lbrace>\<acute>?inv\<rbrace>" = "\<lbrace>\<acute>S = \<acute>M * b\<rbrace>"

  have "\<lbrace>\<acute>M = 0 & \<acute>S = 0\<rbrace> \<subseteq> \<lbrace>\<acute>?inv\<rbrace>" by auto
  also have "\<Gamma>\<turnstile> \<dots> ?while \<lbrace>\<acute>?inv \<and> \<not> (\<acute>M \<noteq> a)\<rbrace>"
  proof
    let ?c = "\<acute>S :== \<acute>S + b;; \<acute>M :== \<acute>M + 1"
    have "\<lbrace>\<acute>?inv \<and> \<acute>M \<noteq> a\<rbrace> \<subseteq> \<lbrace>\<acute>S + b = (\<acute>M + 1) * b\<rbrace>"
      by auto
    also have "\<Gamma>\<turnstile> \<dots> ?c \<lbrace>\<acute>?inv\<rbrace>" by vcg
    finally show "\<Gamma>\<turnstile> \<lbrace>\<acute>?inv \<and> \<acute>M \<noteq> a\<rbrace> ?c \<lbrace>\<acute>?inv\<rbrace>" .
  qed
  also have "\<lbrace>\<acute>?inv \<and> \<not> (\<acute>M \<noteq> a)\<rbrace> \<subseteq> \<lbrace>\<acute>S = a * b\<rbrace>" by auto
  finally show ?thesis by blast
qed

text \<open>
 The subsequent version of the proof applies the \<open>vcg\<close> method
 to reduce the Hoare statement to a purely logical problem that can be
 solved fully automatically.  Note that we have to specify the
 \texttt{WHILE} loop invariant in the original statement.
\<close>

lemma (in state_space)
  shows "\<Gamma>\<turnstile> \<lbrace>\<acute>M = 0 \<and> \<acute>S = 0\<rbrace>
          WHILE \<acute>M \<noteq> a
          INV \<lbrace>\<acute>S = \<acute>M * b\<rbrace>
          DO \<acute>S :== \<acute>S + b;; \<acute>M :== \<acute>M + 1 OD
          \<lbrace>\<acute>S = a * b\<rbrace>"
  apply vcg
  apply auto
  done

text \<open>Here some examples of ``breaking'' out of a loop\<close>

lemma (in state_space)
  shows "\<Gamma>\<turnstile> \<lbrace>\<acute>M = 0 \<and> \<acute>S = 0\<rbrace>
          TRY
            WHILE True
            INV \<lbrace>\<acute>S = \<acute>M * b\<rbrace>
            DO IF \<acute>M = a THEN THROW ELSE \<acute>S :== \<acute>S + b;; \<acute>M :== \<acute>M + 1 FI OD
          CATCH
            SKIP
          END
          \<lbrace>\<acute>S = a * b\<rbrace>"
apply vcg
apply auto
done

lemma (in state_space)
  shows "\<Gamma>\<turnstile> \<lbrace>\<acute>M = 0 \<and> \<acute>S = 0\<rbrace>
          TRY
            WHILE True
            INV \<lbrace>\<acute>S = \<acute>M * b\<rbrace>
            DO IF \<acute>M = a THEN \<acute>Abr :== ''Break'';;THROW
               ELSE \<acute>S :== \<acute>S + b;; \<acute>M :== \<acute>M + 1
               FI
            OD
          CATCH
            IF \<acute>Abr = ''Break'' THEN SKIP ELSE Throw FI
          END
          \<lbrace>\<acute>S = a * b\<rbrace>"
apply vcg
apply auto
done

text \<open>Some more syntactic sugar, the label statement \<open>\<dots> \<bullet> \<dots>\<close> as shorthand
for the \<open>TRY-CATCH\<close> above, and the \<open>RAISE\<close> for an state-update followed
by a \<open>THROW\<close>.
\<close>
lemma (in state_space)
  shows "\<Gamma>\<turnstile> \<lbrace>\<acute>M = 0 \<and> \<acute>S = 0\<rbrace>
          \<lbrace>\<acute>Abr = ''Break''\<rbrace>\<bullet> WHILE True INV \<lbrace>\<acute>S = \<acute>M * b\<rbrace>
           DO IF \<acute>M = a THEN RAISE \<acute>Abr :== ''Break''
              ELSE \<acute>S :== \<acute>S + b;; \<acute>M :== \<acute>M + 1
              FI
           OD
          \<lbrace>\<acute>S = a * b\<rbrace>"
apply vcg
apply auto
done

lemma (in state_space)
  shows "\<Gamma>\<turnstile> \<lbrace>\<acute>M = 0 \<and> \<acute>S = 0\<rbrace>
          TRY
            WHILE True
            INV \<lbrace>\<acute>S = \<acute>M * b\<rbrace>
            DO IF \<acute>M = a THEN RAISE \<acute>Abr :== ''Break''
               ELSE \<acute>S :== \<acute>S + b;; \<acute>M :== \<acute>M + 1
               FI
            OD
          CATCH
            IF \<acute>Abr = ''Break'' THEN SKIP ELSE Throw FI
          END
          \<lbrace>\<acute>S = a * b\<rbrace>"
apply vcg
apply auto
done

lemma (in state_space)
  shows "\<Gamma>\<turnstile> \<lbrace>\<acute>M = 0 \<and> \<acute>S = 0\<rbrace>
          \<lbrace>\<acute>Abr = ''Break''\<rbrace> \<bullet> WHILE True
          INV \<lbrace>\<acute>S = \<acute>M * b\<rbrace>
          DO IF \<acute>M = a THEN RAISE \<acute>Abr :== ''Break''
               ELSE \<acute>S :== \<acute>S + b;; \<acute>M :== \<acute>M + 1
               FI
          OD
          \<lbrace>\<acute>S = a * b\<rbrace>"
apply vcg
apply auto
done

text \<open>Blocks\<close>

lemma  (in state_space)
  shows "\<Gamma>\<turnstile>\<lbrace>\<acute>I = i\<rbrace> LOC \<acute>I;; \<acute>I :== 2  COL \<lbrace>\<acute>I \<le> i\<rbrace>"
  apply vcg
  by simp

subsection \<open>Summing Natural Numbers\<close>

text \<open>
 We verify an imperative program to sum natural numbers up to a given
 limit.  First some functional definition for proper specification of
 the problem.
\<close>

primrec
  sum :: "(nat => nat) => nat => nat"
where
  "sum f 0 = 0"
| "sum f (Suc n) = f n + sum f n"

syntax
  "_sum" :: "idt => nat => nat => nat"
    ("SUMM _<_. _" [0, 0, 10] 10)
translations
  "SUMM j<k. b" == "CONST sum (\<lambda>j. b) k"

text \<open>
 The following proof is quite explicit in the individual steps taken,
 with the \<open>vcg\<close> method only applied locally to take care of
 assignment and sequential composition.  Note that we express
 intermediate proof obligation in pure logic, without referring to the
 state space.
\<close>

theorem (in state_space)
  shows "\<Gamma>\<turnstile> \<lbrace>True\<rbrace>
           \<acute>S :== 0;; \<acute>I :== 1;;
           WHILE \<acute>I \<noteq> n
           DO
             \<acute>S :== \<acute>S + \<acute>I;;
             \<acute>I :== \<acute>I + 1
           OD
           \<lbrace>\<acute>S = (SUMM j<n. j)\<rbrace>"
  (is "\<Gamma>\<turnstile> _ (_;; ?while) _")
proof -
  let ?sum = "\<lambda>k. SUMM j<k. j"
  let ?inv = "\<lambda>s i. s = ?sum i"

  have "\<Gamma>\<turnstile> \<lbrace>True\<rbrace> \<acute>S :== 0;; \<acute>I :== 1 \<lbrace>?inv \<acute>S \<acute>I\<rbrace>"
  proof -
    have "True \<longrightarrow> 0 = ?sum 1"
      by simp
    also have "\<Gamma>\<turnstile> \<lbrace>\<dots>\<rbrace> \<acute>S :== 0;; \<acute>I :== 1 \<lbrace>?inv \<acute>S \<acute>I\<rbrace>"
      by vcg
    finally show ?thesis .
  qed
  also have "\<Gamma>\<turnstile> \<lbrace>?inv \<acute>S \<acute>I\<rbrace> ?while \<lbrace>?inv \<acute>S \<acute>I \<and> \<not> \<acute>I \<noteq> n\<rbrace>"
  proof
    let ?body = "\<acute>S :== \<acute>S + \<acute>I;; \<acute>I :== \<acute>I + 1"
    have "\<And>s i. ?inv s i \<and> i \<noteq> n \<longrightarrow>  ?inv (s + i) (i + 1)"
      by simp
    also have "\<Gamma>\<turnstile> \<lbrace>\<acute>S + \<acute>I = ?sum (\<acute>I + 1)\<rbrace> ?body \<lbrace>?inv \<acute>S \<acute>I\<rbrace>"
      by vcg
    finally show "\<Gamma>\<turnstile> \<lbrace>?inv \<acute>S \<acute>I \<and> \<acute>I \<noteq> n\<rbrace> ?body \<lbrace>?inv \<acute>S \<acute>I\<rbrace>" .
  qed
  also have "\<And>s i. s = ?sum i \<and> \<not> i \<noteq> n \<longrightarrow> s = ?sum n"
    by simp
  finally show ?thesis .
qed

text \<open>
 The next version uses the \<open>vcg\<close> method, while still explaining
 the resulting proof obligations in an abstract, structured manner.
\<close>

theorem (in state_space)
  shows "\<Gamma>\<turnstile> \<lbrace>True\<rbrace>
           \<acute>S :== 0;; \<acute>I :== 1;;
           WHILE \<acute>I \<noteq> n
           INV \<lbrace>\<acute>S = (SUMM j<\<acute>I. j)\<rbrace>
           DO
             \<acute>S :== \<acute>S + \<acute>I;;
             \<acute>I :== \<acute>I + 1
           OD
          \<lbrace>\<acute>S = (SUMM j<n. j)\<rbrace>"
proof -
  let ?sum = "\<lambda>k. SUMM j<k. j"
  let ?inv = "\<lambda>s i. s = ?sum i"

  show ?thesis
  proof vcg
    show "?inv 0 1" by simp
  next
    fix i s assume "?inv s i" "i \<noteq> n"
    thus "?inv (s + i) (i + 1)" by simp
  next
    fix i s assume x: "?inv s i" "\<not> i \<noteq> n"
    thus "s = ?sum n" by simp
  qed
qed

text \<open>
 Certainly, this proof may be done fully automatically as well, provided
 that the invariant is given beforehand.
\<close>

theorem (in state_space)
  shows "\<Gamma>\<turnstile> \<lbrace>True\<rbrace>
           \<acute>S :== 0;; \<acute>I :== 1;;
           WHILE \<acute>I \<noteq> n
           INV \<lbrace>\<acute>S = (SUMM j<\<acute>I. j)\<rbrace>
           DO
             \<acute>S :== \<acute>S + \<acute>I;;
             \<acute>I :== \<acute>I + 1
           OD
           \<lbrace>\<acute>S = (SUMM j<n. j)\<rbrace>"
  apply vcg
  apply auto
  done

subsection \<open>SWITCH\<close>

lemma (in state_space)
  shows "\<Gamma>\<turnstile> \<lbrace>\<acute>N = 5\<rbrace> SWITCH \<acute>B
                        {True} \<Rightarrow> \<acute>N :== 6
                      | {False} \<Rightarrow> \<acute>N :== 7
                     END
          \<lbrace>\<acute>N > 5\<rbrace>"
apply vcg
apply simp
done

lemma (in state_space)
  shows "\<Gamma>\<turnstile> \<lbrace>\<acute>N = 5\<rbrace> SWITCH \<acute>N
                        {v. v < 5} \<Rightarrow> \<acute>N :== 6
                      | {v. v \<ge> 5} \<Rightarrow> \<acute>N :== 7
                     END
          \<lbrace>\<acute>N > 5\<rbrace>"
apply vcg
apply simp
done

subsection \<open>(Mutually) Recursive Procedures\<close>

subsubsection \<open>Factorial\<close>

text \<open>We want to define a procedure for the factorial. We first
define a HOL functions that calculates it to specify the procedure later on.
\<close>

primrec fac:: "nat \<Rightarrow> nat"
where
"fac 0 = 1" |
"fac (Suc n) = (Suc n) * fac n"

lemma fac_simp [simp]: "0 < i \<Longrightarrow>  fac i = i * fac (i - 1)"
  by (cases i) simp_all

text \<open>Now we define the procedure\<close>

procedures
  Fac (N::nat|R::nat)
  "IF \<acute>N = 0 THEN \<acute>R :== 1
   ELSE \<acute>R :== CALL Fac(\<acute>N - 1);;
        \<acute>R :== \<acute>N * \<acute>R
   FI"

print_locale Fac_impl

text \<open>
To see how a call is syntactically translated you can switch off the
printing translation via the configuration option \<open>hoare_use_call_tr'\<close>
\<close>

context Fac_impl
begin
text \<open>
@{term "CALL Fac(\<acute>N,\<acute>R)"} is internally:
\<close>
declare [[hoare_use_call_tr' = false]]
text \<open>
@{term "CALL Fac(\<acute>N,\<acute>R)"}
\<close>
term "CALL Fac(\<acute>N,\<acute>R)"
declare [[hoare_use_call_tr' = true]]

text \<open>
Now let us prove that @{term "Fac"} meets its specification.
\<close>

end

lemma (in Fac_impl) Fac_spec':
  shows "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>{\<sigma>} PROC Fac(\<acute>N,\<acute>R) \<lbrace>\<acute>R = fac \<^bsup>\<sigma>\<^esup>N\<rbrace>"
  apply (hoare_rule HoarePartial.ProcRec1)
  apply vcg
  apply simp
  done

text \<open>
Since the factorial was implemented recursively,
the main ingredient of this proof is, to assume that the specification holds for
the recursive call of @{term Fac} and prove the body correct.
The assumption for recursive calls is added to the context by
the rule @{thm [source] HoarePartial.ProcRec1}
(also derived from general rule for mutually recursive procedures):
@{thm [display] HoarePartial.ProcRec1 [no_vars]}
The verification condition generator will infer the specification out of the
context when it encounters a recursive call of the factorial.
\<close>

text \<open>We can also step through verification condition generation. When
the verification condition generator encounters a procedure call it tries to
  use the rule \<open>ProcSpec\<close>. To be successful there must be a specification
of the procedure in the context.
\<close>

lemma (in Fac_impl) Fac_spec1:
  shows "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>{\<sigma>} \<acute>R :== PROC Fac(\<acute>N) \<lbrace>\<acute>R = fac \<^bsup>\<sigma>\<^esup>N\<rbrace>"
  apply (hoare_rule HoarePartial.ProcRec1)
  apply vcg_step
  apply   vcg_step
  apply  vcg_step
  apply vcg_step
  apply vcg_step
  apply simp
  done

text \<open>Here some Isar style version of the proof\<close>
lemma (in Fac_impl) Fac_spec2:

  shows "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>{\<sigma>} \<acute>R :== PROC Fac(\<acute>N) \<lbrace>\<acute>R = fac \<^bsup>\<sigma>\<^esup>N\<rbrace>"
proof (hoare_rule HoarePartial.ProcRec1)
  have Fac_spec: "\<forall>\<sigma>. \<Gamma>,(\<Theta>\<union>(\<Union>\<sigma>. {({\<sigma>}, Fac_'proc, \<lbrace>\<acute>R = fac \<^bsup>\<sigma>\<^esup>N\<rbrace>,{})}))
                       \<turnstile> {\<sigma>} \<acute>R :== PROC Fac(\<acute>N) \<lbrace>\<acute>R = fac \<^bsup>\<sigma>\<^esup>N\<rbrace>"
    apply (rule allI)
    apply (rule hoarep.Asm)
    by simp
  show "\<forall>\<sigma>. \<Gamma>,(\<Theta>\<union>(\<Union>\<sigma>. {({\<sigma>}, Fac_'proc, \<lbrace>\<acute>R = fac \<^bsup>\<sigma>\<^esup>N\<rbrace>,{})}))
            \<turnstile> {\<sigma>} IF \<acute>N = 0 THEN \<acute>R :== 1
            ELSE \<acute>R :== CALL Fac(\<acute>N - 1);; \<acute>R :== \<acute>N * \<acute>R FI \<lbrace>\<acute>R = fac \<^bsup>\<sigma>\<^esup>N\<rbrace>"
    apply vcg
    apply simp
    done
qed

text \<open>To avoid retyping of potentially large pre and postconditions in
the previous proof we can use the casual term abbreviations of the Isar
language.
\<close>

lemma (in Fac_impl) Fac_spec3:
  shows "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>{\<sigma>} \<acute>R :== PROC Fac(\<acute>N) \<lbrace>\<acute>R = fac \<^bsup>\<sigma>\<^esup>N\<rbrace>"
  (is "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>(?Pre \<sigma>) ?Fac (?Post \<sigma>)")
proof (hoare_rule HoarePartial.ProcRec1)
  have Fac_spec: "\<forall>\<sigma>. \<Gamma>,(\<Theta>\<union>(\<Union>\<sigma>. {(?Pre \<sigma>, Fac_'proc, ?Post \<sigma>,{})}))
                       \<turnstile>(?Pre \<sigma>) ?Fac (?Post \<sigma>)"
    apply (rule allI)
    apply (rule hoarep.Asm)
    by simp
  show "\<forall>\<sigma>. \<Gamma>,(\<Theta>\<union>(\<Union>\<sigma>. {(?Pre \<sigma>, Fac_'proc, ?Post \<sigma>,{})}))
            \<turnstile> (?Pre \<sigma>) IF \<acute>N = 0 THEN \<acute>R :== 1
            ELSE \<acute>R :== CALL Fac(\<acute>N - 1);; \<acute>R :== \<acute>N * \<acute>R FI (?Post \<sigma>)"
    apply vcg
    apply simp
    done
qed

text \<open>The previous proof pattern has still some kind of inconvenience.
The augmented context is always printed in the proof state. That can
mess up the state, especially if we have large specifications. This may
be annoying if we want to develop single step or structured proofs. In this
case it can be a good idea to introduce a new variable for the augmented
context.
\<close>

lemma (in Fac_impl) Fac_spec4:
  shows "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>{\<sigma>} \<acute>R :== PROC Fac(\<acute>N) \<lbrace>\<acute>R = fac \<^bsup>\<sigma>\<^esup>N\<rbrace>"
  (is "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>(?Pre \<sigma>) ?Fac (?Post \<sigma>)")
proof (hoare_rule HoarePartial.ProcRec1)
  define \<Theta>' where "\<Theta>' = \<Theta> \<union> (\<Union>\<sigma>. {(?Pre \<sigma>, Fac_'proc, ?Post \<sigma>,{})})"
  have Fac_spec: "\<forall>\<sigma>. \<Gamma>,\<Theta>'\<turnstile>(?Pre \<sigma>) ?Fac (?Post \<sigma>)"
    by (unfold \<Theta>'_def, rule allI, rule hoarep.Asm) simp
  txt \<open>We have to name the fact \<open>Fac_spec\<close>, so that the vcg can
   use the specification for the recursive call, since it cannot infer it
   from the opaque @{term "\<Theta>'"}.\<close>
  show "\<forall>\<sigma>. \<Gamma>,\<Theta>'\<turnstile> (?Pre \<sigma>) IF \<acute>N = 0 THEN \<acute>R :== 1
            ELSE \<acute>R :== CALL Fac(\<acute>N - 1);; \<acute>R :== \<acute>N * \<acute>R FI (?Post \<sigma>)"
    apply vcg
    apply simp
    done
qed

text \<open>There are different rules available to prove procedure calls,
depending on the kind of postcondition and whether or not the
procedure is recursive or even mutually recursive.
See for example @{thm [source] HoareTotal.ProcRec1},
@{thm [source] HoareTotal.ProcNoRec1}.
They are all derived from the most general rule
@{thm [source] HoareTotal.ProcRec}.
All of them have some side-conditions concerning the parameter
passing protocol and its relation to the pre and postcondition. They can be
solved in a uniform fashion. Thats why we have created the method
\<open>hoare_rule\<close>, which behaves like the method \<open>rule\<close> but automatically
tries to solve the side-conditions.
\<close>

subsubsection \<open>Odd and Even\<close>

text \<open>Odd and even are defined mutually recursive here. In the
\<open>procedures\<close> command we conjoin both definitions with \<open>and\<close>.
\<close>

procedures
 odd(N::nat | A::nat) "IF \<acute>N=0 THEN \<acute>A:==0
                     ELSE IF \<acute>N=1 THEN CALL even (\<acute>N - 1,\<acute>A)
                          ELSE CALL odd (\<acute>N - 2,\<acute>A)
                          FI
                     FI"

and
  even(N::nat | A::nat) "IF \<acute>N=0 THEN \<acute>A:==1
                        ELSE IF \<acute>N=1 THEN CALL odd (\<acute>N - 1,\<acute>A)
                             ELSE CALL even (\<acute>N - 2,\<acute>A)
                             FI
                        FI"
print_theorems
print_locale! odd_even_clique

text \<open>To prove the procedure calls to @{term "odd"} respectively
@{term "even"} correct we first derive a rule to justify that we
can assume both specifications to verify the bodies. This rule can
be derived from the general @{thm [source] HoareTotal.ProcRec} rule. An ML function will
do this work:
\<close>

ML \<open>ML_Thms.bind_thm ("ProcRec2", Hoare.gen_proc_rec @{context} Hoare.Partial 2)\<close>

lemma (in odd_even_clique)
  shows odd_spec: "\<forall>\<sigma>. \<Gamma>\<turnstile>{\<sigma>} \<acute>A :== PROC odd(\<acute>N)
                  \<lbrace>(\<exists>b. \<^bsup>\<sigma>\<^esup>N = 2 * b + \<acute>A) \<and> \<acute>A < 2 \<rbrace>" (is ?P1)
   and even_spec: "\<forall>\<sigma>. \<Gamma>\<turnstile>{\<sigma>} \<acute>A :== PROC even(\<acute>N)
                  \<lbrace>(\<exists>b. \<^bsup>\<sigma>\<^esup>N + 1 = 2 * b + \<acute>A) \<and> \<acute>A < 2 \<rbrace>" (is ?P2)
proof -
  have "?P1 \<and> ?P2"
    apply (hoare_rule ProcRec2)
    apply  vcg
    apply  clarsimp
    apply  (rule_tac x="b + 1" in exI)
    apply  arith
    apply vcg
    apply clarsimp
    apply arith
    done
  thus "?P1" "?P2"
    by iprover+
qed

subsection \<open>Expressions With Side Effects\<close>

(* R := N++ + M++*)
lemma (in state_space) shows "\<Gamma>\<turnstile> \<lbrace>True\<rbrace>
  \<acute>N \<ggreater> n. \<acute>N :== \<acute>N + 1 \<ggreater>
  \<acute>M \<ggreater> m. \<acute>M :== \<acute>M + 1 \<ggreater>
  \<acute>R :== n + m
  \<lbrace>\<acute>R = \<acute>N + \<acute>M - 2\<rbrace>"
apply vcg
apply simp
done

(* R := Fac (N) + Fac (N) *)
lemma (in Fac_impl) shows
  "\<Gamma>\<turnstile> \<lbrace>True\<rbrace>
  CALL Fac(\<acute>N) \<ggreater> n. CALL Fac(\<acute>N) \<ggreater> m.
  \<acute>R :== n + m
  \<lbrace>\<acute>R = fac \<acute>N + fac \<acute>N\<rbrace>"
proof -
  note Fac_spec = Fac_spec4
  show ?thesis
    apply vcg
    done
qed

(* R := Fac (N) + Fac (M) *)
lemma (in Fac_impl) shows
  "\<Gamma>\<turnstile> \<lbrace>True\<rbrace>
  CALL Fac(\<acute>N) \<ggreater> n. CALL Fac(n) \<ggreater> m.
  \<acute>R :== m
  \<lbrace>\<acute>R = fac (fac \<acute>N)\<rbrace>"
proof -
  note Fac_spec = Fac_spec4
  show ?thesis
    apply vcg
    done
qed

subsection \<open>Global Variables and Heap\<close>

text \<open>
Now we will define and verify some procedures on heap-lists. We consider
list structures consisting of two fields, a content element @{term "cont"} and
a reference to the next list element @{term "next"}. We model this by the
following state space where every field has its own heap.
\<close>

hoarestate globals_list =
  "next" :: "ref \<Rightarrow> ref"
  cont :: "ref \<Rightarrow> nat"

text \<open>Updates to global components inside a procedure will
always be propagated to the caller. This is implicitly done by the
parameter passing syntax translations. The record containing the global variables must begin with the prefix "globals".
\<close>

text \<open>We will first define an append function on lists. It takes two
references as parameters. It appends the list referred to by the first
parameter with the list referred to by the second parameter, and returns
the result right into the first parameter.
\<close>

procedures (imports globals_list)
  append(p::ref,q::ref|p::ref)
    "IF \<acute>p=Null THEN \<acute>p :== \<acute>q ELSE \<acute>p \<rightarrow>\<acute>next:== CALL append(\<acute>p\<rightarrow>\<acute>next,\<acute>q) FI"

declare [[hoare_use_call_tr' = false]]
context append_impl
begin
term "CALL append(\<acute>p,\<acute>q,\<acute>p\<rightarrow>\<acute>next)"
end
declare [[hoare_use_call_tr' = true]]

text \<open>Below we give two specifications this time..
The first one captures the functional behaviour and focuses on the
entities that are potentially modified by the procedure, the second one
is a pure frame condition.
The list in the modifies clause has to list all global state components that
may be changed by the procedure. Note that we know from the modifies clause
that the @{term cont} parts of the lists will not be changed. Also a small
side note on the syntax. We use ordinary brackets in the postcondition
of the modifies clause, and also the state components do not carry the
acute, because we explicitly note the state @{term t} here.

The functional specification now introduces two logical variables besides the
state space variable @{term "\<sigma>"}, namely @{term "Ps"} and @{term "Qs"}.
They are universally quantified and range over both the pre and the postcondition, so
that we are able to properly instantiate the specification
during the proofs. The syntax \<open>\<lbrace>\<sigma>. \<dots>\<rbrace>\<close> is a shorthand to fix the current
state: \<open>{s. \<sigma> = s \<dots>}\<close>.
\<close>

lemma (in append_impl) append_spec:
  shows "\<forall>\<sigma> Ps Qs. \<Gamma>\<turnstile>
            \<lbrace>\<sigma>. List \<acute>p \<acute>next Ps \<and>  List \<acute>q \<acute>next Qs \<and> set Ps \<inter> set Qs = {}\<rbrace>
                \<acute>p :== PROC append(\<acute>p,\<acute>q)
            \<lbrace>List \<acute>p \<acute>next (Ps@Qs) \<and> (\<forall>x. x\<notin>set Ps \<longrightarrow> \<acute>next x = \<^bsup>\<sigma>\<^esup>next x)\<rbrace>"
  apply (hoare_rule HoarePartial.ProcRec1)
  apply vcg
  apply fastforce
  done

text \<open>The modifies clause is equal to a proper record update specification
of the following form.
\<close>

lemma (in append_impl) shows "{t. t may_only_modify_globals Z in [next]}
       =
       {t. \<exists>next. globals t=update id id next_' (K_statefun next) (globals Z)}"
  apply (unfold mex_def meq_def)
  apply simp
  done

text \<open>If the verification condition generator works on a procedure call
it checks whether it can find a modifies clause in the context. If one
is present the procedure call is simplified before the Hoare rule
@{thm [source] HoareTotal.ProcSpec} is applied. Simplification of the procedure call means,
that the ``copy back'' of the global components is simplified. Only those
components that occur in the modifies clause will actually be copied back.
This simplification is justified by the rule @{thm [source] HoareTotal.ProcModifyReturn}.
So after this simplification all global components that do not appear in
the modifies clause will be treated as local variables.
\<close>

text \<open>You can study the effect of the modifies clause on the following two
examples, where we want to prove that @{term "append"} does not change
the @{term "cont"} part of the heap.
\<close>
lemma (in append_impl)
  shows "\<Gamma>\<turnstile> \<lbrace>\<acute>p=Null \<and> \<acute>cont=c\<rbrace> \<acute>p :== CALL append(\<acute>p,Null) \<lbrace>\<acute>cont=c\<rbrace>"
  apply vcg
  oops

text \<open>To prove the frame condition,
we have to tell the verification condition generator to use only the
modifies clauses and not to search for functional specifications by
the parameter \<open>spec=modifies\<close> It will also try to solve the
verification conditions automatically.
\<close>

lemma (in append_impl) append_modifies:
  shows
   "\<forall>\<sigma>. \<Gamma>\<turnstile> {\<sigma>} \<acute>p :== PROC append(\<acute>p,\<acute>q){t. t may_only_modify_globals \<sigma> in [next]}"
  apply (hoare_rule HoarePartial.ProcRec1)
  apply (vcg spec=modifies)
  done

lemma (in append_impl)
  shows "\<Gamma>\<turnstile> \<lbrace>\<acute>p=Null \<and> \<acute>cont=c\<rbrace> \<acute>p\<rightarrow>\<acute>next :== CALL append(\<acute>p,Null) \<lbrace>\<acute>cont=c\<rbrace>"
  apply vcg
  apply simp
  done

text \<open>
Of course we could add the modifies clause to the functional specification as
well. But separating both has the advantage that we split up the verification
work. We can make use of the modifies clause before we apply the
functional specification in a fully automatic fashion.
\<close>

text \<open>To verify the body of @{term "append"} we do not need the modifies
clause, since the specification does not talk about @{term "cont"} at all, and
we don't access @{term "cont"} inside the body. This may be different for
more complex procedures.
\<close>

text \<open>
To prove that a procedure respects the modifies clause, we only need
the modifies clauses of the procedures called in the body. We do not need
the functional specifications. So we can always prove the modifies
clause without functional specifications, but me may need the modifies
clause to prove the functional specifications.
\<close>

subsubsection \<open>Insertion Sort\<close>

primrec sorted:: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list  \<Rightarrow> bool"
where
"sorted le [] = True" |
"sorted le (x#xs) = ((\<forall>y\<in>set xs. le x y) \<and> sorted le xs)"

procedures (imports globals_list)
  insert(r::ref,p::ref | p::ref)
    "IF \<acute>r=Null THEN SKIP
     ELSE IF \<acute>p=Null THEN \<acute>p :== \<acute>r;; \<acute>p\<rightarrow>\<acute>next :== Null
          ELSE IF \<acute>r\<rightarrow>\<acute>cont \<le> \<acute>p\<rightarrow>\<acute>cont
               THEN \<acute>r\<rightarrow>\<acute>next :== \<acute>p;; \<acute>p:==\<acute>r
               ELSE \<acute>p\<rightarrow>\<acute>next :== CALL insert(\<acute>r,\<acute>p\<rightarrow>\<acute>next)
               FI
          FI
     FI"

text \<open>
In the postcondition of the functional specification there is a small but
important subtlety. Whenever we talk about the @{term "cont"} part we refer to
the one of the pre-state, even in the conclusion of the implication.
The reason is, that we have separated out, that @{term "cont"} is not modified
by the procedure, to the modifies clause. So whenever we talk about unmodified
parts in the postcondition we have to use the pre-state part, or explicitely
state an equality in the postcondition.
The reason is simple. If the postcondition would talk about \<open>\<acute>cont\<close>
instead of \<open>\<^bsup>\<sigma>\<^esup>cont\<close>, we will get a new instance of \<open>cont\<close> during
verification and the postcondition would only state something about this
new instance. But as the verification condition generator will use the
modifies clause the caller of \<open>insert\<close> instead will still have the
old \<open>cont\<close> after the call. Thats the sense of the modifies clause.
So the caller and the specification will simply talk about two different things,
without being able to relate them (unless an explicit equality is added to
the specification).
\<close>

lemma (in insert_impl) insert_modifies:
  "\<forall>\<sigma>. \<Gamma>\<turnstile> {\<sigma>} \<acute>p :== PROC insert(\<acute>r,\<acute>p){t. t may_only_modify_globals \<sigma> in [next]}"
apply (hoare_rule HoarePartial.ProcRec1)
apply (vcg spec=modifies)
done

lemma (in insert_impl) insert_spec:
    "\<forall>\<sigma> Ps . \<Gamma>\<turnstile> \<lbrace>\<sigma>. List \<acute>p \<acute>next Ps \<and> sorted (op \<le>) (map \<acute>cont Ps) \<and>
                  \<acute>r \<noteq> Null \<and> \<acute>r \<notin> set Ps\<rbrace>
         \<acute>p :== PROC insert(\<acute>r,\<acute>p)
   \<lbrace>\<exists>Qs. List \<acute>p \<acute>next Qs \<and> sorted (op \<le>) (map \<^bsup>\<sigma>\<^esup>cont  Qs) \<and>
           set Qs = insert \<^bsup>\<sigma>\<^esup>r (set Ps) \<and>
           (\<forall>x. x \<notin> set Qs \<longrightarrow> \<acute>next x = \<^bsup>\<sigma>\<^esup>next x)\<rbrace>"

apply (hoare_rule HoarePartial.ProcRec1)
apply vcg
apply (intro conjI impI)
apply    fastforce
apply   fastforce
apply  fastforce
apply (clarsimp)
apply force
done

procedures (imports globals_list)
  insertSort(p::ref | p::ref)
  where r::ref q::ref
  in
    "\<acute>r:==Null;;
     WHILE (\<acute>p \<noteq> Null) DO
       \<acute>q :== \<acute>p;;
       \<acute>p :== \<acute>p\<rightarrow>\<acute>next;;
       \<acute>r :== CALL insert(\<acute>q,\<acute>r)
     OD;;
     \<acute>p:==\<acute>r"

print_locale insertSort_impl

lemma (in insertSort_impl) insertSort_modifies:
  shows
   "\<forall>\<sigma>. \<Gamma>\<turnstile> {\<sigma>} \<acute>p :== PROC insertSort(\<acute>p)
              {t. t may_only_modify_globals \<sigma> in [next]}"
apply (hoare_rule HoarePartial.ProcRec1)
apply (vcg spec=modifies)
done

text \<open>Insertion sort is not implemented recursively here but with a while
loop. Note that the while loop is not annotated with an invariant in the
procedure definition. The invariant only comes into play during verification.
Therefore we will annotate the body during the proof with the
rule @{thm [source] HoareTotal.annotateI}.
\<close>

lemma (in insertSort_impl) insertSort_body_spec:
  shows "\<forall>\<sigma> Ps. \<Gamma>,\<Theta>\<turnstile> \<lbrace>\<sigma>. List \<acute>p \<acute>next Ps \<rbrace>
              \<acute>p :== PROC insertSort(\<acute>p)
          \<lbrace>\<exists>Qs. List \<acute>p \<acute>next Qs \<and> sorted (op \<le>) (map \<^bsup>\<sigma>\<^esup>cont Qs) \<and>
           set Qs = set Ps\<rbrace>"
  apply (hoare_rule HoarePartial.ProcRec1)
  apply (hoare_rule anno=
         "\<acute>r :== Null;;
         WHILE \<acute>p \<noteq> Null
         INV \<lbrace>\<exists>Qs Rs. List \<acute>p \<acute>next Qs \<and> List \<acute>r \<acute>next Rs \<and>
                  set Qs \<inter> set Rs = {} \<and>
                  sorted (op \<le>) (map \<acute>cont Rs) \<and> set Qs \<union> set Rs = set Ps \<and>
                  \<acute>cont = \<^bsup>\<sigma>\<^esup>cont \<rbrace>
          DO \<acute>q :== \<acute>p;; \<acute>p :== \<acute>p\<rightarrow>\<acute>next;; \<acute>r :== CALL insert(\<acute>q,\<acute>r) OD;;
          \<acute>p :== \<acute>r" in HoarePartial.annotateI)
  apply vcg
  apply   fastforce
  prefer 2
  apply  fastforce
  apply (clarsimp)
  apply (rule_tac x=ps in exI)
  apply (intro conjI)
  apply    (rule heap_eq_ListI1)
  apply     assumption
  apply    clarsimp
  apply    (subgoal_tac "x\<noteq>p \<and> x \<notin> set Rs")
  apply     auto
  done

subsubsection "Memory Allocation and Deallocation"

text \<open>The basic idea of memory management is to keep a list of allocated
references in the state space. Allocation of a new reference adds a
new reference to the list deallocation removes a reference. Moreover
we keep a counter "free" for the free memory.
\<close>

(*
record globals_list_alloc = globals_list +
  alloc_'::"ref list"
  free_'::nat

record 'g list_vars' = "'g list_vars" +
  i_'::nat
  first_'::ref
*)

hoarestate globals_list_alloc =
  alloc::"ref list"
  free::nat
  "next"::"ref \<Rightarrow> ref"
  cont::"ref \<Rightarrow> nat"
hoarestate locals_list_alloc =
  i::nat
  first::ref
  p::ref
  q::ref
  r::ref
  root::ref
  tmp::ref
locale list_alloc = globals_list_alloc + locals_list_alloc

definition "sz = (2::nat)"

lemma (in list_alloc)
 shows
  "\<Gamma>,\<Theta>\<turnstile> \<lbrace>\<acute>i = 0 \<and> \<acute>first = Null \<and> n*sz \<le> \<acute>free\<rbrace>
       WHILE \<acute>i < n
       INV \<lbrace>\<exists>Ps. List \<acute>first \<acute>next Ps \<and> length Ps = \<acute>i \<and> \<acute>i \<le> n \<and>
             set Ps \<subseteq> set \<acute>alloc \<and> (n - \<acute>i)*sz \<le> \<acute>free\<rbrace>
       DO
         \<acute>p :== NEW sz [\<acute>cont:==0,\<acute>next:== Null];;
         \<acute>p\<rightarrow>\<acute>next :== \<acute>first;;
         \<acute>first :== \<acute>p;;
         \<acute>i :== \<acute>i+ 1
       OD
       \<lbrace>\<exists>Ps. List \<acute>first \<acute>next  Ps \<and> length Ps = n \<and> set Ps \<subseteq> set \<acute>alloc\<rbrace>"
apply (vcg)
apply   simp
apply  clarsimp
apply  (rule conjI)
apply   clarsimp
apply   (rule_tac x="new (set alloc)#Ps" in exI)
apply   clarsimp
apply   (rule conjI)
apply    fastforce
apply   (simp add: sz_def)
apply  (simp add: sz_def)
apply fastforce
done

lemma (in list_alloc)
 shows
  "\<Gamma>\<turnstile> \<lbrace>\<acute>i = 0 \<and> \<acute>first = Null \<and> n*sz \<le> \<acute>free\<rbrace>
       WHILE \<acute>i < n
       INV \<lbrace>\<exists>Ps. List \<acute>first \<acute>next Ps \<and> length Ps = \<acute>i \<and> \<acute>i \<le> n \<and>
             set Ps \<subseteq> set \<acute>alloc \<and> (n - \<acute>i)*sz \<le> \<acute>free\<rbrace>
       DO
         \<acute>p :== NNEW sz [\<acute>cont:==0,\<acute>next:== Null];;
         \<acute>p\<rightarrow>\<acute>next :== \<acute>first;;
         \<acute>first :== \<acute>p;;
         \<acute>i :== \<acute>i+ 1
       OD
       \<lbrace>\<exists>Ps. List \<acute>first \<acute>next  Ps \<and> length Ps = n \<and> set Ps \<subseteq> set \<acute>alloc\<rbrace>"

apply (vcg)
apply   simp
apply  clarsimp
apply  (rule conjI)
apply   clarsimp
apply   (rule_tac x="new (set alloc)#Ps" in exI)
apply   clarsimp
apply   (rule conjI)
apply    fastforce
apply   (simp add: sz_def)
apply  (simp add: sz_def)
apply fastforce
done

subsection \<open>Fault Avoiding Semantics\<close>

text \<open>
If we want to ensure that no runtime errors occur we can insert guards into
the code. We will not be able to prove any nontrivial Hoare triple
about code with guards, if we cannot show that the guards will never fail.
A trivial Hoare triple is one with an empty precondtion.
\<close>

lemma (in list_alloc) "\<Gamma>,\<Theta>\<turnstile> \<lbrace>True\<rbrace>  \<lbrace>\<acute>p\<noteq>Null\<rbrace>\<longmapsto> \<acute>p\<rightarrow>\<acute>next :== \<acute>p \<lbrace>True\<rbrace>"
apply vcg
oops

lemma (in list_alloc) "\<Gamma>,\<Theta>\<turnstile> {}  \<lbrace>\<acute>p\<noteq>Null\<rbrace>\<longmapsto> \<acute>p\<rightarrow>\<acute>next :== \<acute>p \<lbrace>True\<rbrace>"
apply vcg
done

text \<open>Let us consider this small program that reverts a list. At
first without guards.
\<close>
lemma (in list_alloc)
  shows
  "\<Gamma>,\<Theta>\<turnstile> \<lbrace>List \<acute>p \<acute>next Ps \<and> List \<acute>q \<acute>next Qs \<and> set Ps \<inter> set Qs = {} \<and>
       set Ps \<subseteq> set \<acute>alloc \<and> set Qs \<subseteq> set \<acute>alloc\<rbrace>
  WHILE \<acute>p \<noteq> Null
  INV \<lbrace>\<exists>ps qs. List \<acute>p \<acute>next  ps \<and> List \<acute>q \<acute>next qs \<and> set ps \<inter> set qs = {} \<and>
               rev ps @ qs = rev Ps @ Qs \<and>
               set ps \<subseteq> set \<acute>alloc \<and> set qs \<subseteq> set \<acute>alloc\<rbrace>
  DO \<acute>r :== \<acute>p;;
     \<acute>p :== \<acute>p\<rightarrow> \<acute>next;;
     \<acute>r\<rightarrow>\<acute>next :== \<acute>q;;
     \<acute>q :== \<acute>r OD
  \<lbrace>List \<acute>q \<acute>next (rev Ps @ Qs) \<and> set Ps\<subseteq> set \<acute>alloc \<and> set Qs \<subseteq> set \<acute>alloc\<rbrace>"
apply (vcg)
apply fastforce+
done

text \<open>If we want to ensure that we do not dereference @{term "Null"} or
access unallocated memory, we have to add some guards.
\<close>
lemma (in list_alloc)
  shows
  "\<Gamma>,\<Theta>\<turnstile> \<lbrace>List \<acute>p \<acute>next Ps \<and> List \<acute>q \<acute>next Qs \<and> set Ps \<inter> set Qs = {} \<and>
       set Ps \<subseteq> set \<acute>alloc \<and> set Qs \<subseteq> set \<acute>alloc\<rbrace>
  WHILE \<acute>p \<noteq> Null
  INV \<lbrace>\<exists>ps qs. List \<acute>p \<acute>next  ps \<and> List \<acute>q \<acute>next qs \<and> set ps \<inter> set qs = {} \<and>
               rev ps @ qs = rev Ps @ Qs \<and>
               set ps \<subseteq> set \<acute>alloc \<and> set qs \<subseteq> set \<acute>alloc\<rbrace>
  DO \<acute>r :== \<acute>p;;
     \<lbrace>\<acute>p\<noteq>Null \<and> \<acute>p\<in>set \<acute>alloc\<rbrace>\<longmapsto> \<acute>p :== \<acute>p\<rightarrow> \<acute>next;;
     \<lbrace>\<acute>r\<noteq>Null \<and> \<acute>r\<in>set \<acute>alloc\<rbrace>\<longmapsto> \<acute>r\<rightarrow>\<acute>next :== \<acute>q;;
     \<acute>q :== \<acute>r OD
 \<lbrace>List \<acute>q \<acute>next (rev Ps @ Qs) \<and> set Ps \<subseteq> set \<acute>alloc \<and> set Qs \<subseteq> set \<acute>alloc\<rbrace>"
apply (vcg)
apply fastforce+
done

text \<open>We can also just prove that no faults will occur, by giving the
trivial postcondition.
\<close>
lemma (in list_alloc) rev_noFault:
  shows
  "\<Gamma>,\<Theta>\<turnstile> \<lbrace>List \<acute>p \<acute>next Ps \<and> List \<acute>q \<acute>next Qs \<and> set Ps \<inter> set Qs = {} \<and>
       set Ps \<subseteq> set \<acute>alloc \<and> set Qs \<subseteq> set \<acute>alloc\<rbrace>
  WHILE \<acute>p \<noteq> Null
  INV \<lbrace>\<exists>ps qs. List \<acute>p \<acute>next  ps \<and> List \<acute>q \<acute>next qs \<and> set ps \<inter> set qs = {} \<and>
               rev ps @ qs = rev Ps @ Qs \<and>
               set ps \<subseteq> set \<acute>alloc \<and> set qs \<subseteq> set \<acute>alloc\<rbrace>
  DO \<acute>r :== \<acute>p;;
     \<lbrace>\<acute>p\<noteq>Null \<and> \<acute>p\<in>set \<acute>alloc\<rbrace>\<longmapsto> \<acute>p :== \<acute>p\<rightarrow> \<acute>next;;
     \<lbrace>\<acute>r\<noteq>Null \<and> \<acute>r\<in>set \<acute>alloc\<rbrace>\<longmapsto> \<acute>r\<rightarrow>\<acute>next :== \<acute>q;;
     \<acute>q :== \<acute>r OD
  UNIV,UNIV"
apply (vcg)
apply fastforce+
done

lemma (in list_alloc) rev_moduloGuards:

  shows
  "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/{True}\<^esub> \<lbrace>List \<acute>p \<acute>next Ps \<and> List \<acute>q \<acute>next Qs \<and> set Ps \<inter> set Qs = {} \<and>
       set Ps \<subseteq> set \<acute>alloc \<and> set Qs \<subseteq> set \<acute>alloc\<rbrace>
  WHILE \<acute>p \<noteq> Null
  INV \<lbrace>\<exists>ps qs. List \<acute>p \<acute>next  ps \<and> List \<acute>q \<acute>next qs \<and> set ps \<inter> set qs = {} \<and>
               rev ps @ qs = rev Ps @ Qs \<and>
               set ps \<subseteq> set \<acute>alloc \<and> set qs \<subseteq> set \<acute>alloc\<rbrace>
  DO \<acute>r :== \<acute>p;;
     \<lbrace>\<acute>p\<noteq>Null \<and> \<acute>p\<in>set \<acute>alloc\<rbrace>\<surd> \<longmapsto> \<acute>p :== \<acute>p\<rightarrow> \<acute>next;;
     \<lbrace>\<acute>r\<noteq>Null \<and> \<acute>r\<in>set \<acute>alloc\<rbrace>\<surd> \<longmapsto> \<acute>r\<rightarrow>\<acute>next :== \<acute>q;;
     \<acute>q :== \<acute>r OD
 \<lbrace>List \<acute>q \<acute>next (rev Ps @ Qs) \<and> set Ps \<subseteq> set \<acute>alloc \<and> set Qs \<subseteq> set \<acute>alloc\<rbrace>"
apply vcg
apply fastforce+
done

lemma CombineStrip':
  assumes deriv: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c' Q,A"
  assumes deriv_strip: "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/{}\<^esub> P c'' UNIV,UNIV"
  assumes c'': "c''= mark_guards False (strip_guards (-F) c')"
  assumes c: "c = mark_guards False c'"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/{}\<^esub> P c Q,A"
proof -
  from deriv_strip [simplified c'']
  have "\<Gamma>,\<Theta>\<turnstile> P (strip_guards (- F) c') UNIV,UNIV"
    by (rule HoarePartialProps.MarkGuardsD)
  with deriv
  have "\<Gamma>,\<Theta>\<turnstile> P c' Q,A"
    by (rule HoarePartialProps.CombineStrip)
  hence "\<Gamma>,\<Theta>\<turnstile> P mark_guards False c' Q,A"
    by (rule HoarePartialProps.MarkGuardsI)
  thus ?thesis
    by (simp add: c)
qed

text \<open>We can then combine the prove that no fault will occur with the
functional prove of the programm without guards to get the full proove by
the rule @{thm HoarePartialProps.CombineStrip}
\<close>

lemma (in list_alloc)
  shows
  "\<Gamma>,\<Theta>\<turnstile> \<lbrace>List \<acute>p \<acute>next Ps \<and> List \<acute>q \<acute>next Qs \<and> set Ps \<inter> set Qs = {} \<and>
       set Ps \<subseteq> set \<acute>alloc \<and> set Qs \<subseteq> set \<acute>alloc\<rbrace>
  WHILE \<acute>p \<noteq> Null
  INV \<lbrace>\<exists>ps qs. List \<acute>p \<acute>next  ps \<and> List \<acute>q \<acute>next qs \<and> set ps \<inter> set qs = {} \<and>
               rev ps @ qs = rev Ps @ Qs \<and>
               set ps \<subseteq> set \<acute>alloc \<and> set qs \<subseteq> set \<acute>alloc\<rbrace>
  DO \<acute>r :== \<acute>p;;
     \<lbrace>\<acute>p\<noteq>Null \<and> \<acute>p\<in>set \<acute>alloc\<rbrace>\<longmapsto> \<acute>p :== \<acute>p\<rightarrow> \<acute>next;;
     \<lbrace>\<acute>r\<noteq>Null \<and> \<acute>r\<in>set \<acute>alloc\<rbrace>\<longmapsto> \<acute>r\<rightarrow>\<acute>next :== \<acute>q;;
     \<acute>q :== \<acute>r OD
 \<lbrace>List \<acute>q \<acute>next (rev Ps @ Qs) \<and> set Ps \<subseteq> set \<acute>alloc \<and> set Qs \<subseteq> set \<acute>alloc\<rbrace>"

apply (rule CombineStrip' [OF rev_moduloGuards rev_noFault])
apply  simp
apply simp
done

text \<open>In the previous example the effort to split up the prove did not
really pay off. But when we think of programs with a lot of guards and
complicated specifications it may be better to first focus on a prove without
the messy guards. Maybe it is possible to automate the no fault proofs so
that it suffices to focus on the stripped program.
\<close>

context list_alloc
begin
text \<open>
The purpose of guards is to watch for faults that can occur during
evaluation of expressions. In the example before we watched for null pointer
dereferencing or memory faults. We can also look for array index bounds or
division by zero. As the condition of a while loop is evaluated in each
iteration we cannot just add a guard before the while loop. Instead we need
a special guard for the condition.
Example: @{term "WHILE  \<lbrace>\<acute>p\<noteq>Null\<rbrace>\<longmapsto> \<acute>p\<rightarrow>\<acute>next\<noteq>Null DO SKIP OD"}
\<close>
end

subsection \<open>Cicular Lists\<close>
definition
  distPath :: "ref \<Rightarrow> (ref \<Rightarrow> ref) \<Rightarrow> ref \<Rightarrow> ref list \<Rightarrow> bool" where
  "distPath x next y as = (Path x next y as  \<and>  distinct as)"

lemma neq_dP: "\<lbrakk>p \<noteq> q; Path p h q Ps; distinct Ps\<rbrakk> \<Longrightarrow>
 \<exists>Qs. p\<noteq>Null \<and> Ps = p#Qs \<and> p \<notin> set Qs"
by (cases Ps, auto)

lemma (in list_alloc) circular_list_rev_I:
  "\<Gamma>,\<Theta>\<turnstile> \<lbrace>\<acute>root = r \<and>  distPath \<acute>root \<acute>next \<acute>root (r#Ps)\<rbrace>
   \<acute>p :== \<acute>root;; \<acute>q :== \<acute>root\<rightarrow>\<acute>next;;
  WHILE \<acute>q \<noteq> \<acute>root
  INV \<lbrace>\<exists> ps qs. distPath \<acute>p \<acute>next \<acute>root ps  \<and> distPath \<acute>q \<acute>next \<acute>root qs \<and>
             \<acute>root = r \<and> r\<noteq>Null \<and> r \<notin> set Ps  \<and> set ps \<inter> set qs = {} \<and>
             Ps = (rev ps) @ qs \<rbrace>
  DO \<acute>tmp :== \<acute>q;; \<acute>q :== \<acute>q\<rightarrow>\<acute>next;; \<acute>tmp\<rightarrow>\<acute>next :== \<acute>p;; \<acute>p:==\<acute>tmp OD;;
  \<acute>root\<rightarrow>\<acute>next :== \<acute>p
  \<lbrace>\<acute>root = r \<and> distPath \<acute>root \<acute>next \<acute>root (r#rev Ps)\<rbrace>"
apply (simp only:distPath_def)
apply vcg
apply   (rule_tac x="[]" in exI)
apply   fastforce
apply  clarsimp
apply  (drule (2) neq_dP)
apply  (rule_tac x="q # ps" in exI)
apply  clarsimp
apply fastforce
done

lemma path_is_list:"\<And>a next b. \<lbrakk>Path b next a Ps ; a \<notin> set Ps; a\<noteq>Null\<rbrakk>
\<Longrightarrow> List b (next(a := Null)) (Ps @ [a])"
apply (induct Ps)
apply (auto simp add:fun_upd_apply)
done

text \<open>
The simple algorithm for acyclic list reversal, with modified
annotations, works for cyclic lists as well.:
\<close>

lemma (in list_alloc) circular_list_rev_II:
 "\<Gamma>,\<Theta>\<turnstile>
 \<lbrace>\<acute>p = r \<and> distPath \<acute>p \<acute>next \<acute>p (r#Ps)\<rbrace>
\<acute>q:==Null;;
WHILE \<acute>p \<noteq> Null
INV
 \<lbrace> ((\<acute>q = Null) \<longrightarrow> (\<exists>ps. distPath \<acute>p \<acute>next r ps  \<and>  ps = r#Ps)) \<and>
  ((\<acute>q \<noteq> Null) \<longrightarrow> (\<exists>ps qs. distPath \<acute>q \<acute>next r qs  \<and> List \<acute>p \<acute>next ps  \<and>
                   set ps \<inter> set qs = {} \<and> rev qs @ ps = Ps@[r])) \<and>
  \<not> (\<acute>p = Null \<and> \<acute>q = Null \<and> r = Null )
   \<rbrace>
DO
  \<acute>tmp :== \<acute>p;; \<acute>p :== \<acute>p\<rightarrow>\<acute>next;; \<acute>tmp\<rightarrow>\<acute>next :== \<acute>q;; \<acute>q:==\<acute>tmp
OD
 \<lbrace>\<acute>q = r \<and> distPath \<acute>q \<acute>next \<acute>q (r # rev Ps)\<rbrace>"

apply (simp only:distPath_def)
apply vcg
apply   clarsimp
apply  clarsimp
apply  (case_tac "(q = Null)")
apply   (fastforce intro: path_is_list)
apply  clarify
apply  (rule_tac x="psa" in exI)
apply  (rule_tac x=" p # qs" in exI)
apply  force
apply fastforce
done

text\<open>Although the above algorithm is more succinct, its invariant
looks more involved. The reason for the case distinction on @{term q}
is due to the fact that during execution, the pointer variables can
point to either cyclic or acyclic structures.
\<close>

text \<open>
When working on lists, its sometimes better to remove
@{thm[source] fun_upd_apply} from the simpset, and instead include @{thm[source] fun_upd_same} and @{thm[source] fun_upd_other} to
the simpset
\<close>

(*
declare fun_upd_apply[simp del]fun_upd_same[simp] fun_upd_other[simp]
*)

lemma (in state_space) "\<Gamma>\<turnstile> {\<sigma>}
            \<acute>I :== \<acute>M;;
            ANNO \<tau>. \<lbrace>\<tau>. \<acute>I = \<^bsup>\<sigma>\<^esup>M\<rbrace>
                      \<acute>M :== \<acute>N;; \<acute>N :== \<acute>I
                    \<lbrace>\<acute>M = \<^bsup>\<tau>\<^esup>N \<and> \<acute>N = \<^bsup>\<tau>\<^esup>I\<rbrace>
            \<lbrace>\<acute>M = \<^bsup>\<sigma>\<^esup>N \<and> \<acute>N = \<^bsup>\<sigma>\<^esup>M\<rbrace>"
apply vcg
apply auto
done

context state_space
begin
term "ANNO (\<tau>,m,k). (\<lbrace>\<tau>. \<acute>M = m\<rbrace>) \<acute>M :== \<acute>N;; \<acute>N :== \<acute>I \<lbrace>\<acute>M = \<^bsup> \<tau>\<^esup>N & \<acute>N = \<^bsup>\<tau>\<^esup>I\<rbrace>,{}"
end

lemma (in state_space) "\<Gamma>\<turnstile> ({\<sigma>} \<inter> \<lbrace>\<acute>M = 0 \<and> \<acute>S = 0\<rbrace>)
      (ANNO \<tau>. ({\<tau>} \<inter> \<lbrace>\<acute>A=\<^bsup>\<sigma>\<^esup>A \<and> \<acute>I=\<^bsup>\<sigma>\<^esup>I \<and> \<acute>M=0 \<and> \<acute>S=0\<rbrace>)
      WHILE \<acute>M \<noteq> \<acute>A
      INV \<lbrace>\<acute>S = \<acute>M * \<acute>I \<and> \<acute>A=\<^bsup>\<tau>\<^esup>A \<and> \<acute>I=\<^bsup>\<tau>\<^esup>I\<rbrace>
      DO \<acute>S :== \<acute>S + \<acute>I;; \<acute>M :== \<acute>M + 1 OD
      \<lbrace>\<acute>S = \<^bsup>\<tau>\<^esup>A * \<^bsup>\<tau>\<^esup>I\<rbrace>)
      \<lbrace>\<acute>S = \<^bsup>\<sigma>\<^esup>A * \<^bsup>\<sigma>\<^esup>I\<rbrace>"
apply vcg_step
apply vcg_step
apply simp
apply vcg_step
apply vcg_step
apply simp
apply vcg
apply simp
apply simp
apply vcg_step
apply auto
done

text \<open>Just some test on marked, guards\<close>
lemma (in state_space) "\<Gamma>\<turnstile>\<lbrace>True\<rbrace> WHILE \<lbrace>P \<acute>N \<rbrace>\<surd>, \<lbrace>Q \<acute>M\<rbrace>#, \<lbrace>R \<acute>N\<rbrace>\<longmapsto> \<acute>N < \<acute>M
                    INV \<lbrace>\<acute>N < 2\<rbrace> DO
                    \<acute>N :== \<acute>M
                  OD
           \<lbrace>hard\<rbrace>"
apply vcg
oops

lemma (in state_space) "\<Gamma>\<turnstile>\<^bsub>/{True}\<^esub> \<lbrace>True\<rbrace> WHILE \<lbrace>P \<acute>N \<rbrace>\<surd>, \<lbrace>Q \<acute>M\<rbrace>#, \<lbrace>R \<acute>N\<rbrace>\<longmapsto> \<acute>N < \<acute>M
                    INV \<lbrace>\<acute>N < 2\<rbrace> DO
                    \<acute>N :== \<acute>M
                  OD
           \<lbrace>hard\<rbrace>"
apply vcg
oops

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section {* \isaheader{Deprecated: Data Refinement for the While-Combinator} *}
theory DatRef
imports
  Main
  "~~/src/HOL/Library/While_Combinator"
begin
text_raw {*\label{thy:DatRef}*}

text {*
  Note that this theory is deprecated. For new developments, the refinement
  framework (Refine-Monadic entry of the AFP) should be used.
*}

text {*
  In this theory, a data refinement framework for
  non-deterministic while-loops is developed. The refinement is based on
  showing simulation w.r.t. an abstraction function.
  The case of deterministic while-loops is explicitely handled, to
  support proper code-generation using the While-Combinator.

  Note that this theory is deprecated. For new developments, the refinement
  framework (Refine-Monadic entry of the AFP) should be used.
  *}

(* TODO-LIST and ideas
  - Model nondeterministic algorithms by their step relation, and show refinement stuff for this (more general) model (c.f. dpn-pre^* formalization)
    Then, the nondeterministic while-loop would be a special case.

*)

text {*
  A nondeterministic while-algorithm is described by a set of states, a
  continuation condition, a step relation, a set of possible initial
  states and an invariant.
  *}

  -- "Encapsulates a while-algorithm and its invariant "
record 'S while_algo =
  -- "Termination condition"
  wa_cond :: "'S set"
  -- "Step relation (nondeterministic)"
  wa_step :: "('S \<times> 'S) set"
  -- "Initial state (nondeterministic)"
  wa_initial :: "'S set"
  -- "Invariant"
  wa_invar :: "'S set"

text {*
  A while-algorithm is called {\em well-defined} iff the invariant holds for
  all reachable states and the accessible part of the step-relation is
  well-founded.
*}
  -- {* Conditions that must hold for a well-defined while-algorithm *}
locale while_algo =
  fixes WA :: "'S while_algo"

  -- "A step must preserve the invariant"
  assumes step_invar:
    "\<lbrakk> s\<in>wa_invar WA; s\<in>wa_cond WA; (s,s')\<in>wa_step WA \<rbrakk> \<Longrightarrow> s'\<in>wa_invar WA"
  -- "Initial states must satisfy the invariant"
  assumes initial_invar: "wa_initial WA \<subseteq> wa_invar WA"
  -- "The accessible part of the step relation must be well-founded"
  assumes step_wf:
    "wf { (s',s). s\<in>wa_invar WA \<and> s\<in>wa_cond WA \<and> (s,s')\<in>wa_step WA }"

text {*
  Next, a refinement relation for while-algorithms is defined.
  Note that the involved while-algorithms are not required to
  be well-defined. Later, some lemmas to transfer well-definedness
  along refinement relations are shown.

  Refinement involves a concrete algorithm, an abstract algorithm and an
  abstraction function. In essence, a refinement establishes a simulation
  of the concrete algorithm by the abstract algorithm w.r.t. the abstraction
  function.
*}

locale wa_refine =
  -- "Concrete algorithm"
  fixes WAC :: "'C while_algo"
  -- "Abstract algorithm"
  fixes WAA :: "'A while_algo"

  -- "Abstraction function"
  fixes \<alpha> :: "'C \<Rightarrow> 'A"

  -- "Condition implemented correctly: The concrete condition must be stronger
      than the abstract one. Intuitively, this ensures that the concrete loop
      will not run longer than the abstract one that it is simulated by."
  assumes cond_abs: "\<lbrakk> s\<in>wa_invar WAC; s\<in>wa_cond WAC \<rbrakk> \<Longrightarrow> \<alpha> s \<in> wa_cond WAA"

  -- "Step implemented correctly: The abstract step relation must simulate the
      concrete step relation"
  assumes step_abs: "\<lbrakk> s\<in>wa_invar WAC; s\<in>wa_cond WAC; (s,s')\<in>wa_step WAC \<rbrakk>
                      \<Longrightarrow> (\<alpha> s, \<alpha> s')\<in>wa_step WAA"
  -- "Initial states implemented correctly: The abstractions of the concrete
      initial states must be abstract initial states."
  assumes initial_abs: "\<alpha> ` wa_initial WAC \<subseteq> wa_initial WAA"
  -- {* Invariant implemented correctly: The concrete invariant must be stronger
        then the abstract invariant.
        Note that, usually, the concrete invariant will be of the
        form @{term "I_add \<inter> {s. \<alpha> s \<in> wa_invar WAA}"}, where @{term I_add} are
        the additional invariants added by the concrete algorithm.
     *}
  assumes invar_abs: "\<alpha> ` wa_invar WAC \<subseteq> wa_invar WAA"
begin

  lemma initial_abs': "s\<in>wa_initial WAC \<Longrightarrow> \<alpha> s \<in> wa_initial WAA"
    using initial_abs by auto

  lemma invar_abs': "s\<in>wa_invar WAC \<Longrightarrow> \<alpha> s \<in> wa_invar WAA"
    using invar_abs by auto

end

-- {*
  Given a concrete while-algorithm and a well-defined abstract
  while-algorithm, this lemma shows refinement and
  well-definedness of the concrete while-algorithm.

  Assuming well-definedness of the abstract algorithm and refinement,
  some proof-obligations for well-definedness of the concrete algorithm can be
  discharged automatically.

  For this purpose, the invariant is split into a concrete and an abstract
  part. The abstract part claims that the abstraction of a state satisfies
  the abstract invariant. The concrete part makes some additional claims
  about a valid concrete state. Then, after having shown refinement, the
  assumptions that the abstract part of the invariant is preserved, can
  be discharged automatically.
*}
lemma wa_refine_intro:
  fixes condc :: "'C set" and
        stepc :: "('C\<times>'C) set" and
        initialc :: "'C set" and
        invar_addc :: "'C set"
  fixes WAA :: "'A while_algo"
  fixes \<alpha> :: "'C \<Rightarrow> 'A"
  assumes "while_algo WAA"

  -- "The concrete step preserves the concrete part of the invariant"
  assumes step_invarc:
    "!!s s'. \<lbrakk> s\<in>invar_addc; s\<in>condc; \<alpha> s \<in> wa_invar WAA; (s,s')\<in>stepc \<rbrakk>
              \<Longrightarrow> s'\<in>invar_addc"
  -- "The concrete initial states satisfy the concrete part of the invariant"
  assumes initial_invarc: "initialc \<subseteq> invar_addc"

  -- "Condition implemented correctly"
  assumes cond_abs:
    "!!s. \<lbrakk> s\<in>invar_addc; \<alpha> s \<in> wa_invar WAA; s\<in>condc \<rbrakk> \<Longrightarrow> \<alpha> s \<in> wa_cond WAA"
  -- "Step implemented correctly"
  assumes step_abs:
    "!!s s'. \<lbrakk> s\<in>invar_addc; s\<in>condc; \<alpha> s \<in> wa_invar WAA; (s,s')\<in>stepc \<rbrakk>
             \<Longrightarrow> (\<alpha> s, \<alpha> s')\<in>wa_step WAA"
  -- "Initial states implemented correctly"
  assumes initial_abs: "\<alpha> ` initialc \<subseteq> wa_initial WAA"

  -- "Concrete while-algorithm: The invariant is separated into a concrete and
      an abstract part"
  defines "WAC == \<lparr>
   wa_cond=condc,
   wa_step=stepc,
   wa_initial=initialc,
   wa_invar=(invar_addc \<inter> {s. \<alpha> s\<in> wa_invar WAA}) \<rparr>"

  shows
    "while_algo WAC \<and>
     wa_refine WAC WAA \<alpha>" (is "?T1 \<and> ?T2")
proof
  interpret waa: while_algo WAA by fact
  show G1: "?T1"
    apply (unfold_locales)
    apply (simp_all add: WAC_def)
    apply safe
    apply (blast intro!: step_invarc)

    apply (frule (3) step_abs)
    apply (frule (2) cond_abs)
    apply (erule (2) waa.step_invar)

    apply (erule set_rev_mp[OF _ initial_invarc])

    apply (insert initial_abs waa.initial_invar) [1]
    apply blast

    apply (rule_tac
      r="inv_image { (s',s). s\<in>wa_invar WAA
                     \<and> s\<in>wa_cond WAA
                     \<and> (s,s')\<in>wa_step WAA } \<alpha>"
      in wf_subset)
    apply (simp add: waa.step_wf)
    apply (auto simp add: cond_abs step_abs) [1]
    done
  show ?T2
    apply (unfold_locales)
    apply (auto simp add: cond_abs step_abs initial_abs WAC_def)
    done
qed

  -- {* After refinement has been shown, this lemma transfers
        the well-definedness property up the refinement chain.
        Like in @{thm [source] wa_refine_intro}, some proof-obligations can
        be discharged by assuming refinement and well-definedness of the
        abstract algorithm.
    *}
lemma (in wa_refine) wa_intro:
  -- "Concrete part of the invariant"
  fixes addi :: "'C set"
  -- "The abstract algorithm is well-defined"
  assumes "while_algo WAA"
  -- "The invariant can be split into concrete and abstract part"
  assumes icf: "wa_invar WAC = addi \<inter> {s. \<alpha> s \<in> wa_invar WAA}"

  -- "The step-relation preserves the concrete part of the invariant"
  assumes step_addi:
    "!!s s'. \<lbrakk> s\<in>addi; s\<in>wa_cond WAC; \<alpha> s \<in> wa_invar WAA;
               (s,s')\<in>wa_step WAC
             \<rbrakk> \<Longrightarrow> s'\<in>addi"

  -- "The initial states satisfy the concrete part of the invariant"
  assumes initial_addi: "wa_initial WAC \<subseteq> addi"

  shows
    "while_algo WAC"
proof -
  interpret waa: while_algo WAA by fact
  show ?thesis
    apply (unfold_locales)
    apply (subst icf)
    apply safe
    apply (simp only: icf)
    apply safe
    apply (blast intro!: step_addi)

    apply (frule (2) step_abs)
    apply (frule (1) cond_abs)
    apply (simp only: icf)
    apply clarify
    apply (erule (2) waa.step_invar)

    apply (simp add: icf)
    apply (rule conjI)
    apply (erule set_rev_mp[OF _ initial_addi])
    apply (insert initial_abs waa.initial_invar) [1]
    apply blast

    apply (rule_tac
      r="inv_image { (s',s). s\<in>wa_invar WAA
                    \<and> s\<in>wa_cond WAA
                    \<and> (s,s')\<in>wa_step WAA } \<alpha>"
      in wf_subset)
    apply (simp add: waa.step_wf)
    apply (auto simp add: cond_abs step_abs icf) [1]
    done
qed

text {*
  A special case of refinement occurs, if the concrete condition implements the
  abstract condition precisely. In this case, the concrete algorithm will run
  as long as the abstract one that it is simulated by. This allows to
  transfer properties of the result from the abstract algorithm to the
  concrete one.
*}

-- "Precise refinement"
locale wa_precise_refine = wa_refine +
  constrains \<alpha> :: "'C \<Rightarrow> 'A"
  assumes cond_precise:
    "\<forall>s. s\<in>wa_invar WAC \<and> \<alpha> s\<in>wa_cond WAA \<longrightarrow> s\<in>wa_cond WAC"
begin
  -- "Transfer correctness property"
  lemma transfer_correctness:
    assumes A: "\<forall>s. s\<in>wa_invar WAA \<and> s\<notin>wa_cond WAA \<longrightarrow> P s"
    shows "\<forall>sc. sc\<in>wa_invar WAC \<and> sc\<notin>wa_cond WAC \<longrightarrow> P (\<alpha> sc)"
    using A cond_abs invar_abs cond_precise by blast
end

text {* Refinement as well as precise refinement is reflexive and transitive *}

lemma wa_ref_refl: "wa_refine WA WA id"
  by (unfold_locales) auto

lemma wa_pref_refl: "wa_precise_refine WA WA id"
  by (unfold_locales) auto

lemma wa_ref_trans:
  assumes "wa_refine WC WB \<alpha>1"
  assumes "wa_refine WB WA \<alpha>2"
  shows "wa_refine WC WA (\<alpha>2\<circ>\<alpha>1)"
proof -
  interpret r1: wa_refine WC WB \<alpha>1 by fact
  interpret r2: wa_refine WB WA \<alpha>2 by fact

  show ?thesis (* Cool, everything by auto! *)
    apply unfold_locales
    apply (auto simp add:
      r1.invar_abs' r2.invar_abs'
      r1.cond_abs r2.cond_abs
      r1.step_abs r2.step_abs
      r1.initial_abs' r2.initial_abs')
    done
qed

lemma wa_pref_trans:
  assumes "wa_precise_refine WC WB \<alpha>1"
  assumes "wa_precise_refine WB WA \<alpha>2"
  shows "wa_precise_refine WC WA (\<alpha>2\<circ>\<alpha>1)"
proof -
  interpret r1: wa_precise_refine WC WB \<alpha>1 by fact
  interpret r2: wa_precise_refine WB WA \<alpha>2 by fact

  show ?thesis
    apply intro_locales
    apply (rule wa_ref_trans)
    apply (unfold_locales)
    apply (auto simp add: r1.invar_abs' r2.invar_abs'
                          r1.cond_precise r2.cond_precise)
    done
qed

text {*
  A well-defined while-algorithm is {\em deterministic}, iff
  the step relation is a function and there is just one
  initial state. Such an algorithm is suitable for direct implementation
  by the while-combinator.

  For deterministic while-algorithm, an own record is defined, as well as a
  function that maps it to the corresponding record for non-deterministic
  while algorithms. This makes sense as the step-relation may then be modeled
  as a function, and the initial state may be modeled as a single state rather
  than a (singleton) set of states.
*}

record 'S det_while_algo =
  -- "Termination condition"
  dwa_cond :: "'S \<Rightarrow> bool"
  -- "Step function"
  dwa_step :: "'S \<Rightarrow> 'S"
  -- "Initial state"
  dwa_initial :: "'S"
  -- "Invariant"
  dwa_invar :: "'S set"

  -- "Maps the record for deterministic while-algo to the corresponding record for
      the non-deterministic one"
definition "det_wa_wa DWA == \<lparr>
  wa_cond={s. dwa_cond DWA s},
  wa_step={(s,dwa_step DWA s) | s. True},
  wa_initial={dwa_initial DWA},
  wa_invar = dwa_invar DWA\<rparr>"

  -- "Conditions for a deterministic while-algorithm"
locale det_while_algo =
  fixes WA :: "'S det_while_algo"
  -- "The step preserves the invariant"
  assumes step_invar:
    "\<lbrakk> s\<in>dwa_invar WA; dwa_cond WA s \<rbrakk> \<Longrightarrow> dwa_step WA s \<in> dwa_invar WA"
  -- "The initial state satisfies the invariant"
  assumes initial_invar: "dwa_initial WA \<in> dwa_invar WA"
  -- "The relation made up by the step-function is well-founded."
  assumes step_wf:
    "wf { (dwa_step WA s,s) | s. s\<in>dwa_invar WA \<and> dwa_cond WA s }"

begin
  lemma is_while_algo: "while_algo (det_wa_wa WA)"
    apply (unfold_locales)
    apply (auto simp add: det_wa_wa_def step_invar initial_invar)
    apply (insert step_wf)
    apply (erule_tac P=wf in back_subst)
    apply auto
    done

end

lemma det_while_algo_intro:
  assumes "while_algo (det_wa_wa DWA)"
  shows "det_while_algo DWA"
proof -
  interpret while_algo "(det_wa_wa DWA)" by fact

  show ?thesis using step_invar initial_invar step_wf
    apply (unfold_locales)
    apply (unfold det_wa_wa_def)
    apply auto
    apply (erule_tac P=wf in back_subst)
    apply auto
    done

qed

-- "A deterministic while-algorithm is well-defined, if and only if the
    corresponding non-deterministic while-algorithm is well-defined"
theorem dwa_is_wa:
  "while_algo (det_wa_wa DWA) \<longleftrightarrow> det_while_algo DWA"
  using det_while_algo_intro det_while_algo.is_while_algo by auto

definition (in det_while_algo)
  "loop == (while (dwa_cond WA) (dwa_step WA) (dwa_initial WA))"

-- "Proof rule for deterministic while loops"
lemma (in det_while_algo) while_proof:
  assumes inv_imp: "\<And>s. \<lbrakk>s\<in>dwa_invar WA; \<not> dwa_cond WA s\<rbrakk> \<Longrightarrow> Q s"
  shows "Q loop"
  apply (unfold loop_def)
  apply (rule_tac P="\<lambda>x. x\<in>dwa_invar WA" and
                  r="{ (dwa_step WA s,s) | s. s\<in>dwa_invar WA \<and> dwa_cond WA s }"
                  in while_rule)
  apply (simp_all add: step_invar initial_invar step_wf inv_imp)
  done

  -- "This version is useful when using transferred correctness lemmas"
lemma (in det_while_algo) while_proof':
  assumes inv_imp:
    "\<forall>s. s\<in>wa_invar (det_wa_wa WA) \<and> s\<notin>wa_cond (det_wa_wa WA) \<longrightarrow> Q s"
  shows "Q loop"
  using inv_imp
  apply (simp add: det_wa_wa_def)
  apply (blast intro: while_proof)
  done

lemma (in det_while_algo) loop_invar:
  "loop \<in> dwa_invar WA"
  by (rule while_proof) simp

end


subsection \<open>Relation Between the State and the Heap Monad\<close>

theory State_Heap
  imports
    "../state_monad/DP_CRelVS"
    "HOL-Imperative_HOL.Imperative_HOL"
    State_Heap_Misc
    Heap_Monad_Ext
begin

definition lift_p :: "(heap \<Rightarrow> bool) \<Rightarrow> 'a Heap \<Rightarrow> bool" where
  "lift_p P f =
    (\<forall> heap. P heap \<longrightarrow> (case execute f heap of None \<Rightarrow> False | Some (_, heap) \<Rightarrow> P heap))"

context
  fixes P f heap
  assumes lift: "lift_p P f" and P: "P heap"
begin

lemma execute_cases:
  "case execute f heap of None \<Rightarrow> False | Some (_, heap) \<Rightarrow> P heap"
  using lift P unfolding lift_p_def by auto

lemma execute_cases':
  "case execute f heap of Some (_, heap) \<Rightarrow> P heap"
  using execute_cases by (auto split: option.split)

lemma lift_p_None[simp, dest]:
  False if "execute f heap = None"
  using that execute_cases by auto

lemma lift_p_P:
  "case the (execute f heap) of (_, heap) \<Rightarrow> P heap"
  using execute_cases by (auto split: option.split_asm)

lemma lift_p_P':
  "P heap'" if "the (execute f heap) = (v, heap')"
  using that lift_p_P by auto

lemma lift_p_P'':
  "P heap'" if "execute f heap = Some (v, heap')"
  using that lift_p_P by auto

lemma lift_p_the_Some[simp]:
  "execute f heap = Some (v, heap')" if "the (execute f heap) = (v, heap')"
  using that execute_cases by (auto split: option.split_asm)

lemma lift_p_E:
  obtains v heap' where "execute f heap = Some (v, heap')" "P heap'"
  using execute_cases by (cases "execute f heap") auto

end

definition "state_of s \<equiv> State (\<lambda> heap. the (execute s heap))"

locale heap_mem_defs =
  fixes P :: "heap \<Rightarrow> bool"
    and lookup :: "'k \<Rightarrow> 'v option Heap"
    and update :: "'k \<Rightarrow> 'v \<Rightarrow> unit Heap"
begin

definition rel_state :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> (heap, 'a) state \<Rightarrow> 'b Heap \<Rightarrow> bool" where
  "rel_state R f g \<equiv>
    \<forall> heap. P heap \<longrightarrow>
      (case State_Monad.run_state f heap of (v1, heap1) \<Rightarrow> case execute g heap of
        Some (v2, heap2) \<Rightarrow> R v1 v2 \<and> heap1 = heap2 \<and> P heap2 | None \<Rightarrow> False)"

definition "lookup' k \<equiv> State (\<lambda> heap. the (execute (lookup k) heap))"

definition "update' k v \<equiv> State (\<lambda> heap. the (execute (update k v) heap))"

definition "heap_get = Heap_Monad.Heap (\<lambda> heap. Some (heap, heap))"

definition checkmem :: "'k \<Rightarrow> 'v Heap \<Rightarrow> 'v Heap" where
  "checkmem param calc \<equiv>
    Heap_Monad.bind (lookup param) (\<lambda> x.
    case x of
      Some x \<Rightarrow> return x
    | None \<Rightarrow> Heap_Monad.bind calc (\<lambda> x.
        Heap_Monad.bind (update param x) (\<lambda> _.
        return x
      )
    )
  )
  "

definition checkmem' :: "'k \<Rightarrow> (unit \<Rightarrow> 'v Heap) \<Rightarrow> 'v Heap" where
  "checkmem' param calc \<equiv>
    Heap_Monad.bind (lookup param) (\<lambda> x.
    case x of
      Some x \<Rightarrow> return x
    | None \<Rightarrow> Heap_Monad.bind (calc ()) (\<lambda> x.
        Heap_Monad.bind (update param x) (\<lambda> _.
        return x
      )
    )
  )
  "

lemma checkmem_checkmem':
  "checkmem' param (\<lambda>_. calc) = checkmem param calc"
  unfolding checkmem'_def checkmem_def ..

definition map_of_heap where
  "map_of_heap heap k = fst (the (execute (lookup k) heap))"

lemma rel_state_elim:
  assumes "rel_state R f g" "P heap"
  obtains heap' v v' where
    "State_Monad.run_state f heap = (v, heap')" "execute g heap = Some (v', heap')" "R v v'" "P heap'"
  apply atomize_elim
  using assms unfolding rel_state_def
  apply auto
  apply (cases "State_Monad.run_state f heap")
  apply auto
  apply (auto split: option.split_asm)
  done

lemma rel_state_intro:
  assumes
    "\<And> heap v heap'. P heap \<Longrightarrow> State_Monad.run_state f heap = (v, heap')
      \<Longrightarrow> \<exists> v'. R v v' \<and> execute g heap = Some (v', heap')"
    "\<And> heap v heap'. P heap \<Longrightarrow> State_Monad.run_state f heap = (v, heap') \<Longrightarrow> P heap'"
  shows "rel_state R f g"
  unfolding rel_state_def
  apply auto
  apply (frule assms(1)[rotated])
   apply (auto intro: assms(2))
  done

context
  includes lifting_syntax state_monad_syntax
begin

lemma transfer_bind[transfer_rule]:
  "(rel_state R ===> (R ===> rel_state Q) ===> rel_state Q) State_Monad.bind Heap_Monad.bind"
  unfolding rel_fun_def State_Monad.bind_def Heap_Monad.bind_def
  by (force elim!: rel_state_elim intro!: rel_state_intro)

lemma transfer_return[transfer_rule]:
  "(R ===> rel_state R) State_Monad.return Heap_Monad.return"
  unfolding rel_fun_def State_Monad.return_def Heap_Monad.return_def
  by (fastforce intro: rel_state_intro elim: rel_state_elim simp: execute_heap)

lemma fun_app_lifted_transfer:
  "(rel_state (R ===> rel_state Q) ===> rel_state R ===> rel_state Q)
      State_Monad_Ext.fun_app_lifted Heap_Monad_Ext.fun_app_lifted"
  unfolding State_Monad_Ext.fun_app_lifted_def Heap_Monad_Ext.fun_app_lifted_def by transfer_prover

lemma transfer_get[transfer_rule]:
  "rel_state (=) State_Monad.get heap_get"
  unfolding State_Monad.get_def heap_get_def by (auto intro: rel_state_intro)

end (* Lifting Syntax *)

end (* Heap Mem Defs *)

locale heap_inv = heap_mem_defs _ lookup for lookup :: "'k \<Rightarrow> 'v option Heap"  +
  assumes lookup_inv: "lift_p P (lookup k)"
  assumes update_inv: "lift_p P (update k v)"
begin

lemma rel_state_lookup:
  "rel_state (=) (lookup' k) (lookup k)"
  unfolding rel_state_def lookup'_def using lookup_inv[of k] by (auto intro: lift_p_P')

lemma rel_state_update:
  "rel_state (=) (update' k v) (update k v)"
  unfolding rel_state_def update'_def using update_inv[of k v] by (auto intro: lift_p_P')

context
  includes lifting_syntax
begin

lemma transfer_lookup:
  "((=) ===> rel_state (=)) lookup' lookup"
  unfolding rel_fun_def by (auto intro: rel_state_lookup)

lemma transfer_update:
  "((=) ===> (=) ===> rel_state (=)) update' update"
  unfolding rel_fun_def by (auto intro: rel_state_update)

lemma transfer_checkmem:
  "((=) ===> rel_state (=) ===> rel_state (=))
    (state_mem_defs.checkmem lookup' update') checkmem"
  supply [transfer_rule] = transfer_lookup transfer_update
  unfolding state_mem_defs.checkmem_def checkmem_def by transfer_prover

end (* Lifting Syntax *)

end (* Heap Invariant *)

locale heap_correct =
  heap_inv +
  assumes lookup_correct:
      "P m \<Longrightarrow> map_of_heap (snd (the (execute (lookup k) m))) \<subseteq>\<^sub>m (map_of_heap m)"
  and update_correct:
      "P m \<Longrightarrow> map_of_heap (snd (the (execute (update k v) m))) \<subseteq>\<^sub>m (map_of_heap m)(k \<mapsto> v)"
begin

lemma lookup'_correct:
  "state_mem_defs.map_of lookup' (snd (State_Monad.run_state (lookup' k) m)) \<subseteq>\<^sub>m (state_mem_defs.map_of lookup' m)" if "P m"
  using \<open>P m\<close> unfolding state_mem_defs.map_of_def map_le_def lookup'_def
  by simp (metis (mono_tags, lifting) domIff lookup_correct map_le_def map_of_heap_def)

lemma update'_correct:
  "state_mem_defs.map_of lookup' (snd (State_Monad.run_state (update' k v) m)) \<subseteq>\<^sub>m state_mem_defs.map_of lookup' m(k \<mapsto> v)"
  if "P m"
  unfolding state_mem_defs.map_of_def map_le_def lookup'_def update'_def
  using update_correct[of m k v] that by (auto split: if_split_asm simp: map_le_def map_of_heap_def)

lemma lookup'_inv:
  "DP_CRelVS.lift_p P (lookup' k)"
  unfolding DP_CRelVS.lift_p_def lookup'_def by (auto elim: lift_p_P'[OF lookup_inv])

lemma update'_inv:
  "DP_CRelVS.lift_p P (update' k v)"
  unfolding DP_CRelVS.lift_p_def update'_def by (auto elim: lift_p_P'[OF update_inv])

lemma mem_correct_heap: "mem_correct lookup' update' P"
  by (intro mem_correct.intro lookup'_correct update'_correct lookup'_inv update'_inv)

end (* Heap correct *)

context heap_mem_defs
begin

context
  includes lifting_syntax
begin

lemma mem_correct_heap_correct:
  assumes correct: "mem_correct lookup\<^sub>s update\<^sub>s P"
    and lookup: "((=) ===> rel_state (=)) lookup\<^sub>s lookup"
    and update: "((=) ===> (=) ===> rel_state (=)) update\<^sub>s update"
  shows "heap_correct P update lookup"
proof -
  interpret mem: mem_correct lookup\<^sub>s update\<^sub>s P
    by (rule correct)
  have [simp]: "the (execute (lookup k) m) = run_state (lookup\<^sub>s k) m" if "P m" for k m
    using lookup[THEN rel_funD, OF HOL.refl, of k] \<open>P m\<close> by (auto elim: rel_state_elim)
  have [simp]: "the (execute (update k v) m) = run_state (update\<^sub>s k v) m" if "P m" for k v m
    using update[THEN rel_funD, THEN rel_funD, OF HOL.refl HOL.refl, of k v] \<open>P m\<close>
    by (auto elim: rel_state_elim)
  have [simp]: "map_of_heap m = mem.map_of m" if "P m" for m
    unfolding map_of_heap_def mem.map_of_def using \<open>P m\<close> by simp
  show ?thesis
  apply standard
    subgoal for k
      using mem.lookup_inv[of k] lookup[THEN rel_funD, OF HOL.refl, of k]
      unfolding lift_p_def DP_CRelVS.lift_p_def
      by (auto split: option.splits elim: rel_state_elim)
    subgoal for k v
      using mem.update_inv[of k] update[THEN rel_funD, THEN rel_funD, OF HOL.refl HOL.refl, of k v]
      unfolding lift_p_def DP_CRelVS.lift_p_def
      by (auto split: option.splits elim: rel_state_elim)
    subgoal premises prems for m k
    proof -
      have "P (snd (run_state (lookup\<^sub>s k) m))"
        by (meson DP_CRelVS.lift_p_P mem.lookup_inv prems prod.exhaust_sel)
      with mem.lookup_correct[OF \<open>P m\<close>, of k] \<open>P m\<close> show ?thesis
        by (simp add: prems)
    qed
    subgoal premises prems for m k v
    proof -
      have "P (snd (run_state (update\<^sub>s k v) m))"
        by (meson DP_CRelVS.lift_p_P mem.update_inv prems prod.exhaust_sel)
      with mem.update_correct[OF \<open>P m\<close>, of k] \<open>P m\<close> show ?thesis
        by (simp add: prems)
    qed
    done
qed

end

end

end (* Theory *)


theory Misc
imports Main "HOL-Analysis.Extended_Real_Limits" Tools
begin

instantiation "fun" :: (type,zero) zero begin
definition "0 = (\<lambda>x. 0)"
instance ..
end
instantiation "fun" :: (type,plus) plus begin
definition "f + g = (\<lambda>x. f x + g x)"
instance ..
end
instantiation "fun" :: (type,semigroup_add) semigroup_add begin
instance proof
  fix a b c :: "'a\<Rightarrow>'b"
  show "a + b + c = a + (b + c)"
    unfolding plus_fun_def by (rule ext, rule add.assoc)
qed
end
instantiation "fun" :: (type,ab_semigroup_add) ab_semigroup_add begin
instance proof
  fix a b :: "'a\<Rightarrow>'b"
  show "a + b = b + a"
    unfolding plus_fun_def by (rule ext, rule add.commute)
qed
end
instantiation "fun" :: (type,comm_monoid_add) comm_monoid_add begin
instance proof
  fix a :: "'a\<Rightarrow>'b"
  show "0 + a = a"
    unfolding plus_fun_def zero_fun_def by (rule ext, rule add.left_neutral)
qed
end

instantiation bool :: default begin
definition "default_bool = False"
instance by standard
end

lemma setsum_apply:
  assumes "finite N"
  shows "(\<Sum>n\<in>N. f n) x = (\<Sum>n\<in>N. f n x)"
using assms apply (induction N)
by (auto simp: zero_fun_def plus_fun_def)

lemma SUP_Suc:
  fixes f :: "nat \<Rightarrow> 'a::complete_lattice"
  assumes "mono f"
  shows "(SUP n. f n) = (SUP n. f (Suc n))"
using assms
by (smt SUP_eq bex_UNIV monoD mono_iff_le_Suc order_refl)

lemma mono_apply:
  assumes "mono f" and "mono g"
  shows "mono (\<lambda>n. f (g n))"
by (meson assms(1) assms(2) mono_def)

lemma mono_funD: "\<And>x. mono f \<Longrightarrow> mono (\<lambda>i. f i x)"
  unfolding mono_def le_fun_def by auto
lemma mono_funI: "(\<And>x. mono (\<lambda>i. f i x)) \<Longrightarrow> mono f"
  unfolding mono_def le_fun_def by auto

instantiation prod :: (default,default) default begin
definition "default_prod = (default,default)"
instance by intro_classes
end

lemma SUP_multc_ennreal:
  fixes a::"_ \<Rightarrow> ennreal"
  assumes finite: "b < \<infinity>" and notempty: "A \<noteq> {}"
  shows "(SUP i:A. a i*b) = (SUP i:A. a i)*b"
proof (rule SUP_eqI)
  fix i assume "i\<in>A"
  hence "a i \<le> (SUP i:A. a i)"
    by (simp add: SUP_upper)
  thus "a i * b \<le> (SUP i:A. a i) * b"
    by (simp add: mult_right_mono)
next
  fix y assume bound: "\<And>i. i \<in> A \<Longrightarrow> a i * b \<le> y"
  show "(SUP i:A. a i) * b \<le> y"
  proof (cases "b=0")
    assume "b=0"
    with bound notempty have "y \<ge> 0" by auto
    with `b=0` show ?thesis by auto
  next
    assume "b\<noteq>0" (* with pos have pos': "b>0" *)
      (* using gr_zeroI by blastx *)
    define y' where "y' == y / b"
    with bound finite `b\<noteq>0` have "\<And>i. i \<in> A \<Longrightarrow> a i \<le> y'"
      using leD le_less_linear
      using divide_less_ennreal by fastforce
    hence "(SUP i:A. a i) \<le> y'"
      by (simp add: SUP_least)
    thus ?thesis
      unfolding y'_def using finite `b\<noteq>0`
      using divide_less_ennreal leD by fastforce
  qed
qed

lemma SUP_ennreal_mult_left:
  fixes f :: "'a \<Rightarrow> ennreal"
  assumes "I \<noteq> {}"
  shows "(SUP i:I. c * f i) = c * (SUP i:I. f i)"
    proof (cases "(SUP i: I. f i) = 0")
  case True
  then have "\<And>i. i \<in> I \<Longrightarrow> f i = 0"
    by (metis SUP_upper le_zero_eq)
  with True show ?thesis
    by simp
next
  case False
  then show ?thesis
    apply (subst continuous_at_Sup_mono[where f="\<lambda>x. c * x"])
        using sup_continuous_mono sup_continuous_mult_left_ennreal' close blast
       using sup_continuous_at_left sup_continuous_mult_left_ennreal' close blast
      using assms by auto
qed

lemma sums_ennreal_positive:
  fixes f :: "nat \<Rightarrow> ennreal"
  shows "f sums (SUP n. \<Sum>i<n. f i)"
proof -
  have "incseq (\<lambda>i. \<Sum>j=0..<i. f j)"
    using add_mono
    by (auto intro!: incseq_SucI)
  from LIMSEQ_SUP[OF this]
  show ?thesis unfolding sums_def
    by (simp add: atLeast0LessThan)
qed

lemma suminf_ennreal_eq_SUP:
  fixes f :: "nat \<Rightarrow> ennreal"
  shows "(\<Sum>x. f x) = (SUP n. \<Sum>i<n. f i)"
  using sums_ennreal_positive[of f, THEN sums_unique]
  thm sums_ereal_positive
  by simp

lemma suminf_upper_ennreal:
  fixes f :: "nat \<Rightarrow> ennreal"
  shows "(\<Sum>n<N. f n) \<le> (\<Sum>n. f n)"
  unfolding suminf_ennreal_eq_SUP
  by (auto intro: complete_lattice_class.SUP_upper)

end