(* @TAG(OTHER_LGPL) *)

(*
    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 {* Examples using the Verification Environment *}

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

text {* Some examples, especially the single-step Isar proofs are taken from
\texttt{HOL/Isar\_examples/HoareEx.thy}.
*}

subsection {* State Spaces *}

text {*
 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.
*}

record 'g vars = "'g state" +
  A_' :: nat
  I_' :: nat
  M_' :: nat
  N_' :: nat
  R_' :: nat
  S_' :: nat
  B_' :: bool
  Arr_' :: "nat list"
  Abr_':: string

text {* We decorate the state components in the record with the suffix @{text "_'"},
to avoid cluttering the namespace with the simple names that could no longer
be used for logical variables otherwise.
*}

text {* 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).
*}

subsection {* Basic Examples *}

text {*
 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.
*}

text {*
 Using the basic rule directly is a bit cumbersome.
*}

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

text {*
 If we refer to components (variables) of the state-space of the program
 we always mark these with @{text "\<acute>"}. It is the acute-symbol and is present on
 most keyboards. So all program variables are marked with the acute and all
 logical variables are not.
 The assertions of the Hoare tuple are
 ordinary Isabelle sets. As we usually want to refer to the state space
 in the assertions, we provide special brackets for them. They can be written
 as {\verb+{| |}+} in ASCII or @{text "\<lbrace> \<rbrace>"} with X-symbols. Internally
 marking variables has two effects. First of all we refer to the implicit
 state and secondary we get rid of the suffix @{text "_'"}.
 So the assertion @{term "{|\<acute>N = 5|}"} internally gets expanded to
 @{text "{s. N_' s = 5}"} written in ordinary set comprehension notation of
 Isabelle. It describes the set of states where the @{text "N_'"} component
 is equal to @{text "5"}.
*}

text {*
 Certainly we want the state modification already done, e.g.\ by
 simplification.  The @{text vcg} method performs the basic state
 update for us; we may apply the Simplifier afterwards to achieve
 ``obvious'' consequences as well.
*}

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

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

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

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

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

lemma "\<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 "\<Gamma>\<turnstile> \<lbrace>True\<rbrace> \<acute>M :== a;; \<acute>N :== b \<lbrace>\<acute>M = a \<and> \<acute>N = b\<rbrace>"
  by vcg

lemma "\<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>"
  by vcg

text {*
We can also perform verification conditions generation step by step by using
the @{text vcg_step} method.
*}

lemma "\<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
  done

text {*
 It is important to note that statements like the following one can
 only be proven for each individual program variable.  Due to the
 extra-logical nature of record fields, we cannot formulate a theorem
 relating record selectors and updates schematically.
*}

lemma "\<Gamma>\<turnstile> \<lbrace>\<acute>N = a\<rbrace> \<acute>N :== \<acute>N \<lbrace>\<acute>N = a\<rbrace>"
  by vcg

(*
lemma "\<Gamma>\<turnstile> \<lbrace>\<acute>x = a\<rbrace> \<acute>x :== \<acute>x \<lbrace>\<acute>x = a\<rbrace>"
  apply (rule HoarePartial.Basic)
  -- {* We can't proof this since we don't know what @{text "x_'_update"} is. *}
  oops
 *)
lemma "\<Gamma>\<turnstile>{s. x_' s = a} (Basic (\<lambda>s. x_'_update (x_' s) s)) {s. x_' s = a}"
  oops

text {*
 In the following assignments we make use of the consequence rule in
 order to achieve the intended precondition.  Certainly, the
 @{text vcg} method is able to handle this case, too.
*}

lemma "\<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 "\<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"
      -- {* inclusion of assertions expressed in ``pure'' logic, *}
      -- {* without mentioning the state space *}
    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 "\<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 {* Multiplication by Addition *}

text {*
 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.
*}

lemma "\<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 {*
 The subsequent version of the proof applies the @{text vcg} 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.
*}

lemma "\<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 {* Here some examples of ``breaking'' out of a loop *}

lemma "\<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 "\<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 {* Some more syntactic sugar, the label statement @{text "\<dots> \<bullet> \<dots>"} as shorthand
for the @{text "TRY-CATCH"} above, and the @{text "RAISE"} for an state-update followed
by a @{text "THROW"}.
*}
lemma "\<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 "\<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 "\<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 {* Blocks *}

lemma  "\<Gamma>\<turnstile>\<lbrace>\<acute>I = i\<rbrace> LOC \<acute>I;; \<acute>I :== 2  COL \<lbrace>\<acute>I \<le> i\<rbrace>"
  apply vcg
  by simp
lemma "\<Gamma>\<turnstile> \<lbrace>\<acute>N = n\<rbrace> LOC \<acute>N :== 10;; \<acute>N :== \<acute>N + 2 COL \<lbrace>\<acute>N = n\<rbrace>"
  by vcg

lemma "\<Gamma>\<turnstile> \<lbrace>\<acute>N = n\<rbrace> LOC \<acute>N :== 10, \<acute>M;; \<acute>N :== \<acute>N + 2 COL \<lbrace>\<acute>N = n\<rbrace>"
  by vcg

subsection {* Summing Natural Numbers *}

text {*
 We verify an imperative program to sum natural numbers up to a given
 limit.  First some functional definition for proper specification of
 the problem.
*}

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 {*
 The following proof is quite explicit in the individual steps taken,
 with the @{text vcg} 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.
*}

theorem "\<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 {*
 The next version uses the @{text vcg} method, while still explaining
 the resulting proof obligations in an abstract, structured manner.
*}

theorem "\<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 {*
 Certainly, this proof may be done fully automatically as well, provided
 that the invariant is given beforehand.
*}

theorem "\<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 {* SWITCH *}

lemma "\<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 "\<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 {* (Mutually) Recursive Procedures *}

subsubsection {* Factorial *}

text {* We want to define a procedure for the factorial. We first
define a HOL functions that calculates it to specify the procedure later on.
*}

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 {* Now we define the procedure *}

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

text {* A procedure is given by the signature of the procedure
followed by the procedure body.
The signature consists of the name of the procedure and a list of
parameters. The parameters in front of the pipe @{text "|"} are value parameters
and behind the pipe are the result parameters. Value parameters model call by value
semantics. The value of a result parameter at the end of the procedure is passed back
to the caller.
*}

text {*
Behind the scenes the @{text "procedures"} command provides us convenient syntax
for procedure calls, defines a constant for the procedure body
(named @{term "Fac_body"}) and creates some locales. The purpose of locales
is to set up logical contexts to support modular reasoning.
A locale is named @{text Fac_impl} and extends the @{text hoare} locale
with a theorem @{term "\<Gamma> ''Fac'' = Fac_body"} that simply states how the
procedure is defined in the procedure context. Check out the locales.
The purpose of the locales is to give us easy means to setup the context
in which we will prove programs correct.
In these locales the procedure context @{term "\<Gamma>"} is fixed.
So always use this letter in procedure
specifications. This is crucial, if we later on prove some tuples under the
assumption of some procedure specifications.
*}

thm Fac_body.Fac_body_def
print_locale Fac_impl

