(*  File:       Sequential_Majority_Comparison.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Karsten Diekhoff, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Jonas Kraemer, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Sequential Majority Comparison\<close>

theory Sequential_Majority_Comparison
  imports "Compositional_Structures/Basic_Modules/Plurality_Module"
          "Compositional_Structures/Drop_And_Pass_Compatibility"
          "Compositional_Structures/Revision_Composition"
          "Compositional_Structures/Maximum_Parallel_Composition"
          "Compositional_Structures/Defer_One_Loop_Composition"
begin

text
\<open>Sequential majority comparison compares two alternatives by plurality voting.
The loser gets rejected, and the winner is compared to the next alternative.
This process is repeated until only a single alternative is left, which is
then elected.\<close>

subsection \<open>Definition\<close>

fun smc :: "'a Preference_Relation \<Rightarrow> 'a Electoral_Module" where
  "smc x A p vs=
      ((((((pass_module 2 x) \<triangleright> ((plurality\<down>) \<triangleright> (pass_module 1 x))) \<parallel>\<^sub>\<up>
      (drop_module 2 x)) \<circlearrowleft>\<^sub>\<exists>\<^sub>!\<^sub>d) \<triangleright> elect_module) A p vs)"

subsection \<open>Soundness\<close>

(*
   As all base components are electoral modules (, aggregators, or termination
   conditions), and all used compositional structures create electoral modules,
   sequential majority comparison unsurprisingly is an electoral module.
*)
theorem smc_sound:
  assumes order: "linear_order x"
  shows "electoral_module (smc x)"
  unfolding electoral_module_def
proof (simp, safe, simp_all)
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs:: "'a Pair_Vectors" and
    xa :: "'a"
  let ?a = "max_aggregator"
  let ?t = "defer_equal_condition"
  let ?smc =
    "pass_module 2 x \<triangleright>
       ((plurality\<down>) \<triangleright> pass_module (Suc 0) x) \<parallel>\<^sub>?a
         drop_module 2 x \<circlearrowleft>\<^sub>?t (Suc 0)"
  assume
    fin_A: "finite A" and
    prof_A: "profile A p" and
    vec_A: "vector_pair A vs" and
    reject_xa:
      "xa \<in> reject (?smc) A p vs" and
    elect_xa:
      "xa \<in> elect (?smc) A p vs"
  show "False"
    using IntI drop_mod_sound elect_xa emptyE fin_A
          loop_comp_sound max_agg_sound order prof_A
          par_comp_sound pass_mod_sound reject_xa
          plurality_sound result_disj rev_comp_sound
          seq_comp_sound vec_A
    by metis
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs:: "'a Pair_Vectors" and
    xa :: "'a"
  let ?a = "max_aggregator"
  let ?t = "defer_equal_condition"
  let ?smc =
    "pass_module 2 x \<triangleright>
       ((plurality\<down>) \<triangleright> pass_module (Suc 0) x) \<parallel>\<^sub>?a
         drop_module 2 x \<circlearrowleft>\<^sub>?t (Suc 0)"
  assume
    fin_A: "finite A" and
    prof_A: "profile A p" and
    vec_A: "vector_pair A vs" and
    reject_xa:
      "xa \<in> reject (?smc) A p vs" and
    defer_xa:
      "xa \<in> defer (?smc) A p vs"
  show "False"
    using IntI drop_mod_sound defer_xa emptyE fin_A
          loop_comp_sound max_agg_sound order prof_A
          par_comp_sound pass_mod_sound reject_xa
          plurality_sound result_disj rev_comp_sound
          seq_comp_sound vec_A
    by metis
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs:: "'a Pair_Vectors" and
    xa :: "'a"
  let ?a = "max_aggregator"
  let ?t = "defer_equal_condition"
  let ?smc =
    "pass_module 2 x \<triangleright>
       ((plurality\<down>) \<triangleright> pass_module (Suc 0) x) \<parallel>\<^sub>?a
         drop_module 2 x \<circlearrowleft>\<^sub>?t (Suc 0)"
  assume
    fin_A: "finite A" and
    prof_A: "profile A p" and
    vec_A: "vector_pair A vs" and
    elect_xa:
      "xa \<in> elect (?smc) A p vs"
  show "xa \<in> A"
    using drop_mod_sound elect_in_alts elect_xa fin_A
          in_mono loop_comp_sound max_agg_sound order
          par_comp_sound pass_mod_sound plurality_sound
          prof_A rev_comp_sound seq_comp_sound vec_A
    by (smt (verit))
    (*by metis*)
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs:: "'a Pair_Vectors" and
    xa :: "'a"
  let ?a = "max_aggregator"
  let ?t = "defer_equal_condition"
  let ?smc =
    "pass_module 2 x \<triangleright>
       ((plurality\<down>) \<triangleright> pass_module (Suc 0) x) \<parallel>\<^sub>?a
         drop_module 2 x \<circlearrowleft>\<^sub>?t (Suc 0)"
  assume
    fin_A: "finite A" and
    prof_A: "profile A p" and
    vec_A: "vector_pair A vs" and
    defer_xa:
      "xa \<in> defer (?smc) A p vs"
  show "xa \<in> A"
    using drop_mod_sound defer_in_alts defer_xa fin_A
          in_mono loop_comp_sound max_agg_sound order
          par_comp_sound pass_mod_sound plurality_sound
          prof_A rev_comp_sound seq_comp_sound vec_A
    by (metis (no_types, lifting))
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs:: "'a Pair_Vectors" and
    xa :: "'a"
  let ?a = "max_aggregator"
  let ?t = "defer_equal_condition"
  let ?smc =
    "pass_module 2 x \<triangleright>
       ((plurality\<down>) \<triangleright> pass_module (Suc 0) x) \<parallel>\<^sub>?a
         drop_module 2 x \<circlearrowleft>\<^sub>?t (Suc 0)"
  assume
    fin_A: "finite A" and
    prof_A: "profile A p" and
    vec_A: "vector_pair A vs" and
    reject_xa:
      "xa \<in> reject (?smc) A p vs"
  have plurality_rev_sound:
    "electoral_module
      (plurality::'a set \<Rightarrow> (_ \<times> _) set list \<Rightarrow>  ('a \<times> nat) set list \<Rightarrow>_ set \<times> _ set \<times> _ set\<down>)"
    by simp
  have par1_sound:
    "electoral_module (pass_module 2 x \<triangleright> ((plurality\<down>) \<triangleright> pass_module 1 x))"
    using order
    by simp
  also have par2_sound:
      "electoral_module (drop_module 2 x)"
    using order
    by simp
  show "xa \<in> A"
    using reject_in_alts reject_xa fin_A in_mono
          loop_comp_sound max_agg_sound order
          par_comp_sound pass_mod_sound prof_A
          seq_comp_sound pass_mod_sound par1_sound
          par2_sound plurality_rev_sound vec_A
    by (metis (no_types))
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs:: "'a Pair_Vectors" and
    xa :: "'a"
  let ?a = "max_aggregator"
  let ?t = "defer_equal_condition"
  let ?smc =
    "pass_module 2 x \<triangleright>
       ((plurality\<down>) \<triangleright> pass_module (Suc 0) x) \<parallel>\<^sub>?a
         drop_module 2 x \<circlearrowleft>\<^sub>?t (Suc 0)"
  assume
    fin_A: "finite A" and
    prof_A: "profile A p" and
    vec_A: "vector_pair A vs" and
    xa_in_A: "xa \<in> A" and
    not_defer_xa:
      "xa \<notin> defer (?smc) A p vs" and
    not_reject_xa:
      "xa \<notin> reject (?smc) A p vs"
  show "xa \<in> elect (?smc) A p vs"
    using drop_mod_sound loop_comp_sound max_agg_sound
          order par_comp_sound pass_mod_sound xa_in_A
          plurality_sound rev_comp_sound seq_comp_sound
          electoral_mod_defer_elem fin_A not_defer_xa
          not_reject_xa prof_A vec_A
    by metis
qed

subsection \<open>Electing\<close>

(*
   The sequential majority comparison electoral module is electing.
   This property is needed to convert electoral modules to a social choice
   function. Apart from the very last proof step, it is a part of the
   monotonicity proof below.
*)
theorem smc_electing:
  assumes order: "linear_order x"
  shows "electing (smc x)"
proof -
  let ?pass2 = "pass_module 2 x"
  let ?tie_breaker = "(pass_module 1 x)"
  let ?plurality_defer = "(plurality\<down>) \<triangleright> ?tie_breaker"
  let ?compare_two = "?pass2 \<triangleright> ?plurality_defer"
  let ?drop2 = "drop_module 2 x"
  let ?eliminator = "?compare_two \<parallel>\<^sub>\<up> ?drop2"
  let ?loop =
    "let t = defer_equal_condition 1 in (?eliminator \<circlearrowleft>\<^sub>t)"

  have 00011: "non_electing (plurality\<down>)"
    by simp
  have 00012: "non_electing ?tie_breaker"
    using order
    by simp
  have 00013: "defers 1 ?tie_breaker"
    using order pass_one_mod_def_one
    by simp
  have 20000: "non_blocking (plurality\<down>)"
    by simp

  have 0020: "disjoint_compatibility ?pass2 ?drop2"
    using order
    (*by simp*) (*disj_compat_comm*) sorry
  have 1000: "non_electing ?pass2"
    using order
    by simp
  have 1001: "non_electing ?plurality_defer"
    using 00011 00012
    by simp
  have 2000: "non_blocking ?pass2"
    using order
    by simp
  have 2001: "defers 1 ?plurality_defer"
    using 20000 00011 00013 seq_comp_def_one
    by blast

  have 002: "disjoint_compatibility ?compare_two ?drop2"
    using order 0020
    by simp
  have 100: "non_electing ?compare_two"
    using 1000 1001
    by simp
  have 101: "non_electing ?drop2"
    using order
    by simp
  have 102: "agg_conservative max_aggregator"
    by simp
  have 200: "defers 1 ?compare_two"
    using 2000 1000 2001 seq_comp_def_one
    by auto
  have 201: "rejects 2 ?drop2"
    using order
    (*by simp*) sorry

  have 10: "non_electing ?eliminator"
    using 100 101 102
    by simp
  have 20: "eliminates 1 ?eliminator"
    using 200 100 201 002 par_comp_elim_one
    by metis

  have 2: "defers 1 ?loop"
    using 10 20
    by simp
  have 3: "electing elect_module"
    by simp

  show ?thesis
    using 2 3 smc_sound smc.simps electing_def
          Defer_One_Loop_Composition.iter.simps
          order seq_comp_electing
    by metis
qed

subsection \<open>(Weak) Monotonicity Property\<close>

(*
   The following proof is a fully modular proof for weak monotonicity of
   sequential majority comparison. It is composed of many small steps.
*)
theorem smc_monotone:
  assumes order: "linear_order x"
  shows "monotonicity (smc x)"
proof -
(*Some aliases for parts of the SMC module.*)
  let ?pass2 = "pass_module 2 x"
  let ?tie_breaker = "(pass_module 1 x)"
  let ?plurality_defer = "(plurality\<down>) \<triangleright> ?tie_breaker"
  let ?compare_two = "?pass2 \<triangleright> ?plurality_defer"
  let ?drop2 = "drop_module 2 x"
  let ?eliminator = "?compare_two \<parallel>\<^sub>\<up> ?drop2"
  let ?loop =
    "let t = defer_equal_condition 1 in (?eliminator \<circlearrowleft>\<^sub>t)"

  have 00010: "defer_invariant_monotonicity (plurality\<down>)"
    by simp (*rev_comp_def_inv_mono plurality_strict_strong_mono*)
  have 00011: "non_electing (plurality\<down>)"
    by simp (*rev_comp_non_electing plurality_sound*)
  have 00012: "non_electing ?tie_breaker"
    using order
    by simp (*pass_mod_non_electing*)
  have 00013: "defers 1 ?tie_breaker"
    using order pass_one_mod_def_one
    by simp
  have 00014: "defer_monotonicity ?tie_breaker"
    using order
    by simp (*dl_inv_imp_def_mono pass_mod_dl_inv*)
  have 20000: "non_blocking (plurality\<down>)"
    by simp (*rev_comp_non_blocking plurality_electing*)

  have 0000: "defer_lift_invariance ?pass2"
    using order
    by simp (*pass_mod_dl_inv*)
  have 0001: "defer_lift_invariance ?plurality_defer"
    using 00010 00011 00012 00013 00014
    by simp (*def_inv_mono_imp_def_lift_inv*)
  have 0020: "disjoint_compatibility ?pass2 ?drop2"
    using order sorry
    (*by simp*) (*disj_compat_comm drop_pass_disj_compat*)
  have 1000: "non_electing ?pass2"
    using order
    by simp (*pass_mod_non_electing*)
  have 1001: "non_electing ?plurality_defer"
    using 00011 00012
    by simp (*seq_comp_presv_non_electing*)
  have 2000: "non_blocking ?pass2"
    using order
    by simp (*pass_mod_non_blocking*)
  have 2001: "defers 1 ?plurality_defer"
    using 20000 00011 00013 seq_comp_def_one
    by blast

  have 000: "defer_lift_invariance ?compare_two"
    using 0000 0001
    by simp (*seq_comp_presv_def_lift_inv*)
  have 001: "defer_lift_invariance ?drop2"
    using order
    by simp (* drop_mod_def_lift_inv *)
  have 002: "disjoint_compatibility ?compare_two ?drop2"
    using order 0020
    by simp
      (*disj_compat_seq seq_comp_sound rev_comp_sound
        plurality_sound pass_mod_sound*)
  have 100: "non_electing ?compare_two"
    using 1000 1001
    by simp (*seq_comp_presv_non_electing*)
  have 101: "non_electing ?drop2"
    using order
    by simp (*drop_mod_non_electing*)
  have 102: "agg_conservative max_aggregator"
    by simp (*max_agg_conserv*)
  have 200: "defers 1 ?compare_two"
    using 2000 1000 2001 seq_comp_def_one
    by auto
  have 201: "rejects 2 ?drop2"
    using order
    by simp (*drop_two_mod_rej_two*)

  have 00: "defer_lift_invariance ?eliminator"
    using 000 001 002 par_comp_def_lift_inv
    by simp (*par_comp_def_lift_inv*)
  have 10: "non_electing ?eliminator"
    using 100 101 102
    by simp (*conserv_agg_presv_non_electing*)
  have 20: "eliminates 1 ?eliminator"
    using 200 100 201 002 par_comp_elim_one
    by simp

  have 0: "defer_lift_invariance ?loop"
    using 00 sorry
    (*by simp*) (*loop_comp_presv_def_lift_inv*)
  have 1: "non_electing ?loop"
    using 10
    by simp (*loop_comp_presv_non_electing*)
  have 2: "defers 1 ?loop"
    using 10 20
    by simp (*iter_elim_def_n*)
  have 3: "electing elect_module"
    by simp (*elect_mod_electing*)

  show ?thesis
    using 0 1 2 3
          Electoral_Module.monotonicity_def
          Defer_One_Loop_Composition.iter.simps
           smc.simps order seq_comp_mono
    by (smt (z3) smc_sound)
    (*by (metis (full_types))*)
qed

end


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

(*
 * Contributions by:
 *   2012 Lars Noschinski <noschinl@in.tum.de>
 *     Option monad while loop formalisation.
 *)

