(*
    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
*)

header {* Examples using Statespaces *}

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

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

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

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

text {* Internally we decorate the state components in the statespace 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 (in state_space) "\<Gamma>\<turnstile> {|\<acute>N = 5|} \<acute>N :== 2 * \<acute>N {|\<acute>N = 10|}"
  apply (rule HoarePartial.Basic)
  apply simp
  done

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

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

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

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

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

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

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

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

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

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

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

lemma (in state_space)
  shows "\<Gamma>\<turnstile> \<lbrace>\<acute>M = \<acute>N\<rbrace> \<acute>M :== \<acute>M + 1 \<lbrace>\<acute>M \<noteq> \<acute>N\<rbrace>"
proof -
  have "\<And>m n::nat. m = n \<longrightarrow> m + 1 \<noteq> n"
      -- {* 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 (in state_space)
  shows "\<Gamma>\<turnstile> \<lbrace>\<acute>M = \<acute>N\<rbrace> \<acute>M :== \<acute>M + 1 \<lbrace>\<acute>M \<noteq> \<acute>N\<rbrace>"
  apply vcg
  apply simp
  done

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

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

text {*
 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 (in state_space)
  shows "\<Gamma>\<turnstile> \<lbrace>\<acute>M = 0 \<and> \<acute>S = 0\<rbrace>
          WHILE \<acute>M \<noteq> a
          INV \<lbrace>\<acute>S = \<acute>M * b\<rbrace>
          DO \<acute>S :== \<acute>S + b;; \<acute>M :== \<acute>M + 1 OD
          \<lbrace>\<acute>S = a * b\<rbrace>"
  apply vcg
  apply auto
  done

text {* Here some examples of ``breaking'' out of a loop *}

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

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

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

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

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

text {* Blocks *}

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

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

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

text {*
 The next version uses the @{text vcg} method, while still explaining
 the resulting proof obligations in an abstract, structured manner.
*}

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

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

text {*
 Certainly, this proof may be done fully automatically as well, provided
 that the invariant is given beforehand.
*}

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

subsection {* SWITCH *}

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

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

subsection {* (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::nat|R::nat)
  "IF \<acute>N = 0 THEN \<acute>R :== 1
   ELSE \<acute>R :== CALL Fac(\<acute>N - 1);;
        \<acute>R :== \<acute>N * \<acute>R
   FI"

print_locale Fac_impl

text {*
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>R)"} is internally:
*}
declare [[hoare_use_call_tr' = false]]
text {*
@{term "CALL Fac(\<acute>N,\<acute>R)"}
*}
term "CALL Fac(\<acute>N,\<acute>R)"
declare [[hoare_use_call_tr' = true]]

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

end

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

text {*
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) Fac_spec1:
  shows "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>{\<sigma>} \<acute>R :== PROC Fac(\<acute>N) \<lbrace>\<acute>R = fac \<^bsup>\<sigma>\<^esup>N\<rbrace>"
  apply (hoare_rule HoarePartial.ProcRec1)
  apply vcg_step
  apply   vcg_step
  apply  vcg_step
  apply vcg_step
  apply vcg_step
  apply simp
  done

text {* Here some Isar style version of the proof *}
lemma (in Fac_impl) Fac_spec2:

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

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

text {* 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_spec4:
  shows "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>{\<sigma>} \<acute>R :== PROC Fac(\<acute>N) \<lbrace>\<acute>R = fac \<^bsup>\<sigma>\<^esup>N\<rbrace>"
  (is "\<forall>\<sigma>. \<Gamma>,\<Theta>\<turnstile>(?Pre \<sigma>) ?Fac (?Post \<sigma>)")
proof (hoare_rule HoarePartial.ProcRec1)
  def "\<Theta>'"=="(\<Theta>\<union>(\<Union>\<sigma>. {(?Pre \<sigma>, Fac_'proc, ?Post \<sigma>,{})}))"
  have Fac_spec: "\<forall>\<sigma>. \<Gamma>,\<Theta>'\<turnstile>(?Pre \<sigma>) ?Fac (?Post \<sigma>)"
    by (unfold \<Theta>'_def, rule allI, rule hoarep.Asm) simp
  txt {* 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] HoareTotal.ProcRec1},
@{thm [source] HoareTotal.ProcNoRec1}.
They are all derived from the most general rule
@{thm [source] HoareTotal.ProcRec}.
All of them have some side-conditions concerning the parameter
passing protocol and its relation to the pre and postcondition. They can be
solved in a uniform fashion. Thats why we have created the method
@{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::nat | A::nat) "IF \<acute>N=0 THEN \<acute>A:==0
                     ELSE IF \<acute>N=1 THEN CALL even (\<acute>N - 1,\<acute>A)
                          ELSE CALL odd (\<acute>N - 2,\<acute>A)
                          FI
                     FI"

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

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

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

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

subsection {*Expressions With Side Effects *}

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

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

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

subsection {* Global Variables and Heap *}

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

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

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 will first define an append function on lists. It takes two
references as parameters. It appends the list referred to by the first
parameter with the list referred to by the second parameter, and returns
the result right into the first parameter.
*}

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

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

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

The functional specification now introduces two logical variables besides the
state space variable @{term "\<sigma>"}, namely @{term "Ps"} and @{term "Qs"}.
They are universally quantified and range over both the pre and the postcondition, so
that we are able to properly instantiate the specification
during the proofs. The syntax @{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 (in append_impl) shows "{t. t may_only_modify_globals Z in [next]}
       =
       {t. \<exists>next. globals t=update id id next_' (K_statefun next) (globals Z)}"
  apply (unfold mex_def meq_def)
  apply simp
  done

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

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

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

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

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

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

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

print_locale insertSort_impl

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

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

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
*)

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

definition "sz = (2::nat)"

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

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

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

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

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

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

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

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

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

lemma (in list_alloc) rev_moduloGuards:

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

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

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

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

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

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

context list_alloc
begin
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"}
*}
end

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

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

text {*
The simple algorithm for acyclic list reversal, with modified
annotations, works for cyclic lists as well.:
*}

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

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

text{* 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 (in state_space) "\<Gamma>\<turnstile> {\<sigma>}
            \<acute>I :== \<acute>M;;
            ANNO \<tau>. \<lbrace>\<tau>. \<acute>I = \<^bsup>\<sigma>\<^esup>M\<rbrace>
                      \<acute>M :== \<acute>N;; \<acute>N :== \<acute>I
                    \<lbrace>\<acute>M = \<^bsup>\<tau>\<^esup>N \<and> \<acute>N = \<^bsup>\<tau>\<^esup>I\<rbrace>
            \<lbrace>\<acute>M = \<^bsup>\<sigma>\<^esup>N \<and> \<acute>N = \<^bsup>\<sigma>\<^esup>M\<rbrace>"
apply vcg
apply auto
done

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

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

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

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

end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Strong_Early_Bisim_Subst
  imports Strong_Early_Bisim
begin

abbreviation StrongCongEarlyJudge (infixr "\<sim>\<^sup>s" 65) where   "P \<sim>\<^sup>s Q \<equiv> (P, Q) \<in> (substClosed bisim)"

lemma congBisim:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<sim>\<^sup>s Q"

  shows "P \<sim> Q"
using assms substClosedSubset by blast

lemma eqvt:
  shows "eqvt (substClosed bisim)"
by(rule eqvtSubstClosed[OF Strong_Early_Bisim.eqvt])

lemma eqvtI:
  fixes P :: pi
  and   Q :: pi
  and   perm :: "name prm"

  assumes "P \<sim>\<^sup>s Q"

  shows "(perm \<bullet> P) \<sim>\<^sup>s (perm \<bullet> Q)"
using assms
by(rule eqvtRelI[OF eqvt])

lemma reflexive:
  fixes P :: pi

  shows "P \<sim>\<^sup>s P"
by(force simp add: substClosed_def intro: Strong_Early_Bisim.reflexive)

lemma symetric:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<sim>\<^sup>s Q"

  shows "Q \<sim>\<^sup>s P"
using assms
by(force simp add: substClosed_def intro: Strong_Early_Bisim.bisimE)

lemma partUnfold:
  fixes P :: pi
  and   Q :: pi
  and   s :: "(name \<times> name) list"

  assumes "P \<sim>\<^sup>s Q"

  shows "P[<s>] \<sim>\<^sup>s Q[<s>]"
using assms
proof(auto simp add: substClosed_def)
  fix s'
  assume "\<forall>s. P[<s>] \<sim> Q[<s>]"
  hence "P[<(s@s')>] \<sim> Q[<(s@s')>]" by blast
  moreover have "P[<(s@s')>] = (P[<s>])[<s'>]"
    by(induct s', auto)
  moreover have "Q[<(s@s')>] = (Q[<s>])[<s'>]"
    by(induct s', auto)

  ultimately show "(P[<s>])[<s'>] \<sim> (Q[<s>])[<s'>]"
    by simp
qed

end


theory Simple_Separation_Example
imports
  "Extended_Separation_Algebra"
  "Hoare_Sep_Tactics"
  "../Monad_WP/WhileLoopRules"
  "Sep_SP"
begin

declare [[syntax_ambiguity_warning = false]]

type_synonym heap = "((nat \<Rightarrow> nat option))"

definition maps_to:: "nat \<Rightarrow> nat \<Rightarrow> heap \<Rightarrow> bool" ("_ \<mapsto> _" [56,51] 56)
  where "x \<mapsto> y \<equiv> \<lambda>h. h = [x \<mapsto> y] "

notation pred_ex  (binder "\<exists>" 10)

definition maps_to_ex :: "nat \<Rightarrow> heap \<Rightarrow> bool" ("_ \<mapsto> -" [56] 56)
  where "x \<mapsto> - \<equiv> (\<lambda>s. \<exists>y. (x \<mapsto> y) s)"

lemma maps_to_maps_to_ex [elim!]:
  "(p \<mapsto> v) s \<Longrightarrow> (p \<mapsto> -) s"
  by (auto simp: maps_to_ex_def)

declare maps_to_maps_to_ex[sep_cancel]

  lemma precise_weaken_pre: "precise P \<Longrightarrow> \<lbrace>P \<leadsto>* R\<rbrace> f \<lbrace>\<lambda>_. Q \<and>* R\<rbrace>  \<Longrightarrow> \<lbrace>P \<and>* R\<rbrace> f \<lbrace>\<lambda>_. Q \<and>* R\<rbrace> "
  apply (rule hoare_weaken_pre, assumption)
by (simp add: precise_conj_coimpl)

definition "delete_ptr p = do x <- gets (\<lambda>s. s p);
                           assert (x \<noteq> None);
                           (modify (\<lambda>s x.  if x = p then None else s x )) od"

definition "get_ptr p = do x <- gets (\<lambda>s. s p);
                           assert (x \<noteq> None);
                           (return (the x)) od"

definition "set_ptr p v = do x <- gets (\<lambda>s. s p);
                           assert (x \<noteq> None);
                           (modify (\<lambda>s. s(p \<mapsto> v))) od"

definition "new_ptr  = do  ptrs <- gets dom;
                           p <- (select ptrs);
                           x <- gets (\<lambda>s. s p);
                           assert (x = None);
                           (modify (\<lambda>s. s(p \<mapsto> 0)));
                           return p od"

lemma new_ptr_sp: "\<lbrace>R\<rbrace> new_ptr \<lbrace>\<lambda>rv. (rv \<mapsto> - \<and>* R) \<rbrace>"
  apply (clarsimp simp: new_ptr_def, wp select_wp)
  apply (simp add: Ball_def, intro allI impI)
  apply (clarsimp simp: sep_conj_def)
 done

lemma delete_ptr_sp: "\<lbrace>(p \<mapsto> - \<leadsto>* R)\<rbrace> delete_ptr p \<lbrace>\<lambda>_. R \<rbrace>"
  apply (clarsimp simp: delete_ptr_def, wp)
  apply (intro allI impI)
  apply (clarsimp simp: sep_conj_def sep_coimpl_def pred_neg_def)
  apply (erule_tac x="[p \<mapsto> y] :: heap" in allE)
   apply (drule mp)
  apply (clarsimp simp: maps_to_ex_def maps_to_def, fastforce)
  apply (erule_tac x=" (\<lambda>a. if a = p then None else s a)" in allE)
   apply (drule mp)
  apply (rule ext, clarsimp simp: plus_fun_def plus_option_def)
   apply (drule mp)
  apply (clarsimp simp: sep_disj_fun_def sep_disj_option_def)
  apply (assumption)
done

lemma set_ptr_sp: "\<lbrace>(p \<mapsto> - \<leadsto>* R)\<rbrace> set_ptr p v  \<lbrace>\<lambda>_. (p \<mapsto> v \<and>* R) \<rbrace>"
  apply (clarsimp simp: set_ptr_def, wp)
  apply (intro allI impI)
  apply (clarsimp simp: sep_conj_def sep_coimpl_def pred_neg_def)
   apply (erule_tac x="[p \<mapsto> y] :: heap" in allE)
  apply (drule mp)
  apply (clarsimp simp: maps_to_ex_def maps_to_def, fastforce)
  apply (erule_tac x=" (\<lambda>a. if a = p then None else s a)" in allE)
  apply (drule mp)
   apply (rule ext, clarsimp simp: plus_fun_def plus_option_def)
  apply (drule mp)
   apply (clarsimp simp: sep_disj_fun_def sep_disj_option_def)
  apply (rule_tac x="[p \<mapsto> v] :: heap" in exI)
  apply (rule_tac x=" (\<lambda>a. if a = p then None else s a)" in exI)
  apply (clarsimp, intro conjI)
    apply (clarsimp simp: sep_disj_fun_def sep_disj_option_def)
   apply (rule ext, clarsimp simp: plus_fun_def plus_option_def)
  apply (clarsimp simp: maps_to_ex_def maps_to_def)
done

lemma set_ptr_sp': "\<lbrace>(R)\<rbrace> set_ptr p v  \<lbrace>\<lambda>rv. (p \<mapsto> v \<and>* (p \<mapsto> - -* R )) \<rbrace>"
 apply (rule hoare_chain, rule set_ptr_sp)
  apply (erule (1) sep_snake_septraction, assumption)
 done

 lemma get_ptr_wp: "\<lbrace>EXS x. (p \<mapsto> x \<and>* (p \<mapsto> x \<longrightarrow>* R x ))\<rbrace> get_ptr p \<lbrace>R \<rbrace>"
  apply (clarsimp simp: get_ptr_def, wp)
  apply (intro allI impI)
  apply (clarsimp simp: sep_coimpl_def sep_conj_def pred_neg_def sep_impl_def maps_to_def)
  apply (clarsimp simp: sep_disj_commute sep_add_commute)
  apply (subgoal_tac "x=y")
   apply (clarsimp)
  apply (clarsimp simp: plus_fun_def plus_option_def split: option.splits)
 done

lemma get_ptr_sp_weak: "\<lbrace>(R)\<rbrace> get_ptr p \<lbrace>\<lambda>rv. R and (ALLS x. (p \<mapsto> x \<leadsto>* (\<lambda>s. rv = x))) \<rbrace>"
  apply (clarsimp simp: get_ptr_def,wp)
  apply (intro allI impI)
  apply (clarsimp simp: sep_conj_def)
  apply (clarsimp simp: sep_coimpl_def pred_neg_def sep_conj_def)
  apply (clarsimp simp: septraction_def plus_fun_def plus_option_def pred_neg_def sep_impl_def maps_to_def sep_disj_fun_def sep_disj_option_def split: option.splits if_split_asm)
done

lemma get_ptr_sp: "\<lbrace>(R)\<rbrace> get_ptr p \<lbrace>\<lambda>rv. (p \<mapsto> rv \<and>* (p \<mapsto> rv -* R)) \<rbrace>"
  apply (clarsimp simp: get_ptr_def, wp)
  apply (intro allI impI)
  apply (clarsimp simp: sep_conj_def)
  apply (rule_tac x="[p \<mapsto> y] :: heap" in exI)
  apply (rule_tac x=" (\<lambda>a. if a = p then None else s a)" in exI)
  apply (intro conjI)
    apply (clarsimp simp: sep_disj_fun_def sep_disj_option_def)
     apply (rule ext, clarsimp simp: plus_fun_def plus_option_def)
       apply (clarsimp simp: maps_to_ex_def maps_to_def)
  apply (clarsimp simp: sep_coimpl_def sep_conj_def pred_neg_def sep_impl_def septraction_def)
    apply (rule_tac x="[p \<mapsto> y] :: heap" in exI)
             apply (clarsimp simp: maps_to_ex_def maps_to_def, rule conjI)
                 apply (clarsimp simp: sep_disj_fun_def sep_disj_option_def split: option.splits)
    apply (erule back_subst[where P=R])
      apply (rule ext, clarsimp simp: plus_fun_def plus_option_def split: option.splits)
 done

 lemma get_ptr_sp': "\<lbrace>\<lambda>s. (R (the (s p)) s )\<rbrace> get_ptr p \<lbrace>\<lambda>rv. (p \<mapsto> rv \<and>* (p \<mapsto> rv -* R rv)) \<rbrace>"
  apply (clarsimp simp: get_ptr_def, wp)
  apply (intro allI impI)
  apply (clarsimp simp: sep_conj_def)
  apply (rule_tac x="[p \<mapsto> y] :: heap" in exI)
  apply (rule_tac x=" (\<lambda>a. if a = p then None else s a)" in exI)
  apply (intro conjI)
    apply (clarsimp simp: sep_disj_fun_def sep_disj_option_def)
     apply (rule ext, clarsimp simp: plus_fun_def plus_option_def)
       apply (clarsimp simp: maps_to_ex_def maps_to_def)
  apply (clarsimp simp: sep_coimpl_def sep_conj_def pred_neg_def sep_impl_def septraction_def)
    apply (rule_tac x="[p \<mapsto> y] :: heap" in exI)
             apply (clarsimp simp: maps_to_ex_def maps_to_def, rule conjI)
                 apply (clarsimp simp: sep_disj_fun_def sep_disj_option_def split: option.splits)
    apply (erule_tac P="R y" in back_subst)
      apply (rule ext, clarsimp simp: plus_fun_def plus_option_def split: option.splits)
 done

 lemma extract_forall_septract:"(P -* (ALLS x. R x)) s \<Longrightarrow> \<forall>x. (P -* (R x)) s"
  apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def)
  apply (erule_tac x=x in allE)
  apply (fastforce)
 done

 lemma septraction_snake_trivial_alls: "(P x -* (ALLS x. P x  \<leadsto>* R x)) s \<Longrightarrow> R x s"
  apply (clarsimp simp: septraction_def )
  apply (clarsimp simp: pred_neg_def)
  apply (erule contrapos_np)
  apply (erule sep_curry[rotated])
  apply (rule_tac x=x in exI)
  apply (clarsimp simp: sep_coimpl_def)
  apply (sep_cancel)
  apply (clarsimp simp: pred_neg_def)
 done

 lemma get_ptr_valid: "\<lbrace>ALLS x. (p \<mapsto> x \<leadsto>* R x) \<rbrace> get_ptr p \<lbrace>\<lambda>rv. (p \<mapsto> rv \<and>* R rv) \<rbrace>"
 apply (rule hoare_strengthen_post, rule get_ptr_sp)
 apply (sep_cancel)
 apply (erule septraction_snake_trivial_alls)
 done

 definition "copy_ptr p p' = do x <- get_ptr p;
                                set_ptr p' x od"

 lemma precise_maps_to[precise]: "precise (p \<mapsto> v)"
  apply (clarsimp simp: precise_def maps_to_def)
  done

 lemma precise_maps_to_ex[precise]: "precise (p \<mapsto> -)"
  apply (clarsimp simp: precise_def maps_to_def maps_to_ex_def)
  apply (rule ext, clarsimp simp: sep_substate_def)
  apply (clarsimp simp: plus_fun_def plus_option_def)
  apply (drule fun_cong[where x=p], clarsimp split: option.splits)
 by (metis (full_types) fun_upd_same option.distinct(2) option.simps(5) sep_disj_fun_def sep_disj_option_def)

lemma septract_maps_to:"(p \<mapsto> v -* (p \<mapsto> v' \<and>* R)) s \<Longrightarrow> R s \<and> v = v'"
 apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def maps_to_def sep_conj_def)
 apply (rule conjI)
  apply (erule back_subst[where P=R])
  apply (rule ext)
  apply (drule_tac x=x in fun_cong)
  apply (clarsimp simp: plus_fun_def plus_option_def sep_disj_fun_def sep_disj_option_def)
  apply (erule_tac x=x in allE)
  apply (erule_tac x=x in allE)
  apply (clarsimp split: option.splits if_split_asm)
 apply (drule_tac x=p in fun_cong)
 apply (clarsimp simp: plus_fun_def plus_option_def sep_disj_fun_def sep_disj_option_def)
 apply (erule_tac x=p in allE)
 apply (erule_tac x=p in allE)
 apply (clarsimp split: option.splits)
done

lemma precise_conj_coimpl': "precise P \<Longrightarrow> (\<And>s R. (P \<and>* R) s \<Longrightarrow> (P \<leadsto>* R) s) "
  by (clarsimp simp: precise_conj_coimpl)

lemma septraction_precise_conj: "precise P \<Longrightarrow> (P -* (P \<and>* R)) s \<Longrightarrow> R s "
  apply (drule septraction_impl2)
   apply (erule (1) precise_conj_coimpl')
 by (erule septraction_snake_trivial)

lemma septract_lift_pure[simp]: "(P -* (\<lambda>s. p \<and> Q s)) s \<longleftrightarrow> (P -* Q) s \<and> p"
  apply (rule iffI, rule conjI)
    using septraction_impl2 apply blast
   apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def)
  apply (clarsimp simp: septraction_def pred_neg_def sep_impl_def)
 done

 lemma
copy_ptr_wp: "\<lbrace>EXS x. (p \<mapsto> x \<and>* (p \<mapsto> x \<longrightarrow>* p' \<mapsto> - \<and>* (p' \<mapsto> x \<longrightarrow>* R))) \<rbrace> copy_ptr p p' \<lbrace>\<lambda>rv. R \<rbrace>"
  apply (clarsimp simp: copy_ptr_def)
  apply (rule hoare_seq_ext)
  apply (rule hoare_strengthen_post, rule precise_weaken_pre[OF precise_maps_to_ex], rule set_ptr_sp)
  apply (sep_erule (direct) sep_mp)
  apply (rule get_ptr_wp)
  done

 lemma sep_All_mp:"(P x \<and>* (ALLS v. P v \<longrightarrow>* R v)) s \<Longrightarrow> R x s"
   apply (clarsimp simp: sep_conj_def sep_impl_def)
   apply (erule_tac x=x in allE, erule_tac x=xa in allE)
  by (simp add: sep_add_commute sep_disj_commuteI)

  (* new_rules can be run in both directions *)

  lemma copy_ptr_wp':
  "\<lbrace>ALLS x. (p \<mapsto> x \<leadsto>* (ALLS x. (p \<mapsto> x \<longrightarrow>* (p' \<mapsto> - \<leadsto>* p' \<mapsto> x \<longrightarrow>* R)) ))  \<rbrace>
   copy_ptr p p'  \<lbrace>\<lambda>rv. R\<rbrace>"
  apply (clarsimp simp: copy_ptr_def)
  apply (rule hoare_seq_ext)
   apply (rule hoare_strengthen_post, rule set_ptr_sp)
   apply (sep_erule (direct) sep_mp)
  apply (rule hoare_strengthen_post, rule get_ptr_valid)
  apply (erule sep_All_mp)
  done

lemma copy_ptr_sp:
  "\<lbrace>R\<rbrace> copy_ptr p p'  \<lbrace>\<lambda>rv. \<exists>x. (p' \<mapsto> x \<and>* (p' \<mapsto> - -*  (p \<mapsto> x \<and>* (p \<mapsto> x -* R)))) \<rbrace>"
   apply (clarsimp simp: copy_ptr_def )
   apply (rule seq_ext)
    apply (rule get_ptr_sp)
   apply (rule hoare_chain)
      apply (rule set_ptr_sp, erule (1) sep_snake_septraction)
   apply (rule_tac x=x in exI, clarsimp)
  done

  lemma copy_ptr_valid: "\<lbrace>(p \<mapsto> x \<and>* p' \<mapsto> - \<and>* R)\<rbrace> copy_ptr p p'  \<lbrace>\<lambda>_. (p \<mapsto> x \<and>* p' \<mapsto> x \<and>* R) \<rbrace>"
   apply (wp copy_ptr_wp)
   apply (rule_tac x=x in exI)
   apply (sep_solve)
  done

lemma copy_ptr_valid'': "\<lbrace>(p \<mapsto> x \<and>* p' \<mapsto> - \<and>* (p \<mapsto> x \<and>* p' \<mapsto> x \<longrightarrow>* R))\<rbrace> copy_ptr p p'  \<lbrace>\<lambda>_. (R) \<rbrace>"
   apply (rule hoare_chain, rule copy_ptr_valid)
   apply (assumption)
   apply (sep_solve)
  done

lemma copy_ptr_wp'': "\<lbrace>EXS x. (p \<mapsto> x \<and>* p' \<mapsto> - \<and>* (p \<mapsto> x \<and>* p' \<mapsto> x \<longrightarrow>* R))\<rbrace>
   copy_ptr p p'  \<lbrace>\<lambda>_. (R) \<rbrace>"
 apply (rule hoare_weaken_pre, rule copy_ptr_wp, clarsimp)
 apply (rule_tac x=x in exI)
 apply (sep_cancel)+
 apply (sep_solve)
done

lemma copy_ptr_valid': "\<lbrace>(p \<mapsto> x \<and>* p' \<mapsto> - \<and>* R)\<rbrace> copy_ptr p p'  \<lbrace>\<lambda>_. (p \<mapsto> x \<and>* p' \<mapsto> x \<and>* R) \<rbrace>"
  apply (rule hoare_strengthen_post[OF copy_ptr_sp], elim exE)
  apply (sep_drule septraction_impl2)
   apply (sep_drule septract_maps_to, assumption, clarsimp simp: sep_conj_assoc)
  apply (sep_drule septraction_impl2, erule precise_conj_coimpl'[OF precise_maps_to_ex])
  apply (sep_drule septraction_snake_trivial)
  apply (sep_solve)
done

definition "swap_ptr p p' = do np <- new_ptr;
                              copy_ptr p np;
                              copy_ptr p' p;
                              copy_ptr np p';
                              delete_ptr np od"

lemma delete_ptr_sp': "\<lbrace>R\<rbrace> delete_ptr p \<lbrace>\<lambda>_. (p \<mapsto> - -* R)\<rbrace>"
 apply (rule hoare_weaken_pre[OF delete_ptr_sp])
 apply (erule (1) sep_snake_septraction)
 done

lemma extract_exs_septraction_simp[simp]: "(P -* (EXS v. R v)) = (EXS v. (P -* R v) )"
 apply (rule ext, rule iffI)
 apply (fastforce simp: septraction_def sep_impl_def pred_neg_def)
 apply (fastforce simp: septraction_def sep_impl_def pred_neg_def)
done

lemma extract_exs_septraction_simp'[simp]: "((EXS v. R v) -* P ) = (EXS v. (R v -* P) )"
 apply (rule ext, rule iffI; fastforce simp: septraction_def sep_impl_def pred_neg_def)
 done

lemma new_ptr_wp: "\<lbrace>ALLS p. (p \<mapsto> - \<longrightarrow>* R p)\<rbrace> new_ptr \<lbrace> R \<rbrace>"
   apply (rule hoare_chain, rule new_ptr_sp, assumption)
using sep_conj_commuteI sep_conj_sep_impl2 by blast

lemma delete_ptr_valid: "\<lbrace>(p \<mapsto> - \<and>* R )\<rbrace> delete_ptr p \<lbrace>\<lambda>_. R  \<rbrace>"
 apply (rule hoare_weaken_pre[OF delete_ptr_sp])
 by (erule precise_conj_coimpl'[OF precise_maps_to_ex])

lemma swap_ptr_valid: "\<lbrace>(p \<mapsto> v \<and>* p' \<mapsto> v' \<and>* R)\<rbrace> swap_ptr p p' \<lbrace>\<lambda>_. (p \<mapsto> v' \<and>* p' \<mapsto> v \<and>* R)\<rbrace>"
   apply (clarsimp simp: swap_ptr_def)
   apply (wp delete_ptr_valid)
        apply (wp copy_ptr_wp new_ptr_wp)+
   apply (clarsimp simp: sep_conj_exists)
   apply (sep_cancel)
   apply (rule_tac x=v in exI)
   apply (sep_cancel)+
   apply (rule_tac x=v' in exI)
   apply (sep_cancel add: maps_to_maps_to_ex)+
   apply (rule exI)
   by (sep_solve add: maps_to_maps_to_ex)

lemma septraction_lens: "((P -* Q) \<and>* R) s \<Longrightarrow> (\<And>s. Q' s = Q s) \<Longrightarrow> ((P -* Q') \<and>* R) s"
  apply (sep_cancel) using septract_cancel by blast

lemmas septraction_lens' = septraction_lens[where R=\<box>, simplified]

ML{*
  fun septraction_drule thms ctxt =
     let val lens  = dresolve0_tac  [@{thm septraction_lens}]
         val r = rotator' ctxt
      in sep_drule_tac (dresolve0_tac thms |> r lens) ctxt
   end;

fun septraction_drule_method  thms ctxt = SIMPLE_METHOD' (septraction_drule  thms ctxt)

 fun septraction_drule' thms ctxt =
     let val lens  = dresolve0_tac  [@{thm septraction_lens'}]
         val r = rotator' ctxt
      in (dresolve0_tac thms |> r lens)
   end;

fun septraction_drule_method'  thms ctxt = SIMPLE_METHOD' (septraction_drule'  thms ctxt)

*}

method_setup septract_drule = {*
  (Attrib.thms) >>  septraction_drule_method
*}

method_setup septract_drule' = {*
  (Attrib.thms) >>  septraction_drule_method'
*}

lemma septract_maps_to1:"((p \<mapsto> v -* (p \<mapsto> v' \<and>* R)) \<and>* Q) s \<Longrightarrow> ((R \<and>* Q) and K(v = v')) s"
by (sep_drule septract_maps_to, clarsimp)

lemma septract_maps_to2: "((p \<mapsto> v -* (p \<mapsto> - \<and>* R)) \<and>* Q) s \<Longrightarrow> (R \<and>* Q) s"
apply (sep_cancel)
  using precise_maps_to_ex septraction_impl1 septraction_precise_conj by fastforce

lemma septract_maps_to3: "((p \<mapsto> - -* (p \<mapsto> v' \<and>* R)) \<and>* Q) s \<Longrightarrow> (R \<and>* Q) s "
  apply (sep_cancel)
  by (smt maps_to_maps_to_ex precise_conj_coimpl precise_maps_to_ex sep_rule sep_septraction_snake)

lemma septract_maps_to4: "((p \<mapsto> - -* (p \<mapsto> - \<and>* R)) \<and>* Q) s \<Longrightarrow> (R \<and>* Q) s"
  apply (sep_cancel)
 using precise_maps_to_ex septraction_precise_conj by blast

lemmas septract_maps_to_set = septract_maps_to1 septract_maps_to2 septract_maps_to3 septract_maps_to4

lemmas septract_maps_to_set' = septract_maps_to_set[where Q=sep_empty, simplified]

lemma septraction_extract_pure[simp]: "(P -* (\<lambda>s. R s \<and> r)) = ((P -* R) and K r)"
  by (rule ext, rule iffI; fastforce simp: septraction_def sep_impl_def pred_neg_def)
(*
method septract_cancel = ((septract_drule septract_maps_to_set | septract_drule' septract_maps_to_set') |
                          ((sep_drule septraction_impl2 | drule septraction_impl2), septract_cancel, assumption))

 (* now forwards *)
*)

lemma maps_to_pointer[precise]: "pointer (maps_to p)"
 apply (clarsimp simp:  pointer_def maps_to_def
  sep_conj_def sep_coimpl_def pred_neg_def)
  apply (subgoal_tac "x=y", simp)
  apply (metis sep_add_cancelD sep_add_commute sep_disj_commuteI)
  apply (drule_tac x=p in fun_cong)
 apply (clarsimp simp: plus_fun_def plus_option_def split: option.splits)
  apply (clarsimp simp: sep_disj_fun_def)
  apply (erule_tac x=p in allE)
  apply (erule_tac x=p in allE)
apply (clarsimp simp: sep_disj_fun_def sep_disj_option_def)
done

lemma swap_ptr_valid': "\<lbrace>(p \<mapsto> v \<and>* p' \<mapsto> v' \<and>* R)\<rbrace> swap_ptr p p'
                       \<lbrace>\<lambda>_. (p \<mapsto> v' \<and>* p' \<mapsto> v \<and>* R)\<rbrace>"
  apply (clarsimp simp: swap_ptr_def, intro seq_ext)
      apply (rule new_ptr_sp)
     apply (rule copy_ptr_sp)+
  apply (rule hoare_strengthen_post[OF delete_ptr_sp'])
    apply (clarsimp simp: sep_conj_exists2 sep_conj_assoc)
  apply (sep_invert, sep_forward+, simp, sep_solve)
done

primrec
  list :: "nat \<Rightarrow> nat list \<Rightarrow> heap \<Rightarrow> bool"
where
  "list i [] = (\<langle>i=0\<rangle> and \<box>)"
| "list i (x#xs) = (\<langle>i=x \<and> i\<noteq>0\<rangle> and (EXS j. i \<mapsto> j ** list j xs))"

lemma list_empty [simp]:
  shows "list 0 xs = (\<lambda>s. xs = [] \<and> \<box> s)"
  by (cases xs) auto

lemma list_nonempty:
 shows "0 < i \<Longrightarrow> list i xs = (EXS h t.  (\<langle>i= (h) \<and> i\<noteq>0 \<and> xs = h#t \<rangle> and (EXS j. i \<mapsto> j ** list j (t))))"
  apply (cases xs; clarsimp)
  defer
  apply (rule ext, rule iffI)
  apply (clarsimp simp: pred_conj_def)
    apply (clarsimp simp: pred_conj_def)
done

lemma "
 \<lbrace>((p \<mapsto> - and (\<lambda>s. p \<noteq>0)) \<and>* list q qs)\<rbrace>
 set_ptr p q
 \<lbrace>\<lambda>_. list p (p#qs) \<rbrace>"
  apply (rule hoare_chain, rule precise_weaken_pre[OF precise_maps_to_ex], rule set_ptr_sp)
  defer
  apply (sep_erule (direct) sep_mp)
  apply (clarsimp simp: pred_conj_def)
  apply (sep_cancel)
  apply (sep_lift)
  apply (rule_tac x=q in exI, sep_solve)
  done

 lemma set_ptr_wp: "\<lbrace>(p \<mapsto> - \<and>* (p \<mapsto> v \<longrightarrow>* R)) \<rbrace> set_ptr p v \<lbrace>\<lambda>_. R\<rbrace>"
  apply (rule hoare_chain, rule set_ptr_sp)
  apply (erule precise_conj_coimpl'[OF precise_maps_to_ex])
  apply (sep_solve)
 done

definition "NULL \<equiv> 0::nat"

declare NULL_def[simp]

definition list_rev where
  "list_rev p = do (hd_ptr, rev)  <- whileLoop  (\<lambda>(hd_ptr, rev) s. hd_ptr \<noteq> NULL)
                                    (\<lambda>(hd_ptr, rev). do next_ptr <- get_ptr hd_ptr;
                                                   set_ptr hd_ptr rev;
                                                   return (next_ptr, hd_ptr) od) (p, NULL) ;
                    return rev
                    od   "

definition "reverse_inv xs list' rev' =
                 (EXS ys zs. (list list' ys \<and>*
                     list rev' zs)
                    and (\<lambda>s. rev xs = rev ys @ zs) )"

lemma list_rev_valid_wp:"
  \<lbrace>(list p ps)\<rbrace>
  list_rev p
  \<lbrace>\<lambda>rv. list (rv) (rev ps) \<rbrace>"
  apply (clarsimp simp: list_rev_def, wpsimp)
   apply (subst whileLoop_add_inv [where
        I="\<lambda>(list', rev'). (EXS ys zs. (list list' ys \<and>*
                     list rev' zs)
                    and (\<lambda>s. rev ps = rev ys @ zs)) ",
        unfolded reverse_inv_def])
   apply (wp whileLoop_wp_inv; clarsimp)
   apply (wp set_ptr_wp get_ptr_wp)
   apply (clarsimp simp: pred_conj_def  sep_conj_exists sep_conj_assoc)
   apply (case_tac x; clarsimp simp: pred_conj_def sep_conj_exists sep_conj_assoc)
   apply (rule_tac exI)
   apply (sep_cancel add: maps_to_maps_to_ex)+
   apply (rule_tac x=lista in exI)
   apply (rule_tac x="aa # xa" in exI)
   apply (intro conjI)
   apply (clarsimp)
    apply (sep_cancel)
    apply (rule_tac x=b in exI)
    apply (sep_cancel)
   apply (clarsimp)
  apply (clarsimp split: prod.splits)
 done

 lemma septract_extra_pure1[simp]: "(P -* (\<lambda>s. Q s \<and> q)) = ((P -* Q) and (\<lambda>s. q))"
 by (rule ext, rule iffI; fastforce simp: pred_conj_def septraction_def sep_impl_def pred_neg_def)
 lemma septract_extra_pure2[simp]: "(P -* (\<lambda>s. q \<and> Q s)) = ((P -* Q) and (\<lambda>s. q))"
 by (rule ext, rule iffI; fastforce simp: pred_conj_def septraction_def sep_impl_def pred_neg_def)

lemma septract_false[simp] :"(P -* (sep_false)) = sep_false"
  using sep_septraction_snake by blast

lemma whileLoop_sp_inv:
  "\<lbrakk> \<And>r. \<lbrace>\<lambda>s. I r s \<and> C r s\<rbrace> B r \<lbrace>I\<rbrace>; \<And>s. P s \<Longrightarrow> I r s \<rbrakk>
      \<Longrightarrow> \<lbrace> P \<rbrace> whileLoop_inv C B r I M \<lbrace>\<lambda>rv s. I rv s \<and> \<not> C rv s  \<rbrace>"
  apply (clarsimp simp: whileLoop_inv_def)
  apply (rule hoare_weaken_pre)
  apply (rule valid_whileLoop [where P=I and I=I]; fastforce)
  apply (assumption)
  done

lemma sep_conj_coimpl_mp:"(P \<and>* R) s \<Longrightarrow> (P \<leadsto>* Q) s \<Longrightarrow> (P \<and>* (Q and R)) s"
 apply (drule (2) sep_coimpl_mp_gen, clarsimp simp: pred_conj_def conj_commute)
done

 lemma list_rev_valid_sp: "
  \<lbrace>(list p ps \<and>* R)\<rbrace>
  list_rev p
  \<lbrace>\<lambda>rv. (list (rv) (rev ps) \<and>* R) \<rbrace>"
  apply (clarsimp simp: list_rev_def)
  apply (subst whileLoop_add_inv [where
  I="\<lambda>(list', rev') s. (reverse_inv ps list' rev' \<and>* R) s ",
  unfolded reverse_inv_def])
  apply (sp sp: whileLoop_sp_inv)
  apply (clarsimp)
  apply (sp sp: get_ptr_sp set_ptr_sp')
 apply (clarsimp)
  apply (clarsimp simp: pred_conj_def sep_conj_exists sep_conj_assoc, case_tac x; clarsimp simp: pred_conj_def sep_conj_exists sep_conj_assoc)
  apply (sep_invert; sep_forward+)
  apply (clarsimp)
  apply (rule exI, rule exI, intro conjI, fastforce)
 apply (clarsimp simp: pred_conj_def sep_conj_exists)
  apply (rule_tac exI)
 apply (sep_solve)
  apply (clarsimp)+
  apply (sp, clarsimp)
done

lemma "P s \<Longrightarrow> Q s \<Longrightarrow> (P \<and>* (Q -* (P and Q))) s"
  by (metis disjoint_zero_sym pred_andI pred_neg_def sep_add_zero_sym sep_conjI sep_conj_commuteI sep_mp septraction_def)

end


(*  Title:      HOL/MicroJava/BV/Typing_Framework_err.thy
    Author:     Gerwin Klein
    Copyright   2000 TUM

*)

section \<open>Lifting the Typing Framework to err, app, and eff\<close>

theory Typing_Framework_err imports SemilatAlg begin

definition wt_err_step :: "'s ord \<Rightarrow> 's err step_type \<Rightarrow> 's err list \<Rightarrow> bool"
where
  "wt_err_step r step \<tau>s \<longleftrightarrow> wt_step (Err.le r) Err step \<tau>s"

definition wt_app_eff :: "'s ord \<Rightarrow> (nat \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> bool"
where
  "wt_app_eff r app step \<tau>s \<longleftrightarrow>
    (\<forall>p < size \<tau>s. app p (\<tau>s!p) \<and> (\<forall>(q,\<tau>) \<in> set (step p (\<tau>s!p)). \<tau> <=_r \<tau>s!q))"

definition map_snd :: "('b \<Rightarrow> 'c) \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('a \<times> 'c) list"
where
  "map_snd f = map (\<lambda>(x,y). (x, f y))"

definition error :: "nat \<Rightarrow> (nat \<times> 'a err) list"
where
  "error n = map (\<lambda>x. (x,Err)) [0..<n]"

definition err_step :: "nat \<Rightarrow> (nat \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's step_type \<Rightarrow> 's err step_type"
where
  "err_step n app step p t =
  (case t of
    Err   \<Rightarrow> error n
  | OK \<tau> \<Rightarrow> if app p \<tau> then map_snd OK (step p \<tau>) else error n)"

definition app_mono :: "'s ord \<Rightarrow> (nat \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 's set \<Rightarrow> bool"
where
  "app_mono r app n A \<longleftrightarrow>
    (\<forall>s p t. s \<in> A \<and> p < n \<and> s \<sqsubseteq>\<^sub>r t \<longrightarrow> app p t \<longrightarrow> app p s)"

lemmas err_step_defs = err_step_def map_snd_def error_def

lemma bounded_err_stepD:
  "\<lbrakk> bounded (err_step n app step) n;
     p < n; app p a; (q,b) \<in> set (step p a) \<rbrakk> \<Longrightarrow> q < n"
(*<*)
  apply (simp add: bounded_def err_step_def)
  apply (erule allE, erule impE, assumption)
  apply (erule_tac x = "OK a" in allE, drule bspec)
   apply (simp add: map_snd_def)
   apply fast
  apply simp
  done
(*>*)

lemma in_map_sndD: "(a,b) \<in> set (map_snd f xs) \<Longrightarrow> \<exists>b'. (a,b') \<in> set xs"
(*<*)
  apply (induct xs)
  apply (auto simp add: map_snd_def)
  done
(*>*)

lemma bounded_err_stepI:
  "\<forall>p. p < n \<longrightarrow> (\<forall>s. ap p s \<longrightarrow> (\<forall>(q,s') \<in> set (step p s). q < n))
  \<Longrightarrow> bounded (err_step n ap step) n"
(*<*)
apply (clarsimp simp: bounded_def err_step_def split: err.splits)
apply (simp add: error_def image_def)
apply (blast dest: in_map_sndD)
done
(*>*)

lemma bounded_lift:
  "bounded step n \<Longrightarrow> bounded (err_step n app step) n"
(*<*)
  apply (unfold bounded_def err_step_def error_def)
  apply clarify
  apply (erule allE, erule impE, assumption)
  apply (case_tac \<tau>)
  apply (auto simp add: map_snd_def split: if_split_asm)
  done
(*>*)

lemma le_list_map_OK [simp]:
  "\<And>b. (map OK a [\<sqsubseteq>\<^bsub>Err.le r\<^esub>] map OK b) = (a [\<sqsubseteq>\<^sub>r] b)"
(*<*)
  apply (induct a)
   apply simp
  apply simp
  apply (case_tac b)
   apply simp
  apply simp
  done
(*>*)

lemma map_snd_lessI:
  "set xs {\<sqsubseteq>\<^bsub>r\<^esub>} set ys \<Longrightarrow> set (map_snd OK xs) {\<sqsubseteq>\<^bsub>Err.le r\<^esub>} set (map_snd OK ys)"
(*<*)
  apply (induct xs)
  apply (unfold lesubstep_type_def map_snd_def)
  apply auto
  done
(*>*)

lemma mono_lift:
  "\<lbrakk> order r A; app_mono r app n A; bounded (err_step n app step) n;
    \<forall>s p t. s \<in> A \<and> p < n \<and> s \<sqsubseteq>\<^sub>r t \<longrightarrow> app p t \<longrightarrow> set (step p s) {\<sqsubseteq>\<^bsub>r\<^esub>} set (step p t) \<rbrakk>
  \<Longrightarrow>  mono (Err.le r) (err_step n app step) n (err A)"
(*<*)
apply (simp only: app_mono_def SemilatAlg.mono_def err_step_def)
apply clarify
apply (case_tac \<tau>)
  defer
apply simp
apply (case_tac \<tau>')
 apply simp
 apply clarify
 apply (simp add: lesubstep_type_def error_def)
 apply clarify
 apply (drule in_map_sndD)
 apply clarify
 apply (drule bounded_err_stepD, assumption+)
 apply (rule exI [of _ Err])
 apply simp
apply simp
apply (erule allE, erule allE, erule allE, erule impE)
 apply (rule conjI, assumption)
 apply (rule conjI, assumption)
 apply assumption
apply (rule conjI)
apply clarify
apply (erule allE, erule allE, erule allE, erule impE)
 apply (rule conjI, assumption)
 apply (rule conjI, assumption)
 apply assumption
apply (erule impE, assumption)
apply (rule map_snd_lessI, assumption)
apply clarify
apply (simp add: lesubstep_type_def error_def)
apply clarify
apply (drule in_map_sndD)
apply clarify
apply (drule bounded_err_stepD, assumption+)
apply (rule exI [of _ Err])
apply simp
  apply (auto simp: lesubstep_type_def error_def)
done
(*>*)

lemma in_errorD: "(x,y) \<in> set (error n) \<Longrightarrow> y = Err"
(*<*) by (auto simp add: error_def) (*>*)

lemma pres_type_lift:
  "\<forall>s\<in>A. \<forall>p. p < n \<longrightarrow> app p s \<longrightarrow> (\<forall>(q, s')\<in>set (step p s). s' \<in> A)
  \<Longrightarrow> pres_type (err_step n app step) n (err A)"
(*<*)
apply (unfold pres_type_def err_step_def)
apply clarify
apply (case_tac b)
 apply simp
apply (case_tac \<tau>)
 apply simp
 apply (drule in_errorD)
 apply simp
apply (simp add: map_snd_def split: if_split_asm)
 apply fast
apply (drule in_errorD)
apply simp
done
(*>*)

lemma wt_err_imp_wt_app_eff:
  assumes wt: "wt_err_step r (err_step (size ts) app step) ts"
  assumes b:  "bounded (err_step (size ts) app step) (size ts)"
  shows "wt_app_eff r app step (map ok_val ts)"
(*<*)
proof (unfold wt_app_eff_def, intro strip, rule conjI)
  fix p assume "p < size (map ok_val ts)"
  hence lp: "p < size ts" by simp
  hence ts: "0 < size ts" by (cases p) auto
  hence err: "(0,Err) \<in> set (error (size ts))" by (simp add: error_def)

  from wt lp
  have [intro?]: "\<And>p. p < size ts \<Longrightarrow> ts ! p \<noteq> Err"
    by (unfold wt_err_step_def wt_step_def) simp

  show app: "app p (map ok_val ts ! p)"
  proof (rule ccontr)
    from wt lp obtain s where
      OKp:  "ts ! p = OK s" and
      less: "\<forall>(q,t) \<in> set (err_step (size ts) app step p (ts!p)). t <=_(Err.le r) ts!q"
      by (unfold wt_err_step_def wt_step_def stable_def)
         (auto iff: not_Err_eq)
    assume "\<not> app p (map ok_val ts ! p)"
    with OKp lp have "\<not> app p s" by simp
    with OKp have "err_step (size ts) app step p (ts!p) = error (size ts)"
      by (simp add: err_step_def)
    with err ts obtain q where
      "(q,Err) \<in> set (err_step (size ts) app step p (ts!p))" and
      q: "q < size ts" by auto
    with less have "ts!q = Err" by auto
    moreover from q have "ts!q \<noteq> Err" ..
    ultimately show False by blast
  qed

  show "\<forall>(q,t)\<in>set(step p (map ok_val ts ! p)). t \<sqsubseteq>\<^sub>r map ok_val ts ! q"
  proof clarify
    fix q t assume q: "(q,t) \<in> set (step p (map ok_val ts ! p))"

    from wt lp q
    obtain s where
      OKp:  "ts ! p = OK s" and
      less: "\<forall>(q,t) \<in> set (err_step (size ts) app step p (ts!p)). t <=_(Err.le r) ts!q"
      by (unfold wt_err_step_def wt_step_def stable_def)
         (auto iff: not_Err_eq)

    from b lp app q have lq: "q < size ts" by (rule bounded_err_stepD)
    hence "ts!q \<noteq> Err" ..
    then obtain s' where OKq: "ts ! q = OK s'" by (auto iff: not_Err_eq)

    from lp lq OKp OKq app less q
    show "t \<sqsubseteq>\<^sub>r map ok_val ts ! q"
      by (auto simp add: err_step_def map_snd_def)
  qed
qed
(*>*)

lemma wt_app_eff_imp_wt_err:
  assumes app_eff: "wt_app_eff r app step ts"
  assumes bounded: "bounded (err_step (size ts) app step) (size ts)"
  shows "wt_err_step r (err_step (size ts) app step) (map OK ts)"
(*<*)
proof (unfold wt_err_step_def wt_step_def, intro strip, rule conjI)
  fix p assume "p < size (map OK ts)"
  hence p: "p < size ts" by simp
  thus "map OK ts ! p \<noteq> Err" by simp
  { fix q t
    assume q: "(q,t) \<in> set (err_step (size ts) app step p (map OK ts ! p))"
    with p app_eff obtain
      "app p (ts ! p)" "\<forall>(q,t) \<in> set (step p (ts!p)). t \<sqsubseteq>\<^sub>r ts!q"
      by (unfold wt_app_eff_def) blast
    moreover
    from q p bounded have "q < size ts"
      by - (rule boundedD)
    hence "map OK ts ! q = OK (ts!q)" by simp
    moreover
    have "p < size ts" by (rule p)
    moreover note q
    ultimately
    have "t \<sqsubseteq>\<^bsub>Err.le r\<^esub> map OK ts ! q"
      by (auto simp add: err_step_def map_snd_def)
  }
  thus "stable (Err.le r) (err_step (size ts) app step) (map OK ts) p"
    by (unfold stable_def) blast
qed
(*>*)

end


theory Note_on_signed_division_on_words
  imports "HOL-Library.Word" "HOL-Library.Rounded_Division"
begin

unbundle bit_operations_syntax

context semiring_bit_operations
begin

lemma take_bit_Suc_from_most:
  \<open>take_bit (Suc n) a = 2 ^ n * of_bool (bit a n) OR take_bit n a\<close>
  by (rule bit_eqI) (auto simp add: bit_simps less_Suc_eq)

end

context ring_bit_operations
begin

lemma signed_take_bit_exp_eq_int:
  \<open>signed_take_bit m (2 ^ n) =
    (if n < m then 2 ^ n else if n = m then - (2 ^ n) else 0)\<close>
  by (rule bit_eqI) (auto simp add: bit_simps simp flip: mask_eq_exp_minus_1)

end

lift_definition signed_divide_word :: \<open>'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>  (infixl \<open>wdiv\<close> 70)
  is \<open>\<lambda>a b. signed_take_bit (LENGTH('a) - Suc 0) a rdiv signed_take_bit (LENGTH('a) - Suc 0) b\<close>
  by (simp flip: signed_take_bit_decr_length_iff)

lift_definition signed_modulo_word :: \<open>'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>  (infixl \<open>wmod\<close> 70)
  is \<open>\<lambda>a b. signed_take_bit (LENGTH('a) - Suc 0) a rmod signed_take_bit (LENGTH('a) - Suc 0) b\<close>
  by (simp flip: signed_take_bit_decr_length_iff)

lemma signed_take_bit_eq_wmod:
  \<open>signed_take_bit n w = w wmod (2 ^ Suc n)\<close>
proof (transfer fixing: n)
  show \<open>take_bit LENGTH('a) (signed_take_bit n (take_bit LENGTH('a) k)) =
    take_bit LENGTH('a) (signed_take_bit (LENGTH('a) - Suc 0) k rmod signed_take_bit (LENGTH('a) - Suc 0) (2 ^ Suc n))\<close> for k :: int
  proof (cases \<open>LENGTH('a) = Suc (Suc n)\<close>)
    case True
    then show ?thesis
      by (simp add: signed_take_bit_exp_eq_int signed_take_bit_take_bit rmod_minus_eq flip: power_Suc signed_take_bit_eq_rmod)
  next
    case False
    then show ?thesis
      by (auto simp add: signed_take_bit_exp_eq_int signed_take_bit_take_bit take_bit_signed_take_bit simp flip: power_Suc signed_take_bit_eq_rmod)
  qed
qed

end