text {*
To see how a call is syntactically translated you can switch off the
printing translation via the configuration option @{text hoare_use_call_tr'}
*}

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

text {*
Now let us prove that @{term "Fac"} meets its specification.
*}

text {*
Procedure specifications are ordinary Hoare tuples. We use the parameterless
call for the specification; @{text "\<acute>R :== PROC Fac(\<acute>N)"} is syntactic sugar
for @{text "Call ''Fac''"}. This emphasises that the specification
describes the internal behaviour of the procedure, whereas parameter passing
corresponds to the procedure call.
*}

lemma (in Fac_impl)
  shows "\<forall>n. \<Gamma>,\<Theta>\<turnstile>\<lbrace>\<acute>N=n\<rbrace>  PROC Fac(\<acute>N,\<acute>R) \<lbrace>\<acute>R = fac n\<rbrace>"
  apply (hoare_rule HoarePartial.ProcRec1)
  apply vcg
  apply simp
  done

text {*
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.
*}

text {* We can also step through verification condition generation. When
the verification condition generator encounters a procedure call it tries to
use the rule @{text ProcSpec}. To be successful there must be a specification
of the procedure in the context.
*}

lemma (in Fac_impl)
  shows "\<forall>n. \<Gamma>\<turnstile>\<lbrace>\<acute>N=n\<rbrace> \<acute>R :== PROC Fac(\<acute>N) \<lbrace>\<acute>R = fac 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 {* Here some Isar style version of the proof *}
lemma (in Fac_impl)
  shows "\<forall>n. \<Gamma>\<turnstile>\<lbrace>\<acute>N=n\<rbrace> \<acute>R :== PROC Fac(\<acute>N) \<lbrace>\<acute>R = fac n\<rbrace>"
proof (hoare_rule HoarePartial.ProcRec1)
  have Fac_spec: "\<forall>n. \<Gamma>,(\<Union>n. {(\<lbrace>\<acute>N=n\<rbrace>, Fac_'proc, \<lbrace>\<acute>R = fac n\<rbrace>,{})})
                       \<turnstile> \<lbrace>\<acute>N=n\<rbrace> \<acute>R :== PROC Fac(\<acute>N) \<lbrace>\<acute>R = fac n\<rbrace>"
    apply (rule allI)
    apply (rule hoarep.Asm)
    by auto
  show "\<forall>n. \<Gamma>,(\<Union>n. {(\<lbrace>\<acute>N=n\<rbrace>, Fac_'proc, \<lbrace>\<acute>R = fac n\<rbrace>,{})})
            \<turnstile> \<lbrace>\<acute>N=n\<rbrace> 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 n\<rbrace>"
    apply vcg
    apply simp
    done
qed

text {* To avoid retyping of potentially large pre and postconditions in
the previous proof we can use the casual term abbreviations of the Isar
language.
*}

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

text {* 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.
*}

lemma (in Fac_impl) Fac_spec:
  shows "\<forall>n. \<Gamma>\<turnstile>\<lbrace>\<acute>N=n\<rbrace> \<acute>R :== PROC Fac(\<acute>N) \<lbrace>\<acute>R = fac n\<rbrace>"
  (is "\<forall>n. \<Gamma>\<turnstile>(?Pre n) ?Fac (?Post n)")
proof (hoare_rule HoarePartial.ProcRec1)
  def "\<Theta>'"=="(\<Union>n. {(?Pre n, Fac_'proc, ?Post n,{}::('a, 'b) vars_scheme set)})"
  have Fac_spec: "\<forall>n. \<Gamma>,\<Theta>'\<turnstile>(?Pre n) ?Fac (?Post n)"
    by (unfold \<Theta>'_def, rule allI, rule hoarep.Asm) auto
  txt {* We have to name the fact @{text "Fac_spec"}, so that the vcg can
   use the specification for the recursive call, since it cannot infer it
   from the opaque @{term "\<Theta>'"}. *}
  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 {* 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] HoarePartial.ProcRec1},
@{thm [source] HoarePartial.ProcNoRec1}.
They are all derived from the most general rule
@{thm [source] HoarePartial.ProcRec}.
All of them have some side-condition concerning definedness of the procedure.
They can be
solved in a uniform fashion. Thats why we have created the method
@{text "hoare_rule"}, which behaves like the method @{text "rule"} but automatically
tries to solve the side-conditions.
*}

subsubsection {* Odd and Even *}

text {* Odd and even are defined mutually recursive here. In the
@{text "procedures"} command we conjoin both definitions with @{text "and"}.
*}

procedures
 odd(N | A) = "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 | A) = "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
thm odd_body.odd_body_def
thm even_body.even_body_def
print_locale odd_even_clique

text {* 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] HoarePartial.ProcRec} rule. An ML function does
this work:
*}

ML {* ML_Thms.bind_thm ("ProcRec2", Hoare.gen_proc_rec @{context} Hoare.Partial 2) *}

lemma (in odd_even_clique)
  shows odd_spec: "\<forall>n. \<Gamma>\<turnstile>\<lbrace>\<acute>N=n\<rbrace> \<acute>A :== PROC odd(\<acute>N)
                  \<lbrace>(\<exists>b. n = 2 * b + \<acute>A) \<and> \<acute>A < 2 \<rbrace>" (is ?P1)
   and even_spec: "\<forall>n. \<Gamma>\<turnstile>\<lbrace>\<acute>N=n\<rbrace> \<acute>A :== PROC even(\<acute>N)
                  \<lbrace>(\<exists>b. 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 {*Expressions With Side Effects *}

text {* \texttt{R := N++ + M++} *}
lemma "\<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

text {*\texttt{R := Fac (N) + Fac (M)} *}
lemma (in Fac_impl) shows
  "\<Gamma>\<turnstile> \<lbrace>True\<rbrace>
  CALL Fac(\<acute>N) \<ggreater> n. CALL Fac(\<acute>M) \<ggreater> m.
  \<acute>R :== n + m
  \<lbrace>\<acute>R = fac \<acute>N + fac \<acute>M\<rbrace>"
apply vcg
done

text {*\texttt{ R := (Fac(Fac (N)))}*}
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>"
apply vcg
done

subsection {* Global Variables and Heap *}

text {*
Now we 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.
*}

record globals_list =
  next_' :: "ref \<Rightarrow> ref"
  cont_' :: "ref \<Rightarrow> nat"

record 'g list_vars = "'g state" +
  p_'    :: "ref"
  q_'    :: "ref"
  r_'    :: "ref"
  root_' :: "ref"
  tmp_'  :: "ref"

text {* 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".
*}

text {* We 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.
*}

procedures
  append(p,q|p) =
    "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"

(*
  append_spec:
   "\<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>"

  append_modifies:
   "\<forall>\<sigma>. \<Gamma>\<turnstile> {\<sigma>} \<acute>p :== PROC append(\<acute>p,\<acute>q){t. t may_only_modify_globals \<sigma> in [next]}"
*)

context append_impl
begin
declare [[hoare_use_call_tr' = false]]
term "CALL append(\<acute>p,\<acute>q,\<acute>p\<rightarrow>\<acute>next)"
declare [[hoare_use_call_tr' = true]]
end
text {* Below we give two specifications this time.
One captures the functional behaviour and focuses on the
entities that are potentially modified by the procedure, the other 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 @{text "\<lbrace>\<sigma>. \<dots>\<rbrace>"} is a shorthand to fix the current
state: @{text "{s. \<sigma> = s \<dots>}"}.
*}

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 {* The modifies clause is equal to a proper record update specification
of the following form.
*}

lemma "{t. t may_only_modify_globals Z in [next]}
       =
       {t. \<exists>next. globals t=next_'_update (\<lambda>_. next) (globals Z)}"
  apply (unfold mex_def meq_def)
  apply (simp)
  done

text {* If the verification condition generator works on a procedure call
it checks whether it can find a modified clause in the context. If one
is present the procedure call is simplified before the Hoare rule
@{thm [source] HoarePartial.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] HoarePartial.ProcModifyReturn}.
So after this simplification all global components that do not appear in
the modifies clause will be treated as local variables.
*}

text {* 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.
*}

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 {* 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 @{text "spec=modifies"} It will also try to solve the
verification conditions automatically.
*}

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 {*
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.
*}

text {* 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.
*}

text {*
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.
*}

subsubsection {*Insertion Sort*}

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
  insert(r,p | p) =
    "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 {*
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 explicitly
state an equality in the postcondition.
The reason is simple. If the postcondition would talk about @{text "\<acute>cont"}
instead of @{text "\<^bsup>\<sigma>\<^esup>cont"}, we get a new instance of @{text "cont"} during
verification and the postcondition would only state something about this
new instance. But as the verification condition generator uses the
modifies clause the caller of @{text "insert"} instead still has the
old @{text "cont"} after the call. Thats the very reason for 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).
*}

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
  insertSort(p | p) =
    "\<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"

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 {* 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] HoarePartial.annotateI}.
*}

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 {* 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.
*}

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

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

definition "sz = (2::nat)"

text {* Restrict locale @{text hoare} to the required type. *}

locale hoare_ex =
  hoare \<Gamma> for \<Gamma> :: "'c ~=> (('a globals_list_alloc_scheme, 'b) list_vars'_scheme, 'c, 'd) com"

lemma (in hoare_ex)
  "\<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 :== 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 hoare_ex)
  "\<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 {* Fault Avoiding Semantics *}

text {*
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 precondition.
*}

lemma "\<Gamma>\<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 "\<Gamma>\<turnstile> {}  \<lbrace>\<acute>p\<noteq>Null\<rbrace>\<longmapsto> \<acute>p\<rightarrow>\<acute>next :== \<acute>p \<lbrace>True\<rbrace>"
apply vcg
done

text {* Let us consider this small program that reverts a list. At
first without guards.
*}
lemma (in hoare_ex) rev_strip:
  "\<Gamma>\<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 {* If we want to ensure that we do not dereference @{term "Null"} or
access unallocated memory, we have to add some guards.
*}