theory OptionMonad (* FIXME: this is really a Reader_Option_Monad *)
  imports
    Monad_Lib
    Fun_Pred_Syntax
    Less_Monad_Syntax
begin

section \<open>Projections\<close>

type_synonym ('s,'a) lookup = "'s \<Rightarrow> 'a option"

text \<open>Similar to map_option but the second function returns option as well\<close>
definition opt_map :: "('s,'a) lookup \<Rightarrow> ('a \<Rightarrow> 'b option) \<Rightarrow> ('s,'b) lookup" (infixl "|>" 54) where
  "f |> g \<equiv> \<lambda>s. case f s of None \<Rightarrow> None | Some x \<Rightarrow> g x"

abbreviation opt_map_Some :: "('s \<rightharpoonup> 'a) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 's \<rightharpoonup> 'b" (infixl "||>" 54) where
  "f ||> g \<equiv> f |> (Some \<circ> g)"

lemmas opt_map_Some_def = opt_map_def

definition map_set :: "('a \<Rightarrow> 'b set option) \<Rightarrow> 'a \<Rightarrow> 'b set" where
  "map_set f \<equiv> case_option {} id \<circ> f"

definition opt_pred :: "('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'a option) \<Rightarrow> ('b \<Rightarrow> bool)" (infixl "|<" 55) where
  "P |< proj \<equiv> (\<lambda>x. case_option False P (proj x))"

subsection \<open>Lemmas for @{const opt_map}\<close>

lemma opt_map_cong[fundef_cong]:
  "\<lbrakk> f = f'; \<And>v s. f s = Some v \<Longrightarrow> g v = g' v\<rbrakk> \<Longrightarrow> f |> g = f' |> g'"
  by (rule ext) (simp add: opt_map_def split: option.splits)

lemma in_opt_map_eq:
  "((f |> g) s = Some v) = (\<exists>v'. f s = Some v' \<and> g v' = Some v)"
  by (simp add: opt_map_def split: option.splits)

lemma in_opt_map_None_eq:
  "((f |> g) s = None) = (f s = None \<or> (\<exists>v. f s = Some v \<and> g v = None))"
  by (simp add: opt_map_def split: option.splits)

lemma opt_mapE:
  "\<lbrakk> (f |> g) s = Some v; \<And>v'. \<lbrakk>f s = Some v'; g v' = Some v \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (auto simp: in_opt_map_eq)

lemma opt_map_red:
  "f x = Some y \<Longrightarrow> (f |> g) x = g y"
  by (clarsimp simp: opt_map_def)

lemma opt_map_left_None:
  "f x = None \<Longrightarrow> (f |> g) x = None"
  by (clarsimp simp: opt_map_def)

lemma opt_map_assoc:
  "f |> (g |> h) = f |> g |> h"
  by (fastforce simp: opt_map_def split: option.splits)

lemma opt_map_if_l:
  "(if P then f else f') |> g = (if P then f |> g else f' |> g)"
  by (auto simp: opt_map_def)

lemma opt_map_if_r:
  "f |> (if P then g else g') = (if P then f |> g else f |> g')"
  by (auto simp: opt_map_def)

lemma opt_map_upd_None:
  "f(x := None) |> g = (f |> g)(x := None)"
  by (auto simp: opt_map_def)

lemma opt_map_upd_Some:
  "f(x \<mapsto> v) |> g = (f |> g)(x := g v)"
  by (auto simp: opt_map_def)

lemma opt_map_Some_upd_Some:
  "f(x \<mapsto> v) ||> g = (f ||> g)(x \<mapsto> g v)"
  by (simp add: opt_map_upd_Some)

lemmas opt_map_upd[simp] = opt_map_upd_None opt_map_upd_Some opt_map_Some_upd_Some

lemma opt_map_upd_triv:
  "t k = Some x \<Longrightarrow> (t |> f)(k := f x) = t |> f"
  by (rule ext) (clarsimp simp add: opt_map_red)

lemma opt_map_Some_upd_triv:
  "t k = Some x \<Longrightarrow> (t ||> f)(k \<mapsto> f x) = t ||> f"
  by (rule ext) (clarsimp simp add: opt_map_red)

lemma opt_map_upd_triv_None:
  "t k = None \<Longrightarrow> (t |> f)(k := None) = t |> f"
  by (rule ext) (clarsimp simp add: opt_map_def)

lemmas opt_map_upd_triv_simps = opt_map_upd_triv opt_map_Some_upd_triv opt_map_upd_triv_None

lemma opt_map_foldr_upd:
  "foldr (\<lambda>p kh. kh(p := new)) ptrs f |> g
   = foldr (\<lambda>p kh. kh(p := (case new of Some x \<Rightarrow> g x | _ \<Rightarrow> None))) ptrs (f |> g)"
  by (induct ptrs arbitrary: new; clarsimp split: option.splits)

lemma opt_map_Some_foldr_upd:
  "foldr (\<lambda>p kh. kh(p := new)) ptrs f ||> g
   = foldr (\<lambda>p kh. kh(p := map_option g new)) ptrs (f ||> g)"
  by (induct ptrs arbitrary: new; clarsimp simp: map_option_case split: option.splits)

lemmas opt_map_foldr_upd_simps = opt_map_foldr_upd opt_map_Some_foldr_upd

lemma opt_map_Some_comp[simp]:
  "f ||> g ||> h = f ||> h o g"
  by (fastforce simp: opt_map_def split: option.split)

lemma opt_map_fold_l:
  "(id |> g) (f x) = (f |> g) x"
  by (clarsimp simp: opt_map_def)

(* LHS is the same as (f ||> id) *)
lemma opt_map_Some_id_r[simp]:
  "f |> Some = f"
  by (fastforce simp: opt_map_def split: option.split)

lemma opt_map_Some_id_l[simp]:
  "Some |> f = f"
  by (clarsimp simp: opt_map_def split: option.split)

lemma opt_map_zero_l[simp]:
  "Map.empty |> g = Map.empty"
  by (clarsimp simp: opt_map_def)

lemma opt_map_zero_r[simp]:
  "f |> Map.empty = Map.empty"
  by (fastforce simp: opt_map_def split: option.split)

lemma opt_map_Some_eta_fold:
  "f |> (\<lambda>x. Some (g x)) = f ||> g"
  by (simp add: o_def)

lemma case_opt_map_distrib:
  "(\<lambda>s. case_option None g (f s)) |> h = (\<lambda>s. case_option None (g |> h) (f s))"
  by (fastforce simp: opt_map_def split: option.splits)

lemma opt_map_apply_left_eq:
  "f s = f s' \<Longrightarrow> (f |> g) s = (f |> g) s'"
  by (simp add: opt_map_def)

declare None_upd_eq[simp]

(* None_upd_eq[simp] so that this pattern is by simp. Hopefully not too much slowdown. *)
lemma "\<lbrakk> (f |> g) x = None; g v = None \<rbrakk> \<Longrightarrow> f(x \<mapsto> v) |> g = f |> g"
  by simp

subsection \<open>Lemmas for @{const opt_pred}\<close>

lemma opt_pred_conj:
  "((P |< hp) p \<and> (Q |< hp) p) = ((P and Q) |< hp) p"
  by (fastforce simp: pred_conj_def opt_pred_def split: option.splits)

lemma opt_pred_disj:
  "((P |< hp) p \<or> (Q |< hp) p) = ((P or Q) |< hp) p"
  by (fastforce simp: pred_disj_def opt_pred_def split: option.splits)

lemma in_opt_pred:
  "(P |< f) p = (\<exists>v. f p = Some v \<and> P v)"
  by (auto simp: opt_pred_def split: option.splits)

lemmas opt_predD = in_opt_pred[THEN iffD1]

lemma opt_predE:
  "\<lbrakk>(P |< proj) x; \<And>y. \<lbrakk>proj x = Some y; P y\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  by (blast dest: opt_predD)

lemma opt_pred_unfold_map:
  "P |< (f |> g) = P |< g |< f"
  by (fastforce simp: opt_map_def in_opt_pred split: option.splits)

lemma opt_pred_unfold_proj:
  "P |< (f ||> g) = P o g |< f"
  by (clarsimp simp: opt_map_def opt_pred_def split: option.splits)

lemma opt_pred_proj_upd_eq[simp]:
  "(P |< proj (p \<mapsto> v)) p = P v"
  by (simp add: in_opt_pred)

section \<open>The Reader Option Monad\<close>

definition obind :: "('s,'a) lookup \<Rightarrow> ('a \<Rightarrow> ('s,'b) lookup) \<Rightarrow> ('s,'b) lookup" (infixl "|>>" 53)
  where
  "f |>> g \<equiv> \<lambda>s. case f s of None \<Rightarrow> None | Some x \<Rightarrow> g x s"

(* Enable "do { .. }" syntax *)
adhoc_overloading
  Monad_Syntax.bind obind

definition ofail :: "('s, 'a) lookup" where
  "ofail = K None"

definition oreturn :: "'a \<Rightarrow> ('s, 'a) lookup" where
  "oreturn = K o Some"

definition oassert :: "bool \<Rightarrow> ('s, unit) lookup" where
  "oassert P \<equiv> if P then oreturn () else ofail"

definition oassert_opt :: "'a option \<Rightarrow> ('s, 'a) lookup" where
  "oassert_opt r \<equiv> case r of None \<Rightarrow> ofail | Some x \<Rightarrow> oreturn x"

definition oapply :: "'a \<Rightarrow> ('a \<Rightarrow> 'b option) \<Rightarrow> 'b option" where
  "oapply x \<equiv> \<lambda>s. s x"

definition oapply2 :: "'a \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c option) \<Rightarrow> 'c option" where
  "oapply2 x y \<equiv> \<lambda>s. s x y"

definition oliftM :: "('a \<Rightarrow> 'b) \<Rightarrow> ('s,'a) lookup \<Rightarrow> ('s,'b) lookup" where
  "oliftM f m \<equiv> do { x \<leftarrow> m; oreturn (f x) }"

definition ounless :: "bool \<Rightarrow> ('s, unit) lookup \<Rightarrow> ('s, unit) lookup" where
  "ounless P f \<equiv> if P then oreturn () else f"

definition owhen :: "bool \<Rightarrow> ('s, unit) lookup \<Rightarrow> ('s, unit) lookup" where
  "owhen P f \<equiv> if P then f else oreturn ()"

(* Reader monad interface: *)
abbreviation (input) ask :: "('s, 's) lookup" where
  "ask \<equiv> Some"

definition asks :: "('s \<Rightarrow> 'a) \<Rightarrow> ('s, 'a) lookup" where
  "asks f = do { v <- ask; oreturn (f v) }"

abbreviation ogets :: "('s \<Rightarrow> 'a) \<Rightarrow> ('s, 'a) lookup" where
  "ogets \<equiv> asks"

text \<open>
  Integration with exception monad.
  Corresponding bindE would be analogous to lifting in NonDetMonad.\<close>

definition
  "oreturnOk x = K (Some (Inr x))"

definition
  "othrow e = K (Some (Inl e))"

definition
  "oguard G \<equiv> (\<lambda>s. if G s then Some () else None)"

definition
  "ocondition c L R \<equiv> (\<lambda>s. if c s then L s else R s)"

definition
  "oskip \<equiv> oreturn ()"

lemmas omonad_defs = ofail_def oreturn_def oassert_def oassert_opt_def asks_def ounless_def
                     owhen_def

subsection \<open>Monad laws\<close>

lemma oreturn_bind[simp]:
  "(oreturn x |>> f) = f x"
  by (auto simp add: oreturn_def obind_def K_def)

lemma obind_return[simp]:
  "(m |>> oreturn) = m"
  by (auto simp add: oreturn_def obind_def K_def split: option.splits)

lemma obind_assoc:
  "(m |>> f) |>> g  =  m |>> (\<lambda>x. f x |>> g)"
  by (auto simp add: oreturn_def obind_def K_def split: option.splits)

subsection \<open>Binding and fail\<close>

lemma obind_fail [simp]:
  "f |>> (\<lambda>_. ofail) = ofail"
  by (auto simp add: ofail_def obind_def K_def split: option.splits)

lemma ofail_bind [simp]:
  "ofail |>> m = ofail"
  by (auto simp add: ofail_def obind_def K_def split: option.splits)

subsection \<open>Function package setup\<close>

lemma opt_bind_cong[fundef_cong]:
  "\<lbrakk> f = f'; \<And>v s. f' s = Some v \<Longrightarrow> g v s = g' v s \<rbrakk> \<Longrightarrow> f |>> g = f' |>> g'"
  by (rule ext) (simp add: obind_def split: option.splits)

lemma opt_bind_cong_apply[fundef_cong]:
  "\<lbrakk> f s = f' s; \<And>v. f' s = Some v \<Longrightarrow> g v s = g' v s \<rbrakk> \<Longrightarrow> (f |>> g) s = (f' |>> g') s"
  by (simp add: obind_def split: option.splits)

lemma oassert_bind_cong[fundef_cong]:
  "\<lbrakk> P = P'; P' \<Longrightarrow> m = m' \<rbrakk> \<Longrightarrow> oassert P |>> m = oassert P' |>> m'"
  by (auto simp: oassert_def)

lemma oassert_bind_cong_apply[fundef_cong]:
  "\<lbrakk> P = P'; P' \<Longrightarrow> m () s = m' () s \<rbrakk> \<Longrightarrow> (oassert P |>> m) s = (oassert P' |>> m') s"
  by (auto simp: oassert_def)

lemma oreturn_bind_cong[fundef_cong]:
  "\<lbrakk> x = x'; m x' = m' x' \<rbrakk> \<Longrightarrow> oreturn x |>> m = oreturn x' |>> m'"
  by simp

lemma oreturn_bind_cong_apply[fundef_cong]:
  "\<lbrakk> x = x'; m x' s = m' x' s \<rbrakk> \<Longrightarrow> (oreturn x |>> m) s = (oreturn x' |>> m') s"
  by simp

lemma oreturn_bind_cong2[fundef_cong]:
  "\<lbrakk> x = x'; m x' = m' x' \<rbrakk> \<Longrightarrow> (oreturn $ x) |>> m = (oreturn $ x') |>> m'"
  by simp

lemma oreturn_bind_cong2_apply[fundef_cong]:
  "\<lbrakk> x = x'; m x' s = m' x' s \<rbrakk> \<Longrightarrow> ((oreturn $ x) |>> m) s = ((oreturn $ x') |>> m') s"
  by simp

lemma ocondition_cong[fundef_cong]:
"\<lbrakk>c = c'; \<And>s. c' s \<Longrightarrow> l s = l' s; \<And>s. \<not>c' s \<Longrightarrow> r s = r' s\<rbrakk>
  \<Longrightarrow> ocondition c l r = ocondition c' l' r'"
  by (auto simp: ocondition_def)

subsection \<open>Decomposition\<close>

lemma ocondition_K_true[simp]:
  "ocondition (\<lambda>_. True) T F = T"
  by (simp add: ocondition_def)

lemma ocondition_K_false[simp]:
  "ocondition (\<lambda>_. False) T F = F"
  by (simp add: ocondition_def)

