(*  Title:      HOL/HOLCF/Lift.thy
    Author:     Olaf Mueller
*)

section \<open>Lifting types of class type to flat pcpo's\<close>

theory Lift
imports Discrete Up
begin

default_sort type

pcpodef 'a lift = "UNIV :: 'a discr u set"
by simp_all

lemmas inst_lift_pcpo = Abs_lift_strict [symmetric]

definition
  Def :: "'a \<Rightarrow> 'a lift" where
  "Def x = Abs_lift (up\<cdot>(Discr x))"

subsection \<open>Lift as a datatype\<close>

lemma lift_induct: "\<lbrakk>P \<bottom>; \<And>x. P (Def x)\<rbrakk> \<Longrightarrow> P y"
apply (induct y)
apply (rule_tac p=y in upE)
apply (simp add: Abs_lift_strict)
apply (case_tac x)
apply (simp add: Def_def)
done

old_rep_datatype "\<bottom>::'a lift" Def
  by (erule lift_induct) (simp_all add: Def_def Abs_lift_inject inst_lift_pcpo)

text \<open>\<^term>\<open>bottom\<close> and \<^term>\<open>Def\<close>\<close>

lemma not_Undef_is_Def: "(x \<noteq> \<bottom>) = (\<exists>y. x = Def y)"
  by (cases x) simp_all

lemma lift_definedE: "\<lbrakk>x \<noteq> \<bottom>; \<And>a. x = Def a \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  by (cases x) simp_all

text \<open>
  For \<^term>\<open>x ~= \<bottom>\<close> in assumptions \<open>defined\<close> replaces \<open>x\<close> by \<open>Def a\<close> in conclusion.\<close>