locale hoare_ex_guard =
  hoare \<Gamma> for \<Gamma> :: "'c ~=> (('a globals_list_alloc_scheme, 'b) list_vars'_scheme, 'c, bool) com"

lemma
  (in hoare_ex_guard)
  "\<Gamma>\<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 {* We can also just prove that no faults will occur, by giving the
trivial postcondition.
*}
lemma (in hoare_ex_guard) rev_noFault:
  "\<Gamma>\<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 hoare_ex_guard) rev_moduloGuards:
  "\<Gamma>\<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 {* We can then combine the prove that no fault will occur with the
functional proof of the programme without guards to get the full prove by
the rule @{thm HoarePartialProps.CombineStrip}
*}

lemma
  (in hoare_ex_guard)
  "\<Gamma>\<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 {* 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.
*}

text {*
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"}
*}

subsection {* Circular Lists *}
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 circular_list_rev_I:
  "\<Gamma>\<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 {*
The simple algorithm for acyclic list reversal, with modified
annotations, works for cyclic lists as well.:
*}

lemma circular_list_rev_II:
 "\<Gamma>\<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{* 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.
*}

text {*
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
*}

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

lemma "\<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

lemma "\<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 {* Instead of annotations one can also directly use previously proven lemmas.*}
lemma foo_lemma: "\<forall>n m. \<Gamma>\<turnstile> \<lbrace>\<acute>N = n \<and> \<acute>M = m\<rbrace> \<acute>N :== \<acute>N + 1;; \<acute>M :== \<acute>M + 1
                     \<lbrace>\<acute>N = n + 1 \<and> \<acute>M = m + 1\<rbrace>"
  by vcg

lemma "\<Gamma>\<turnstile> \<lbrace>\<acute>N = n \<and> \<acute>M = m\<rbrace> LEMMA foo_lemma
                               \<acute>N :== \<acute>N + 1;; \<acute>M :== \<acute>M + 1
                             END;;
                             \<acute>N :== \<acute>N + 1
           \<lbrace>\<acute>N = n + 2 \<and> \<acute>M = m + 1\<rbrace>"
  apply vcg
  apply simp
  done

lemma "\<Gamma>\<turnstile> \<lbrace>\<acute>N = n \<and> \<acute>M = m\<rbrace>
           LEMMA foo_lemma
              \<acute>N :== \<acute>N + 1;; \<acute>M :== \<acute>M + 1
           END;;
           LEMMA foo_lemma
              \<acute>N :== \<acute>N + 1;; \<acute>M :== \<acute>M + 1
           END
           \<lbrace>\<acute>N = n + 2 \<and> \<acute>M = m + 2\<rbrace>"
  apply vcg
  apply simp
  done

lemma "\<Gamma>\<turnstile> \<lbrace>\<acute>N = n \<and> \<acute>M = m\<rbrace>
              \<acute>N :== \<acute>N + 1;; \<acute>M :== \<acute>M + 1;;
              \<acute>N :== \<acute>N + 1;; \<acute>M :== \<acute>M + 1
           \<lbrace>\<acute>N = n + 2 \<and> \<acute>M = m + 2\<rbrace>"
  apply (hoare_rule anno=
          "LEMMA foo_lemma
              \<acute>N :== \<acute>N + 1;; \<acute>M :== \<acute>M + 1
           END;;
           LEMMA foo_lemma
              \<acute>N :== \<acute>N + 1;; \<acute>M :== \<acute>M + 1
           END"
          in HoarePartial.annotate_normI)
  apply vcg
  apply simp
  done

text {* Just some test on marked, guards *}
lemma "\<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 "\<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

term "\<Gamma>\<turnstile>\<^bsub>/{True}\<^esub> \<lbrace>True\<rbrace> WHILE\<^sub>g  \<acute>N < \<acute>Arr!i
                    FIX Z.
                    INV \<lbrace>\<acute>N < 2\<rbrace>

                  DO
                    \<acute>N :== \<acute>M
                  OD
           \<lbrace>hard\<rbrace>"

lemma "\<Gamma>\<turnstile>\<^bsub>/{True}\<^esub> \<lbrace>True\<rbrace> WHILE\<^sub>g  \<acute>N < \<acute>Arr!i
                    FIX Z.
                    INV \<lbrace>\<acute>N < 2\<rbrace>
                    VAR arbitrary
                  DO
                    \<acute>N :== \<acute>M
                  OD
           \<lbrace>hard\<rbrace>"
apply vcg
oops

lemma "\<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
                    FIX Z.
                    INV \<lbrace>\<acute>N < 2\<rbrace>
                    VAR arbitrary
                  DO
                    \<acute>N :== \<acute>M
                  OD
           \<lbrace>hard\<rbrace>"
apply vcg
oops

end


(*<*)
(* Author: Thomas Bauereiss *)
theory Address_Translation_Pure
  imports AArch64_Aux Address_Translation_Orig
begin
(*>*)

section \<open>Pure characterisation\<close>

subsection \<open>Types\<close>

text \<open>Translation tables are represented as a list of entries, each of which might recursively
contain another table.\<close>

datatype TableEntry =
  Invalid
  | Descriptor "64 word" (* 64-bit block or page descriptor *)
  | Table "52 word" bool bool bool bool bool "TableEntry list" (* base address, table attributes, entries *)

text \<open>A record for the main parameters of the translation, e.g. address size or page size.\<close>

record Parameters =
  inputsize :: int
  outputsize :: int
  grainsize :: int
  firstblocklevel :: int
  updateAF :: bool
  SH :: "2 word"
  ORGN :: "2 word"
  IRGN :: "2 word"

subsection \<open>Auxiliary functions for our pure characterisation, e.g. for reading the translation
parameters from the control registers or decoding descriptor attributes.\<close>

definition read_params :: "bool \<Rightarrow> regstate sequential_state \<Rightarrow> Parameters" where
  "read_params high s =
     (let
        largegrain = (if high then Word.slice 30 (TCR_EL1 (regstate s)) = (3 :: 2 word)
                      else Word.slice 14 (TCR_EL1 (regstate s)) = (1 :: 2 word));
        midgrain = (if high then Word.slice 30 (TCR_EL1 (regstate s)) = (1 :: 2 word)
                    else Word.slice 14 (TCR_EL1 (regstate s)) = (2 :: 2 word));
        grainsize = (if largegrain then 16 else if midgrain then 14 else 12);
        outputsize = calc_outputsize (Word.slice 32 (TCR_EL1 (regstate s))) largegrain;
        inputsize_max = (if largegrain then 52 else 48);
        inputsize = 64 - (uint (Word.slice (if high then 16 else 0) (TCR_EL1 (regstate s)) :: 6 word)) in
      \<lparr>inputsize = min (max inputsize 25) inputsize_max,
       outputsize = outputsize,
       grainsize = grainsize,
       firstblocklevel = (if \<not>largegrain \<and> midgrain then 2 else 1),
       updateAF = TCR_EL1 (regstate s) !! 39,
       SH = Word.slice (if high then 28 else 12) (TCR_EL1 (regstate s)),
       ORGN = Word.slice (if high then 26 else 10) (TCR_EL1 (regstate s)),
       IRGN = Word.slice (if high then 24 else 8) (TCR_EL1 (regstate s))\<rparr>)"