lemma ocondition_False:
    "\<lbrakk> \<And>s. \<not> P s \<rbrakk> \<Longrightarrow> ocondition P L R = R"
  by (rule ext, clarsimp simp: ocondition_def)

lemma ocondition_True:
    "\<lbrakk> \<And>s. P s \<rbrakk> \<Longrightarrow> ocondition P L R = L"
  by (rule ext, clarsimp simp: ocondition_def)

lemma in_oreturn [simp]:
  "(oreturn x s = Some v) = (v = x)"
  by (auto simp: oreturn_def K_def)

lemma oreturn_None[simp]:
  "\<not> oreturn x s = None"
  by (simp add: oreturn_def K_def)

lemma oreturnE:
  "\<lbrakk>oreturn x s = Some v; v = x \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by simp

lemma in_ofail[simp]:
  "ofail s \<noteq> Some v"
  by (auto simp: ofail_def K_def)

lemma ofailE:
  "ofail s = Some v \<Longrightarrow> P"
  by simp

lemma in_oassert_eq[simp]:
  "(oassert P s = Some v) = P"
  by (simp add: oassert_def)

lemma oassert_True[simp]:
  "oassert True = oreturn ()"
  by (simp add: oassert_def)

lemma oassert_False[simp]:
  "oassert False = ofail"
  by (simp add: oassert_def)

lemma oassertE:
  "\<lbrakk> oassert P s = Some v; P \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
  by simp

lemma in_obind_eq:
  "((f |>> g) s = Some v) = (\<exists>v'. f s = Some v' \<and> g v' s = Some v)"
  by (simp add: obind_def split: option.splits)

lemma obind_None_eq:
  "((f |>> g) s = None) = (f s = None \<or> (\<exists>v. f s = Some v \<and> g v s = None))"
  by (simp add: obind_def split: option.split)

lemma obind_eqI:
  "\<lbrakk> f s = f s' ; \<And>x. f s = Some x \<Longrightarrow> g x s = g' x s' \<rbrakk> \<Longrightarrow> obind f g s = obind f g' s'"
  by (simp add: obind_def split: option.splits)

(* full form of obind_eqI; the second equality makes more sense flipped here, as we end up
   with "f s = Some x ; f s' = f s" preventing "Some x = ..." *)
lemma obind_eqI_full:
  "\<lbrakk> f s = f s' ; \<And>x. \<lbrakk> f s = Some x; f s' = f s \<rbrakk> \<Longrightarrow> g x s = g' x s' \<rbrakk>
   \<Longrightarrow> obind f g s = obind f g' s'"
  by (drule sym[where s="f s"]) (* prevent looping *)
     (clarsimp simp: obind_def split: option.splits)

lemma obindE:
  "\<lbrakk> (f |>> g) s = Some v; \<And>v'. \<lbrakk>f s = Some v'; g v' s = Some v\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (auto simp: in_obind_eq)

lemma in_othrow_eq[simp]:
  "(othrow e s = Some v) = (v = Inl e)"
  by (auto simp: othrow_def K_def)

lemma othrowE:
  "\<lbrakk>othrow e s = Some v; v = Inl e \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by simp

lemma in_oreturnOk_eq[simp]:
  "(oreturnOk x s = Some v) = (v = Inr x)"
  by (auto simp: oreturnOk_def K_def)

lemma oreturnOkE:
  "\<lbrakk>oreturnOk x s = Some v; v = Inr x \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by simp

lemmas omonadE[elim!] = obindE oreturnE ofailE othrowE oreturnOkE oassertE

lemma in_opt_map_Some_eq:
  "((f ||> g) x = Some y) = (\<exists>v. f x = Some v \<and> g v = y)"
  by (simp add: in_opt_map_eq)

lemma in_opt_map_Some_None_eq[simp]:
  "((f ||> g) x = None) = (f x = None)"
  by (simp add: opt_map_def split: option.splits)

lemma oreturn_comp[simp]:
  "oreturn x \<circ> f = oreturn x"
  by (simp add: oreturn_def K_def o_def)

lemma ofail_comp[simp]:
  "ofail \<circ> f = ofail"
  by (auto simp: ofail_def K_def)

lemma oassert_comp[simp]:
  "oassert P \<circ> f = oassert P"
  by (simp add: oassert_def)

lemma fail_apply[simp]:
  "ofail s = None"
  by (simp add: ofail_def K_def)

lemma oassert_apply[simp]:
  "oassert P s = (if P then Some () else None)"
  by (simp add: oassert_def)

lemma oreturn_apply[simp]:
  "oreturn x s = Some x"
  by simp

lemma oapply_apply[simp]:
  "oapply x s = s x"
  by (simp add: oapply_def)

lemma oapply2_apply[simp]:
  "oapply2 x y s = s x y"
  by (simp add: oapply2_def)

lemma obind_comp_dist:
  "obind f g o h = obind (f o h) (\<lambda>x. g x o h)"
  by (auto simp: obind_def split: option.splits)

lemma if_comp_dist:
  "(if P then f else g) o h = (if P then f o h else g o h)"
  by auto

lemma obindK_is_opt_map:
  "f \<bind> (\<lambda>x. K $ g x) = f |> g"
  by (simp add: obind_def opt_map_def K_def)

section \<open>"While" loops over option monad.\<close>

text \<open>
  This is an inductive definition of a while loop over the plain option monad
  (without passing through a state)
\<close>

inductive_set option_while' :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a option) \<Rightarrow> 'a option rel" for C B where
    final: "\<not> C r \<Longrightarrow> (Some r, Some r) \<in> option_while' C B"
  | fail: "\<lbrakk> C r; B r = None \<rbrakk> \<Longrightarrow> (Some r, None) \<in> option_while' C B"
  | step: "\<lbrakk> C r;  B r = Some r'; (Some r', sr'') \<in> option_while' C B \<rbrakk>
           \<Longrightarrow> (Some r, sr'') \<in> option_while' C B"