method_setup defined = \<open>
  Scan.succeed (fn ctxt => SIMPLE_METHOD'
    (eresolve_tac ctxt @{thms lift_definedE} THEN' asm_simp_tac ctxt))
\<close>

lemma DefE: "Def x = \<bottom> \<Longrightarrow> R"
  by simp

lemma DefE2: "\<lbrakk>x = Def s; x = \<bottom>\<rbrakk> \<Longrightarrow> R"
  by simp

lemma Def_below_Def: "Def x \<sqsubseteq> Def y \<longleftrightarrow> x = y"
by (simp add: below_lift_def Def_def Abs_lift_inverse)

lemma Def_below_iff [simp]: "Def x \<sqsubseteq> y \<longleftrightarrow> Def x = y"
by (induct y, simp, simp add: Def_below_Def)

subsection \<open>Lift is flat\<close>

instance lift :: (type) flat
proof
  fix x y :: "'a lift"
  assume "x \<sqsubseteq> y" thus "x = \<bottom> \<or> x = y"
    by (induct x) auto
qed

subsection \<open>Continuity of \<^const>\<open>case_lift\<close>\<close>

lemma case_lift_eq: "case_lift \<bottom> f x = fup\<cdot>(\<Lambda> y. f (undiscr y))\<cdot>(Rep_lift x)"
apply (induct x, unfold lift.case)
apply (simp add: Rep_lift_strict)
apply (simp add: Def_def Abs_lift_inverse)
done

lemma cont2cont_case_lift [simp]:
  "\<lbrakk>\<And>y. cont (\<lambda>x. f x y); cont g\<rbrakk> \<Longrightarrow> cont (\<lambda>x. case_lift \<bottom> (f x) (g x))"
unfolding case_lift_eq by (simp add: cont_Rep_lift)

subsection \<open>Further operations\<close>

definition
  flift1 :: "('a \<Rightarrow> 'b::pcpo) \<Rightarrow> ('a lift \<rightarrow> 'b)"  (binder "FLIFT " 10)  where
  "flift1 = (\<lambda>f. (\<Lambda> x. case_lift \<bottom> f x))"

translations
  "\<Lambda>(XCONST Def x). t" => "CONST flift1 (\<lambda>x. t)"
  "\<Lambda>(CONST Def x). FLIFT y. t" <= "FLIFT x y. t"
  "\<Lambda>(CONST Def x). t" <= "FLIFT x. t"

definition
  flift2 :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a lift \<rightarrow> 'b lift)" where
  "flift2 f = (FLIFT x. Def (f x))"

lemma flift1_Def [simp]: "flift1 f\<cdot>(Def x) = (f x)"
by (simp add: flift1_def)

lemma flift2_Def [simp]: "flift2 f\<cdot>(Def x) = Def (f x)"
by (simp add: flift2_def)

lemma flift1_strict [simp]: "flift1 f\<cdot>\<bottom> = \<bottom>"
by (simp add: flift1_def)

lemma flift2_strict [simp]: "flift2 f\<cdot>\<bottom> = \<bottom>"
by (simp add: flift2_def)

lemma flift2_defined [simp]: "x \<noteq> \<bottom> \<Longrightarrow> (flift2 f)\<cdot>x \<noteq> \<bottom>"
by (erule lift_definedE, simp)

lemma flift2_bottom_iff [simp]: "(flift2 f\<cdot>x = \<bottom>) = (x = \<bottom>)"
by (cases x, simp_all)

lemma FLIFT_mono:
  "(\<And>x. f x \<sqsubseteq> g x) \<Longrightarrow> (FLIFT x. f x) \<sqsubseteq> (FLIFT x. g x)"
by (rule cfun_belowI, case_tac x, simp_all)

lemma cont2cont_flift1 [simp, cont2cont]:
  "\<lbrakk>\<And>y. cont (\<lambda>x. f x y)\<rbrakk> \<Longrightarrow> cont (\<lambda>x. FLIFT y. f x y)"
by (simp add: flift1_def cont2cont_LAM)

end


subsubsection\<open>Tseytin transformation\<close>

theory Tseytin
imports Formulas CNF_Formulas
begin

text\<open>The @{const cnf} transformation clearly has exponential complexity.
If the intention is to use Resolution to decide validity of a formula,
that is clearly a deal-breaker for any practical implementation,
since validity can be decided by brute force in exponential time.
This theory pair shows the Tseytin transformation, a way to transform a formula
while preserving validity.
The @{const cnf} of the transformed formula will have clauses with maximally 3 atoms,
and an amount of clauses linear in the size of the formula,
at the cost of introducing one new atom for each subformula of \<open>F\<close> (i.e. @{term "size F"} many).
\<close>

definition "pair_fun_upd f p \<equiv> (case p of (k,v) \<Rightarrow> fun_upd f k v)"

lemma fold_pair_upd_triv: "A \<notin> fst ` set U \<Longrightarrow> foldl pair_fun_upd F U A = F A"
  by(induction U arbitrary: F; simp)
    (metis fun_upd_apply pair_fun_upd_def prod.simps(2) surjective_pairing)

lemma distinct_pair_update_one: "(k,v) \<in> set U \<Longrightarrow> distinct (map fst U) \<Longrightarrow> foldl pair_fun_upd F U k = v"
  by(induction U arbitrary: F; clarsimp simp add: pair_fun_upd_def fold_pair_upd_triv split: prod.splits)
    (insert fold_pair_upd_triv, fastforce)

lemma distinct_zipunzip: "distinct xs \<Longrightarrow> distinct (map fst (zip xs ys))" by (simp add: distinct_conv_nth)

(* hm, this foldl pair_fun_upd business might have been a bad idea. *)
lemma foldl_pair_fun_upd_map_of: "distinct (map fst U) \<Longrightarrow> foldl pair_fun_upd F U = (\<lambda>k. case map_of U k of Some v \<Rightarrow> v | None \<Rightarrow> F k)"
  by(unfold fun_eq_iff; induction U arbitrary: F; clarsimp split: option.splits simp: pair_fun_upd_def rev_image_eqI)

lemma map_of_map_apsnd: "map_of (map (apsnd t) M) = map_option t \<circ> (map_of M)"
  by(unfold fun_eq_iff comp_def; induction M; simp)

definition biimp (infix "\<^bold>\<leftrightarrow>" 67) where "F \<^bold>\<leftrightarrow> G \<equiv> (F \<^bold>\<rightarrow> G) \<^bold>\<and> (G \<^bold>\<rightarrow> F)"
lemma atoms_biimp[simp]: "atoms (F \<^bold>\<leftrightarrow> G) = atoms F \<union> atoms G"
  unfolding biimp_def by auto
lemma biimp_size[simp]: "size (F \<^bold>\<leftrightarrow> G) = (2 * (size F + size G)) + 3"
  by(simp add: biimp_def)

locale freshstuff =
  fixes fresh :: "'a set \<Rightarrow> 'a"
  assumes isfresh: "finite S \<Longrightarrow> fresh S \<notin> S"
begin

primrec nfresh where
"nfresh S 0 = []" |
"nfresh S (Suc n) = (let f = fresh S in f # nfresh (f \<triangleright> S) n)"

lemma length_nfresh: "length (nfresh S n) = n"
  by(induction n arbitrary: S; simp add: Let_def)

lemma nfresh_isfresh: "finite S \<Longrightarrow> set (nfresh S n) \<inter> S = {}"
  by(induction n arbitrary: S; auto simp add: Let_def isfresh)

lemma nfresh_distinct: "finite S \<Longrightarrow> distinct (nfresh S n)"
  by(induction n arbitrary: S; simp add: Let_def; meson disjoint_iff_not_equal finite_insert insertI1 nfresh_isfresh)

definition "tseytin_assmt F \<equiv> let SF = remdups (subformulae F) in zip (nfresh (atoms F) (length SF)) SF"

lemma tseytin_assmt_distinct: "distinct (map fst (tseytin_assmt F))"
  unfolding tseytin_assmt_def using nfresh_distinct by (simp add: Let_def length_nfresh)

lemma tseytin_assmt_has: "G \<in> set (subformulae F) \<Longrightarrow> \<exists>n. (n,G) \<in> set (tseytin_assmt F)"
proof -
  assume "G \<in> set (subformulae F)"
  then have "\<exists>n. G = subformulae F ! n \<and> n < length (subformulae F)"
    by (simp add: set_conv_nth)
  then have "\<exists>a. (a, G) \<in> set (zip (nfresh (atoms F) (length (subformulae F))) (subformulae F))"
    by (metis (no_types) in_set_zip length_nfresh prod.sel(1) prod.sel(2))
  thus ?thesis by(simp add: tseytin_assmt_def Let_def) (metis fst_conv in_set_conv_nth in_set_zip length_nfresh set_remdups snd_conv)
qed

lemma tseytin_assmt_new_atoms: "(k,l) \<in> set (tseytin_assmt F) \<Longrightarrow> k \<notin> atoms F"
  unfolding tseytin_assmt_def Let_def using nfresh_isfresh by (fastforce dest: set_zip_leftD)

primrec tseytin_tran1 where
"tseytin_tran1 S (Atom k) = [Atom k \<^bold>\<leftrightarrow> S (Atom k)]" |
"tseytin_tran1 S \<bottom> = [\<bottom> \<^bold>\<leftrightarrow> S \<bottom>]" |
"tseytin_tran1 S (Not F) = [S (Not F) \<^bold>\<leftrightarrow> Not (S F)] @ tseytin_tran1 S F" |
"tseytin_tran1 S (And F G) = [S (And F G) \<^bold>\<leftrightarrow> And (S F) (S G)] @ tseytin_tran1 S F @ tseytin_tran1 S G" |
"tseytin_tran1 S (Or F G) = [S (Or F G) \<^bold>\<leftrightarrow> Or (S F) (S G)] @ tseytin_tran1 S F @ tseytin_tran1 S G" |
"tseytin_tran1 S (Imp F G) = [S (Imp F G) \<^bold>\<leftrightarrow> Imp (S F) (S G)] @ tseytin_tran1 S F @ tseytin_tran1 S G"
definition "tseytin_toatom F \<equiv> Atom \<circ> the \<circ> map_of (map (\<lambda>(a,b). (b,a)) (tseytin_assmt F))"
definition "tseytin_tran F \<equiv> \<^bold>\<And>(let S = tseytin_toatom F in S F # tseytin_tran1 S F)"

lemma distinct_snd_tseytin_assmt: "distinct (map snd (tseytin_assmt F))"
  unfolding tseytin_assmt_def by(simp add: Let_def length_nfresh)

lemma tseytin_assmt_backlookup: assumes "J \<in> set (subformulae F)"
  shows "(the (map_of (map (\<lambda>(a, b). (b, a)) (tseytin_assmt F)) J), J) \<in> set (tseytin_assmt F)"
proof -
  have 1: "distinct (map snd M) \<Longrightarrow> J \<in> snd ` set M \<Longrightarrow> (the (map_of (map (\<lambda>(a, b). (b, a)) M) J), J) \<in> set M" for J M
    by(induction M; clarsimp split: prod.splits)
  have 2: "J \<in> set (subformulae F) \<Longrightarrow> J \<in> snd ` set (tseytin_assmt F)" for J using image_iff tseytin_assmt_has by fastforce
  from 1[OF distinct_snd_tseytin_assmt 2, OF assms] show ?thesis .
qed

lemma tseytin_tran_small_clauses: "\<forall>C \<in> cnf (nnf (tseytin_tran F)). card C \<le> 3"
proof -
  have 3: "card S \<le> 2 \<Longrightarrow> card (a \<triangleright> S) \<le> 3" for a S
    by(cases "finite S"; simp add: card_insert_le_m1)
  have 2: "card S \<le> 1 \<Longrightarrow> card (a \<triangleright> S) \<le> 2" for a S
    by(cases "finite S"; simp add: card_insert_le_m1)
  have 1: "card S \<le> 0 \<Longrightarrow> card (a \<triangleright> S) \<le> 1" for a S
    by(cases "finite S"; simp add: card_insert_le_m1)
  have *: "\<lbrakk>G \<in> set (tseytin_tran1 (Atom \<circ> S) F); C \<in> cnf (nnf G)\<rbrakk> \<Longrightarrow> card C \<le> 3" for G C S
    by(induction F arbitrary: G; simp add: biimp_def; (elim disjE exE conjE | intro 1 2 3 | simp)+)
  show ?thesis
    unfolding tseytin_tran_def  tseytin_toatom_def Let_def
    by(clarsimp simp add: cnf_BigAnd nnf_BigAnd comp_assoc *)
qed

lemma tseytin_tran_few_clauses: "card (cnf (nnf (tseytin_tran F))) \<le> 3 * size F + 1"
proof -
  have "size Bot = 1" by simp  (* just a thing to keep in mind. *)
  have ws: "{c \<triangleright> D |D. D = {c1} \<or> D = {c2}} = {{c,c1},{c,c2}}" for c1 c2 c by auto
  have grr: "Suc (card S) \<le> c \<Longrightarrow> card (a \<triangleright> S) \<le> c" for a S c
    by(cases "finite S"; simp add: card_insert_le_m1)
  have *: "card (\<Union>a\<in>set (tseytin_tran1 (Atom \<circ> S) F). cnf (nnf a)) \<le> 3 * size F" for S
    by(induction F; simp add: biimp_def; ((intro grr card_Un_le[THEN le_trans] | simp add: ws)+)?)
  show ?thesis
    unfolding tseytin_tran_def tseytin_toatom_def Let_def
    by(clarsimp simp: nnf_BigAnd cnf_BigAnd; intro grr; simp add: comp_assoc *)
qed

lemma tseytin_tran_new_atom_count: "card (atoms (tseytin_tran F)) \<le> size F + card (atoms F)"
proof -
  have tseytin_tran1_atoms: "H \<in> set (tseytin_tran1 (tseytin_toatom F) G) \<Longrightarrow> G \<in> set (subformulae F) \<Longrightarrow>
    atoms H \<subseteq> atoms F \<union> (\<Union>I \<in> set (subformulae F). atoms (tseytin_toatom F I))" for G H
  proof(induction G arbitrary: H)
    case (Atom k)
    hence "k \<in> atoms F"
      by simp (meson formula.set_intros(1) rev_subsetD subformula_atoms)
    with Atom show ?case by simp blast
  next
    case Bot then show ?case by simp blast
  next
    case (Not G)
    show ?case by(insert Not.prems(1,2);
         frule subformulas_in_subformulas; simp; elim disjE; (elim Not.IH | force))
  next
    case (And G1 G2)
    show ?case by(insert And.prems(1,2);
         frule subformulas_in_subformulas; simp; elim disjE; (elim And.IH; simp | force))
  next
    case (Or G1 G2)
    show ?case by(insert Or.prems(1,2);
         frule subformulas_in_subformulas; simp; elim disjE; (elim Or.IH; simp | force))
  next
    case (Imp G1 G2)
    show ?case by(insert Imp.prems(1,2);
         frule subformulas_in_subformulas; simp; elim disjE; (elim Imp.IH; simp | force))
  qed
  have tseytin_tran1_atoms: "(\<Union>G\<in>set (tseytin_tran1 (tseytin_toatom F) F). atoms G) \<subseteq>
      atoms F \<union> (\<Union>I\<in>set (subformulae F). atoms (tseytin_toatom F I))"
    using tseytin_tran1_atoms[OF _ subformulae_self] by blast
  have 1: "card (atoms (tseytin_tran F)) \<le>
  card (atoms (tseytin_toatom F F) \<union> (\<Union>x\<in>set (tseytin_tran1 (tseytin_toatom F) F). atoms x))"
    unfolding tseytin_tran_def by(simp add: Let_def tseytin_tran1_atoms)
  have 2: "atoms (tseytin_toatom F F) \<union> (\<Union>x\<in>set (tseytin_tran1 (tseytin_toatom F) F). atoms x) \<subseteq>
     (atoms F \<union> (\<Union>I\<in>set (subformulae F). atoms (tseytin_toatom F I)))"
    using tseytin_tran1_atoms by blast
  have twofin: "finite (atoms F \<union> (\<Union>I\<in>set (subformulae F). atoms (tseytin_toatom F I)))" by simp
  have card_subformulae: "card (set (subformulae F)) \<le> size F" using length_subformulae by (metis card_length)
  have card_singleton_union: "finite S \<Longrightarrow> card (\<Union>x\<in>S. {f x}) \<le> card S" for f S
    by(induction S rule: finite_induct; simp add: card_insert_if)
  have 3: "card (\<Union>I\<in>set (subformulae F). atoms (tseytin_toatom F I)) \<le> size F"
    unfolding tseytin_toatom_def using le_trans[OF card_singleton_union card_subformulae]
    by simp fast
  have 4: "card (atoms (tseytin_tran F)) \<le> card (atoms F) + card (\<Union>f\<in>set (subformulae F). atoms (tseytin_toatom F f))"
    using le_trans[OF 1 card_mono[OF twofin 2]] card_Un_le le_trans by blast
  show ?thesis using 3 4 by linarith
qed

end

definition "freshnat S \<equiv>  Suc (Max (0 \<triangleright> S))"
primrec nfresh_natcode where
"nfresh_natcode S 0 = []" |
"nfresh_natcode S (Suc n) = (let f = freshnat S in f # nfresh_natcode (f \<triangleright> S) n)"
interpretation freshnats: freshstuff freshnat unfolding freshnat_def by standard (meson Max_ge Suc_n_not_le_n finite_insert insertCI)
(* interpreting the locale is easy. making it executable\<dots> not so. *)
lemma [code_unfold]: "freshnats.nfresh = nfresh_natcode"
proof -
  have "freshnats.nfresh S n  = nfresh_natcode S n" for S n by(induction n arbitrary: S; simp)
  thus ?thesis by auto
qed
lemmas freshnats_code[code_unfold] = freshnats.tseytin_tran_def freshnats.tseytin_toatom_def freshnats.tseytin_assmt_def freshnats.nfresh.simps

lemma "freshnats.tseytin_tran (Atom 0 \<^bold>\<rightarrow> (\<^bold>\<not> (Atom 1))) = \<^bold>\<And>[
  Atom 2,
  Atom 2 \<^bold>\<leftrightarrow> Atom 3 \<^bold>\<rightarrow> Atom 4,
  Atom 0 \<^bold>\<leftrightarrow> Atom 3,
  Atom 4 \<^bold>\<leftrightarrow> \<^bold>\<not> (Atom 5),
  Atom 1 \<^bold>\<leftrightarrow> Atom 5
]" (is "?l = ?r")
proof -
  have "cnf (nnf ?r) =
    {{Pos 2},
     {Neg 4, Pos 2}, {Pos 3, Pos 2}, {Neg 2, Neg 3, Pos 4},
     {Neg 3, Pos 0}, {Neg 0, Pos 3},
     {Pos 5, Pos 4}, {Neg 4, Neg 5},
     {Neg 5, Pos 1}, {Neg 1, Pos 5}}" by eval
  have ?thesis by eval
  show ?thesis by code_simp
qed

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory WPTutorial
imports "Refine.Bits_R"
begin

text \<open>
This is a tutorial on the use of the various Hoare mechanisms developed
for the L4.verified project. We import Bits_R above, which is a compromise
between the twin goals of getting the Hoare setup from L4.verified and not
importing existing properties. It's probably best to work from a prebuilt
Refine Isabelle image which includes Bits_R.
\<close>

text \<open>The point of our apparatus is to prove Hoare triples. These are a
triple of a precondition, function, and postcondition. In our state-monadic
world, the precondition is a function of the state, and the postcondition
is a function of the return value and the state. In example 1 below,
the precondition doesn't impose any restriction on the state, and the
postcondition only requires that the return value be the obvious one.\<close>

text \<open>The weakest precondition tool, wp, attempts to construct the
weakest precondition for a given postcondition. Use wp (with the command
"apply wp") to solve example 1\<close>

lemma example_1:
  "\<lbrace>\<lambda>s. True\<rbrace> return 1 \<lbrace>\<lambda>rv s. rv = 1\<rbrace>"
  apply wp
  apply simp
  done

text \<open>The wp tool works in reverse order (from postcondition to weakest
precondition, rather than from precondition to strongest postcondition).
It stops when it encounters a postcondition/function pair it doesn't
know any rules for. Try example 2 below, noting where wp gets stuck.

The wp method already knows how to handle most monadic operations
(liftE, catch, assert, when, if-then-else, etc) but there are some
exceptions. One is the split operator, which hides behind Isabelle syntax
that looks like (\<lambda>(x, y). blah), {(x, y). blah}, (\<forall>(x, y) \<in> S. blah).
Solve the problem by unfolding it with (simp add: split_def).

The intermediate precondition seen when wp stops is a schematic variable.
The wp tool uses Isabelle's underlying unification mechanism to set the
precondition as it goes. This usually works well, but there are some
problems, especially with tuples. Note the strange behaviour if we use
clarsimp instead of (simp add: split_def) to deal with the split constant.
The root cause of this strange behaviour is that the unification mechanism
does not know how to construct a ?P such that "?P (a, b) = a". This is
annoying, since it means that clarsimp/clarify/safe must frequently be
avoided.
\<close>

lemma example_2:
  "\<lbrace>\<lambda>s. s = [(True, False), (False, True)]\<rbrace> do
     v \<leftarrow> gets length;
     (x, y) \<leftarrow> gets hd;
     return x
   od \<lbrace>\<lambda>rv s. rv\<rbrace>"
  apply wp
     apply (simp add: split_def)
     apply wp+
  apply simp
  done

text \<open>
An additional annoyance to the clarsimp/tuple issue described above is
the splitter. The wp tool is designed to work on a hoare triple with a
schematic precondition. Note how the simplifier splits the problem
in two because it contains an if constant. Delete the split
rule from the simpset with (simp split del: if_split) to avoid this
issue and see where wp gets stuck.

We still need to deal with the if constant. In this (somewhat contrived)
example we can give the simplifier the rule if_apply_def2 to make
progress.

Note that wp can deal with a function it knows nothing about if
the postcondition is constant in the return value and state.
\<close>

lemma example_3:
  "\<lbrace>\<lambda>s. s = [False, True]\<rbrace> do
     x \<leftarrow> gets hd;
     possible_state_change_that_isnt_defined;
     y \<leftarrow> gets (if x then \<bottom> else \<top>);
     return $ y \<and> \<not> x
   od \<lbrace>\<lambda>rv s. rv\<rbrace>"
  apply wp
    apply (simp add: if_apply_def2 split del: if_split)
    apply wp+
  apply simp
  done

text \<open>Let's make this more interesting by introducing some functions
from the abstract specification. The set_endpoint function (an abbreviation
for the function set_simple_ko) is used to set the contents of an endpoint
object somewhere in the kernel object heap (kheap). The cap derivation
tree (cdt) lives in an entirely different field of the state to the kheap,
so this fact about it should be unchanged by the endpoint update.
Solve example 4 - you'll have to unfold enough definitions that wp knows
what to do.\<close>

lemma example_4:
  "\<lbrace>\<lambda>s. cdt s (42, [True, False]) = None\<rbrace>
      set_endpoint ptr Structures_A.IdleEP
   \<lbrace>\<lambda>rv s. cdt s (42, [True, False]) = None\<rbrace>"
  apply (simp add: set_simple_ko_def set_object_def get_object_def)
  apply wp
  apply clarsimp
  done

text \<open>
Example 4 proved that a property about the cdt was preserved from
before set_endpoint to after. This preservation property is true for
any property that just talks about the cdt. Example 5 rephrases
example 4 in this style. Get used to this style of Hoare triple,
it is very common in our proofs.
\<close>

lemma example_5:
  "\<lbrace>\<lambda>s. P (cdt s)\<rbrace>
      set_endpoint ptr Structures_A.IdleEP
   \<lbrace>\<lambda>rv s. P (cdt s)\<rbrace>"
  apply (simp add: set_simple_ko_def set_object_def get_object_def)
  apply wp
  apply clarsimp
  done

text \<open>
The set_cap function from the abstract specification is not much different
to set_endpoint. However, caps can live within CSpace objects or within
TCBs, and the set_cap function handles this issue with a case division.

The wp tool doesn't know anything about how to deal with case statements.
In addition to the tricks we've learned already, use the wpc tool to break
up the case statement into components so that wp can deal with it to solve
example 6.
\<close>

lemma example_6:
  "\<lbrace>\<lambda>s. P (cdt s)\<rbrace>
     set_cap cap ptr
   \<lbrace>\<lambda>rv s. P (cdt s)\<rbrace>"
  apply (simp add: set_cap_def split_def set_object_def
                   get_object_def)
  apply (wp | wpc)+
  apply simp
  done

text \<open>
The wp method can be given additional arguments which are theorems to use
as summaries. Solve example 7 by supplying example 6 as a rule to
use with (wp example_6).
\<close>

lemma example_7:
  "\<lbrace>\<lambda>s. cdt s ptr' = None\<rbrace> do
     set_cap cap.NullCap ptr;
     v \<leftarrow> gets (\<lambda>s. cdt s ptr);
     assert (v = None);
     set_cap cap.NullCap ptr';
     set_cap cap.IRQControlCap ptr';
     return True
   od \<lbrace>\<lambda>rv s. cdt s ptr = None \<and> cdt s ptr' = None\<rbrace>"
  apply (wp example_6)
  apply simp
  done

text \<open>
There isn't a good reason not to use example_6 whenever possible, so we can
declare example_6 a member of the wp rule set by changing its proof site to
"lemma example_6[wp]:", by doing "declare example_6[wp]", or by putting it
in a group of lemmas declared wp with "lemmas foo[wp] = example_6".
Pick one of those options and remove the manual reference to example_6 from
the proof of example_7.
\<close>

text \<open>
These preservation Hoare triples are often easy to prove and apply, so much
of the effort is in typing them all out. To speed this up we have the crunch
tool. Let's prove that setup_reply_master and set_endpoint don't change
another field of the state, machine_state. I've typed out the required
crunch command below. Let's explain the bits. The naming scheme
"machine_state_preserved:" sets a common suffix for all the lemmas
proved. Just like with lemma names, we could add the theorems to the wp set
with "machine_state_preserved[wp]:". What follows is a list of functions.
The crunch tool also descends through the call graph of functions, so it
proves a rule about set_cap because setup_reply_master calls it. The last
argument is the term to appear in the precondition and postcondition.

The final, optional bit of the crunch syntax is a group of modifiers, which
go between the parentheses inserted below. The crunch command doesn't
currently work. We need to provide some additional simp and wp rules
with syntax like (simp: some rules wp: some rules). If you look at the way
crunch failed, you'll spot which simp rule we need to add to make some
progress.

But not much more progress. To get through set_endpoint, we need to deal
with a slightly complex postcondition to get_object, one which incorporates
an assertion about its return value. We can solve this problem by simply
throwing the extra assumption away - supplying the wp rule hoare_drop_imps
does this. There are standard sets of simp and wp rules which are frequently
helpful to crunch, crunch_simps and crunch_wps, which contain the rules we
added here.

Finally, this proof needs to simplify the predicates underneath an
@{text "if"}, which uses a congruence rule. The crunch command doesn't provide
syntax for this and more rarely used simp and wp modifiers. We can still supply
the necessary rules by putting the crunch command in a context block that declares
those rules.
\<close>

context
notes if_cong[cong]
begin

crunch machine_state_preserved:
  setup_reply_master, set_simple_ko
    "\<lambda>s. P (machine_state s)"
  (simp: split_def wp: crunch_wps)

end

end


theory Launchbury
imports Terms Substitution
begin

subsubsection \<open>The natural semantics\<close>

text \<open>This is the semantics as in \<^cite>\<open>"launchbury"\<close>, with two differences:
\begin{itemize}
\item Explicit freshness requirements for bound variables in the application and the Let rule.
\item An additional parameter that stores variables that have to be avoided, but do not occur
in the judgement otherwise, follwing \<^cite>\<open>"sestoft"\<close>.
\end{itemize}
\<close>

inductive
  reds :: "heap \<Rightarrow> exp \<Rightarrow> var list \<Rightarrow> heap \<Rightarrow> exp \<Rightarrow> bool"
  ("_ : _ \<Down>\<^bsub>_\<^esub> _ : _" [50,50,50,50] 50)
where
  Lambda:
    "\<Gamma> : (Lam [x]. e) \<Down>\<^bsub>L\<^esub> \<Gamma> : (Lam [x]. e)"
 | Application: "\<lbrakk>
    atom y \<sharp> (\<Gamma>,e,x,L,\<Delta>,\<Theta>,z) ;
    \<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : (Lam [y]. e');
    \<Delta> : e'[y ::= x] \<Down>\<^bsub>L\<^esub> \<Theta> : z
  \<rbrakk>  \<Longrightarrow>
    \<Gamma> : App e x \<Down>\<^bsub>L\<^esub> \<Theta> : z"
 | Variable: "\<lbrakk>
    map_of \<Gamma> x = Some e; delete x \<Gamma> : e \<Down>\<^bsub>x#L\<^esub> \<Delta> : z
  \<rbrakk> \<Longrightarrow>
    \<Gamma> : Var x \<Down>\<^bsub>L\<^esub> (x, z) # \<Delta> : z"
 | Let: "\<lbrakk>
    atom ` domA \<Delta> \<sharp>* (\<Gamma>, L);
    \<Delta> @ \<Gamma> : body \<Down>\<^bsub>L\<^esub> \<Theta> : z
  \<rbrakk> \<Longrightarrow>
    \<Gamma> : Let \<Delta> body \<Down>\<^bsub>L\<^esub> \<Theta> : z"
 | Bool:
    "\<Gamma> : Bool b \<Down>\<^bsub>L\<^esub> \<Gamma> : Bool b"
 | IfThenElse: "\<lbrakk>
    \<Gamma> : scrut \<Down>\<^bsub>L\<^esub> \<Delta> : (Bool b);
    \<Delta> : (if b then e\<^sub>1 else e\<^sub>2) \<Down>\<^bsub>L\<^esub> \<Theta> : z
  \<rbrakk>  \<Longrightarrow>
    \<Gamma> : (scrut ? e\<^sub>1 : e\<^sub>2) \<Down>\<^bsub>L\<^esub> \<Theta> : z"

equivariance reds

nominal_inductive reds
  avoids Application: "y"
  by (auto simp add: fresh_star_def fresh_Pair)

subsubsection \<open>Example evaluations\<close>

lemma eval_test:
  "[] : (Let [(x, Lam [y]. Var y)] (Var x)) \<Down>\<^bsub>[]\<^esub> [(x, Lam [y]. Var y)] : (Lam [y]. Var y)"
apply(auto intro!: Lambda Application Variable Let
 simp add: fresh_Pair fresh_Cons fresh_Nil fresh_star_def)
done

lemma eval_test2:
  "y \<noteq> x \<Longrightarrow> n \<noteq> y \<Longrightarrow> n \<noteq> x \<Longrightarrow>[] : (Let [(x, Lam [y]. Var y)] (App (Var x) x)) \<Down>\<^bsub>[]\<^esub> [(x, Lam [y]. Var y)] : (Lam [y]. Var y)"
  by (auto intro!: Lambda Application Variable Let simp add: fresh_Pair fresh_at_base fresh_Cons fresh_Nil fresh_star_def pure_fresh)

subsubsection \<open>Better introduction rules\<close>

text \<open>
This variant do not require freshness.
\<close>

lemma reds_ApplicationI:
  assumes "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : Lam [y]. e'"
  assumes "\<Delta> : e'[y::=x] \<Down>\<^bsub>L\<^esub> \<Theta> : z"
  shows "\<Gamma> : App e x \<Down>\<^bsub>L\<^esub> \<Theta> : z"
proof-
  obtain y' :: var where "atom y' \<sharp> (\<Gamma>, e, x, L, \<Delta>, \<Theta>, z, e')" by (rule obtain_fresh)

  have a: "Lam [y']. ((y' \<leftrightarrow> y) \<bullet> e') = Lam [y]. e'"
    using \<open>atom y' \<sharp> _\<close>
    by (auto simp add: Abs1_eq_iff fresh_Pair fresh_at_base)

  have b: "((y' \<leftrightarrow> y) \<bullet> e')[y'::=x] = e'[y::=x]"
  proof(cases "x = y")
    case True
    have "atom y' \<sharp> e'" using \<open>atom y' \<sharp> _\<close> by simp
    thus ?thesis
      by (simp add: True subst_swap_same  subst_subst_back)
  next
    case False
    hence "atom y \<sharp> x" by simp

    have [simp]: "(y' \<leftrightarrow> y) \<bullet> x = x" using \<open>atom y \<sharp> _\<close>  \<open>atom y' \<sharp> _\<close>
        by (simp add: flip_fresh_fresh fresh_Pair fresh_at_base)

    have "((y' \<leftrightarrow> y) \<bullet> e')[y'::=x] = (y' \<leftrightarrow> y) \<bullet> (e'[y::=x])" by simp
    also have "\<dots> = e'[y::=x]"
      using \<open>atom y \<sharp> _\<close>  \<open>atom y' \<sharp> _\<close>
      by (simp add: flip_fresh_fresh fresh_Pair fresh_at_base subst_pres_fresh)
    finally
    show ?thesis.
  qed
  have "atom y' \<sharp> (\<Gamma>, e, x, L, \<Delta>, \<Theta>, z)" using  \<open>atom y' \<sharp> _\<close> by (simp add: fresh_Pair)
  from this assms[folded a b]
  show ?thesis ..
qed

lemma reds_SmartLet: "\<lbrakk>
    atom ` domA \<Delta> \<sharp>* (\<Gamma>, L);
    \<Delta> @ \<Gamma> : body \<Down>\<^bsub>L\<^esub> \<Theta> : z
  \<rbrakk> \<Longrightarrow>
    \<Gamma> : SmartLet \<Delta> body \<Down>\<^bsub>L\<^esub> \<Theta> : z"
unfolding SmartLet_def
by (auto intro: reds.Let)

text \<open>
A single rule for values
\<close>
lemma reds_isValI:
  "isVal z \<Longrightarrow> \<Gamma> : z \<Down>\<^bsub>L\<^esub> \<Gamma> : z"
by (cases z rule:isVal.cases) (auto intro: reds.intros)

subsubsection \<open>Properties of the semantics\<close>

text \<open>
Heap entries are never removed.
\<close>

lemma reds_doesnt_forget:
  "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z \<Longrightarrow> domA \<Gamma> \<subseteq> domA \<Delta>"
by(induct rule: reds.induct) auto

text \<open>
Live variables are not added to the heap.
\<close>

lemma reds_avoids_live':
 assumes "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z"
 shows "(domA \<Delta> - domA \<Gamma>) \<inter> set L = {}"
using assms
by(induct rule:reds.induct)
  (auto dest: map_of_domAD fresh_distinct_list simp add: fresh_star_Pair)

lemma reds_avoids_live:
  "\<lbrakk> \<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z;
   x \<in> set L;
   x \<notin> domA \<Gamma>
  \<rbrakk> \<Longrightarrow> x \<notin> domA \<Delta>"
using reds_avoids_live' by blast

text \<open>
Fresh variables either stay fresh or are added to the heap.
\<close>

lemma reds_fresh:" \<lbrakk> \<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z;
   atom (x::var) \<sharp> (\<Gamma>, e)
  \<rbrakk> \<Longrightarrow> atom x \<sharp> (\<Delta>, z) \<or> x \<in> (domA \<Delta> - set L)"
proof(induct rule: reds.induct)
case (Lambda \<Gamma> x e) thus ?case by auto
next
case (Application y \<Gamma> e x' L \<Delta> \<Theta> z e')
  hence "atom x \<sharp> (\<Delta>, Lam [y]. e') \<or> x \<in> domA \<Delta> - set (x' # L)" by (auto simp add: fresh_Pair)

  thus ?case
  proof
    assume  "atom x \<sharp> (\<Delta>, Lam [y]. e')"
    hence "atom x \<sharp> e'[y ::= x']"
      using Application.prems
      by (auto intro: subst_pres_fresh simp add: fresh_Pair)
    thus ?thesis using Application.hyps(5) \<open>atom x \<sharp> (\<Delta>, Lam [y]. e')\<close> by auto
  next
    assume "x \<in> domA \<Delta> - set (x' # L)"
    thus ?thesis using reds_doesnt_forget[OF Application.hyps(4)] by auto
  qed
next

case(Variable \<Gamma> v e L \<Delta> z)
  have "atom x \<sharp> \<Gamma>" and "atom x \<sharp> v" using Variable.prems(1) by (auto simp add: fresh_Pair)
  from fresh_delete[OF this(1)]
  have "atom x \<sharp> delete v \<Gamma>".
  moreover
  have "v \<in> domA \<Gamma>" using Variable.hyps(1) by (metis domA_from_set map_of_SomeD)
  from fresh_map_of[OF this  \<open>atom x \<sharp> \<Gamma>\<close>]
  have "atom x \<sharp> the (map_of \<Gamma> v)".
  hence "atom x \<sharp> e" using \<open>map_of \<Gamma> v = Some e\<close> by simp
  ultimately
  have "atom x \<sharp> (\<Delta>, z) \<or> x \<in> domA \<Delta> - set (v # L)"  using Variable.hyps(3) by (auto simp add: fresh_Pair)
  thus ?case using \<open>atom x \<sharp> v\<close> by (auto simp add: fresh_Pair fresh_Cons fresh_at_base)
next

case (Bool \<Gamma> b L)
  thus ?case by auto
next

case (IfThenElse \<Gamma> scrut L \<Delta> b e\<^sub>1 e\<^sub>2 \<Theta> z)
  from \<open>atom x \<sharp> (\<Gamma>, scrut ? e\<^sub>1 : e\<^sub>2)\<close>
  have "atom x \<sharp> (\<Gamma>, scrut)" and "atom x \<sharp> (e\<^sub>1, e\<^sub>2)" by (auto simp add: fresh_Pair)
  from IfThenElse.hyps(2)[OF this(1)]
  show ?case
  proof
    assume "atom x \<sharp> (\<Delta>, Bool b)" with \<open>atom x \<sharp> (e\<^sub>1, e\<^sub>2)\<close>
    have "atom x \<sharp> (\<Delta>, if b then e\<^sub>1 else e\<^sub>2)" by auto
    from IfThenElse.hyps(4)[OF this]
    show ?thesis.
  next
    assume "x \<in> domA \<Delta> - set L"
    with reds_doesnt_forget[OF \<open>\<Delta> : (if b then e\<^sub>1 else e\<^sub>2) \<Down>\<^bsub>L\<^esub> \<Theta> : z\<close>]
    show ?thesis by auto
  qed
next

case (Let \<Delta> \<Gamma> L body \<Theta> z)
  show ?case
  proof (cases "x \<in> domA \<Delta>")
    case False
      hence "atom x \<sharp> \<Delta>" using Let.prems by(auto simp add: fresh_Pair)
      show ?thesis
        apply(rule Let.hyps(3))
        using Let.prems \<open>atom x \<sharp> \<Delta>\<close> False
        by (auto simp add: fresh_Pair fresh_append)
  next
    case True
      hence "x \<notin> set L"
        using Let(1)
        by (metis fresh_PairD(2) fresh_star_def image_eqI set_not_fresh)
      with True
      show ?thesis
      using reds_doesnt_forget[OF Let.hyps(2)] by auto
  qed
qed

lemma reds_fresh_fv: "\<lbrakk> \<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z;
   x \<in> fv (\<Delta>, z) \<and> (x \<notin> domA \<Delta> \<or>  x \<in> set L)
  \<rbrakk> \<Longrightarrow> x \<in> fv (\<Gamma>, e)"
using reds_fresh
unfolding fv_def fresh_def
by blast

lemma new_free_vars_on_heap:
  assumes "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z"
  shows "fv (\<Delta>, z) - domA \<Delta> \<subseteq> fv (\<Gamma>, e) - domA \<Gamma>"
using reds_fresh_fv[OF assms(1)] reds_doesnt_forget[OF assms(1)] by auto

lemma reds_pres_closed:
  assumes "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z"
  and     "fv (\<Gamma>, e) \<subseteq> set L \<union> domA \<Gamma>"
  shows   "fv (\<Delta>, z) \<subseteq> set L \<union> domA \<Delta>"
using new_free_vars_on_heap[OF assms(1)] assms(2) by auto

text \<open>
Reducing the set of variables to avoid is always possible.
\<close>

lemma reds_smaller_L: "\<lbrakk> \<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z;
   set L' \<subseteq> set L
  \<rbrakk> \<Longrightarrow> \<Gamma> : e \<Down>\<^bsub>L'\<^esub> \<Delta> : z"
proof(nominal_induct avoiding : L' rule: reds.strong_induct)
case (Lambda \<Gamma> x e L L')
  show ?case
    by (rule reds.Lambda)
next
case (Application y \<Gamma> e xa L \<Delta> \<Theta> z e' L')
  from Application.hyps(10)[OF Application.prems] Application.hyps(12)[OF Application.prems]
  show ?case
    by (rule reds_ApplicationI)
next
case (Variable \<Gamma> xa e L \<Delta> z L')
  have "set (xa # L') \<subseteq> set (xa # L)"
    using Variable.prems by auto
  thus ?case
    by (rule reds.Variable[OF Variable(1) Variable.hyps(3)])
next
case (Bool b)
  show ?case..
next
case (IfThenElse \<Gamma> scrut L \<Delta> b e\<^sub>1 e\<^sub>2 \<Theta> z L')
  thus ?case by (metis  reds.IfThenElse)
next
case (Let \<Delta> \<Gamma>  L body \<Theta> z L')
  have "atom ` domA \<Delta> \<sharp>* (\<Gamma>, L')"
    using Let(1-3) Let.prems
    by (auto simp add: fresh_star_Pair  fresh_star_set_subset)
  thus ?case
    by (rule reds.Let[OF _ Let.hyps(4)[OF Let.prems]])
qed

text \<open>Things are evaluated to a lambda expression, and the variable can be freely chose.\<close>

lemma result_evaluated:
  "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z \<Longrightarrow> isVal z"
by (induct \<Gamma> e L \<Delta> z rule:reds.induct) (auto dest: reds_doesnt_forget)

lemma result_evaluated_fresh:
  assumes "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z"
  obtains y e'
  where "z = (Lam [y]. e')" and "atom y \<sharp> (c::'a::fs)" | b where "z = Bool b"
proof-
  from assms
  have "isVal z" by (rule result_evaluated)
  hence "(\<exists> y e'. z = Lam [y]. e' \<and> atom y \<sharp> c) \<or> (\<exists> b. z = Bool b)"
    by (nominal_induct z avoiding: c rule:exp_strong_induct) auto
  thus thesis using that by blast
qed

end


(*
    File:        SndLBeta.thy
    Time-stamp:  <2016-01-06T17:03:46Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: ZF (of Isabelle2015)
*)

theory SndLBeta imports LBeta begin

consts

  SndLBeta1 :: i

inductive
  domains "SndLBeta1" <= "LTerm * LTerm"

  intros
    baseI: "LFreeForIn(B, x, A) ==>
            <LApp(LLam(x, A), B), Lsubst(A, x, B)>: SndLBeta1"

    LLamI: "[| <M, M'>: SndLBeta1;  x: LVariable |] ==>
            <LLam(x, M), LLam(x, M')>: SndLBeta1"

    LAppI1: "[| <A, A'>: SndLBeta1;  B: LTerm |] ==>
             <LApp(A, B), LApp(A', B)>: SndLBeta1"

    LAppI2: "[| <B, B'>: SndLBeta1;  A: LTerm |] ==>
             <LApp(A, B), LApp(A, B')>: SndLBeta1"

  type_intros LTerm.intros SigmaI nat_0I Lsubst_type
  type_elims SigmaE2 LFreeForInE

lemma SndLBeta1_LBeta1:
  "<M, N>: SndLBeta1 ==> LBeta1(M, N)"
apply (erule SndLBeta1.induct)
apply (assumption | rule LBeta1_baseI LBeta1_LLamI
         LBeta1_LAppI1 LBeta1_LAppI2)+
done

lemma LBeta1_SndLBeta1:
  assumes prem: "LBeta1(M, N)"
  shows "<M, N>: SndLBeta1"
apply (rule prem [THEN rev_mp])
apply (rule prem [THEN LBeta1_type2, THEN [2] bspec])
apply (rule prem [THEN LBeta1_type1, THEN LTerm.induct])
apply (safe elim!: LBeta1_LTermEs LTerm_typeEs)
apply (drule_tac [4] bspec [THEN mp], erule_tac [4] asm_rl,
       erule_tac [4] asm_rl)
apply (drule_tac [3] bspec [THEN mp], erule_tac [3] asm_rl,
       erule_tac [3] asm_rl)
apply (drule_tac [1] bspec [THEN mp], erule_tac [1] asm_rl,
       erule_tac [1] asm_rl)
apply (assumption | erule SndLBeta1.intros)+
done

lemma SndLBeta1_iff_LBeta1:
  "<M, N> : SndLBeta1 <-> LBeta1(M, N)"
apply (rule iffI)
apply (erule SndLBeta1_LBeta1)
apply (erule LBeta1_SndLBeta1)
done

end


(*
 * @TAG(OTHER_LGPL)
 *)

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

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

Copyright (C) 2006-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 for Total Correctness *}

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

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

lemma "\<Gamma>\<turnstile>\<^sub>t \<lbrace>\<acute>M = 0 \<and> \<acute>S = 0\<rbrace>
          WHILE \<acute>M \<noteq> a
          INV \<lbrace>\<acute>S = \<acute>M * b \<and> \<acute>M \<le> a\<rbrace>
          VAR MEASURE a - \<acute>M
          DO \<acute>S :== \<acute>S + b;; \<acute>M :== \<acute>M + 1 OD
          \<lbrace>\<acute>S = a * b\<rbrace>"
apply vcg
apply (auto)
done

lemma "\<Gamma>\<turnstile>\<^sub>t \<lbrace>\<acute>I \<le> 3\<rbrace>
     WHILE \<acute>I < 10 INV \<lbrace>\<acute>I\<le> 10\<rbrace> VAR MEASURE 10 - \<acute>I
     DO
       \<acute>I :== \<acute>I + 1
     OD
  \<lbrace>\<acute>I = 10\<rbrace>"
apply vcg
apply auto
done

text {* Total correctness of a nested loop. In the inner loop we have to
express that the loop variable of the outer loop is not changed. We use
@{text "FIX"} to introduce a new logical variable
*}

lemma "\<Gamma>\<turnstile>\<^sub>t \<lbrace>\<acute>M=0 \<and> \<acute>N=0\<rbrace>
      WHILE (\<acute>M < i)
      INV \<lbrace>\<acute>M \<le> i \<and> (\<acute>M \<noteq> 0 \<longrightarrow> \<acute>N = j) \<and> \<acute>N \<le> j\<rbrace>
      VAR MEASURE (i - \<acute>M)
      DO
         \<acute>N :== 0;;
         WHILE (\<acute>N < j)
         FIX m.
         INV \<lbrace>\<acute>M=m \<and> \<acute>N \<le> j\<rbrace>
         VAR MEASURE (j - \<acute>N)
         DO
           \<acute>N :== \<acute>N + 1
         OD;;
       \<acute>M :== \<acute>M + 1
       OD
       \<lbrace>\<acute>M=i \<and> (\<acute>M\<noteq>0 \<longrightarrow> \<acute>N=j)\<rbrace>"
apply vcg
apply simp_all
apply arith
done

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

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

lemma (in Fac_impl) Fac_spec:
  shows "\<forall>n. \<Gamma>\<turnstile>\<^sub>t \<lbrace>\<acute>N=n\<rbrace> \<acute>R :== PROC Fac(\<acute>N) \<lbrace>\<acute>R = fac n\<rbrace>"
  apply (hoare_rule HoareTotal.ProcRec1 [where r="measure (\<lambda>(s,p). \<^bsup>s\<^esup>N)"])
  apply vcg
  apply simp
  done

procedures
  p91(R,N | R) = "IF 100 < \<acute>N THEN \<acute>R :== \<acute>N - 10
                      ELSE \<acute>R :== CALL p91(\<acute>R,\<acute>N+11);;
                           \<acute>R :== CALL p91(\<acute>R,\<acute>R) FI"

  p91_spec: "\<forall>n. \<Gamma>\<turnstile>\<^sub>t \<lbrace>\<acute>N=n\<rbrace> \<acute>R :== PROC p91(\<acute>R,\<acute>N)
                        \<lbrace>if 100 < n then \<acute>R = n - 10 else \<acute>R = 91\<rbrace>,{}"

lemma (in p91_impl) p91_spec:
  shows "\<forall>\<sigma>. \<Gamma>\<turnstile>\<^sub>t {\<sigma>} \<acute>R :== PROC p91(\<acute>R,\<acute>N)
                       \<lbrace>if 100 < \<^bsup>\<sigma>\<^esup>N then \<acute>R = \<^bsup>\<sigma>\<^esup>N - 10 else \<acute>R = 91\<rbrace>,{}"
  apply (hoare_rule HoareTotal.ProcRec1 [where r="measure (\<lambda>(s,p). 101 - \<^bsup>s\<^esup>N)"])
  apply vcg
  apply clarsimp
  apply arith
  done

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"

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"

lemma (in append_impl)
  shows
   "\<forall>\<sigma> Ps Qs. \<Gamma>\<turnstile>\<^sub>t
      \<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 HoareTotal.ProcRec1
            [where r="measure (\<lambda>(s,p). length (list \<^bsup>s\<^esup>p \<^bsup>s\<^esup>next))"])
   apply vcg
   apply (fastforce  simp add: List_list)
   done

lemma (in append_impl)
  shows
   "\<forall>\<sigma> Ps Qs. \<Gamma>\<turnstile>\<^sub>t
      \<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 HoareTotal.ProcRec1
            [where r="measure (\<lambda>(s,p). length (list \<^bsup>s\<^esup>p \<^bsup>s\<^esup>next))"])
   apply vcg
   apply (fastforce  simp add: List_list)
   done

lemma (in append_impl)
  shows
  append_spec:
   "\<forall>\<sigma>. \<Gamma>\<turnstile>\<^sub>t ({\<sigma>} \<inter> \<lbrace>islist \<acute>p \<acute>next\<rbrace>)  \<acute>p :== PROC append(\<acute>p,\<acute>q)
    \<lbrace>\<forall>Ps Qs. List \<^bsup>\<sigma>\<^esup>p \<^bsup>\<sigma>\<^esup>next Ps \<and>  List \<^bsup>\<sigma>\<^esup>q \<^bsup>\<sigma>\<^esup>next Qs \<and> set Ps \<inter> set Qs = {}
     \<longrightarrow>
     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 HoareTotal.ProcRec1
            [where r="measure (\<lambda>(s,p). length (list \<^bsup>s\<^esup>p \<^bsup>s\<^esup>next))"])
   apply vcg
   apply fastforce
   done

lemma "\<Gamma>\<turnstile>\<lbrace>List \<acute>p \<acute>next Ps\<rbrace>
       \<acute>q :== Null;;
       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\<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;;
       \<acute>p :==\<acute>q
       \<lbrace>List \<acute>p \<acute>next (rev Ps)\<rbrace> "
apply vcg
apply   clarsimp
apply  clarsimp
apply force
apply simp
done

lemma conjI2: "\<lbrakk>Q; Q \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P \<and> Q"
by blast

procedures Rev(p|p) =
      "\<acute>q :== Null;;
       WHILE \<acute>p \<noteq> Null
       DO
         \<acute>r :== \<acute>p;; \<lbrace>\<acute>p \<noteq> Null\<rbrace>\<longmapsto> \<acute>p :== \<acute>p\<rightarrow>\<acute>next;;
         \<lbrace>\<acute>r \<noteq> Null\<rbrace>\<longmapsto> \<acute>r\<rightarrow>\<acute>next :== \<acute>q;; \<acute>q :== \<acute>r
       OD;;
       \<acute>p :==\<acute>q"
 Rev_spec:
  "\<forall>Ps. \<Gamma>\<turnstile>\<^sub>t \<lbrace>List \<acute>p \<acute>next Ps\<rbrace> \<acute>p :== PROC Rev(\<acute>p) \<lbrace>List \<acute>p \<acute>next (rev Ps)\<rbrace>"
 Rev_modifies:
  "\<forall>\<sigma>. \<Gamma>\<turnstile>\<^bsub>/UNIV\<^esub> {\<sigma>} \<acute>p :== PROC Rev(\<acute>p) {t. t may_only_modify_globals \<sigma> in [next]}"

text {* We only need partial correctness of modifies clause!*}

lemma upd_hd_next:
  assumes p_ps: "List p next (p#ps)"
  shows "List (next p) (next(p := q)) ps"
proof -
  from p_ps
  have "p \<notin> set ps"
    by auto
  with p_ps show ?thesis
    by simp
qed

lemma (in Rev_impl) shows
 Rev_spec:
  "\<forall>Ps. \<Gamma>\<turnstile>\<^sub>t \<lbrace>List \<acute>p \<acute>next Ps\<rbrace> \<acute>p :== PROC Rev(\<acute>p) \<lbrace>List \<acute>p \<acute>next (rev Ps)\<rbrace>"
apply (hoare_rule HoareTotal.ProcNoRec1)
apply (hoare_rule anno =
       "\<acute>q :== Null;;
       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\<rbrace>
       VAR MEASURE (length (list \<acute>p \<acute>next) )
        DO
         \<acute>r :== \<acute>p;; \<lbrace>\<acute>p \<noteq> Null\<rbrace>\<longmapsto>\<acute>p :== \<acute>p\<rightarrow>\<acute>next;;
         \<lbrace>\<acute>r \<noteq> Null\<rbrace>\<longmapsto>\<acute>r\<rightarrow>\<acute>next :== \<acute>q;; \<acute>q :== \<acute>r
       OD;;
       \<acute>p :==\<acute>q" in HoareTotal.annotateI)
apply vcg
apply   clarsimp
apply  clarsimp
apply  (rule conjI2)
apply   force
apply  clarsimp
apply  (subgoal_tac "List p next (p#ps)")
prefer 2 apply simp
apply  (frule_tac q=q in upd_hd_next)
apply  (simp only: List_list)
apply  simp
apply simp
done

lemma (in Rev_impl) shows
 Rev_modifies:
  "\<forall>\<sigma>. \<Gamma>\<turnstile>\<^bsub>/UNIV \<^esub>{\<sigma>} \<acute>p :== PROC Rev(\<acute>p) {t. t may_only_modify_globals \<sigma> in [next]}"
apply (hoare_rule HoarePartial.ProcNoRec1)
apply (vcg spec=modifies)
done

lemma "\<Gamma>\<turnstile>\<^sub>t \<lbrace>List \<acute>p \<acute>next Ps\<rbrace>
       \<acute>q :== Null;;
       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\<rbrace>
       VAR MEASURE (length (list \<acute>p \<acute>next) )
        DO
         \<acute>r :== \<acute>p;; \<acute>p :== \<acute>p\<rightarrow>\<acute>next;;
         \<acute>r\<rightarrow>\<acute>next :== \<acute>q;; \<acute>q :== \<acute>r
       OD;;
       \<acute>p :==\<acute>q
       \<lbrace>List \<acute>p \<acute>next (rev Ps)\<rbrace> "
apply vcg
apply   clarsimp
apply  clarsimp
apply  (rule conjI2)
apply   force
apply  clarsimp
apply  (subgoal_tac "List p next (p#ps)")
prefer 2 apply simp
apply  (frule_tac q=q in upd_hd_next)
apply  (simp only: List_list)
apply  simp
apply simp
done

procedures
  pedal(N,M) = "IF 0 < \<acute>N THEN
                            IF 0 < \<acute>M THEN CALL coast(\<acute>N- 1,\<acute>M- 1) FI;;
                            CALL pedal(\<acute>N- 1,\<acute>M)
                         FI"

and

  coast(N,M) = "CALL pedal(\<acute>N,\<acute>M);;
                         IF 0 < \<acute>M THEN CALL coast(\<acute>N,\<acute>M- 1) FI"

ML {* bind_thm ("HoareTotal_ProcRec2", Hoare.gen_proc_rec Hoare.Total 2)*}

lemma (in pedal_coast_clique)
  shows "(\<Gamma>\<turnstile>\<^sub>t \<lbrace>True\<rbrace>  PROC pedal(\<acute>N,\<acute>M) \<lbrace>True\<rbrace>) \<and>
         (\<Gamma>\<turnstile>\<^sub>t \<lbrace>True\<rbrace> PROC coast(\<acute>N,\<acute>M) \<lbrace>True\<rbrace>)"
  apply (hoare_rule HoareTotal_ProcRec2
          [where ?r= "inv_image (measure (\<lambda>m. m) <*lex*>
                                  measure (\<lambda>p. if p = coast_'proc then 1 else 0))
                      (\<lambda>(s,p). (\<^bsup>s\<^esup>N + \<^bsup>s\<^esup>M,p))"])
  apply simp_all
  apply  vcg
  apply  simp
  apply vcg
  apply simp
  done

lemma (in pedal_coast_clique)
  shows "(\<Gamma>\<turnstile>\<^sub>t \<lbrace>True\<rbrace> PROC pedal(\<acute>N,\<acute>M) \<lbrace>True\<rbrace>) \<and>
         (\<Gamma>\<turnstile>\<^sub>t \<lbrace>True\<rbrace> PROC coast(\<acute>N,\<acute>M) \<lbrace>True\<rbrace>)"
  apply (hoare_rule HoareTotal_ProcRec2
          [where ?r= "inv_image (measure (\<lambda>m. m) <*lex*>
                                  measure (\<lambda>p. if p = coast_'proc then 1 else 0))
                      (\<lambda>(s,p). (\<^bsup>s\<^esup>N + \<^bsup>s\<^esup>M,p))"])
  apply simp_all
  apply  vcg
  apply  simp
  apply vcg
  apply simp
  done

lemma (in pedal_coast_clique)
  shows "(\<Gamma>\<turnstile>\<^sub>t \<lbrace>True\<rbrace> PROC pedal(\<acute>N,\<acute>M) \<lbrace>True\<rbrace>) \<and>
         (\<Gamma>\<turnstile>\<^sub>t \<lbrace>True\<rbrace> PROC coast(\<acute>N,\<acute>M) \<lbrace>True\<rbrace>)"
  apply(hoare_rule HoareTotal_ProcRec2
     [where ?r= "measure (\<lambda>(s,p). \<^bsup>s\<^esup>N + \<^bsup>s\<^esup>M + (if p = coast_'proc then 1 else 0))"])
  apply simp_all
  apply  vcg
  apply  simp
  apply  arith
  apply vcg
  apply simp
  done

lemma (in pedal_coast_clique)
  shows "(\<Gamma>\<turnstile>\<^sub>t \<lbrace>True\<rbrace> PROC pedal(\<acute>N,\<acute>M) \<lbrace>True\<rbrace>) \<and>
         (\<Gamma>\<turnstile>\<^sub>t \<lbrace>True\<rbrace> PROC coast(\<acute>N,\<acute>M) \<lbrace>True\<rbrace>)"
  apply(hoare_rule HoareTotal_ProcRec2
     [where ?r= "(\<lambda>(s,p). \<^bsup>s\<^esup>N) <*mlex*> (\<lambda>(s,p). \<^bsup>s\<^esup>M) <*mlex*>
                 measure (\<lambda>(s,p). if p = coast_'proc then 1 else 0)"])
   apply  simp_all
   apply  vcg
   apply  simp
   apply vcg
   apply simp
   done

lemma (in pedal_coast_clique)
  shows "(\<Gamma>\<turnstile>\<^sub>t \<lbrace>True\<rbrace> PROC pedal(\<acute>N,\<acute>M) \<lbrace>True\<rbrace>) \<and>
         (\<Gamma>\<turnstile>\<^sub>t \<lbrace>True\<rbrace> PROC coast(\<acute>N,\<acute>M) \<lbrace>True\<rbrace>)"
  apply(hoare_rule HoareTotal_ProcRec2
     [where ?r= "measure (\<lambda>s. \<^bsup>s\<^esup>N + \<^bsup>s\<^esup>M) <*lex*>
                 measure (\<lambda>p. if p = coast_'proc then 1 else 0)"])
   apply simp_all
   apply  vcg
   apply  simp
   apply vcg
   apply simp
   done

end