abbreviation "largegrain p \<equiv> (grainsize p = 16)"
abbreviation "midgrain p \<equiv> (grainsize p = 14)"

definition startlevel :: "Parameters \<Rightarrow> int" where
  "startlevel p \<equiv> calc_startlevel (inputsize p) (grainsize p) (grainsize p - 3)"

definition baselowerbound :: "Parameters \<Rightarrow> int" where
  "baselowerbound p \<equiv>
     3 + (inputsize p) - ((3 - startlevel p) * (grainsize p - 3) + (grainsize p))"

abbreviation "contiguousbitcheck p level \<equiv>
  calc_contiguousbitcheck (inputsize p) (largegrain p) (midgrain p) level"

definition baseaddress :: "64 word \<Rightarrow> int \<Rightarrow> int \<Rightarrow> 52 word" where
  "baseaddress baseregister baselowerbound_arg outputsize_arg \<equiv>
     (if outputsize_arg = 52 then
        (let z = max baselowerbound_arg 6 in
         concat_vec (Word.slice 2 baseregister :: 4 word)
                    (slice_zeros_concat 48 baseregister z (48 - z) z :: 48 word))
      else
        place_slice 52 baseregister baselowerbound_arg (48 - baselowerbound_arg) baselowerbound_arg)"

definition valid_vaddr :: "64 word \<Rightarrow> int \<Rightarrow> regstate sequential_state \<Rightarrow> bool" where
  "valid_vaddr addr addrtop s \<equiv>
     (let high = addr !! nat addrtop;
          p = read_params high s in
        (if high
         then addr AND slice_mask 64 (inputsize p) (addrtop - inputsize p + 1) =
              slice_mask 64 (inputsize p) (addrtop - inputsize p + 1)
         else addr AND slice_mask 64 (inputsize p) (addrtop - inputsize p + 1) = 0))"

abbreviation IsBlockDescriptor :: "64 word \<Rightarrow> bool" where
  "IsBlockDescriptor desc \<equiv> Word.slice 0 desc = (0b01 :: 2 word)"

definition ValidDescriptor :: "int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> 64 word \<Rightarrow> bool" where
  "ValidDescriptor level grainsize_arg outputsize_arg desc \<equiv>
     desc !! 0 \<and>
     \<not>(IsBlockDescriptor desc \<and> level = 3) \<and>
     (\<not>IsBlockDescriptor desc \<and> level < 3 \<longrightarrow>
        (outputsize_arg < 52 \<and> grainsize_arg = 16 \<longrightarrow> Word.slice 12 desc = (0 :: 4 word)) \<and>
        (outputsize_arg < 48 \<longrightarrow> desc AND slice_mask 64 outputsize_arg (48 - outputsize_arg) = 0))"

definition read_WalkAttrDecode :: "2 word \<Rightarrow> 2 word \<Rightarrow> 2 word \<Rightarrow> bool \<Rightarrow> regstate sequential_state \<Rightarrow> MemoryAttributes" where
  "read_WalkAttrDecode SH_arg ORGN_arg IRGN_arg secondstage s \<equiv>
     \<lparr>MemoryAttributes_typ = MemType_Normal, MemoryAttributes_device = DeviceType_GRE,
             MemoryAttributes_inner =
               \<lparr>MemAttrHints_attrs =
                  if \<not> secondstage \<and> (read_SCTLR (read_S1TranslationRegime (read_EL s) s) s !! 2 \<longrightarrow> IRGN_arg = 0) \<or>
                     secondstage \<and> (HCR_EL2 (regstate s) !! 32 \<or> IRGN_arg = 0)
                  then 0 else if IRGN_arg = 1 \<or> IRGN_arg \<noteq> 2 then 3 else 2,
                  MemAttrHints_hints =
                    if \<not> secondstage \<and> (read_SCTLR (read_S1TranslationRegime (read_EL s) s) s !! 2 \<longrightarrow> IRGN_arg = 0) \<or>
                       secondstage \<and> (HCR_EL2 (regstate s) !! 32 \<or> IRGN_arg = 0)
                    then MemHint_No else if IRGN_arg = 1 then MemHint_RWA else MemHint_RA,
                  MemAttrHints_transient = False\<rparr>,
             MemoryAttributes_outer =
               \<lparr>MemAttrHints_attrs =
                  if \<not> secondstage \<and> (read_SCTLR (read_S1TranslationRegime (read_EL s) s) s !! 2 \<longrightarrow> ORGN_arg = 0) \<or>
                     secondstage \<and> (HCR_EL2 (regstate s) !! 32 \<or> ORGN_arg = 0)
                  then 0 else if ORGN_arg = 1 \<or> ORGN_arg \<noteq> 2 then 3 else 2,
                  MemAttrHints_hints =
                    if \<not> secondstage \<and> (read_SCTLR (read_S1TranslationRegime (read_EL s) s) s !! 2 \<longrightarrow> ORGN_arg = 0) \<or>
                       secondstage \<and> (HCR_EL2 (regstate s) !! 32 \<or> ORGN_arg = 0)
                    then MemHint_No else if ORGN_arg = 1 then MemHint_RWA else MemHint_RA,
                  MemAttrHints_transient = False\<rparr>,
             MemoryAttributes_shareable =
               if \<not> secondstage then read_SCTLR (read_S1TranslationRegime (read_EL s) s) s !! 2 \<longrightarrow> IRGN_arg = 0 \<and> ORGN_arg = 0 \<or> SH_arg !! Suc 0
               else (HCR_EL2 (regstate s) !! 32 \<or> IRGN_arg = 0) \<and> (HCR_EL2 (regstate s) !! 32 \<or> ORGN_arg = 0) \<or> SH_arg !! Suc 0,
             MemoryAttributes_outershareable =
               if \<not> secondstage then read_SCTLR (read_S1TranslationRegime (read_EL s) s) s !! 2 \<longrightarrow> IRGN_arg = 0 \<and> ORGN_arg = 0 \<or> SH_arg = 2
               else (HCR_EL2 (regstate s) !! 32 \<or> IRGN_arg = 0) \<and> (HCR_EL2 (regstate s) !! 32 \<or> ORGN_arg = 0) \<or> SH_arg = 2\<rparr>"

definition read_S1CacheDisabled :: "AccType \<Rightarrow> regstate sequential_state \<Rightarrow> bool" where
  "read_S1CacheDisabled acctype s =
     (let sctlr = read_SCTLR (read_S1TranslationRegime (read_EL s) s) s in
      if acctype = AccType_IFETCH then \<not>(sctlr !! 12) else \<not>(sctlr !! 2))"

definition read_LongConvertAttrsHints :: "4 word \<Rightarrow> AccType \<Rightarrow> regstate sequential_state \<Rightarrow> MemAttrHints" where
  "read_LongConvertAttrsHints attrfield acctype s \<equiv>
     \<lparr>MemAttrHints_attrs =
        if read_S1CacheDisabled acctype s \<or> attrfield = 4 then MemAttr_NC else
        if Word.slice 2 attrfield = (0 :: 2 word) then MemAttr_WT else
        if Word.slice 2 attrfield = (1 :: 2 word) then Word.slice 0 attrfield else
        Word.slice 2 attrfield,
      MemAttrHints_hints =
        if read_S1CacheDisabled acctype s \<or> attrfield = 4 then MemHint_No else
        if Word.slice 2 attrfield = (0 :: 2 word) then Word.slice 0 attrfield else
        if Word.slice 2 attrfield = (1 :: 2 word) then MemAttr_WB else (* Is this intentional? *)
        Word.slice 0 attrfield,
      MemAttrHints_transient =
        if read_S1CacheDisabled acctype s then False else
        attrfield \<noteq> 4 \<and> \<not>(attrfield !! 3)\<rparr>"