definition
  "option_while C B r \<equiv>
    (if (\<exists>s. (Some r, s) \<in> option_while' C B) then
      (THE s. (Some r, s) \<in> option_while' C B) else None)"

lemma option_while'_inj:
  assumes "(s,s') \<in> option_while' C B" "(s, s'') \<in> option_while' C B"
  shows "s' = s''"
  using assms
  by (induct rule: option_while'.induct) (auto elim: option_while'.cases)

lemma option_while'_THE:
  assumes "(Some r, sr') \<in> option_while' C B"
  shows "(THE s. (Some r, s) \<in> option_while' C B) = sr'"
  using assms by (blast dest: option_while'_inj)

lemma option_while_simps:
  "\<not> C s \<Longrightarrow> option_while C B s = Some s"
  "C s \<Longrightarrow> B s = None \<Longrightarrow> option_while C B s = None"
  "C s \<Longrightarrow> B s = Some s' \<Longrightarrow> option_while C B s = option_while C B s'"
  "(Some s, ss') \<in> option_while' C B \<Longrightarrow> option_while C B s = ss'"
  using option_while'_inj_step[of C s B s']
  by (auto simp: option_while_def option_while'_THE
           intro: option_while'.intros
           dest: option_while'_inj
           elim: option_while'.cases)

lemma option_while_rule:
  assumes "option_while C B s = Some s'"
  assumes "I s"
  assumes istep: "\<And>s s'. C s \<Longrightarrow> I s \<Longrightarrow> B s = Some s' \<Longrightarrow> I s'"
  shows "I s' \<and> \<not> C s'"
proof -
  { fix ss ss' assume "(ss, ss') \<in> option_while' C B" "ss = Some s" "ss' = Some s'"
    then have ?thesis using \<open>I s\<close>
      by (induct arbitrary: s) (auto intro: istep) }
  then show ?thesis using assms(1)
    by (auto simp: option_while_def option_while'_THE split: if_split_asm)
qed

lemma option_while'_term:
  assumes "I r"
  assumes "wf M"
  assumes step_less: "\<And>r r'. \<lbrakk>I r; C r; B r = Some r'\<rbrakk> \<Longrightarrow> (r',r) \<in> M"
  assumes step_I: "\<And>r r'. \<lbrakk>I r; C r; B r = Some r'\<rbrakk> \<Longrightarrow> I r'"
  obtains sr' where "(Some r, sr') \<in> option_while' C B"
  apply atomize_elim
  using assms(2,1)
proof induct
  case (less r)
  show ?case
  proof (cases "C r" "B r" rule: bool.exhaust[case_product option.exhaust])
    case (True_Some r')
    then have "(r',r) \<in> M" "I r'"
      by (auto intro: less step_less step_I)
    then obtain sr' where "(Some r', sr') \<in> option_while' C B"
      by atomize_elim (rule less)
    then have "(Some r, sr') \<in> option_while' C B"
      using True_Some by (auto intro: option_while'.intros)
    then show ?thesis ..
  qed (auto intro: option_while'.intros)
qed

lemma option_while_rule':
  assumes "option_while C B s = ss'"
  assumes "wf M"
  assumes "I (Some s)"
  assumes less: "\<And>s s'. C s \<Longrightarrow> I (Some s) \<Longrightarrow> B s = Some s' \<Longrightarrow> (s', s) \<in> M"
  assumes step: "\<And>s s'. C s \<Longrightarrow> I (Some s) \<Longrightarrow> B s = Some s' \<Longrightarrow> I (Some s')"
  assumes final: "\<And>s. C s \<Longrightarrow> I (Some s) \<Longrightarrow> B s = None \<Longrightarrow> I None"
  shows "I ss' \<and> (case ss' of Some s' \<Rightarrow> \<not> C s' | _ \<Rightarrow> True)"
proof -
  define ss where "ss \<equiv> Some s"
  obtain ss1' where "(Some s, ss1') \<in> option_while' C B"
    using assms(3,2,4,5) by (rule option_while'_term)
  then have *: "(ss, ss') \<in> option_while' C B" using \<open>option_while C B s = ss'\<close>
    by (auto simp: option_while_simps ss_def)
  show ?thesis
  proof (cases ss')
    case (Some s') with * ss_def show ?thesis using \<open>I _\<close>
      by (induct arbitrary:s) (auto intro: step)
  next
    case None with * ss_def show ?thesis using \<open>I _\<close>
      by (induct arbitrary:s) (auto intro: step final)
  qed
qed

section \<open>Lift @{term option_while} to the @{typ "('a,'s) lookup"} monad\<close>

definition owhile :: "('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> ('s,'a) lookup) \<Rightarrow> 'a \<Rightarrow> ('s,'a) lookup" where
 "owhile c b a \<equiv> \<lambda>s. option_while (\<lambda>a. c a s) (\<lambda>a. b a s) a"

lemma owhile_unroll:
  "owhile C B r = ocondition (C r) (B r |>> owhile C B) (oreturn r)"
  by (auto simp: ocondition_def obind_def oreturn_def owhile_def
                 option_while_simps
           split: option.split)

text \<open>Rule for terminating loops\<close>

lemma owhile_rule:
  assumes "I r s"
  assumes "wf M"
  assumes less: "\<And>r r'. \<lbrakk>I r s; C r s; B r s = Some r'\<rbrakk> \<Longrightarrow> (r',r) \<in> M"
  assumes step: "\<And>r r'. \<lbrakk>I r s; C r s; B r s = Some r'\<rbrakk> \<Longrightarrow> I r' s"
  assumes fail: "\<And>r. \<lbrakk>I r s; C r s; B r s = None\<rbrakk> \<Longrightarrow> Q None"
  assumes final: "\<And>r. \<lbrakk>I r s; \<not>C r s\<rbrakk> \<Longrightarrow> Q (Some r)"
  shows "Q (owhile C B r s)"
proof -
  let ?rs' = "owhile C B r s"
  have "(case ?rs' of Some r \<Rightarrow> I r s | _ \<Rightarrow> Q None)
      \<and> (case ?rs' of Some r' \<Rightarrow> \<not> C r' s | _ \<Rightarrow> True)"
    by (rule option_while_rule'[where B="\<lambda>r. B r s" and s=r, OF _ \<open>wf _\<close>])
       (auto simp: owhile_def intro: assms)
  then show ?thesis by (auto intro: final split: option.split_asm)
qed

end


theory TestSdiv

imports Main "../ContractSem"

begin

declare eval_annotation_def [simp]

definition this_address :: address
where "this_address = undefined"

abbreviation test_sdiv_code :: "inst list"
where
"test_sdiv_code ==
   Stack (PUSH_N [255])
 # Stack (PUSH_N [2])
 # Arith EXP
 # Dup 1
 # Annotation (\<lambda> aenv. length (aenv_stack aenv) = 2)
 # Stack (PUSH_N [0])
 # Bits inst_NOT
 # Swap 1
 # Annotation (\<lambda> aenv. length (aenv_stack aenv) = 3)
 # Sarith SDIV
 # Annotation (\<lambda> aenv. length (aenv_stack aenv) = 2)
 # Annotation (\<lambda> aenv. (aenv_stack aenv ! 0) = (aenv_stack aenv ! 1))
 # Misc STOP
 # []"

abbreviation test_sdiv_account_state :: "account_state"
where
"test_sdiv_account_state ==
   \<lparr> account_address = this_address
   , account_storage = \<lambda> _. 0
   , account_code = test_sdiv_code
   , account_balance = 0
   , account_ongoing_calls = []
   \<rparr>"

abbreviation test_sdiv_spec :: "response_to_world"
where
" test_sdiv_spec ==
  \<lparr> when_called = \<lambda> _. (ContractReturn [],
                        \<lambda> a. True)
  , when_returned = \<lambda> _. (ContractFail,
                           \<lambda> a. True)
  , when_failed = (ContractFail,
                     \<lambda> a. True)
  \<rparr>
"

value "32 div sint (max_word :: uint)"

lemma test_sdiv_correct:
"
  account_state_responds_to_world
  (\<lambda> a. a = test_sdiv_account_state)
  test_sdiv_spec
"
apply(rule AccountStep; auto)
apply(case_tac steps; auto)
apply(simp add:max_word_def)
apply(simp add:max_word_def)
done

end


(* Author: Max Haslbeck *)

theory Nielson_VCG imports Nielson_Hoare begin

subsection "Verification Condition Generator"

text\<open>Annotated commands: commands where loops are annotated with
  invariants.\<close>

datatype acom =
  Askip                  ("SKIP") |
  Aassign vname aexp     ("(_ ::= _)" [1000, 61] 61) |
  Aseq   acom acom       ("_;;/ _"  [60, 61] 60) |
  Aif bexp acom acom     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61) |
  Aconseq assn2 assn2 tbd  acom
  ("({_'/_'/_}/ CONSEQ _)"  [0, 0, 0, 61] 61)|
  Awhile "(assn2)*((state\<Rightarrow>state)*(tbd))" bexp acom  ("({_}/ WHILE _/ DO _)"  [0, 0, 61] 61)

notation com.SKIP ("SKIP")

text\<open>Strip annotations:\<close>

fun strip :: "acom \<Rightarrow> com" where
  "strip SKIP = SKIP" |
  "strip (x ::= a) = (x ::= a)" |
  "strip (C\<^sub>1;; C\<^sub>2) = (strip C\<^sub>1;; strip C\<^sub>2)" |
  "strip (IF b THEN C\<^sub>1 ELSE C\<^sub>2) = (IF b THEN strip C\<^sub>1 ELSE strip C\<^sub>2)" |
  "strip ({_/_/_} CONSEQ C) = strip C" |
  "strip ({_} WHILE b DO C) = (WHILE b DO strip C)"

text "support of an expression"

subsubsection "support and supportE"

definition supportE :: "((char list \<Rightarrow> nat) \<Rightarrow> (char list \<Rightarrow> int) \<Rightarrow> nat)  \<Rightarrow> string set" where
  "supportE P = {x. \<exists>l1 l2 s. (\<forall>y. y \<noteq> x \<longrightarrow> l1 y = l2 y) \<and> P l1 s \<noteq> P l2 s}"

lemma expr_lupd: "x \<notin> supportE Q \<Longrightarrow> Q (l(x:=n)) = Q l"
  by(simp add: supportE_def fun_upd_other fun_eq_iff)
    (metis (no_types, lifting) fun_upd_def)

lemma supportE_if: "supportE (\<lambda>l s. if b s then A l s else B l s)
  \<subseteq> supportE A \<union> supportE B"
  unfolding supportE_def apply(auto)
  by metis+

lemma support_eq: "support (\<lambda>l s. l x = E l s) \<subseteq> supportE E \<union> {x}"
  unfolding support_def supportE_def
  apply(auto)
   apply blast
  by metis

lemma support_impl_in: "G e \<longrightarrow> support (\<lambda>l s.  H e l s) \<subseteq> T
  \<Longrightarrow> support (\<lambda>l s. G e \<longrightarrow>  H e l s) \<subseteq> T"
  unfolding support_def apply(auto)
   apply blast+ done

lemma support_supportE: "\<And>P e. support (\<lambda>l s.  P (e l) s) \<subseteq> supportE e"
  unfolding support_def supportE_def
  apply(rule subsetI)
  apply(simp)
proof (clarify, goal_cases)
  case (1 P e x l1 l2 s)
  have P: "\<forall>s. e l1 s = e l2 s \<Longrightarrow> e l1 = e l2" by fast
  show "\<exists>l1 l2. (\<forall>y. y \<noteq> x \<longrightarrow> l1 y = l2 y) \<and> (\<exists>s. e l1 s \<noteq> e l2 s)"
    apply(rule exI[where x=l1])
    apply(rule exI[where x=l2])
    apply(safe)
    using 1 apply blast
    apply(rule ccontr)
    apply(simp)
    using 1(2) P by force
qed

\<comment> \<open>collects the logical variables in the Invariants and Loop Bodies as well as the annotated
    assertions at CONSEQs of an annotated command\<close>
fun varacom :: "acom \<Rightarrow> lvname set" where
  "varacom (C\<^sub>1;; C\<^sub>2)= varacom C\<^sub>1 \<union> varacom C\<^sub>2"
| "varacom (IF b THEN C\<^sub>1 ELSE C\<^sub>2)= varacom C\<^sub>1 \<union> varacom C\<^sub>2"
| "varacom ({P/Qannot/_} CONSEQ C)= support P \<union> varacom C \<union> support Qannot"
| "varacom ({(I,(S,(E)))} WHILE b DO C) = support I \<union> varacom C"
| "varacom _ = {}"

text\<open>Weakest precondition from annotated commands:\<close>

fun preT :: "acom \<Rightarrow> tbd \<Rightarrow> tbd" where
  "preT SKIP e = e" |
  "preT (x ::= a) e = (\<lambda>s. e(s(x := aval a s)))" |
  "preT (C\<^sub>1;; C\<^sub>2) e = preT C\<^sub>1 (preT C\<^sub>2 e)" |
  "preT ({_/_/_} CONSEQ C) e = preT C e" |
  "preT (IF b THEN C\<^sub>1 ELSE C\<^sub>2) e =
  (\<lambda>s. if bval b s then preT C\<^sub>1 e s else preT C\<^sub>2 e s)" |
  "preT ({(_,(S,_))} WHILE b DO C) e = e o S"

lemma preT_linear: "preT C (%s. k * e s) = (%s. k * preT C e s)"
by (induct C arbitrary: e, auto)

fun postQ :: "acom \<Rightarrow> state \<Rightarrow> state" where (* seems to be forward?! *)
  "postQ SKIP s = s" |
  "postQ (x ::= a) s =  s(x := aval a s)" |
  "postQ (C\<^sub>1;; C\<^sub>2) s = postQ C\<^sub>2 (postQ C\<^sub>1 s)" |
  "postQ ({_/_/_} CONSEQ C) s = postQ C s" |
  "postQ (IF b THEN C\<^sub>1 ELSE C\<^sub>2) s =
  (if bval b s then postQ C\<^sub>1 s else postQ C\<^sub>2 s)" |
  "postQ ({(_,(S,_))} WHILE b DO C) s = S s"

lemma TQ: "preT C e s = e (postQ C s)"
  apply(induct C arbitrary: e s) by (auto)

(* given a state, how often will a While loop be evaluated ? *)
function (domintros) times :: "state \<Rightarrow> bexp \<Rightarrow> acom \<Rightarrow> nat" where
  "times s b C = (if bval b s then Suc (times (postQ C s) b C) else 0)"
   apply(auto) done

lemma assumes I: "I z s" and
  i:   "\<And>s z. I (Suc z) s \<Longrightarrow> bval b s \<and> I z (postQ C s)"
  and  ii:  "\<And>s. I 0 s \<Longrightarrow> ~ bval b s"
shows times_z: "times s b C = z"
proof -
  have "I z s \<Longrightarrow> times_dom (s, b, C) \<and> times s b C = z"
  proof(induct z arbitrary: s)
    case 0
    have A: "times_dom (s, b, C)"
      apply(rule times.domintros)
      apply(simp add:  ii[OF 0] ) done
    have B: "times s b C = 0"
      using times.psimps[OF A] by(simp add:  ii[OF 0])

    show ?case using A B by simp
  next
    case (Suc z)
    from i[OF Suc(2)] have bv: "bval b s"
      and g:  "I z (postQ C s)" by simp_all
    from Suc(1)[OF g] have p1: "times_dom (postQ C s, b, C)"
      and p2: "times (postQ C s) b C = z" by simp_all
    have A: "times_dom (s, b, C)"
      apply(rule times.domintros) apply(rule p1) done
    have B: "times s b C = Suc z"
      using times.psimps[OF A] bv p2 by simp
    show ?case using A B by simp
  qed

  then show "times s b C = z" using I by simp
qed

function (domintros) postQs :: "acom \<Rightarrow> bexp \<Rightarrow> state \<Rightarrow> state" where
  "postQs C b s = (if bval b s then (postQs C b (postQ C s))  else s)"
  apply(auto) done

fun postQz :: "acom \<Rightarrow> state \<Rightarrow> nat \<Rightarrow> state" where
  "postQz C s 0 = s" |
  "postQz C s (Suc n) =  (postQz C (postQ C s) n)"

fun preTz :: "acom \<Rightarrow> tbd \<Rightarrow> nat \<Rightarrow> tbd" where
  "preTz C e 0 = e" |
  "preTz C e (Suc n) = preT C (preTz C e n)"

lemma TzQ: "preTz C e n s = e (postQz C s n)"
  by (induct n arbitrary: s, simp_all add: TQ)

subsubsection \<open>Weakest precondition from annotated commands:\<close>

fun pre :: "acom \<Rightarrow> assn2 \<Rightarrow> assn2" where
  "pre SKIP Q  = Q" |
  "pre (x ::= a) Q = (\<lambda>l s. Q l (s(x := aval a s)))" |
  "pre (C\<^sub>1;; C\<^sub>2) Q  = pre C\<^sub>1 (pre C\<^sub>2 Q)" |
  "pre ({P'/_/_} CONSEQ C) Q = P'" |
  "pre (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q =
  (\<lambda>l s. if bval b s then pre C\<^sub>1 Q l s else pre C\<^sub>2 Q l s)" |
  "pre ({(I,(S,(E)))} WHILE b DO C) Q = I"

lemma supportE_preT: "supportE (%l. preT C (e l)) \<subseteq> supportE e"
proof(induct C arbitrary: e)
  case (Aif b C1 C2 e)
  show ?case
    apply(simp)
    apply(rule subset_trans[OF supportE_if])
    using Aif by fast
next
  case (Awhile A y C e)
  obtain I S E  where A: "A= (I,S,E)" using prod_cases3 by blast
  show ?case using A apply(simp) unfolding supportE_def
    by blast
next
  case (Aseq)
  then show ?case by force
qed (simp_all add: supportE_def, blast)

lemma supportE_twicepreT: "supportE (%l. preT C1 (preT C2 (e l))) \<subseteq> supportE e"
  by (rule subset_trans[OF supportE_preT supportE_preT])

lemma supportE_preTz: "supportE (%l. preTz C (e l) n) \<subseteq> supportE e"
proof (induct n)
  case (Suc n)
  show ?case
    apply(simp)
    apply(rule subset_trans[OF supportE_preT])
    by fact
qed simp

lemma supportE_preTz_Un: (* like in support_wpw_Un *)
  "supportE (\<lambda>l. preTz C (e l) (l x)) \<subseteq> insert x (UN n. supportE (\<lambda>l. preTz C (e l) n))"
  apply(auto simp add: supportE_def subset_iff)
  apply metis
  done

lemma supportE_preTz2: "supportE (%l. preTz C (e l) (l x)) \<subseteq> insert x (supportE e)"
  apply(rule subset_trans[OF supportE_preTz_Un])
  using supportE_preTz by blast

lemma pff: "\<And>n. support (\<lambda>l. I (l(x := n))) \<subseteq> support I - {x}"
  unfolding support_def apply(auto)  using fun_upd_apply apply smt
    apply (smt fun_upd_apply)  oops

lemma pff: "\<And>n. support (\<lambda>l. I (l(x := n))) \<subseteq> support I"
  unfolding support_def apply(auto)  using fun_upd_apply apply smt
  by (smt fun_upd_apply)

lemma supportAB: "support (\<lambda>l s. A l s \<and> B s) \<subseteq> support A"
  apply(rule subset_trans[OF support_and])
    by (simp add: support_inv)

lemma "support (pre ({(I,(S,(E )))} WHILE b DO C) Q) \<subseteq> support I"
 by (simp add: supportAB)

lemma support_pre: "support (pre C Q) \<subseteq> support Q \<union> varacom C"
proof (induct C arbitrary: Q)
  case (Awhile A b C Q)
  obtain I S E  where A: "A= (I,(S,(E )))" using prod_cases3 by blast
  have support_inv: "\<And>P. support (\<lambda>l s. P s) = {}"
    unfolding support_def by blast
  show ?case unfolding A  apply(simp) using supportAB  by fast
next
  case (Aseq C1 C2)
  then show ?case by(auto)
next
  case (Aif x C1 C2 Q)
  have s1: "support (\<lambda>l s. bval x s \<longrightarrow> pre C1 Q l s) \<subseteq> support Q \<union> varacom C1"
    apply(rule subset_trans[OF support_impl]) by(rule Aif)
  have s2: "support (\<lambda>l s. ~ bval x s \<longrightarrow> pre C2 Q l s) \<subseteq> support Q \<union> varacom C2"
    apply(rule subset_trans[OF support_impl]) by(rule Aif)

  show ?case apply(simp)
    apply(rule subset_trans[OF support_and])
    using s1 s2 by blast
next
  case (Aconseq x1 x2 x3 C)
  then show ?case by(auto)
qed (auto simp add: support_def)

lemma finite_support_pre[simp]: "finite (support Q)  \<Longrightarrow> finite (varacom C) \<Longrightarrow>  finite (support (pre C Q))"
  using finite_subset support_pre finite_UnI by metis

fun time :: "acom \<Rightarrow> tbd" where
  "time SKIP = (%s. Suc 0)" |
  "time (x ::= a) = (%s. Suc 0)" |
  "time (C\<^sub>1;; C\<^sub>2) = (%s. time C\<^sub>1 s + preT C\<^sub>1 (time C\<^sub>2) s)" |
  "time ({_/_/e} CONSEQ C) = e" |
  "time (IF b THEN C\<^sub>1 ELSE C\<^sub>2) =
  (\<lambda>s. if bval b s then 1 + time C\<^sub>1 s else 1 + time C\<^sub>2 s)" |
  "time ({(_,(E',(E )))} WHILE b DO C) = E"

lemma supportE_single: "supportE (\<lambda>l s. P) = {}"
  unfolding supportE_def by blast

lemma supportE_plus: "supportE (\<lambda>l s. e1 l s + e2 l s) \<subseteq> supportE e1 \<union> supportE e2"
  unfolding supportE_def apply(auto)
  by metis

lemma supportE_Suc: "supportE (\<lambda>l s. Suc (e1 l s)) = supportE e1"
  unfolding supportE_def by (auto)

lemma supportE_single2: "supportE (\<lambda>l . P) = {}"
  unfolding supportE_def by blast

lemma supportE_time: "supportE (\<lambda>l. time C) = {}"
  using supportE_single2 by simp

lemma "\<And>s. (\<forall>l. I (l(x:=0)) s) = (\<forall>l. l x = 0 \<longrightarrow> I l s)"
  apply(auto)
  by (metis fun_upd_triv)

lemma "\<And>s. (\<forall>l. I (l(x:=Suc (l x))) s) = (\<forall>l. (\<exists>n. l x = Suc n) \<longrightarrow> I l s)"
  apply(auto)
proof (goal_cases)
  case (1 s l n)
  then have "\<And>l. I (l(x := Suc (l x))) s" by simp
  from this[where l="l(x:=n)"]
  have "I ((l(x:=n))(x := Suc ((l(x:=n)) x))) s" by simp
  then show ?case using 1(2) apply(simp)
    by (metis fun_upd_triv)
qed

text\<open>Verification condition:\<close>
fun vc :: "acom \<Rightarrow> assn2  \<Rightarrow> bool" where
  "vc SKIP Q = True" |
  "vc (x ::= a) Q = True" |
  "vc (C\<^sub>1 ;; C\<^sub>2) Q = ((vc C\<^sub>1 (pre C\<^sub>2 Q)) \<and> (vc C\<^sub>2 Q) )" |
  "vc (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q = (vc C\<^sub>1 Q \<and> vc C\<^sub>2 Q)" |
  "vc ({P'/Q/e'} CONSEQ C) Q' = (vc C Q \<and> (\<exists>k>0. (\<forall>l s. P' l s \<longrightarrow> time C s \<le> k * e' s  \<and> (\<forall>t. \<exists>l'. (pre C Q) l' s \<and> ( Q l' t \<longrightarrow> Q' l t) ))))" |

  "vc ({(I,(S,(E)))} WHILE b DO C) Q =
  ((\<forall>l s. (I l s \<and> bval b s \<longrightarrow>  pre C I l s \<and>   E s \<ge> 1 + preT C E s + time C s
  \<and> S s = S (postQ C s)) \<and>
  (I l s \<and> \<not> bval b s \<longrightarrow> Q l s \<and> E s \<ge> 1 \<and> S s = s) ) \<and>
  vc C I)"

lemma pre_mono:
  "(\<forall>l s. P l s \<longrightarrow> P' l s) \<Longrightarrow> pre C P l s \<Longrightarrow> pre C P' l s"
proof (induction C arbitrary: P P' l s)
  case (Aseq C1 C2)
  then have A: "pre C1 (pre C2 P) l s" by(simp)
  from Aseq(2)[OF Aseq(3)] Aseq(1)[OF _ A]
  show ?case by simp
next
  case (Awhile A b C)
  then obtain I S E   where A: "A = (I,S,E )"  using prod_cases3 by blast
  from Awhile show ?case unfolding A by simp
qed simp_all

lemma vc_mono: "(\<forall>l s. P l s \<longrightarrow> P' l s) \<Longrightarrow> vc C P \<Longrightarrow> vc C P'"
  apply (induct C arbitrary: P P')
       apply auto
  subgoal using pre_mono by metis
  subgoal using pre_mono by metis
  done

subsubsection \<open>Soundness:\<close>

abbreviation "preSet U C l s == (Ball U (%u. case u of (x,e) \<Rightarrow> l x = preT C e s))"
abbreviation "postSet U l s == (Ball U (%u. case u of (x,e) \<Rightarrow> l x = e s))"

fun ListUpdate where
  "ListUpdate f [] l = f"
| "ListUpdate f ((x,e)#xs) q = (ListUpdate f xs q)(x:=q e x)"

lemma allg:
  assumes U2: "\<And>l s n x. x\<in> fst ` upds \<Longrightarrow> A (l(x := n))  = A l"
  shows
    "fst ` set xs \<subseteq> fst ` upds \<Longrightarrow> A (ListUpdate l'' xs q) = A l''"
proof (induct xs)
  case (Cons a xs)
  obtain x e where axe: "a = (x,e)" by fastforce
  have "A (ListUpdate l'' (a # xs) q)
    = A ((ListUpdate l'' xs q)(x := q e x))  " unfolding axe by(simp)
  also have
    "\<dots> =  A  (ListUpdate l'' xs q)  "
    apply(rule U2)
    using Cons axe by force
  also have "\<dots> = A l'' "
    using Cons by force
  finally show ?case .
qed simp

fun ListUpdateE where
  "ListUpdateE f []   = f"
| "ListUpdateE f ((x,v)#xs)  = (ListUpdateE f xs  )(x:=v)"

lemma ListUpdate_E: "ListUpdateE f xs = ListUpdate f xs (%e x. e)"
  apply(induct xs) apply(simp_all)
  subgoal for a xs apply(cases a) apply(simp) done
  done
lemma allg_E: fixes A::assn2
    assumes
   " (\<And>l s n x. x \<in> fst ` upds \<Longrightarrow> A (l(x := n)) = A l)" "fst ` set xs \<subseteq> fst ` upds"
   shows "A (ListUpdateE f xs) = A f"
proof -
  have " A (ListUpdate f xs (%e x. e)) = A f"
    apply(rule allg)
    apply fact+ done
  then show ?thesis by(simp only: ListUpdate_E)
qed

lemma ListUpdateE_updates: "distinct (map fst xs) \<Longrightarrow> x \<in> set xs \<Longrightarrow> ListUpdateE l'' xs (fst x) = snd x"
proof (induct xs)
  case Nil
  then show ?case apply(simp) done
next
  case (Cons a xs)
  show ?case
  proof (cases "fst a = fst x")
    case True
    then obtain y e where a: "a=(y,e)" by fastforce
    with True have fstx: "fst x=y" by simp
    from Cons(2,3) fstx  a have a2: "x=a"
      by force
    show ?thesis unfolding a2 a by(simp)
  next
    case False
    with Cons(3) have A: "x\<in>set xs" by auto
    obtain y e where a: "a=(y,e)" by fastforce
    from Cons(2) have B: "distinct (map fst xs)" by simp
    from Cons(1)[OF B A] False
      show ?thesis unfolding a by(simp)
  qed
qed

lemma ListUpdate_updates: "x \<in> fst ` (set xs) \<Longrightarrow> ListUpdate l'' xs (%e. l) x = l x"
proof(induct xs)
  case Nil
  then show ?case by(simp)
next
  case (Cons a xs)
  obtain q p where axe: "a = (p,q)" by fastforce
  from Cons show ?case unfolding axe
    apply(cases "x=p")
    by(simp_all)
qed

abbreviation "lesvars xs == fst ` (set xs)"

fun preList where
  "preList [] C l s = True"
| "preList ((x,e)#xs) C l s = (l x = preT C e s \<and> preList xs C l s)"

lemma preList_Seq: "preList upds (C1;; C2) l s = preList (map (\<lambda>(x, e). (x, preT C2 e)) upds) C1 l s"
proof (induct upds)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  obtain y e where a: "a=(y,e)" by fastforce
  from Cons show ?case unfolding a by (simp)
qed

lemma support_True[simp]: "support (\<lambda>a b. True) = {}"
  unfolding support_def
  by fast

lemma support_preList: "support (preList upds C1) \<subseteq> lesvars upds"
proof (induct upds)
  case Nil
  then show ?case by simp
next
  case (Cons a upds)
  obtain y e where a: "a=(y,e)" by fastforce
  from Cons show ?case unfolding a apply (simp)
    apply(rule subset_trans[OF support_and])
    apply(rule Un_least)
    subgoal apply(rule subset_trans[OF support_eq])
      using supportE_twicepreT subset_trans  supportE_single2 by simp
    subgoal by auto
    done
qed

lemma preListpreSet: "preSet (set xs) C l s \<Longrightarrow> preList xs C l s"
proof (induct xs)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  obtain y e where a: "a=(y,e)" by fastforce
  from Cons show ?case unfolding a by (simp)
qed

lemma preSetpreList: "preList xs C l s \<Longrightarrow>  preSet (set xs) C l s"
proof (induct xs)
  case (Cons a xs)
  obtain y e where a: "a=(y,e)" by fastforce
  from Cons show ?case unfolding a
    by(simp)
qed simp

(* surprise. but makes sense, if the clauses are contradictory on the
    left side, so are they on the right side *)
lemma preSetpreList_eq: "preList xs C l s = preSet (set xs) C l s"
proof (induct xs)
  case (Cons a xs)
  obtain y e where a: "a=(y,e)" by fastforce
  from Cons show ?case unfolding a
    by(simp)
qed simp

fun postList where
  "postList []  l s = True"
| "postList ((x,e)#xs)  l s = (l x = e s \<and> postList xs l s)"

lemma support_postList: "support (postList xs) \<subseteq> lesvars xs"
proof (induct xs)
  case (Cons a xs)
  obtain y e where a: "a=(y,e)" by fastforce
  from Cons show ?case unfolding a
    apply(simp) apply(rule subset_trans[OF support_and])
    apply(rule Un_least)
    subgoal apply(rule subset_trans[OF support_eq])
      using supportE_twicepreT subset_trans  supportE_single2 by simp
    subgoal by(auto)
      done
qed simp

lemma postpreList_inv: assumes "S s = S (postQ C s)"
  shows "postList (map (\<lambda>(x, e). (x, \<lambda>s. e (S s))) upds) l s =  preList (map (\<lambda>(x, e). (x, \<lambda>s. e (S s))) upds) C l s"
proof (induct upds)
  case (Cons a upds)
  obtain y e where axe: "a = (y,e)" by fastforce

  from Cons show ?case unfolding axe apply(simp)
      apply(simp only: TQ) using assms by auto
qed simp

lemma postList_preList: "postList (map (\<lambda>(x, e). (x, preT C e)) upds) l s = preList upds C l s"
proof (induct upds)
  case (Cons a xs)
  obtain y e where a: "a=(y,e)" by fastforce
  from Cons show ?case unfolding a
    by(simp)
qed simp

lemma postSetpostList: "postList xs l s \<Longrightarrow>  postSet (set xs) l s"
proof (induct xs)
  case (Cons a xs)
  obtain y e where a: "a=(y,e)" by fastforce
  from Cons show ?case unfolding a
    by(simp)
qed simp

lemma postListpostSet: "postSet (set xs) l s \<Longrightarrow> postList xs l s"
proof (induct xs)
  case (Cons a xs)
  obtain y e where a: "a=(y,e)" by fastforce
  from Cons show ?case unfolding a
    by(simp)
qed simp

lemma ListAskip: "preList xs Askip l s = postList xs  l s"
  apply(induct xs)
   apply(simp) by force

lemma SetAskip: "preSet U Askip l s = postSet U l s"
by simp

lemma ListAassign: "preList upds (Aassign x1 x2) l s = postList upds l (s[x2/x1])"
  apply(induct upds)
   apply(simp) by force

lemma SetAassign: "preSet U (Aassign x1 x2) l s = postSet U l (s[x2/x1])"
by simp

lemma ListAconseq: "preList upds (Aconseq x1 x2 x3 C) l s = preList upds C l s"
  apply(induct upds)
   apply(simp) by force

lemma SetAconseq: "preSet U (Aconseq x1 x2 x3 C) l s = preSet U C l s"
by simp

lemma ListAif1: "bval b s \<Longrightarrow> preList upds (IF b THEN C1 ELSE C2) l s = preList upds C1 l s"
  apply(induct upds)
   apply(simp) by force
lemma SetAif1: "bval b s \<Longrightarrow> preSet upds (IF b THEN C1 ELSE C2) l s = preSet upds C1 l s"
  apply(simp) done
lemma ListAif2: "~ bval b s \<Longrightarrow> preList upds (IF b THEN C1 ELSE C2) l s = preList upds C2 l s"
  apply(induct upds)
   apply(simp) by force

lemma SetAif2: "~ bval b s \<Longrightarrow> preSet upds (IF b THEN C1 ELSE C2) l s = preSet upds C2 l s"
  apply(simp) done

(*
  In upds we collect pairs of logical variables and time expressions, these logical variables
  are bound to the value of these expressions. postList upds C l s is an assertion stating that
  for every (x,e) in upds, l x = e s; preList upds C l s does the same, but pulls the expression
  e through the command c, i.e. stating for ever (x,e) in upds, l x = preT C e s.

  we have to make sure, that no variable is assigned twice (the 5th premise), as well as they are
  different from all the logical variables that occur in the annotated program C (4th premise)

  we have to make sure that we can always choose new logical variables (premise 2, 3)
*)
lemma vc_sound: "vc C Q \<Longrightarrow> finite (support Q) \<Longrightarrow> finite (varacom C)
  \<Longrightarrow> fst ` (set upds) \<inter> varacom C = {} \<Longrightarrow> distinct (map fst upds)
  \<Longrightarrow>  \<turnstile>\<^sub>1 {%l s. pre C Q l s \<and> preList upds C l s} strip C { time C \<Down> %l s. Q l s \<and> postList upds l s}
  \<and> (\<forall>l s. pre C Q l s \<longrightarrow> Q l (postQ C s))"
proof(induction C arbitrary: Q upds)
  case (Askip Q upds)
  then show ?case
    apply(auto)
    apply(rule weaken_post[where Q="%l s. Q l s \<and> preList upds Askip l s"])
     apply(simp add: Skip)  using ListAskip
    by fast
next
  case (Aassign x1 x2 Q upds)
  then show ?case apply(safe) apply(auto simp add: Assign)[1]
     apply(rule weaken_post[where Q="%l s. Q l s \<and> postList upds l s"])
      apply(simp only: ListAassign)
      apply(rule Assign) apply simp
    apply(simp only: postQ.simps pre.simps) done
next
  case (Aif b C1 C2 Q upds )
  then show ?case apply(auto simp add: Assign)
     apply(rule If2[where e="\<lambda>a. if bval b a then  time C1 a else time C2 a"])
    subgoal
      apply(simp cong: rev_conj_cong)
      apply(rule ub_cost[where e'="time C1"])
       apply(simp) apply(auto)[1]
      apply(rule strengthen_pre[where P="%l s. pre C1 Q l s \<and> preList upds C1 l s"])
        using ListAif1
       apply fast
      apply(rule Aif(1)[THEN conjunct1])
           apply(auto)
      done
    subgoal
      apply(simp cong: rev_conj_cong)
      apply(rule ub_cost[where e'="time C2"])  (* k=1 and *)
       apply(simp) apply(auto)[1]
      apply(rule strengthen_pre[where P="%l s. pre C2 Q l s \<and> preList upds C2 l s"])
        using ListAif2
       apply fast
      apply(rule Aif(2)[THEN conjunct1])
           apply(auto)
      done
     apply auto apply fast+ done
next
  case (Aconseq P' Qannot eannot C Q upds)
  then obtain k where k: "k>0" and ih1: "vc C Qannot"
    and ih1': " (\<forall>l s. P' l s \<longrightarrow>  time C s \<le> k * eannot s \<and> (\<forall>t. \<exists>l'. pre C Qannot l' s \<and> (Qannot l' t \<longrightarrow> Q l t)))"
    by auto

  have ih2': "\<forall>l s. pre C Qannot l s \<longrightarrow> Qannot l (postQ C s)"
    apply(rule Aconseq(1)[THEN conjunct2]) using Aconseq(2-6) by auto

  have G1: "\<turnstile>\<^sub>1 {\<lambda>l s. P' l s \<and> preList upds ({P'/Qannot/eannot} CONSEQ C) l s} strip C
         { eannot \<Down> \<lambda>l s. Q l s \<and> postList upds l s}"
  proof (rule conseq[rotated])
    show "\<turnstile>\<^sub>1 {\<lambda>l s. pre C Qannot l s \<and> preList upds C l s} strip C { time C \<Down> \<lambda>l s. Qannot l s \<and> postList upds l s}"
    apply(rule Aconseq(1)[THEN conjunct1])
      using Aconseq(2-6) by auto
  next
    show "\<exists>k>0. \<forall>l s. P' l s \<and> preList upds ({P'/Qannot/eannot} CONSEQ C) l s \<longrightarrow>
              time C s \<le> k * eannot s \<and>
              (\<forall>t. \<exists>l'. (pre C Qannot l' s \<and> preList upds C l' s) \<and>
                        (Qannot l' t \<and> postList upds l' t \<longrightarrow> Q l t \<and> postList upds l t))"
    proof(rule exI[where x=k], safe)
      fix l s
      assume P': "P' l s" and prelist: "preList upds ({P'/Qannot/eannot} CONSEQ C) l s"
      then show "time C s \<le> k * eannot s" using ih1' by simp

      fix t
      \<comment> \<open>we now have to construct a logical environment, that both
          * satisfies the annotated postcondition Qannot (we obtain it from the first IH)
          * lets the updates come true (we have to show that resetting these logical variables
              does not interfere with the other variables)\<close>

      from ih1' P' have satQan:"(\<exists>l'. pre C Qannot l' s \<and> (Qannot l' t \<longrightarrow> Q l t))" by simp
      then obtain l' where i': "pre C Qannot l' s" and ii': "(Qannot l' t \<longrightarrow> Q l t)" by blast

      let ?upds' = "(map (%(x,e). (x,preT C e s)) upds)"
      let ?l'' = "(ListUpdateE l' ?upds')"

      {
        fix l s n x
        assume "x \<in> fst ` (set upds)"
        then have "x \<notin> support (pre C Qannot)" using Aconseq(5) support_pre by auto
        from assn2_lupd[OF this] have "pre C Qannot (l(x := n))  = pre C Qannot l" .
      } note U2=this
      {
        fix l s n x
        assume "x \<in> fst ` (set upds)"
        then have "x \<notin> support Qannot" using Aconseq(5) by auto
        from assn2_lupd[OF this] have "Qannot (l(x := n))  = Qannot l" .
      } note K2=this

      have "pre C Qannot ?l''  = pre C Qannot l'  "
        apply(rule allg_E[where ?upds="set upds"]) apply(rule U2) by force+
      with i' have i'': "pre C Qannot ?l'' s" by simp

      have "Qannot ?l'' = Qannot l'"
        apply(rule allg_E[where ?upds="set upds"]) apply(rule K2) by force+
      then have K: "(%l' s. Qannot l' t \<longrightarrow> Q l t) ?l'' s = (%l' s. Qannot l' t \<longrightarrow> Q l t) l' s"
        by simp
      with ii' have ii'': "(Qannot ?l'' t \<longrightarrow> Q l t)" by simp

      have xs_upds: "map fst ?upds' = map fst upds"
           by auto
      have resets: "\<And>x. x \<in> set ?upds' \<Longrightarrow> ListUpdateE l' ?upds' (fst x) = snd x" apply(rule ListUpdateE_updates)
         apply(simp only: xs_upds) using Aconseq(6) apply simp
           apply(simp) done

      have A: "preList upds C ?l'' s"
      proof (rule preListpreSet,safe,goal_cases)
        case (1 x e)
        then have "(x, preT C e s) \<in> set ?upds'"
          by fastforce
        from resets[OF this, simplified]
        show ?case .
      qed

      have B: "Qannot ?l'' t \<Longrightarrow> postList upds ?l'' t \<Longrightarrow> postList upds l t"
      proof (rule postListpostSet, safe, goal_cases)
        case (1 x e)
        from postSetpostList[OF 1(2)] have g: "postSet (set upds) ?l'' t" .
        with 1(3) have A: "?l'' x = e t"
          by fast
        from 1(3) resets[of "(x,preT C e s)"] have   B: "?l'' x = snd (x, preT C e s)"
          by fastforce
        from A B have X: "e t = preT C e s" by fastforce
        from preSetpreList[OF prelist] have "preSet (set upds) ({P'/Qannot/eannot} CONSEQ C) l s" .
        with 1(3) have Y: "l x = preT C e s" apply(simp) by fast
        from X Y show ?case by simp
      qed

      show "\<exists>l'. (pre C Qannot l' s \<and> preList upds C l' s) \<and>
                  (Qannot l' t \<and> postList upds l' t \<longrightarrow> Q l t \<and> postList upds l t)"
        apply(rule exI[where x="?l''"], safe)
        using i'' A ii'' B by auto
    qed fact
  qed

  have G2: "\<And>l s. P' l s \<Longrightarrow> Q l (postQ C s)"
  proof -
    fix l s
    assume "P' l s"
    with ih1' ih2' show "Q l (postQ C s)" by blast
  qed

  show ?case using G1 G2 by auto
next
  case (Aseq C1 C2 Q upds)

  let ?P = "(\<lambda>l s. pre (C1;; C2) Q l s \<and> preList upds (C1;;C2) l s  )"
  let ?P' = "support Q \<union> varacom C1 \<union> varacom C2 \<union> lesvars upds"

  have finite_varacom: "finite (varacom (C1;; C2))" by fact
  have sup_L: "support (preList upds (C1;;C2)) \<subseteq> lesvars upds"
    apply(rule support_preList) done

  \<comment> \<open>choose a fresh logical variable ?y in order to pull through the cost of the second command\<close>
  let ?y = "SOME x. x \<notin> ?P'"
  have fP': "finite (?P')" using finite_varacom Aseq(4,5)   apply simp done
  from fP' have "\<exists>x. x \<notin> ?P'" using infinite_UNIV_listI
    using ex_new_if_finite by metis
  hence ynP': "?y \<notin> ?P'" by (rule someI_ex)
  hence ysupC1: "?y \<notin> varacom C1" using support_pre by auto
  have sup_B: "support ?P \<subseteq> ?P'"
    apply(rule subset_trans[OF support_and]) apply simp using support_pre sup_L by blast

  \<comment> \<open>we show the first goal: we can deduce the desired Hoare Triple\<close>
  have C1: "\<turnstile>\<^sub>1 {\<lambda>l s. pre (C1;; C2) Q l s \<and> preList upds (C1;; C2) l s} strip C1;; strip C2
         { time (C1;; C2) \<Down> \<lambda>l s. Q l s \<and> postList upds l s}"
  proof (rule Seq[rotated])
    \<comment> \<open>start from the back: we can simply use the IH for C2,
          and solve the side conditions automatically\<close>
    show "\<turnstile>\<^sub>1 {(%l s. pre C2 Q l s \<and>  preList upds C2 l s )} strip C2 { time C2 \<Down> (%l s. Q l s \<and> postList upds l s)}"
      apply(rule Aseq(2)[THEN conjunct1])
      using Aseq(3-7) by auto
  next
    \<comment> \<open>prepare the new updates: pull them through C2 and save the new execution time of C2 in ?y\<close>
    let ?upds = "map (\<lambda>a. case a of (x,e) \<Rightarrow> (x, preT C2 e )) upds"
    let ?upds' = "(?y,time C2)#?upds"

    have dst_upds': "distinct (map fst ?upds')"
      using  ynP' Aseq(7) apply simp apply safe
        using image_iff apply fastforce  by (simp add: case_prod_beta' distinct_conv_nth)

    \<comment> \<open>now use the first induction hypothesis (specialised with the augmented upds list, and the
        weakest precondition of Q through C as post condition)\<close>
    have IH1s: "\<turnstile>\<^sub>1 {\<lambda>l s. pre C1 (pre C2 Q) l s \<and> preList ?upds' C1 l s} strip C1
                    { time C1 \<Down> \<lambda>l s. pre C2 Q l s \<and> postList ?upds' l s}"
      apply(rule Aseq(1)[THEN conjunct1])
        using Aseq(3-7) ysupC1 dst_upds' by auto

    \<comment> \<open>glue it together with a consequence rule, side conditions are automatic\<close>
    show " \<turnstile>\<^sub>1 {\<lambda>l s. (pre (C1;; C2) Q l s \<and> preList upds (C1;; C2) l s) \<and> l ?y = preT C1 (time C2) s} strip C1
     { time C1 \<Down> \<lambda>l s. (\<lambda>l s. pre C2 Q l s \<and> preList upds C2 l s) l s \<and> time C2 s \<le> l ?y}"
      apply(rule conseq_old[OF _ IH1s])
      by (auto simp: preList_Seq postList_preList)
  next
    \<comment> \<open>solve some side conditions showing that, ?y is indeed fresh\<close>
    show "?y \<notin> support ?P"
      using sup_B ynP' by auto
    have F: "support (preList upds C2) \<subseteq> lesvars upds"
      apply(rule support_preList) done
    have "support (\<lambda>l s. pre C2 Q  l s \<and> preList upds C2 l s) \<subseteq> ?P'"
      apply(rule subset_trans[OF support_and]) using F support_pre by blast
    with ynP'
    show "?y \<notin> support (\<lambda>l s. pre C2 Q l s \<and> preList upds C2 l s)" by blast
  qed simp

  \<comment> \<open>we show the second goal: weakest precondition implies, that
        Q holds after the execution of C1 and C2\<close>
  have C2: "\<And>l s. pre (C1;; C2) Q l s \<Longrightarrow> Q l (postQ (C1;; C2) s)"
  proof -
    fix l s
    assume p: "pre (C1;; C2) Q l s"
    have A: "\<forall>l s. pre C1 (pre C2 Q )  l s \<longrightarrow> pre C2 Q  l (postQ C1 s)"
      apply(rule Aseq(1)[where upds="[]", THEN conjunct2])
      using Aseq by auto
    have B: "(\<forall>l s. pre C2 Q  l s \<longrightarrow> Q l (postQ C2 s))"
      apply(rule Aseq(2)[where upds="[]", THEN conjunct2])
      using Aseq by auto
    from p A B show "Q l (postQ (C1;; C2) s)" by simp
  qed

  show ?case using C1 C2 by simp
next
  case (Awhile A b C Q upds)

  \<comment> \<open>Let us first see, what we got from the induction hypothesis:\<close>
  obtain I S E  where [simp]: "A = (I,(S,(E)))" using prod_cases3 by blast
  with \<open>vc (Awhile A b C) Q\<close> have "vc (Awhile (I,S,E) b C) Q" by blast
  then  have vc: "vc C I"  and  pre2: "\<And>l s. I l s \<Longrightarrow> \<not> bval b s \<Longrightarrow>  Q l s \<and> 1 \<le> E s \<and> S s = s"
    and IQ2: "\<And>l s. I l s \<Longrightarrow> bval b s \<Longrightarrow>
                         pre C I l s
                          \<and>  1 + preT C E s + time C s \<le> E s \<and> S s = S (postQ C s)"  by auto

  \<comment> \<open>the logical variable x represents the number of loop unfoldings\<close>

  from IQ2 have IQ_in: "\<And>l s. I l s \<Longrightarrow>   bval b s \<Longrightarrow> S s = S (postQ C s)" by auto

  have inv_impl: "\<And>l s.  I l s \<Longrightarrow>   bval b s \<Longrightarrow>  pre C I  l s" using IQ2 by auto

  have yC: " lesvars upds \<inter> varacom C = {}" using Awhile(5) by auto

  let ?upds = "map (%(x,e). (x, %s. e (S s))) upds"
  let ?INV = "%l s. I l s \<and> postList ?upds l s"

  have "lesvars upds \<inter> support I = {}" using Awhile(5) by auto

  \<comment> \<open>we need a fresh variable ?z to remember the time bound of the tail of the loop\<close>
  let ?P="lesvars upds \<union> varacom ({A} WHILE b DO C)"
  let ?z="SOME z::lvname. z \<notin> ?P"
  have "finite ?P" using Awhile by auto
  hence "\<exists>z. z\<notin>?P"  using infinite_UNIV_listI
    using ex_new_if_finite by metis
  hence znP: "?z \<notin> ?P" by (rule someI_ex)
  from znP have (* znx:  "?z\<noteq>x"
    and *) zny:  "?z \<notin> lesvars upds"
    and zI:   "?z \<notin> support I"
    and blb:  "?z \<notin> varacom C" by (simp_all)

  from Awhile(4,6) have 23: "finite (varacom C)"
    and  26: "finite (support I)" by auto

  have "\<forall>l s.  pre C I  l s \<longrightarrow> I l (postQ C s)"
    apply(rule Awhile(1)[THEN conjunct2]) by(fact)+
  hence step: "\<And>l s. pre C I l s \<Longrightarrow> I l (postQ C s)" by simp

  \<comment> \<open>we adapt the updates, by pulling them through the loop body
      and remembering the time bound of the tail of the loop\<close>
  let ?upds = "map (\<lambda>(x, e). (x, \<lambda>s. e (S s))) upds"
  have fua: "lesvars ?upds = lesvars upds"
    by force
  let ?upds' = "(?z,E) # ?upds"

  have g: "\<And>e. e \<circ> S = (%s. e (S s))" by auto

  \<comment> \<open>show that the Hoare Rule is derivable\<close>
  have G1: "\<turnstile>\<^sub>1 {\<lambda>l s. I l s \<and> preList upds ({(I, S, E)} WHILE b DO C) l s} WHILE b DO strip C
         { E \<Down> \<lambda>l s. Q l s \<and> postList upds l s}"
  proof(rule conseq_old)
    show "\<turnstile>\<^sub>1 {\<lambda>l s. I l s \<and> postList ?upds l s} WHILE b DO strip C
              { E \<Down> \<lambda>l s. (I l s \<and> postList ?upds l s) \<and> \<not>bval b s }"
    \<comment> \<open>We use the While Rule and then have to show, that ...\<close>
    proof(rule While, goal_cases)
      \<comment> \<open>A) the loop body preserves the loop invariant\<close>
      have "lesvars ?upds' \<inter> varacom C = {}"
        using yC blb by(auto)

      have z: "(fst \<circ> (\<lambda>(x, e). (x, \<lambda>s. e (S s)))) = fst" by auto
      have "distinct (map fst ?upds')"
        using Awhile(6) zny by (auto simp add: z)

      \<comment> \<open>for showing preservation of the invariant, use the consequence rule ...\<close>
      show "\<turnstile>\<^sub>1 {\<lambda>l s. (I l s \<and> postList ?upds l s) \<and> bval b s \<and> preT C E s = l ?z}
       strip C {  time C \<Down> \<lambda>l s. (I l s \<and> postList ?upds l s) \<and> E s \<le> l ?z}"
      proof (rule conseq_old)
        \<comment> \<open>... and employ the induction hypothesis, ...\<close>
        show " \<turnstile>\<^sub>1 {\<lambda>l s. pre C I l s \<and> preList ?upds' C l s} strip C
                { time C \<Down> \<lambda>l s. I l s \<and> postList ?upds' l s}"
          apply(rule Awhile.IH[THEN conjunct1]) by fact+
      next
        \<comment> \<open>finally we have to prove the side condition.\<close>
        show "\<exists>k>0. \<forall>l s. (I l s \<and> postList ?upds l s) \<and> bval b s \<and> preT C E s = l ?z
                   \<longrightarrow> (pre C I l s \<and> preList ?upds' C l s) \<and> time C s \<le> k * time C s"
          apply(rule exI[where x=1]) apply(simp)
        proof (safe, goal_cases)
          case (2 l s)
          note upds_invariant=postpreList_inv[OF IQ_in[OF 2(1)]]
          from 2  upds_invariant   show ?case by auto
        next
          case (1 l s) then show ?case using inv_impl by auto
        qed
      qed auto
    next
      \<comment> \<open>B) the invariant with number of loop unfoldings greater than 0 implies true loop guard
             and running time is correctly bounded\<close>
      show "\<forall>l s. bval b s  \<and> I l s \<and> postList ?upds l s \<longrightarrow> 1 + preT C E s + time C s \<le> E s"
      proof (clarify, goal_cases)
        case (1 l s)
        show ?case using IQ2 1(1,2) by auto
      qed
    next
      \<comment> \<open>C) the invariant with number of loop unfoldings equal to 0 implies false loop guard
             and running time is correctly bounded\<close>
      show "\<forall>l s.  \<not> bval b s \<and> I l s \<and> postList ?upds l s \<longrightarrow>  1 \<le> E s"
      proof (clarify, goal_cases)
        case (1 l s)
        then show ?case
          using pre2 1(2) by auto
      qed
    next
      \<comment> \<open>D) ?z is indeed a fresh variable\<close>
      have pff: "?z \<notin> lesvars ?upds" apply(simp only: fua) by fact
      have "support (\<lambda>l s. I l s \<and> postList ?upds l s) \<subseteq> support I \<union> support (postList ?upds)"
        by(rule support_and)
      also have "support (postList ?upds) \<subseteq> lesvars ?upds"
           apply(rule support_postList) done
      finally
      have "support (\<lambda>l s. I l s \<and> postList ?upds l s) \<subseteq> support I \<union> lesvars ?upds"
        by blast
      thus "?z \<notin> support (\<lambda>l s. I l s \<and> postList ?upds l s)"
        apply(rule contra_subsetD)
        using zI pff by(simp)
    qed
  next
    show "\<exists>k>0. \<forall>l s. I l s  \<and> preList upds ({(I, S, E)} WHILE b DO C) l s \<longrightarrow>
              (I l s \<and> postList (map (\<lambda>(x, e). (x, \<lambda>s. e (S s))) upds) l s) \<and> E s \<le> k * E s"
       apply(rule exI[where x=1])   apply(auto)  apply(simp only: postList_preList[symmetric] ) apply (auto)
        apply(simp only:   g)
        done
  next
    show "\<forall>l s. (I l s \<and> postList (map (\<lambda>(x, e). (x, \<lambda>s. e (S s))) upds) l s) \<and> \<not> bval b s  \<longrightarrow> Q l s \<and> postList upds l s"
      using pre2  by(induct upds, auto)
  qed

  have G2: "\<And>l s. pre ({A} WHILE b DO C) Q l s \<Longrightarrow> Q l (postQ ({A} WHILE b DO C) s)"
  proof -
    fix l s
    assume "pre ({A} WHILE b DO C) Q l s"
    then have I: "I l s" by simp
    { fix n
    have "E s = n \<Longrightarrow> I l s \<Longrightarrow> Q l (postQ ({A} WHILE b DO C) s)"
    proof (induct n arbitrary: s l rule: less_induct)
      case (less n)
      then show ?case
      proof (cases "bval b s")
        case True
        with less IQ2 have "pre C I l s" and S: "S s = S (postQ C s)" and t: "1 + preT C E s + time C s \<le> E s" by auto
        with step have I': "I l (postQ C s)" and "1 + E (postQ C s) + time C s \<le> E s" using TQ by auto
        with less have "E (postQ C s) < n" by auto
        with less(1) I' have "Q l (postQ ({A} WHILE b DO C) (postQ C s))" by auto
        with step show ?thesis using S by simp
      next
        case False
        with pre2 less(3) have "Q l s" "S s = s" by auto
        then show ?thesis by simp
      qed
    qed
    }
    with I show "Q l (postQ ({A} WHILE b DO C) s)" by simp
  qed

  show ?case  using G1  G2 by auto
qed

corollary vc_sound':
  assumes "vc C Q"
          "finite (support Q)" "finite (varacom C)"
          "\<forall>l s. P l s \<longrightarrow> pre C Q l s"
  shows "\<turnstile>\<^sub>1 {P} strip C {time C \<Down> Q}"
proof -
  show ?thesis
    apply(rule conseq_old)
      prefer 2 apply(rule vc_sound[where upds="[]", OF assms(1-3), THEN conjunct1])
    using assms(4) apply auto
    done
qed

lemma preT_constant: "preT C (%_. a) = (%_. a)"
  apply(induct C) by (auto)

corollary vc_sound'':
  "\<lbrakk> vc C Q; (\<exists>k>0. \<forall>l s. P l s \<longrightarrow> pre C Q l s \<and> time C s \<le> k * e s);
  finite (support Q); finite (varacom C)\<rbrakk> \<Longrightarrow> \<turnstile>\<^sub>1 {P} strip C {e \<Down> Q}"
  apply(rule ub_cost[where e'="time C"])
   apply(auto)
  apply(rule vc_sound') by auto

subsubsection \<open>Completeness:\<close>

lemma vc_complete:
  "\<turnstile>\<^sub>1 {P} c { e \<Down> Q} \<Longrightarrow>   \<exists>C. strip C = c \<and> vc C Q
  \<and> (\<forall>l s. P l s \<longrightarrow> pre C Q l s \<and> Q l (postQ C s))
  \<and> (\<exists>k. \<forall>l s. P l s \<longrightarrow>  time C s \<le> k * e s)  "
  (is "_ \<Longrightarrow>   \<exists>C. ?G P c Q C e")
proof (induction  rule: hoare1.induct )
  case Skip
  show ?case (is "\<exists>C. ?C C")
  proof show "?C Askip" by auto
  qed
next
  case (Assign P a x  )
  show ?case (is "\<exists>C. ?C C")
  proof show "?C(Aassign x a)" apply (simp del: fun_upd_apply) apply(auto) done qed
next
  case (Seq P x e2' c1 e1 Q e2 c2 R e)
  from Seq.IH(1)   obtain C1 where "?G (\<lambda>l s. P l s \<and> l x = e2' s) c1 (\<lambda>a b. Q a b \<and> e2 b \<le> a x) C1 e1 " by blast
  then obtain k where ih1: "strip C1 = c1"
    "vc C1 (\<lambda>a b. Q a b \<and> e2 b \<le> a x)"
    "\<And>l s. P l s \<Longrightarrow> l x = e2' s \<Longrightarrow> pre C1 (\<lambda>la sa. (Q la sa \<and> e2 sa \<le> la x)) l s"
    "(\<forall>l s. P l s \<and> l x = e2' s \<longrightarrow>  time C1 s \<le> k * e1 s)"
    "\<And>l s.  P l s \<Longrightarrow> l x = e2' s \<Longrightarrow> Q l (postQ C1 s) \<and> e2 (postQ C1 s) \<le> l x"
    apply auto done

  from Seq.IH(2)   obtain C2 where ih2: "?G Q c2 R C2 e2  " by blast
  then obtain k2 where ih2: "strip C2 = c2"
    "vc C2 R"
    "(\<And>l s. Q l s \<Longrightarrow> pre C2 R l s)"
    "(\<forall>l s. Q l s \<longrightarrow>  time C2 s \<le> k2 * e2 s)"
    "\<And>l s . Q l s \<Longrightarrow> R l (postQ C2 s)"  apply auto done

  show ?case (is "\<exists>C. ?C C")
  proof
    show "?C(Aseq (Aconseq P Q (time C1) C1) C2)" (* with Q being (\<lambda>la sa. (Q la sa \<and> e2 sa \<le> la x)) some less mono is needed *)
    proof (safe, goal_cases)
      case 1
      then show ?case apply(simp add: ih1(1) ih2(1)) done
    next
      case 2
      then show ?case apply(simp) apply(safe)
        subgoal apply(rule vc_mono) prefer 2 apply (rule ih1(2)) apply(auto) done
        subgoal apply(rule exI[where x=1]) apply safe
          subgoal by(auto)
          subgoal for l s t
            apply(rule exI[where x="l(x:= e2' s)"])
            apply(safe)
            subgoal apply(rule pre_mono) prefer 2 apply (rule ih1(3))
                apply(subst assn2_lupd) using Seq(3) by auto
            subgoal apply(rule ih2(3)) using assn2_lupd[OF Seq(4)] by auto
            done
          done
        subgoal by (rule ih2(2))
        done
    next
      case (3 l s)
      then show ?case apply(simp) done
    next

      case (4 l s)
      from 4 have "P (l(x:=e2' s)) s" using assn2_lupd[OF Seq(3)] by simp
      with ih1(5)[where l="l(x:=e2' s)"]
      have "Q (l(x := e2' s)) (postQ C1 s)" by simp
      then have "Q l (postQ C1 s)" using assn2_lupd[OF Seq(4)] by simp
      with ih2(3) have "Q l (postQ C1 s)" by simp
      with  ih2(5)
      show ?case apply(auto) done
    next
      case 5
      from ih1(4) have
        gg: "\<And>l s. \<lbrakk>P l s; e2' s = l x\<rbrakk> \<Longrightarrow>   time C1 s \<le> k * e1 s" by auto

      show ?case
      proof (rule exI[where x="(max k  k2)"], safe, goal_cases)
        case (1 l s)
        have xnP: "x \<notin> support P" by fact
        have 41: "P (l(x := e2' s)) s"
          apply(subst assn2_lupd)
           apply(fact xnP)
          apply(fact 5) done

        have A: "  time C1 s \<le> k * e1 s"
          apply(rule gg[where l="l(x:=e2' s)"])
           apply(rule 41)
          apply(simp)  done

        have B: "preT C1 (time C2) s \<le> k2 * e2' s"
        proof -
          from  1 have "P (l(x := e2' s)) s" using assn2_lupd[OF xnP] by simp

          have F: "Q (l(x:=e2' s)) (postQ C1 s) \<and> e2 (postQ C1 s) \<le> (l(x:=e2' s)) x"
            apply(rule ih1(5)[where l="l(x:=e2' s)" and s=s])
             apply(fact)
            apply(simp) done
          then have " time C2 (postQ C1 s) \<le> k2 * e2 (postQ C1 s)" using ih2(4) by auto
          with F have "time C2 (postQ C1 s) \<le> k2 * e2' s"
            using order_subst1 by fastforce
          then show "preT C1 (time C2) s \<le> k2 * e2' s" using TQ by simp
        qed
        have "time C1 s + preT C1 (time C2) s \<le> k  * e1 s + k2 * e2' s" using A B by linarith
        also have "\<dots> \<le> (max k  k2) * e1 s + (max k  k2) * e2' s"
        using nat_mult_max_left by auto
      also have "\<dots> = (max k  k2) * (e1 s + e2' s)" by algebra
      also have "\<dots> \<le> (max k  k2) * e s" using Seq(5)[OF 1] by auto
      finally
      have "time C1 s + preT C1 (time C2) s \<le> (max k  k2) * e s" .
      then show ?case
        by auto
    qed
  qed
  qed

next
  case (If P b c1 e1 Q c2)
  from If.IH(1) obtain C1 where "?G (\<lambda>l s. P l s \<and> bval b s) c1 Q C1 e1"
    by blast
  then obtain k1 where ih1: " strip C1 = c1 \<and> vc C1 Q \<and> (\<forall>l s. P l s \<and> bval b s \<longrightarrow> pre C1 Q l s \<and> Q l (postQ C1 s)) \<and>  ( \<forall>l s. P l s \<and> bval b s \<longrightarrow> time C1 s \<le> k1 * e1 s) "
      by blast
  from If.IH(2) obtain C2 where "?G (\<lambda>l s. P l s \<and> \<not>bval b s) c2 Q C2 e1"
    by blast
  then obtain k2 where ih2: " strip C2 = c2 \<and> vc C2 Q \<and> (\<forall>l s. P l s \<and> \<not>bval b s \<longrightarrow> pre C2 Q l s \<and> Q l (postQ C2 s)) \<and>  ( \<forall>l s. P l s \<and> \<not>bval b s \<longrightarrow> time C2 s \<le> k2 * e1 s )"
    by blast
  define k' where "k' == max (k1+1) (k2+1)"
  show ?case (is "\<exists>C. ?C C")
  proof
    show "?C(Aif b C1 C2)"
      apply(safe)
          prefer 5
      apply(rule exI[where x="k'"]) apply(safe)
      subgoal for l s  apply(auto)
      proof(goal_cases)
        case 1
        with ih1 have "time C1 s \<le> k1 * e1 s" by blast
        then have "Suc (time C1 s) \<le> 1 + k1 * e1 s" by auto
        also have "\<dots> \<le> k' + k1 * e1 s" unfolding k'_def by(auto)
        also have "\<dots> \<le> k' + k' * e1 s" unfolding k'_def
          by (simp add: max_def)
        finally show ?case .
      next
        case 2
        with ih2 have "time C2 s \<le> k2 * e1 s" by blast
        then have "Suc (time C2 s) \<le> 1 + k2 * e1 s" by auto
        also have "\<dots> \<le> k' + k2 * e1 s" unfolding k'_def by(auto)
        also have "\<dots> \<le> k' + k' * e1 s" unfolding k'_def
          by (simp add: max_def)
        finally show ?case .
      qed
      using ih1 ih2 apply(simp)
      using ih1 ih2 apply(auto)
      done
  qed
next
  case (While P b e' y c e'' e)
  have supportPre: "support (\<lambda>l s. P l s \<and> bval b s \<and> e' s = l y) \<subseteq> support P \<union> {y}"
  using support_and support_single   by fast
  from   While.IH  obtain C where
    ih: "?G (\<lambda>l s. P l s \<and> bval b s \<and> e' s = l y) c (\<lambda>a b. P a b \<and> e b \<le> a y) C e''"
    using supportPre by blast
  then obtain k where ih2: "vc C (\<lambda>a b. P a b \<and> e b \<le> a y)"
    "\<And>l s. \<lbrakk> P l s ; bval b s ; e' s = l y \<rbrakk> \<Longrightarrow> pre C (\<lambda>la sa. (P la sa \<and> e sa \<le> la y)) l s"
    "\<And>l s. \<lbrakk> P l s ; bval b s ; e' s = l y \<rbrakk> \<Longrightarrow>   time C s \<le> k * e'' s "
    "\<And>l s.\<lbrakk> P l s ; bval b s ; e' s = l y\<rbrakk> \<Longrightarrow> P l (postQ C s) \<and> e (postQ C s) \<le> l y"
    by fast

  let ?S = "postQs C b"
  {
    fix l s n
    have "e s = n \<Longrightarrow> P l s \<Longrightarrow> postQs_dom (C, b, s) \<and> P l (?S s) \<and> ~ bval b (?S s)"
    proof (induct n arbitrary: l s rule: less_induct)
      case (less x)
      show ?case
      proof (cases "bval b s")
        case True
        with While(2) less(3) have "1 + e' s + e'' s \<le> e s" by auto
        then have e'e: "e' s < e s" by simp
        have "P (l(y:=e' s)) s" using less(3) assn2_lupd[OF While(4)] by simp
        from ih2(4)[OF this] True have ee': "e (postQ C s) \<le> e' s" and P': "P (l(y := e' s)) (postQ C s)" by auto
        from P' have P'': "P l (postQ C s)" using less(3) assn2_lupd[OF While(4)] by simp
        from ee' e'e less(2) have "e (postQ C s) < x" by auto
        from less(1)[OF this _ P''] have d: "postQs_dom (C, b, postQ C s)"
              and p: "P l (postQs C b (postQ C s))"
              and b: "\<not> bval b (postQs C b (postQ C s))" by auto
        have d': "postQs_dom (C, b, s)"
          by (simp add: d postQs.domintros)
        have p': " P l (postQs C b s) "
          using True d p postQs.domintros postQs.psimps by fastforce
        have b': "\<not> bval b (postQs C b s)"
          by (metis b d postQs.domintros postQs.pelims)

        from d' p' b' show ?thesis by auto
      next
        case False
        then have 1: "postQs_dom (C, b, s)"
          using postQs.domintros by blast
        then have 2: "?S s = s" using postQs.psimps False by force
        from 1 2 less(3) False show ?thesis by simp
      qed
    qed
  }
  then have Pdom: "\<And>l s. P l s \<Longrightarrow> postQs_dom (C, b, s) \<and> P l (?S s) \<and> ~ bval b (?S s)" by simp

  have S1: "\<And>l s. P l s \<Longrightarrow> P l (?S s)" using Pdom by simp
  have S2: "\<And>l s. P l s \<Longrightarrow> ~ bval b (?S s)" using Pdom by simp
  have S3: "\<And>l s. P l s \<Longrightarrow> bval b s \<Longrightarrow> ?S s = ?S (postQ C s)" using postQs.psimps Pdom by simp
  have S4: "\<And>l s. P l s \<Longrightarrow> \<not> bval b s \<Longrightarrow> ?S s = s" using postQs.psimps Pdom by simp

  let ?w = "{(P,?S,(%s. max k 1 * e s))} WHILE b DO (Aconseq (\<lambda>l s. P l s \<and> bval b s) (\<lambda>la sa. P la sa \<and> e sa \<le> la y) (time C) C)"

  show ?case (is "\<exists>C. ?C C")
  proof
    show "?C ?w"
    proof (safe, goal_cases)
      case 1
      then show ?case using ih by(simp)
    next
      case 2
      then show ?case
      proof(simp, safe, goal_cases)
        case (1 l s)
        from 2 have z: "P (l(y := e' s)) s "
          using 1 assn2_lupd[OF While(4)]  by metis
        from ih2(3)[where l="l(y := e' s)" and s=s]
        have A: " time C s \<le> k * e'' s " using 1 z by(simp)

        from ih2(4)[where l="l(y := e' s)" and s=s]
        have "e (postQ C s) \<le> (l(y := e' s)) y" apply(simp) using 1 z by(simp)
        then have "e (postQ C s) \<le> e' s" by simp

        with TQ have B: "preT C e s \<le> e' s" by simp
        let ?eskal = "(\<lambda>s. max k (Suc 0) * e s)"
        have "preT C (\<lambda>s. max k (Suc 0) * e s) s = max k (Suc 0) * preT C e s"
          using preT_linear by simp
        with B have  B: "preT C ?eskal s \<le> max k (Suc 0) * e' s" by auto

        from  While.hyps(2) 1 have C: "1 + e' s + e'' s \<le> e s" by auto
        have "Suc (preT C ?eskal s + time C s) \<le> 1 + (max k 1) * e' s + k * e'' s"
          using A B by linarith
        also have "\<dots> \<le> (max k 1) + (max k 1) * e' s + (max k 1) * e'' s"
          using nat_mult_max_left by auto
        also have "\<dots> = (max k 1) * (1 + e' s + e'' s)"
          by algebra
        also have "\<dots> \<le> (max k 1) * e s"
          using C by (metis mult.assoc mult_le_mono2)
        finally have "Suc (preT C ?eskal s + time C s) \<le> ((max k 1) ) * e s" .
        thus ?case by auto
      next
        case (3 l s)
        with While.hyps(3) show ?case by auto
      next
        case 5
        then show ?case
           apply(rule vc_mono)
           prefer 2 apply(fact ih2(1)) by auto
      next
        case 6
        show ?case apply(rule exI[where x="1"]) apply(safe)
          subgoal by simp
          subgoal for l s t apply(rule exI[where x="l(y:=e' s)"])

          proof (safe)
            assume 8: "P l s" and b: " bval b s"
            then have "P (l(y := e' s)) s" using assn2_lupd[OF While(4)]  by metis
            with b ih2(2)  show "pre C (\<lambda>la sa. P la sa \<and> e sa \<le> la y) (l(y := e' s)) s"
              apply(auto) done
            fix t
            assume "P (l(y := e' s)) t"
            thus "P l t" using assn2_lupd[OF While(4)] by simp
          qed
          done
      qed (simp_all add: S4 S3)
    next
      case 6
      show ?case apply(rule exI[where x="k+1"]) by auto
    qed (simp_all add: S1 S2)
  qed
next
  case (conseq P' e e' P Q Q' c)
  then obtain C k where C: "strip C = c"
    "vc C Q"
    "(\<forall>l s  . P l s \<longrightarrow> pre C Q  l s )"
    "(\<forall>l s . P l s \<longrightarrow> Q l (postQ C s))"
    "(\<forall>l s. P l s \<longrightarrow>  time C s \<le> k * e s)" by metis
  from conseq(1) obtain k2 where cons: " \<forall>l s. P' l s \<longrightarrow> e s \<le> k2 * e' s \<and> (\<forall>t. \<exists>l'. P l' s \<and> (Q l' t \<longrightarrow> Q' l t))" by auto

  show ?case
    apply(rule exI[where x="Aconseq P' Q (time C) C"])
    apply(safe)
    subgoal apply(simp) by(fact)
    subgoal apply(simp)
      apply(safe)
      subgoal using C(2)
          apply(fast) done
      subgoal
        apply(rule exI[where x="k+1"])
        apply auto
        using C(2) cons C(3) by blast
      done
    subgoal apply(rule pre_mono)
      prefer 2 apply(simp) using C(3) conseq(1) apply fast
      done
    subgoal
      apply(simp)
      using C(4) conseq(1,3) apply blast done
    apply(rule exI[where x="k*k2"]) apply(safe)
    subgoal for l s
      using C(5) cons apply(auto)
    proof(goal_cases)
      case 1
      then have absch: "e s \<le> k2 * e' s" "time C s \<le> k  * e s" by blast+
      show ?case
        using absch order_trans by fastforce
    qed
    done
qed

end


section \<open>Open Singly Linked Lists\<close>
theory LLVM_DS_Open_List
imports LLVM_DS_List_Seg (*Imp_List_Spec*)
begin

subsection \<open>Definitions\<close>
type_synonym 'a os_list = "'a node ptr"

definition os_list_assn :: "('a list, ('a::llvm_rep) os_list) dr_assn" where
  "os_list_assn \<equiv> mk_assn (\<lambda>l p. lseg l p null)"

lemma os_list_assn_simps:
  "\<upharpoonleft>os_list_assn [] p = \<up>(p=null)"
  "\<upharpoonleft>os_list_assn xs null = \<up>(xs=[])"
  "\<upharpoonleft>os_list_assn (x#xs) p = (EXS q. \<upharpoonleft>ll_bpto (Node x q) p ** \<upharpoonleft>os_list_assn xs q)"
  unfolding os_list_assn_def
  subgoal by auto
  subgoal by auto
  subgoal by (cases "p=null") (auto simp: sep_algebra_simps)
  done

subsection \<open>Operations\<close>
subsubsection \<open>Allocate Empty List\<close>

definition os_empty :: "_ os_list llM" where [llvm_code, llvm_inline]:
  "os_empty \<equiv> return null"

lemma os_empty_rule[vcg_rules]: "llvm_htriple \<box> os_empty (\<lambda>r. \<upharpoonleft>os_list_assn [] r)"
  unfolding os_empty_def os_list_assn_def
  apply vcg
  done

subsubsection \<open>Delete\<close>

partial_function (ners) os_delete :: "_ os_list \<Rightarrow> unit llM" where
  "os_delete p = doM {
    if p=null then return ()
    else doM {
      n \<leftarrow> ll_load p;
      ll_free p;
      os_delete (node.next n)
    }
  }"

lemma os_delete_rule[vcg_rules]:
  "llvm_htriple (\<upharpoonleft>os_list_assn xs p) (os_delete p) (\<lambda>_. \<box>)"
proof (induction xs arbitrary: p)
  case Nil
  note [simp] = os_list_assn_simps
  show ?case
    apply (subst os_delete.simps)
    by vcg
next
  case (Cons a xs)

  note [vcg_rules] = Cons.IH
  note [simp] = os_list_assn_simps

  interpret llvm_prim_ctrl_setup .

  show ?case
    apply (subst os_delete.simps)
    apply vcg
    done

qed

subsubsection \<open>Emptiness check\<close>
text \<open>A linked list is empty, iff it is the null pointer.\<close>

find_consts bool "1 word"

definition os_is_empty :: "_ os_list \<Rightarrow> 1 word llM" where [llvm_code, llvm_inline]:
  "os_is_empty b \<equiv> return (from_bool (b = null))"

lemma os_is_empty_rule[vcg_rules]:
  "llvm_htriple (\<upharpoonleft>os_list_assn xs b) (os_is_empty b) (\<lambda>r. \<upharpoonleft>os_list_assn xs b ** \<up>(r = from_bool (xs = [])))"
  unfolding os_is_empty_def os_list_assn_def
  apply (cases "b=null"; cases xs; simp)
  apply vcg
  done

definition os_is_empty' :: "'a os_list \<Rightarrow> 8 word llM"
where [llvm_code, llvm_inline]: "os_is_empty' xsi \<equiv> doM {
  b \<leftarrow> os_is_empty xsi;
  if to_bool b then return 1 else return 0
}"

lemma os_is_empty'_rule[vcg_rules]:
  "llvm_htriple (\<upharpoonleft>os_list_assn xs b) (os_is_empty' b) (\<lambda>r. \<upharpoonleft>os_list_assn xs b ** \<up>(r = (if xs = [] then 1 else 0)))"
proof -
  interpret llvm_prim_ctrl_setup .
  show ?thesis
    unfolding os_is_empty'_def
    by vcg

qed

subsubsection \<open>Prepend\<close>

text \<open>To push an element to the front of a list we allocate a new node which
  stores the element and the old list as successor. The new list is the new
  allocated reference.\<close>

definition os_prepend :: "'a \<Rightarrow> 'a::llvm_rep os_list \<Rightarrow> 'a os_list llM" where [llvm_code, llvm_inline]:
  "os_prepend a n = doM { ll_ref (Node a n) }"

lemma os_prepend_rule[vcg_rules]:
  "llvm_htriple (\<upharpoonleft>os_list_assn xs n) (os_prepend x n) (\<lambda>r. \<upharpoonleft>os_list_assn (x # xs) r)"
  unfolding os_prepend_def os_list_assn_def
  apply vcg
  done

subsubsection\<open>Pop\<close>
text \<open>To pop the first element out of the list we look up the value and the
  reference of the node and return the pair of those.\<close>

definition os_pop :: "'a::llvm_rep os_list \<Rightarrow> ('a \<times> 'a os_list) llM" where
  [llvm_code]: "os_pop p = doM { n \<leftarrow> ll_load p; ll_free p; return (node.val n, node.next n) }"

lemma os_pop_rule[vcg_rules]:
  "xs \<noteq> [] \<Longrightarrow> llvm_htriple
    (\<upharpoonleft>os_list_assn xs r)
    (os_pop r)
    (\<lambda>(x,r'). \<up>(x=hd xs) ** \<upharpoonleft>os_list_assn (tl xs) r')
  "
  apply (cases xs; simp)
  unfolding os_pop_def os_list_assn_def
  by vcg

definition os_pop' :: "'a::llvm_rep os_list \<Rightarrow> ('a \<times> 'a os_list) ptr \<Rightarrow> unit llM"
where [llvm_code, llvm_inline]:
"os_pop' xsi resultp \<equiv> doM {
  r \<leftarrow> os_pop xsi;
  ll_store r resultp
}"

lemma os_pop'_rule[vcg_rules]:
  "xs \<noteq> [] \<Longrightarrow> llvm_htriple
    (\<upharpoonleft>os_list_assn xs r ** \<upharpoonleft>ll_pto XX resultp)
    (os_pop' r resultp)
    (\<lambda>_. EXS x r'. \<upharpoonleft>ll_pto (x,r') resultp ** \<up>(x=hd xs) ** \<upharpoonleft>os_list_assn (tl xs) r')
  "
proof -
  interpret llvm_prim_setup .
  assume "xs\<noteq>[]"
  then show ?thesis
    unfolding os_pop'_def
    by vcg
qed

subsubsection \<open>Reverse\<close>

text \<open>The following reversal function is equivalent to the one from
  Imperative HOL. And gives a more difficult example.\<close>

partial_function (ners) os_reverse_aux
  :: "'a::llvm_rep os_list \<Rightarrow> 'a os_list \<Rightarrow> 'a os_list llM"
  where
  "os_reverse_aux q p = doM {
    if p=null then return q
    else doM {
      v \<leftarrow> ll_load p;
      ll_store (Node (node.val v) q) p;
      os_reverse_aux p (node.next v)
    }
  }"

lemmas [llvm_code] = os_reverse_aux.simps

lemma os_reverse_aux_simps[simp]:
  "os_reverse_aux q null = return q"
  "p\<noteq>null \<Longrightarrow> os_reverse_aux q p = doM {
      v \<leftarrow> ll_load p;
      ll_store (Node (node.val v) q) p;
      os_reverse_aux p (node.next v)
    }"
  apply (subst os_reverse_aux.simps)
  apply simp
  apply (subst os_reverse_aux.simps)
  apply simp
  done

definition [llvm_code, llvm_inline]: "os_reverse p = os_reverse_aux null p"

lemma os_reverse_aux_rule:
  "llvm_htriple
    (\<upharpoonleft>os_list_assn xs p ** \<upharpoonleft>os_list_assn ys q)
    (os_reverse_aux q p)
    (\<lambda>r. \<upharpoonleft>os_list_assn ((rev xs) @ ys) r)"
proof (induct xs arbitrary: p q ys)
  case Nil
  thus ?case
    supply [simp] = os_list_assn_simps
    apply vcg
    done
next
  case (Cons x xs)

  note [vcg_rules] = Cons.hyps[where ys = "x#ys"]
  note [simp, named_ss fri_prepare_simps] = os_list_assn_simps

  show ?case
    apply (cases "p\<noteq>null"; simp)
    by vcg

qed

lemma os_reverse_rule[vcg_rules]: "llvm_htriple
  (\<upharpoonleft>os_list_assn xs p)
  (os_reverse p)
  (\<lambda>r. \<upharpoonleft>os_list_assn (rev xs) r)"
  unfolding os_reverse_def
  supply [simp] = os_list_assn_simps
  supply R = os_reverse_aux_rule[where ys="[]", simplified]
  supply [vcg_rules] = R
  by vcg

subsubsection \<open>Remove\<close>

text \<open>Remove all appearances of an element from a linked list.\<close>

partial_function (ners) os_rem
  :: "'a::llvm_rep \<Rightarrow> 'a node ptr \<Rightarrow> 'a node ptr llM"
  where
  "os_rem x p = doM {
    if p=null then return null
    else doM {
      n \<leftarrow> ll_load p;
      q \<leftarrow> os_rem x (node.next n);
      if node.val n = x then doM {
        ll_free p;
        return q
      } else doM {
        ll_store (Node (node.val n) q) p;
        return p
      }
    }
  }"

lemmas [llvm_code] = os_rem.simps

lemma os_rem_rule[vcg_rules]:
  "llvm_htriple (\<upharpoonleft>os_list_assn xs p) (os_rem x p) (\<lambda>r. \<upharpoonleft>os_list_assn (removeAll x xs) r)"
proof (induct xs arbitrary: p x) (* Have to generalize over x, as
    preprocessor introduces a new variable. *)
  case Nil

  note [simp] = os_list_assn_simps
  show ?case
    apply vcg
    done
next
  case (Cons y xs)

  note [vcg_rules] = Cons.hyps

  note [simp] = os_list_assn_simps
  show ?case
    apply (cases "p=null"; simp)
    by vcg

qed

export_llvm
  "os_empty :: 64 word os_list llM" is "os_list os_empty ()"
  "os_is_empty' :: 64 word os_list \<Rightarrow> _" is "char os_is_empty (os_list)"
  "os_prepend :: 64 word \<Rightarrow> _" is "os_list os_prepend(_, os_list)"
  "os_pop' :: 64 word os_list \<Rightarrow> _" is "void os_pop(os_list,pop_result*)"
  "os_reverse:: 64 word os_list \<Rightarrow> _" is os_reverse
  "os_rem :: 64 word \<Rightarrow> _" is os_rem
  defines \<open>
    typedef list_elem * os_list;
    typedef struct {uint64_t data; list_elem *next;} list_elem;
    typedef struct {uint64_t data; list_elem *list;} pop_result;
  \<close>
  rewrites \<open>64 word node\<close> = list_elem
  file "../../regression/gencode/open_list.ll"

end