definition read_S1AttrDecode :: "2 word \<Rightarrow> 3 word \<Rightarrow> AccType \<Rightarrow> regstate sequential_state \<Rightarrow> MemoryAttributes" where
  "read_S1AttrDecode SH_arg attr acctype s =
     (let mair = read_MAIR (read_S1TranslationRegime (read_EL s) s) s;
          attrslo = Word.slice (nat (8 * uint attr)) mair :: 4 word;
          attrshi = Word.slice (4 + nat (8 * uint attr)) mair :: 4 word;
          ihints = read_LongConvertAttrsHints attrslo acctype s;
          ohints = read_LongConvertAttrsHints attrshi acctype s in
      \<lparr>MemoryAttributes_typ = if attrslo = 0 \<or> attrshi = 0 then MemType_Device else MemType_Normal,
       MemoryAttributes_device =
         if attrslo = 0 \<or> attrshi = 0 then
           (if attrslo = 0 then DeviceType_nGnRnE
            else if attrslo = 4 then DeviceType_nGnRE
            else if attrslo = 8 then DeviceType_nGRE
            else if attrslo = 12 then DeviceType_GRE
            else DeviceType_nGnRnE)
         else DeviceType_GRE,
       MemoryAttributes_inner =
         if attrslo \<noteq> 0 \<and> attrshi \<noteq> 0 then ihints
         else \<lparr>MemAttrHints_attrs = 0, MemAttrHints_hints = 0, MemAttrHints_transient = False\<rparr>,
       MemoryAttributes_outer =
         if attrslo \<noteq> 0 \<and> attrshi \<noteq> 0 then ohints
         else \<lparr>MemAttrHints_attrs = 0, MemAttrHints_hints = 0, MemAttrHints_transient = False\<rparr>,
       MemoryAttributes_shareable =
         attrslo = 0 \<or> attrshi = 0 \<or>
         MemAttrHints_attrs ihints = 0 \<and> MemAttrHints_attrs ohints = 0 \<or>
         SH_arg !! 1,
       MemoryAttributes_outershareable =
         attrslo = 0 \<or> attrshi = 0 \<or>
         MemAttrHints_attrs ihints = 0 \<and> MemAttrHints_attrs ohints = 0 \<or>
         SH_arg = 2\<rparr>)"

fun read_TTBR0 where
  "read_TTBR0 s =
     (let el = read_S1TranslationRegime (read_EL s) s in
      if el = 3 then TTBR0_EL3 (regstate s) else
      if el = 2 then TTBR0_EL2 (regstate s) else TTBR0_EL1 (regstate s))"

fun read_TTBR1 where
  "read_TTBR1 s =
     (let el = read_S1TranslationRegime (read_EL s) s in
      if el = 3 then TTBR0_EL3 (regstate s) else
      if el = 2 then TTBR1_EL2 (regstate s) else TTBR1_EL1 (regstate s))"

definition read_TTBR :: "bool \<Rightarrow> regstate sequential_state \<Rightarrow> 64 word" where
  "read_TTBR high s = (if high then read_TTBR1 s else read_TTBR0 s)"

definition TTBR_valid_for_vaddr :: "64 word \<Rightarrow> int \<Rightarrow> regstate sequential_state \<Rightarrow> bool" where
  "TTBR_valid_for_vaddr addr addrtop s \<equiv>
     (let high = addr !! nat addrtop;
          p = read_params high s in
        (outputsize p < 48 \<longrightarrow> read_TTBR high s AND slice_mask 64 (outputsize p) (48 - outputsize p) = 0))"

definition addrselecttop :: "int \<Rightarrow> Parameters \<Rightarrow> int" where
  "addrselecttop level p =
     (min (inputsize p) ((4 - level) * (grainsize p - 3) + grainsize p) - 1)"

definition addrselectbottom :: "int \<Rightarrow> Parameters \<Rightarrow> int" where
  "addrselectbottom level p = (3 - level) * (grainsize p - 3) + grainsize p"

definition stride :: "int \<Rightarrow> Parameters \<Rightarrow> int" where
  "stride level p = addrselecttop level p - addrselectbottom level p + 1"

function read_table :: "int \<Rightarrow> bool \<Rightarrow> 52 word \<Rightarrow> regstate sequential_state \<Rightarrow> TableEntry list" where
  "read_table level high baseaddr s =
     (let p = read_params high s;
          stride = stride level p;
          descaddrs = map (\<lambda>idx. baseaddr OR (word_of_int idx << 3)) [0..2 ^ nat stride - 1];
          read_desc =
            (\<lambda>addr. case read_mem_word addr 8 s of
                      None \<Rightarrow> Invalid
                    | Some desc \<Rightarrow>
                        let desc = if read_bigendian s then reverse_endianness desc else desc in
                        (if ValidDescriptor level (grainsize p) (outputsize p) desc \<and> level \<ge> 0 \<and> level < 4 then
                           (if (IsBlockDescriptor desc \<or> level = 3) then Descriptor desc
                            else
                              let lbaseaddr = ((Word.slice (nat (grainsize p)) desc) << nat (grainsize p)) :: 48 word;
                                  ubaseaddr = (if outputsize p = 52 then Word.slice 12 desc else 0) :: 4 word;
                                  baseaddr = word_cat ubaseaddr lbaseaddr :: 52 word;
                                  ns = desc !! 63; ap1 = desc !! 62; ap0 = desc !! 61; xn = desc !! 60; pxn = desc !! 59 in
                              Table baseaddr ns ap1 ap0 xn pxn (read_table (level + 1) high baseaddr s))
                         else Invalid)) in
      map read_desc descaddrs)"
  by pat_completeness auto
termination by (relation "measure (\<lambda>(level, _). 4 - nat level)") auto

lemma size_list_table_nth_dec[termination_simp]:
  assumes i: "i < length table" and table': "table ! i = Table baseaddr ns ap1 ap0 xn pxn table'"
  shows "size_list size table' < size_list size table"
  using table'
  by (auto intro: size_list_estimation[OF nth_mem[OF i]])

fun walk_table :: "64 word \<Rightarrow> int \<Rightarrow> Parameters \<Rightarrow> 52 word \<Rightarrow> TableEntry list \<Rightarrow>
                       (64 word \<times> 52 word \<times> 52 word \<times> int \<times> bool \<times> bool \<times> bool \<times> bool \<times> bool) option" where
  "walk_table inputaddr level p baseaddr table =
     (let index = uint (inputaddr AND slice_mask 52 (addrselectbottom level p) (stride level p) >> nat (addrselectbottom level p));
          descaddr = baseaddr OR (word_of_int index << 3) in
      if nat index < length table then
        (case table ! nat index of
           Invalid \<Rightarrow> None
         | Descriptor desc \<Rightarrow> Some (desc, descaddr, baseaddr, level, False, False, False, False, False)
         | Table baseaddr ns ap1 ap0 xn pxn table \<Rightarrow>
             (case walk_table inputaddr (level + 1) p baseaddr table of
               None \<Rightarrow> None
              | Some (desc, descaddr, baseaddr, level, ns', ap1', ap0', xn', pxn') \<Rightarrow>
                  Some (desc, descaddr, baseaddr, level, ns \<or> ns', ap1 \<or> ap1', ap0 \<or> ap0', xn \<or> xn', pxn \<or> pxn')))
      else None)"

declare walk_table.simps[simp del]

abbreviation
  "default_FaultRecord \<equiv>
     \<lparr>FaultRecord_typ = Fault_None, FaultRecord_acctype = AccType_NORMAL, FaultRecord_ipaddress = 0,
      FaultRecord_s2fs1walk = False, FaultRecord_write = False, FaultRecord_level = 0,
      FaultRecord_extflag = 0, FaultRecord_secondstage = False, FaultRecord_domain = 0,
      FaultRecord_errortype = 0, FaultRecord_debugmoe = 0\<rparr>"

definition valid_perms :: "Permissions \<Rightarrow> AccType \<Rightarrow> bool \<Rightarrow> regstate sequential_state \<Rightarrow> bool" where
  "valid_perms perms acctype iswrite s \<equiv>
     (let wxn = SCTLR_EL1 (regstate s) !! 19;
          r = Permissions_ap perms !! 1;
          w = (Word.slice 1 (Permissions_ap perms) = (1 :: 2 word));
          xn = (Permissions_xn perms = 1) \<or> (w \<and> wxn) in
      if acctype = AccType_IFETCH then \<not>xn
      else if acctype \<in> { AccType_ATOMICRW, AccType_ORDEREDRW } then r \<and> w
      else if iswrite then w
      else r)"

definition lookup_TLBRecord :: "64 word \<Rightarrow> AccType \<Rightarrow> regstate sequential_state \<Rightarrow> TLBRecord option" where
  "lookup_TLBRecord vaddress acctype s =
     (let top = read_AddrTop_EL0 vaddress (acctype = AccType_IFETCH) s;
          high = vaddress !! nat top;
          p = read_params high s;
          baseaddress = baseaddress (read_TTBR high s) (baselowerbound p) (outputsize p);
          hierattrs = \<not>(if high then TCR_EL1 (regstate s) !! 42 else TCR_EL1 (regstate s) !! 41);
          secure = \<not> SCR_EL3 (regstate s) !! 0 in
      case walk_table vaddress (startlevel p) p baseaddress
             (read_table (startlevel p) high baseaddress s) of
        None \<Rightarrow> None
      | Some (desc, descaddr, baseaddr, level, ns, ap1, ap0, xn, pxn) \<Rightarrow>
          let addrselectbottom = addrselectbottom level p;
              walkattrs = read_WalkAttrDecode (SH p) (ORGN p) (IRGN p) False s;
              memattrs = read_S1AttrDecode (Word.slice 8 desc) (Word.slice (Suc (Suc 0)) desc) acctype s;
              perms =
                \<lparr>Permissions_ap = of_bl [\<not>desc !! 51 \<and> desc !! 7 \<or> hierattrs \<and> ap1, desc !! 6 \<and> \<not>(hierattrs \<and> ap0), True],
                 Permissions_xn = of_bl [desc !! 54 \<or> hierattrs \<and> xn],
                 Permissions_xxn = 0,
                 Permissions_pxn = of_bl [desc !! 53 \<or> hierattrs \<and> pxn]\<rparr> in
          if level \<ge> firstblocklevel p \<and>
             valid_vaddr vaddress top s \<and>
             TTBR_valid_for_vaddr vaddress top s \<and>
             (outputsize p < 48 \<longrightarrow>
                desc AND slice_mask 64 (outputsize p) (48 - outputsize p) = 0) \<and>
             (outputsize p < 52 \<and> largegrain p \<longrightarrow> Word.slice 12 desc = (0 :: 4 word)) \<and>
             (contiguousbitcheck p level \<longrightarrow> \<not>desc !! 52)
          then
            let outputaddr :: 52 word =
              if outputsize p = 52
              then word_cat (Word.slice 12 desc :: 4 word)
                     (slice_slice_concat 48 desc addrselectbottom (48 - addrselectbottom)
                                         vaddress 0 addrselectbottom :: 48 word)
              else slice_slice_concat 52 desc addrselectbottom (48 - addrselectbottom) vaddress 0 addrselectbottom in
            Some \<lparr>TLBRecord_perms = perms,
                  TLBRecord_nG = of_bl [desc !! 11 \<or> (secure \<and> ns)],
                  TLBRecord_domain = 0, TLBRecord_contiguous = desc !! 52,
                  TLBRecord_level = level,
                  TLBRecord_blocksize = 2 ^ (nat addrselectbottom),
                  TLBRecord_descupdate =
                    \<lparr>DescriptorUpdate_AF = \<not>desc !! 10,
                     DescriptorUpdate_AP = desc !! 51 \<and> desc !! 7,
                     DescriptorUpdate_descaddr =
                       \<lparr>AddressDescriptor_fault = default_FaultRecord,
                        AddressDescriptor_memattrs = walkattrs,
                        AddressDescriptor_paddress =
                          \<lparr>FullAddress_physicaladdress = descaddr,
                           FullAddress_NS = of_bl [ns \<or> \<not>secure]\<rparr>,
                        AddressDescriptor_vaddress = vaddress\<rparr>\<rparr>,
                  TLBRecord_CnP = of_bl [read_TTBR high s !! 0],
                  TLBRecord_addrdesc =
                    \<lparr>AddressDescriptor_fault = default_FaultRecord,
                     AddressDescriptor_memattrs = memattrs,
                     AddressDescriptor_paddress =
                       \<lparr>FullAddress_physicaladdress = outputaddr,
                        FullAddress_NS = of_bl [desc !! 5 \<or> ns \<or> \<not>secure]\<rparr>,
                     AddressDescriptor_vaddress = vaddress\<rparr> \<rparr>
          else None)"

definition translate_address :: "64 word \<Rightarrow> AccType \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> regstate sequential_state \<Rightarrow> TLBRecord option" where
  "translate_address vaddress acctype iswrite wasaligned s =
     (case lookup_TLBRecord vaddress acctype s of
        None \<Rightarrow> None
      | Some r \<Rightarrow>
          let top = read_AddrTop_EL0 vaddress (acctype = AccType_IFETCH) s in
          if valid_perms (TLBRecord_perms r) acctype iswrite s \<and>
             AddressDescriptor_physicaladdress (DescriptorUpdate_descaddr (TLBRecord_descupdate r)) \<noteq> 0x13000000 \<and> (* debug console hard-coded in this ASL model *)
             (MemoryAttributes_typ (AddressDescriptor_memattrs (TLBRecord_addrdesc r)) = MemType_Device \<longrightarrow>
              wasaligned \<and> acctype \<notin> {AccType_IFETCH, AccType_DCZVA})
          then Some r else None)"

definition read_descriptor :: "52 word \<Rightarrow> regstate sequential_state \<Rightarrow> 64 word option" where
  "read_descriptor addr s \<equiv>
     (case read_mem_word addr 8 s of
        None \<Rightarrow> None
      | Some desc \<Rightarrow> Some (if read_bigendian s then reverse_endianness desc else desc))"

definition write_descriptor :: "52 word \<Rightarrow> 64 word \<Rightarrow> regstate sequential_state \<Rightarrow> regstate sequential_state" where
  "write_descriptor addr desc s \<equiv>
     (let desc = if read_bigendian s then reverse_endianness desc else desc in
      write_mem_bytes (uint addr) 8 (mem_bytes_of_word desc) (s\<lparr>write_ea := Some (Write_plain, uint addr, 8)\<rparr>))"

definition update_descriptor :: "DescriptorUpdate \<Rightarrow> AccType \<Rightarrow> bool \<Rightarrow> regstate sequential_state \<Rightarrow> regstate sequential_state" where
  "update_descriptor descupd acctype iswrite s \<equiv>
     (case read_descriptor (AddressDescriptor_physicaladdress (DescriptorUpdate_descaddr descupd)) s of
        None \<Rightarrow> s
      | Some desc \<Rightarrow>
          (let ap = DescriptorUpdate_AP descupd \<and>
                    (iswrite \<or> acctype = AccType_ATOMICRW \<or> acctype = AccType_ORDEREDRW) \<and>
                    acctype \<noteq> AccType_AT \<and> acctype \<noteq> AccType_DC;
               af = DescriptorUpdate_AF descupd;
               desc = if af then set_bit desc 10 True else desc;
               desc = if ap then set_bit desc 7 False else desc;
               addr = AddressDescriptor_physicaladdress (DescriptorUpdate_descaddr descupd) in
           if af \<or> ap
           then write_descriptor addr desc s
           else s))"

end


chapter {* Distributed and executable algorithm *}

theory AbstractMultiPaxosR3
  imports Utils FinFun_Supplemental MaxByKey IOA Quorums Paxos_Sig
begin

unbundle finfun_syntax

type_synonym bal = nat
type_synonym inst = nat

section {* Local state and transitions *}

subsection {* Data structures *}

record ('a, 'v) acc =
  -- {* The local state of an acceptor. *}
  id :: 'a
  acceptors :: "'a set"
  ballot :: bal
  decision :: "inst \<Rightarrow>f 'v option"
    -- {* Last ballot in which the acceptor voted. *}
  inst_status :: "bal \<Rightarrow>f (inst \<Rightarrow>f 'v option) option"
    -- {* Mirrors the member of the same name in R1 *}
  proposal :: "inst \<Rightarrow>f bal \<Rightarrow>f 'v option"
  votes :: "inst \<Rightarrow>f ('v \<times> bal) option"
  onebs :: "bal \<Rightarrow>f ('a \<Rightarrow>f (inst \<Rightarrow>f ('v\<times>bal) option) option)"
    -- {* The oneb messages received when the acceptor tries to acquire leadership.
    Note that we need the outermost option to signify that we did not receive a oneb message
    from the acceptor, as opposed to receiving a oneb message from an acceptor that never voted.  *}
  twobs :: "inst \<Rightarrow>f bal \<Rightarrow>f 'a set"
    -- {* the twob messages received (they are broadcast). *}

datatype ('aa,'vv) msg =
  Phase1a bal
  | Phase1b 'aa bal "inst \<Rightarrow>f ('vv \<times> bal) option"
  | Phase2a inst bal 'vv
  | Phase2b 'aa inst bal 'vv
  | Fwd 'vv

datatype ('aa,'vv) packet =
  Packet 'aa  "('aa,'vv) msg"

locale amp_r3 =
  fixes leader :: "bal \<Rightarrow> 'a::linorder"
  and next_bal :: "bal \<Rightarrow> 'a \<Rightarrow> bal"
  and as :: "'a set"
  and quorums :: "'a set set"
begin

definition local_start where "local_start a \<equiv>
  \<lparr>id = a, acceptors = as, ballot = 0, decision = K$ None, inst_status = K$ None,
  proposal = K$ K$ None, votes = K$ None, onebs = K$ K$ None, twobs = K$ K$ {}\<rparr>"

end

subsection {* The propose action *}

definition send_all where send_all_def[code del]:
  "send_all s m \<equiv> { Packet a m | a . a \<in> acceptors s \<and> a \<noteq> id s}"
  -- {* TODO: This definition does not always work for code generation. Why?
  That's why there is a code equation below. *}

lemma send_all_code[code]:
  "send_all s m = (flip Packet m) ` (acceptors s - {id s})"
  by (auto simp add:send_all_def)

fun first_hole :: "nat list \<Rightarrow> nat" where
  "first_hole [] = 0"
| "first_hole [x] = Suc x"
| "first_hole (x#y#xs) = (if y = Suc x then first_hole (y#xs) else Suc x)"

lemma first_hole_lemma:
  assumes "sorted l" and "distinct l"
    shows "first_hole l \<notin> set l" and "l \<noteq> [] \<Longrightarrow> first_hole l > hd l"
proof -
  have "first_hole l \<notin> set l \<and> (l \<noteq> [] \<longrightarrow> first_hole l > hd l)"
    using assms
  proof (induct l rule:first_hole.induct)
    case 1
    then show ?case
      by simp
  next
    case (2 x)
    then show ?case
      by simp
  next
    case (3 x y xs)
    from "3.prems" have 4:"sorted (y#xs)" and 5:"distinct (y#xs)" using sorted_Cons by auto
    show ?case proof (cases "y = Suc x")
      case True
      hence 6:"first_hole (x#y#xs) = first_hole (y#xs)" by auto
      have 7:"y < first_hole (y#xs)" using 4 5 3 True by auto
      show ?thesis using 3 4 5 6 7 True by auto
    next
      case False
      with \<open>sorted (x#y#xs)\<close> and \<open>distinct (x#y#xs)\<close> have "\<And> z . z \<in> set (y#xs) \<Longrightarrow> z > Suc x"
        apply auto by (metis Suc_lessI le_imp_less_or_eq le_less_Suc_eq le_trans sorted_Cons)
      then show ?thesis apply simp using not_less by blast
    qed
  qed
  thus "first_hole l \<notin> set l" and "l \<noteq> [] \<Longrightarrow> first_hole l > hd l"
    by auto
qed

context amp_r3
begin

definition next_inst where "next_inst s \<equiv> let b = ballot s in
  first_hole (finfun_to_list (the (inst_status s $ b)))"

lemma next_inst_lemma:
  fixes s
  assumes "inst_status s $ (ballot s) = Some f" and "finfun_default f = None"
  shows "f $ (next_inst s) = None"
proof -
  let ?b="ballot s"
  let ?l="finfun_to_list (the (inst_status s $ ?b))"
  have 2:"distinct ?l" and 3:"sorted ?l" by (simp_all add: distinct_finfun_to_list sorted_finfun_to_list)
  moreover have "next_inst s = first_hole (finfun_to_list f)" using assms(1) unfolding next_inst_def  by auto
  ultimately show "f $ (next_inst s) = None" using assms first_hole_lemma[OF 3 2] by (auto simp add:next_inst_def finfun_dom_conv)
qed

definition do_2a where "do_2a s v \<equiv>
  let
    i = next_inst s;
    b = ballot s;
    s' = s\<lparr>proposal := (proposal s)(i $:= (proposal s $ i)(b $:= Some v)),
      twobs := (twobs s)(i $:= (twobs s $ i)(b $:= {id s}))\<rparr>;
    msgs = send_all s (Phase2a i b v)
  in (s', msgs)"

definition propose where "propose s v \<equiv>
  let l = leader (ballot s) in
    if l = id s
    then (do_2a s v)
    else (s, {Packet l (Fwd v)})"
  -- {* TODO: Here we loose the proposal if it happens during an unsuccessful leadership acquisition attempt. *}

subsection {* The @{text receive_fwd} action *}

definition receive_fwd where "receive_fwd s v \<equiv>
  let l = leader (ballot s) in
    if l = id s
    then do_2a s v
    else (s, {Packet l (Fwd v)})"
  -- {* TODO: Here we loose the proposal if it happens during an unsuccessful leadership acquisition attempt. *}

end

subsection {* The @{text try_acquire_leadership} action *}

context amp_r3 begin

definition try_acquire_leadership where "try_acquire_leadership s \<equiv>
  let
    a = id s;
    b = next_bal (ballot s) a;
    s' = s\<lparr>onebs := (onebs s)(b $:= ((onebs s) $ b)(a $:= Some (votes s))),
      ballot := b\<rparr>;
    msgs = send_all s (Phase1a b)
  in (s', msgs)"

subsection {* The @{text receive_1a} action *}

definition receive_1a where "receive_1a s b \<equiv>
  if b > ballot s then let
      msgs = {Packet (leader b) (Phase1b (id s) b (votes s))};
      s' = s\<lparr>ballot := b\<rparr>
    in (s', msgs)
  else (s, {})"

end

subsection {* The @{text receive_1b} action *}

locale receive_1b =
  fixes onebs :: "'a \<Rightarrow>f (inst \<Rightarrow>f ('v\<times>bal) option) option"
  fixes q :: "'a set"
  fixes decision :: "inst \<Rightarrow>f 'v option"
  fixes b :: bal
begin

text {* Why not do things with @{term finfun_rec}? *}

text {* Intended to be used when a oneb message has been received from each member of q. *}

definition c where
  "c a vs \<equiv> (\<lambda> (vo, vs) . option_as_set vo \<union> vs) o$ ($ the (onebs $ a), vs $)"

definition pre_votes_per_inst where
  "pre_votes_per_inst S \<equiv> Finite_Set.fold c (K$ {}) S"

definition votes_per_inst where
  "votes_per_inst \<equiv> pre_votes_per_inst q"

sublocale folding_idem c "K$ {}"
  apply (unfold_locales)
   apply (auto simp add:c_def option_as_set_def fun_eq_iff expand_finfun_eq split!:option.splits)
  done

lemma votes_per_inst_code[code]:
  "pre_votes_per_inst (set (x#xs)) = c x (pre_votes_per_inst (set xs))"
  using insert_idem[of "set xs" x]
  by (simp add: eq_fold pre_votes_per_inst_def)

definition max_per_inst where "max_per_inst \<equiv> (flip max_by_key snd) o$ votes_per_inst"

definition new_status where "new_status \<equiv>
  (map_option fst) o$ (\<lambda> m . if m = {} then None else Some (the_elem m)) o$ max_per_inst"

definition to_propose where "to_propose \<equiv>
  (\<lambda> (d,s) . case d of Some _ \<Rightarrow> {} | None \<Rightarrow> fst ` s) o$ ($ decision, max_per_inst $)"

definition msgs where "msgs \<equiv>
  let
    is = finfun_to_list to_propose;
    to_propose = map (\<lambda> i . (i, to_propose $ i)) is;
    msg_list = map (\<lambda> (i,vs) . (Phase2a i b) ` vs) to_propose
  in \<Union> (set msg_list)"

lemma msgs_lemma:
  "\<And> m . m \<in> msgs \<Longrightarrow> case m of (Phase2a _ _ _) \<Rightarrow> True | _ \<Rightarrow> False"
  by (auto simp add:local.msgs_def)

end

global_interpretation r1b:receive_1b onebs as decision b for onebs as decision b
  defines new_status = receive_1b.new_status and msgs = receive_1b.msgs
  .

context amp_r3 begin

definition receive_1b where "receive_1b s a b vs \<equiv>
  let s' = s\<lparr>onebs := (onebs s)(b $:= ((onebs s) $ b)(a $:= Some vs))\<rparr>
  in (if (set (finfun_to_list (onebs s' $ b)) = acceptors s)
      \<and> inst_status s $ b = None
    then let
        s'' = s'\<lparr>inst_status := (inst_status s)(b $:= Some (new_status (onebs s $ b) (acceptors s)))\<rparr>;
        msgs = msgs (onebs s $ b) (acceptors s) (decision s) (ballot s)
      in (s'', \<Union> {send_all s m | m . m \<in> msgs})
    else (s', {}))"

subsection {* The @{text receive_2a} action *}

abbreviation(input) decided where "decided s i \<equiv>
  case (decision s $ i) of Some _ \<Rightarrow> True | _ \<Rightarrow> False"

definition receive_2a where "receive_2a s i b v \<equiv>
  if b \<ge> ballot s then
    let s' = s\<lparr>votes := (votes s)(i $:= Some (v, b)),
      twobs := (twobs s)(i $:= (twobs s $ i)(b $:= insert (id s) (twobs s $ i $ b))),
      ballot := b\<rparr>;
      msgs = send_all s (Phase2b (id s) i b v)
    in (s', msgs)
  else (s, {})"

subsection {* The @{text receive_2b} action *}

definition receive_2b where "receive_2b s i b a v \<equiv>
  if (~ decided s i)
  then let
      s' = s\<lparr>twobs := (twobs s)(i $:= (twobs s $ i)(b $:= insert a (twobs s $ i $ b)))\<rparr>
    in (
      if (twobs s' $ i $ b = (acceptors s))
      then let s'' = s'\<lparr>decision := (decision s)(i $:= Some v)\<rparr>
        in (s'', {})
      else (s', {}) )
  else (s, {})"

subsection {* The @{text process_msg} action *}

fun process_msg where
  "process_msg s (Phase1a b) = receive_1a s b"
  | "process_msg s (Phase2a i b v) = receive_2a s i b v"
  | "process_msg s (Phase2b a i b v) = receive_2b s i b a v"
  | "process_msg s (Phase1b a b vs) = receive_1b s a b vs"
  | "process_msg s (Fwd v) = receive_fwd s v"

end

subsection {* Global system IOA. *}

record ('a,'v) global_state =
  lstate :: "'a \<Rightarrow> ('a, 'v)acc"
  network :: "('a, 'v) packet set"

context amp_r3 begin

definition global_start where "global_start \<equiv>
  \<lparr>lstate = (\<lambda> a . local_start a), network = {}\<rparr>"

inductive trans_rel :: "(('a,'v) global_state \<times> 'v paxos_action \<times> ('a,'v) global_state) \<Rightarrow> bool" where
  "\<lbrakk>(Packet a m) \<in> network s; process_msg ((lstate s) a) m = (sa', ms); m = Phase2b a i b v;
    decision ((lstate s) a) \<noteq> decision sa'\<rbrakk>
    \<Longrightarrow> trans_rel (s, Learn i v,
      s\<lparr>lstate := (lstate s)(a := sa'), network := network s \<union> ms\<rparr>)"
| "\<lbrakk>(Packet a m) \<in> network s; process_msg ((lstate s) a) m = (sa', ms)\<rbrakk>
    \<Longrightarrow> trans_rel (s, Internal,
      s\<lparr>lstate := (lstate s)(a := sa'), network := network s \<union> ms\<rparr>)"
| "\<lbrakk>propose ((lstate s) a) v = (sa', ms)\<rbrakk>
    \<Longrightarrow> trans_rel (s, Propose v,
      s\<lparr>lstate := (lstate s)(a := sa'), network := network s \<union> ms\<rparr>)"
| "\<lbrakk>try_acquire_leadership ((lstate s) a) = (sa', ms)\<rbrakk>
    \<Longrightarrow> trans_rel (s, Internal,
      s\<lparr>lstate := (lstate s)(a := sa'), network := network s \<union> ms\<rparr>)"

inductive_cases trans_rel_cases:"trans_rel (s,a,s')"

abbreviation(input) local_step where "local_step a p r r' \<equiv>
  r' = r\<lparr>lstate := (lstate r)(a := fst p), network := network r \<union> snd p\<rparr>"

lemma trans_cases:
  assumes "trans_rel (r, act, r')"
  obtains
    (propose) a v where "act = Propose v" and "local_step a (propose (lstate r a) v) r r'"
  | (learn) a i b v m p where "act = Learn i v" and "m = Phase2b a i b v"
    and "p = receive_2b (lstate r a) i b a v"
    and "local_step a p r r'"
    and "Packet a m \<in> network r"
    and "decision (lstate r a) \<noteq> decision (fst p)"
  | (acquire_leadership) a where "act = Internal" and "local_step a (try_acquire_leadership (lstate r a)) r r'"
  | (receive_1a) a b m p where "act = Internal" and "m = Phase1a b"
    and "p = receive_1a (lstate r a) b"
    and "local_step a p r r'"
    and "Packet a m \<in> network r"
  | (receive_2a) a i b v m p where "act = Internal" and "m = Phase2a i b v"
    and "p = receive_2a (lstate r a) i b v"
    and "local_step a p r r'"
    and "Packet a m \<in> network r"
  | (receive_2b) a a2 i b v m p where "act = Internal" and "m = Phase2b a2 i b v"
    and "p = receive_2b (lstate r a) i b a2 v"
    and "local_step a p r r'"
    and "Packet a m \<in> network r"
  | (receive_1b) a b vs m p a2 where "act = Internal" and "m = Phase1b a2 b vs"
    and "p = receive_1b (lstate r a) a2 b vs"
    and "local_step a p r r'"
    and "Packet a m \<in> network r"
  | (fwd) a v m p where "act = Internal" and "m = Fwd v"
    and "p = receive_fwd (lstate r a) v"
    and "local_step a p r r'"
    and "Packet a m \<in> network r"
proof -
  show ?thesis using assms
    apply (rule trans_rel_cases)
       apply (metis fst_conv learn snd_conv)
      defer
      apply (metis fst_conv propose snd_conv)
     apply (metis acquire_leadership fst_conv snd_conv)
    subgoal premises prems for a m (* TODO: how to apply induct here without subgoal? *)
      using prems
      apply (induct rule:process_msg.induct)
          apply (metis fst_conv process_msg.simps(1) receive_1a snd_conv)
         apply (metis fst_conv process_msg.simps(2) receive_2a snd_conv)
        defer
        apply (metis fst_conv process_msg.simps(4) receive_1b snd_conv)
       apply (metis amp_r3.process_msg.simps(5) fst_conv fwd snd_conv)
      by (metis fst_conv process_msg.simps(3) receive_2b snd_conv)
    done
qed

definition ioa where
  "ioa \<equiv> \<lparr>ioa.asig = paxos_asig, ioa.start = {global_start}, ioa.trans = Collect trans_rel\<rparr>"

end

end