theory Correctness
  imports "CorrectnessStacked" "Launchbury-Unstack"
begin

text {* Fresh bindings can be added to the heap *}

lemma ESem_add_fresh:
  assumes fresh: "atom x \<sharp> (\<Gamma>, e)"
  and "x \<notin> fdom \<rho>"
  shows "\<lbrakk>e\<rbrakk>\<^bsub>\<lbrace>(x, e') # \<Gamma>\<rbrace>\<rho>\<^esub> = \<lbrakk>e\<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub>"
proof(rule ESem_ignores_fresh[symmetric])
  have "\<lbrace>\<Gamma>\<rbrace>\<rho> = fmap_restr (fdom \<rho> \<union> heapVars \<Gamma>) (\<lbrace>(x, e') # \<Gamma>\<rbrace>\<rho>) "
    apply (rule HSem_add_fresh[OF _ `x \<notin> fdom \<rho>`, symmetric])
    using fresh by (simp add: fresh_Pair)
  thus "\<lbrace>\<Gamma>\<rbrace>\<rho> \<le> \<lbrace>(x, e') # \<Gamma>\<rbrace>\<rho>"
    by (auto simp add: fmap_less_restrict)

  have "(insert x (fdom \<rho> \<union> heapVars \<Gamma>) - (fdom \<rho> \<union> heapVars \<Gamma>)) = {x}"
    using fresh `x \<notin> fdom \<rho>` by (auto simp add: fresh_Pair  heapVars_not_fresh)
  thus "atom ` (fdom (\<lbrace>(x, e') # \<Gamma>\<rbrace>\<rho>) - fdom (\<lbrace>\<Gamma>\<rbrace>\<rho>)) \<sharp>* e"
    using fresh
    by (simp add: fresh_star_def fresh_Pair)
qed

text {*
As a corollary of the correctness of the stacked semantics and its equivalence to the original
semantics we obtaim Theorem 2 from \cite{launchbury}.
*}

theorem correctness:
  assumes "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : z"
  and [simp]:"distinctVars \<Gamma>"
  shows "\<lbrakk>e\<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<^esub> = \<lbrakk>z\<rbrakk>\<^bsub>\<lbrace>\<Delta>\<rbrace>\<^esub>" and "\<lbrace>\<Gamma>\<rbrace> \<le> \<lbrace>\<Delta>\<rbrace>"
proof-
  obtain x :: var where fresh: "atom x \<sharp> (\<Gamma>,e,\<Delta>,z)"
    by (rule obtain_fresh)

  have "\<Gamma> : e \<Down>\<^bsub>x#L\<^esub> \<Delta> : z"
    by (rule reds_add_var_L[OF assms(1) fresh], simp)
  hence "\<Gamma> : [(x, e)] \<Down> \<Delta> : [(x, z)]"
    by (rule add_stack, simp_all add: supp_Nil)
  moreover
  from fresh
  have "x \<notin> heapVars \<Gamma>"
    by (metis heapVars_not_fresh fresh_Pair)
  hence "distinctVars ([(x, e)] @ \<Gamma>)"
    by (simp add: distinctVars_append distinctVars_Cons)
  ultimately
  have le: "\<lbrace>[(x, e)] @ \<Gamma>\<rbrace> \<le> \<lbrace>[(x, z)] @ \<Delta>\<rbrace>"
    by (rule CorrectnessStacked.correctness)

  have "\<lbrace>\<Gamma>\<rbrace> = fmap_restr (heapVars \<Gamma>) (\<lbrace>(x, e) # \<Gamma>\<rbrace>)"
    apply (rule HSem_add_fresh[where \<rho> = "f\<emptyset>", simplified, symmetric])
    using fresh apply (simp add: fresh_Pair)
    done
  also have "... \<le> fmap_restr (heapVars \<Delta>) (\<lbrace>(x, z) # \<Delta>\<rbrace>)"
    by (rule fmap_restr_le[OF le Launchbury.reds_doesnt_forget[OF assms(1)], simplified])
  also have "... = \<lbrace>\<Delta>\<rbrace>"
    apply (rule HSem_add_fresh[where \<rho> = "f\<emptyset>", simplified])
    using fresh by (simp add: fresh_Pair)
  finally show "\<lbrace>\<Gamma>\<rbrace> \<le> \<lbrace>\<Delta>\<rbrace>".

  have "\<lbrakk>e\<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<^esub> = \<lbrakk>e\<rbrakk>\<^bsub>\<lbrace>(x, e) # \<Gamma>\<rbrace>\<^esub>"
    apply (rule ESem_add_fresh[where \<rho> = "f\<emptyset>", symmetric, simplified])
    using fresh by (simp add: fresh_Pair)
  also have "... = \<lbrace>(x, e) # \<Gamma>\<rbrace> f! x"
    by (simp add: the_lookup_HSem_heap)
  also have "... = \<lbrace>(x, z) # \<Delta>\<rbrace> f! x" by (simp add: fmap_less_eqD[OF le, simplified])
  also have "... = \<lbrakk>z\<rbrakk>\<^bsub>\<lbrace>(x, z) # \<Delta>\<rbrace>\<^esub>" by (simp add: the_lookup_HSem_heap)
  also have "... =  \<lbrakk>z\<rbrakk>\<^bsub>\<lbrace>\<Delta>\<rbrace>\<^esub>"
    apply (rule ESem_add_fresh[where \<rho> = "f\<emptyset>", simplified])
    using fresh by (simp add: fresh_Pair)
  finally show "\<lbrakk> e \<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<^esub> = \<lbrakk> z \<rbrakk>\<^bsub>\<lbrace>\<Delta>\<rbrace>\<^esub>".
qed
end


(*  Title:      HOL/Proofs/Lambda/ListApplication.thy
    Author:     Tobias Nipkow
    Copyright   1998 TU Muenchen
*)

section \<open>Application of a term to a list of terms\<close>

theory ListApplication imports Lambda begin

abbreviation
  list_application :: "dB => dB list => dB"  (infixl "\<degree>\<degree>" 150) where
  "t \<degree>\<degree> ts == foldl (op \<degree>) t ts"

lemma apps_eq_tail_conv [iff]: "(r \<degree>\<degree> ts = s \<degree>\<degree> ts) = (r = s)"
  by (induct ts rule: rev_induct) auto

lemma Var_eq_apps_conv [iff]: "(Var m = s \<degree>\<degree> ss) = (Var m = s \<and> ss = [])"
  by (induct ss arbitrary: s) auto

lemma Var_apps_eq_Var_apps_conv [iff]:
    "(Var m \<degree>\<degree> rs = Var n \<degree>\<degree> ss) = (m = n \<and> rs = ss)"
  apply (induct rs arbitrary: ss rule: rev_induct)
   apply simp
   apply blast
  apply (induct_tac ss rule: rev_induct)
   apply auto
  done

lemma App_eq_foldl_conv:
  "(r \<degree> s = t \<degree>\<degree> ts) =
    (if ts = [] then r \<degree> s = t
    else (\<exists>ss. ts = ss @ [s] \<and> r = t \<degree>\<degree> ss))"
  apply (rule_tac xs = ts in rev_exhaust)
   apply auto
  done

lemma Abs_eq_apps_conv [iff]:
    "(Abs r = s \<degree>\<degree> ss) = (Abs r = s \<and> ss = [])"
  by (induct ss rule: rev_induct) auto

lemma apps_eq_Abs_conv [iff]: "(s \<degree>\<degree> ss = Abs r) = (s = Abs r \<and> ss = [])"
  by (induct ss rule: rev_induct) auto

lemma Abs_apps_eq_Abs_apps_conv [iff]:
    "(Abs r \<degree>\<degree> rs = Abs s \<degree>\<degree> ss) = (r = s \<and> rs = ss)"
  apply (induct rs arbitrary: ss rule: rev_induct)
   apply simp
   apply blast
  apply (induct_tac ss rule: rev_induct)
   apply auto
  done

lemma Abs_App_neq_Var_apps [iff]:
    "Abs s \<degree> t \<noteq> Var n \<degree>\<degree> ss"
  by (induct ss arbitrary: s t rule: rev_induct) auto

lemma Var_apps_neq_Abs_apps [iff]:
    "Var n \<degree>\<degree> ts \<noteq> Abs r \<degree>\<degree> ss"
  apply (induct ss arbitrary: ts rule: rev_induct)
   apply simp
  apply (induct_tac ts rule: rev_induct)
   apply auto
  done

lemma ex_head_tail:
  "\<exists>ts h. t = h \<degree>\<degree> ts \<and> ((\<exists>n. h = Var n) \<or> (\<exists>u. h = Abs u))"
  apply (induct t)
    apply (rule_tac x = "[]" in exI)
    apply simp
   apply clarify
   apply (rename_tac ts1 ts2 h1 h2)
   apply (rule_tac x = "ts1 @ [h2 \<degree>\<degree> ts2]" in exI)
   apply simp
  apply simp
  done

lemma size_apps [simp]:
  "size (r \<degree>\<degree> rs) = size r + foldl (op +) 0 (map size rs) + length rs"
  by (induct rs rule: rev_induct) auto

lemma lem0: "[| (0::nat) < k; m <= n |] ==> m < n + k"
  by simp

lemma lift_map [simp]:
    "lift (t \<degree>\<degree> ts) i = lift t i \<degree>\<degree> map (\<lambda>t. lift t i) ts"
  by (induct ts arbitrary: t) simp_all

lemma subst_map [simp]:
    "subst (t \<degree>\<degree> ts) u i = subst t u i \<degree>\<degree> map (\<lambda>t. subst t u i) ts"
  by (induct ts arbitrary: t) simp_all

lemma app_last: "(t \<degree>\<degree> ts) \<degree> u = t \<degree>\<degree> (ts @ [u])"
  by simp

text \<open>\medskip A customized induction schema for \<open>\<degree>\<degree>\<close>.\<close>

lemma lem:
  assumes "!!n ts. \<forall>t \<in> set ts. P t ==> P (Var n \<degree>\<degree> ts)"
    and "!!u ts. [| P u; \<forall>t \<in> set ts. P t |] ==> P (Abs u \<degree>\<degree> ts)"
  shows "size t = n \<Longrightarrow> P t"
  apply (induct n arbitrary: t rule: nat_less_induct)
  apply (cut_tac t = t in ex_head_tail)
  apply clarify
  apply (erule disjE)
   apply clarify
   apply (rule assms)
   apply clarify
   apply (erule allE, erule impE)
    prefer 2
    apply (erule allE, erule mp, rule refl)
   apply simp
   apply (simp only: foldl_conv_fold add.commute fold_plus_sum_list_rev)
   apply (fastforce simp add: sum_list_map_remove1)
  apply clarify
  apply (rule assms)
   apply (erule allE, erule impE)
    prefer 2
    apply (erule allE, erule mp, rule refl)
   apply simp
  apply clarify
  apply (erule allE, erule impE)
   prefer 2
   apply (erule allE, erule mp, rule refl)
  apply simp
  apply (rule le_imp_less_Suc)
  apply (rule trans_le_add1)
  apply (rule trans_le_add2)
  apply (simp only: foldl_conv_fold add.commute fold_plus_sum_list_rev)
  apply (simp add: member_le_sum_list_nat)
  done

theorem Apps_dB_induct:
  assumes "!!n ts. \<forall>t \<in> set ts. P t ==> P (Var n \<degree>\<degree> ts)"
    and "!!u ts. [| P u; \<forall>t \<in> set ts. P t |] ==> P (Abs u \<degree>\<degree> ts)"
  shows "P t"
  apply (rule_tac t = t in lem)
    prefer 3
    apply (rule refl)
    using assms apply iprover+
  done

end


theory HaskellLibs_1
imports "$HETS_LIB/Isabelle/MainHC"
uses "$HETS_LIB/Isabelle/prelude"
begin

datatype Nat = X0 | Suc "Nat"

datatype 'a List = Nil | Cons 'a "'a List"

datatype Bool = TrueX | FalseX

consts
"PlusXPlusX" :: "('a List * 'a List) => 'a List"   ( "PlusXPlusX" )
"filter" :: "(('a => Bool option) * 'a List) => 'a List option"   ( "filter" )
"foldl" :: "(((('a * 'b) => 'a option) * 'a) * 'b List) => 'a option"   ( "foldl" )
"foldr" :: "(((('a * 'b) => 'b option) * 'b) * 'a List) => 'b option"   ( "foldr" )
"head" :: "'a List => 'a option"   ( "head" )
"lengtH" :: "'a List => Nat"   ( "lengtH" )
"map" :: "(('a => 'b option) * 'a List) => 'b List option"   ( "map" )
"o" :: "(('b => 'c option) * ('a => 'b option)) => ('a => 'c option)"   ( "o" )
"unzip" :: "('a * 'b) List => ('a List * 'b List)"   ( "unzip" )
"zip" :: "('a List * 'b List) => ('a * 'b) List"   ( "zip" )
lemma case_Nat_SomeProm [simp]:" (case caseVar of X0 => Some (x)
   | Suc nat => Some (s nat)
) =
Some (case caseVar of X0 => x
   | Suc nat => s nat
)"
apply (case_tac caseVar)
apply (auto)
done
lemma case_List_SomeProm [simp]:" (case caseVar of Nil => Some (n)
   | Cons a list => Some (c a list)
) =
Some (case caseVar of Nil => n
   | Cons a list => c a list
)"
apply (case_tac caseVar)
apply (auto)
done
lemma case_Bool_SomeProm [simp]:" (case caseVar of TrueX => Some (t)
   | FalseX => Some (f)
) =
Some (case caseVar of TrueX => t
   | FalseX => f
)"
apply (case_tac caseVar)
apply (auto)
done

axioms
ga_Nat: "True"
ga_Bool: "True"
comp: "apt (Some o) (pair (Some f) (Some g)) = (Some (% x . app (Some f) (app (Some g) (Some x))))"
ga_List: "True"
lengtH_nil: "apt (Some lengtH) (Some Nil) = (Some X0)"
lengtH_cons: "apt (Some lengtH) (apt (apt (Some Cons) (Some x)) (Some xs)) = apt (Some Suc) (apt (Some lengtH) (Some xs))"
not_def_head: "(Not (defOp (app (Some head) (Some Nil))))"
head_def: "app (Some head) (apt (apt (Some Cons) (Some x)) (Some xs)) = (Some x)"
foldr_nil: "app (Some foldr) (pair (pair (Some f) (Some s)) (Some Nil)) = (Some s)"
foldr_cons: "app (Some foldr) (pair (pair (Some f) (Some s)) (apt (apt (Some Cons) (Some x)) (Some xs))) = app (Some f) (pair (Some x) (app (Some foldr) (pair (pair (Some f) (Some s)) (Some xs))))"
foldl_nil: "app (Some foldl) (pair (pair (Some g) (Some t)) (Some Nil)) = (Some t)"
foldl_cons: "app (Some foldl) (pair (pair (Some g) (Some t)) (apt (apt (Some Cons) (Some z)) (Some zs))) = app (Some foldl) (pair (pair (Some g) (app (Some g) (pair (Some t) (Some z)))) (Some zs))"
map_nil: "app (Some map) (pair (Some h) (Some Nil)) = (Some Nil)"
map_cons: "app (Some map) (pair (Some h) (apt (apt (Some Cons) (Some x)) (Some xs))) = apt (apt (Some Cons) (app (Some h) (Some x))) (app (Some map) (pair (Some h) (Some xs)))"
filter_nil: "app (Some filter) (pair (Some p) (Some Nil)) = (Some Nil)"
filter_cons: "app (Some filter) (pair (Some p) (apt (apt (Some Cons) (Some x)) (Some xs))) = (case app (Some p) (Some x) of None => None
   | Some caseVar => (case caseVar of TrueX => apt (apt (Some Cons) (Some x)) (app (Some filter) (pair (Some p) (Some xs)))
   | FalseX => app (Some filter) (pair (Some p) (Some xs))))"
PlusPlus_nil: "apt (Some PlusXPlusX) (pair (Some Nil) (Some l)) = (Some l)"
PlusPlus_cons: "apt (Some PlusXPlusX) (pair (apt (apt (Some Cons) (Some x)) (Some xs)) (Some l)) = apt (apt (Some Cons) (Some x)) (apt (Some PlusXPlusX) (pair (Some xs) (Some l)))"
zip_nil: "apt (Some zip) (pair (Some Nil) (Some l)) = (Some Nil)"
zip_cons: "apt (Some zip) (pair (apt (apt (Some Cons) (Some x)) (Some xs)) (Some l)) = (case l of Nil => (Some Nil)
   | Cons y ys => apt (apt (Some Cons) (pair (Some x) (Some y))) (apt (Some zip) (pair (Some xs) (Some ys))))"
unzip_nil: "apt (Some unzip) (Some Nil) = pair (Some Nil) (Some Nil)"
unzip_cons: "apt (Some unzip) (apt (apt (Some Cons) (pair (Some x) (Some z))) (Some ps)) = app (Some (% (ys, zs) . pair (apt (apt (Some Cons) (Some x)) (Some ys)) (apt (apt (Some ConsS) (Some z)) (Some zs)))) (apt (Some unzip) (Some ps))"

lemmas ga_Nat' = ga_Nat [simplified]
lemmas ga_Bool' = ga_Bool [simplified]
lemmas comp' = comp [simplified]
lemmas ga_List' = ga_List [simplified]
lemmas lengtH_nil' = lengtH_nil [simplified]
lemmas lengtH_cons' = lengtH_cons [simplified]
lemmas not_def_head' = not_def_head [simplified]
lemmas head_def' = head_def [simplified]
lemmas foldr_nil' = foldr_nil [simplified]
lemmas foldr_cons' = foldr_cons [simplified]
lemmas foldl_nil' = foldl_nil [simplified]
lemmas foldl_cons' = foldl_cons [simplified]
lemmas map_nil' = map_nil [simplified]
lemmas map_cons' = map_cons [simplified]
lemmas filter_nil' = filter_nil [simplified]
lemmas filter_cons' = filter_cons [simplified]
lemmas PlusPlus_nil' = PlusPlus_nil [simplified]
lemmas PlusPlus_cons' = PlusPlus_cons [simplified]

declare List.weak_case_cong [cong del]
declare List.case_cong [cong]

lemmas zip_nil' = zip_nil [simplified]
lemmas zip_cons' = zip_cons [simplified]
lemmas unzip_nil' = unzip_nil [simplified]
lemmas unzip_cons' = unzip_cons [simplified]

declare ga_Nat' [simp]
declare ga_Nat [simp]
declare ga_Bool' [simp]
declare ga_Bool [simp]
declare comp' [simp]
declare comp [simp]
declare ga_List' [simp]
declare ga_List [simp]
declare lengtH_nil' [simp]
declare lengtH_nil [simp]
declare lengtH_cons' [simp]
declare lengtH_cons [simp]
declare not_def_head' [simp]
declare not_def_head [simp]
declare head_def' [simp]
declare head_def [simp]
declare foldr_nil' [simp]
declare foldr_nil [simp]
declare foldr_cons' [simp]
declare foldr_cons [simp]
declare foldl_nil' [simp]
declare foldl_nil [simp]
declare foldl_cons' [simp]
declare foldl_cons [simp]
declare map_nil' [simp]
declare map_nil [simp]
declare map_cons' [simp]
declare map_cons [simp]
declare filter_nil' [simp]
declare filter_nil [simp]
declare filter_cons' [simp]
declare filter_cons [simp]
declare PlusPlus_nil' [simp]
declare PlusPlus_nil [simp]
declare PlusPlus_cons' [simp]
declare PlusPlus_cons [simp]
declare zip_nil' [simp]
declare zip_nil [simp]
declare zip_cons' [simp]
declare zip_cons [simp]
declare unzip_nil' [simp]
declare unzip_nil [simp]
declare unzip_cons' [simp]
declare unzip_cons [simp]

theorem foldl_decomp: "app (Some foldl) (pair (pair (Some i) (Some e)) (apt (Some PlusXPlusX) (pair (Some xs) (Some zs)))) = app (Some foldl) (pair (pair (Some i) (app (Some foldl) (pair (pair (Some i) (Some e)) (Some xs)))) (Some zs))"
apply (simp)
apply (rule_tac  x = e in spec)
apply (rule_tac  x = zs in spec)
apply (induct_tac xs)
apply (simp)
apply (simp only: PlusPlus_cons')
apply (simp only: foldl_cons')
apply (case_tac "i(xa,a)")
apply auto
apply (case_tac "i(xaa,a)")
apply auto
apply (case_tac "i(xaa,a)")
apply auto
done
theorem map_decomp: "app (Some map) (pair (Some f) (apt (Some PlusXPlusX) (pair (Some xs) (Some zs)))) = apt (Some PlusXPlusX) (pair (app (Some map) (pair (Some f) (Some xs))) (app (Some map) (pair (Some f) (Some zs))))"
apply (simp)
apply (rule_tac  x = zs in spec)
apply (induct_tac xs)
apply (simp)
apply (rule allI)
apply (case_tac "map (f, x)")
apply (simp_all)
apply (rule allI)
apply (case_tac "f a")
apply (simp_all)
apply (case_tac "map (f, List)")
apply (simp_all)
apply (case_tac "map (f, x)")
apply (simp_all)
done
theorem map_functor: "app (Some map) (pair (apt (Some o) (pair (Some g) (Some f))) (Some xs)) = app (Some map) (pair (Some g) (app (Some map) (pair (Some f) (Some xs))))"
apply (induct_tac xs)
apply (simp_all)
apply (case_tac "f a")
apply (simp_all)
apply (case_tac "g aa")
apply (simp)
apply (case_tac [!] "map (f, List)")
apply (simp_all)
done
theorem filter_prom: "app (Some filter) (pair (Some p) (app (Some map) (pair (Some f) (Some xs)))) = app (Some map) (pair (Some f) (app (Some filter) (pair (apt (Some o) (pair (Some p) (Some f))) (Some xs))))"
apply (induct_tac xs)
apply (auto)
apply (case_tac "option_case None p (f a) = None")
apply (auto)
apply (case_tac [!] "f a  = None")
apply (auto)
apply (case_tac [!] "map (f, List) = None")
apply (auto)
apply (case_tac [!] y)
apply (auto)
apply (case_tac [!] "filter (%x. option_case None p (f x), List)")
apply (auto)
done
lemma option_inj_new: "Some x = Some y ==> x = y"
apply (auto)
done

theorem zip_spec: "apt (Some lengtH) (Some xs) = apt (Some lengtH) (Some ys) --> apt (Some unzip) (apt (Some zip) (pair (Some xs) (Some ys))) = pair (Some xs) (Some ys)"
apply (simp only: apt.simps pair.simps)
apply (simp)
apply (rule_tac  x = ys in spec)
apply (induct_tac xs)
apply simp
apply (rule allI)
apply (case_tac x)
apply (auto)
apply (case_tac x)
apply (simp)
apply (simp)
apply (rule option_inj_new)
apply (simp)
done

end


theory PreferenceLogicTests1                (*Benzmüller & Fuenmayor, 2020*)
   imports PreferenceLogicBasics
begin (*Tests for the SSE of van Benthem, Girard and Roy, JPL 2009, in HOL*)
(*Fact 1: definability of the four principal operators and verification*)
lemma Fact1_9:  "(\<phi> \<^bold>\<preceq>\<^sub>E\<^sub>E \<psi>) u \<longleftrightarrow> (\<phi> \<preceq>\<^sub>E\<^sub>E \<psi>) u" by smt
lemma Fact1_10: "(\<phi> \<^bold>\<preceq>\<^sub>A\<^sub>E \<psi>) u \<longleftrightarrow> (\<phi> \<preceq>\<^sub>A\<^sub>E \<psi>) u" by smt
lemma Fact1_11: "(\<phi> \<^bold>\<prec>\<^sub>E\<^sub>E \<psi>) u \<longleftrightarrow> (\<phi> \<prec>\<^sub>E\<^sub>E \<psi>) u" by smt
lemma Fact1_12: "(\<phi> \<^bold>\<prec>\<^sub>A\<^sub>E \<psi>) u \<longleftrightarrow> (\<phi> \<prec>\<^sub>A\<^sub>E \<psi>) u" by smt
(*Fact 2: definability of remaining preference operators and verification*)
lemma Fact2_13: "is_total SBR \<longrightarrow> ((\<phi> \<^bold>\<prec>\<^sub>A\<^sub>A \<psi>) u \<longleftrightarrow> (\<phi> \<prec>\<^sub>A\<^sub>A \<psi>) u)"  by smt
lemma Fact2_14: "is_total SBR \<longrightarrow> ((\<phi> \<^bold>\<succ>\<^sub>E\<^sub>A \<psi>) u \<longleftrightarrow> (\<phi> \<succ>\<^sub>E\<^sub>A \<psi>) u)"  by smt
lemma Fact2_15: "is_total SBR \<longrightarrow> ((\<phi> \<^bold>\<preceq>\<^sub>A\<^sub>A \<psi>) u \<longleftrightarrow> (\<phi> \<preceq>\<^sub>A\<^sub>A \<psi>) u)"  by smt
lemma Fact2_16: "is_total SBR \<longrightarrow> ((\<phi> \<^bold>\<succeq>\<^sub>E\<^sub>A \<psi>) u \<longleftrightarrow> (\<phi> \<succeq>\<^sub>E\<^sub>A \<psi>) u)"  by smt
(*Section 3.5 "Axiomatization" -- verify interaction axioms*)
lemma Inclusion_1:   "\<lfloor>(\<^bold>\<diamond>\<^sup>\<prec>\<phi>) \<^bold>\<rightarrow> (\<^bold>\<diamond>\<^sup>\<preceq>\<phi>)\<rfloor>"      by auto
lemma Interaction_1: "\<lfloor>(\<^bold>\<diamond>\<^sup>\<preceq>\<^bold>\<diamond>\<^sup>\<prec>\<phi>) \<^bold>\<rightarrow> (\<^bold>\<diamond>\<^sup>\<prec>\<phi>)\<rfloor>"   using tBR by blast
lemma Trans_le:      "\<lfloor>(\<^bold>\<diamond>\<^sup>\<prec>\<^bold>\<diamond>\<^sup>\<prec>\<phi>) \<^bold>\<rightarrow> (\<^bold>\<diamond>\<^sup>\<prec>\<phi>)\<rfloor>"   using tBR by blast
lemma Interaction_2: "\<lfloor>(\<phi> \<^bold>\<and> \<^bold>\<diamond>\<^sup>\<preceq>\<psi>) \<^bold>\<rightarrow>  ((\<^bold>\<diamond>\<^sup>\<prec>\<psi>) \<^bold>\<or> \<^bold>\<diamond>\<^sup>\<preceq>(\<psi> \<^bold>\<and>  \<^bold>\<diamond>\<^sup>\<preceq>\<phi>))\<rfloor>" by blast
lemma Fact4:         "\<lfloor>(\<phi> \<^bold>\<and> \<^bold>\<diamond>\<^sup>\<preceq>\<psi>) \<^bold>\<rightarrow> ((\<^bold>\<diamond>\<^sup>\<prec>\<psi>) \<^bold>\<or> \<^bold>\<diamond>\<^sup>\<preceq>(\<psi> \<^bold>\<and>  \<^bold>\<diamond>\<^sup>\<preceq>\<phi>))\<rfloor> \<longleftrightarrow>
                       (\<forall>w. \<forall>v. (((w \<preceq> v) \<and> \<not>(v \<preceq> w)) \<longrightarrow> (w \<prec> v)))" by smt
lemma Interaction_3:   "\<lfloor>(\<^bold>\<diamond>\<^sup>\<prec>\<^bold>\<diamond>\<^sup>\<preceq>\<phi>) \<^bold>\<rightarrow> (\<^bold>\<diamond>\<^sup>\<prec>\<phi>)\<rfloor>" using tBR by blast
lemma Inclusion_2:     "\<lfloor>(\<^bold>\<diamond>\<^sup>\<preceq>\<phi>) \<^bold>\<rightarrow> (\<^bold>E\<phi>)\<rfloor>"      by blast
(*Section 3.6 "A binary preference fragment"*)
(* \<^bold>\<preceq>\<^sub>E\<^sub>E is the dual of \<^bold>\<prec>\<^sub>A\<^sub>A *)
lemma "\<lfloor>(\<phi> \<^bold>\<preceq>\<^sub>E\<^sub>E \<psi>) \<^bold>\<leftrightarrow> \<^bold>\<not>(\<psi> \<^bold>\<prec>\<^sub>A\<^sub>A \<phi>)\<rfloor> \<and> \<lfloor>(\<phi> \<^bold>\<prec>\<^sub>A\<^sub>A \<psi>) \<^bold>\<leftrightarrow> \<^bold>\<not>(\<psi> \<^bold>\<preceq>\<^sub>E\<^sub>E \<phi>)\<rfloor>"  by simp
(* \<preceq>\<^sub>E\<^sub>E is the dual of \<prec>\<^sub>A\<^sub>A only if totality is assumed*)
lemma "\<lfloor>(\<phi> \<preceq>\<^sub>E\<^sub>E \<psi>) \<^bold>\<leftrightarrow> \<^bold>\<not>(\<psi> \<prec>\<^sub>A\<^sub>A \<phi>)\<rfloor>"  nitpick oops (*countermodel*)
lemma "\<lfloor>(\<phi> \<preceq>\<^sub>E\<^sub>E \<psi>) \<^bold>\<rightarrow> \<^bold>\<not>(\<psi> \<prec>\<^sub>A\<^sub>A \<phi>)\<rfloor>"  by blast (* only this direction holds*)
lemma "is_total SBR \<longrightarrow> \<lfloor>(\<phi> \<preceq>\<^sub>E\<^sub>E \<psi>) \<^bold>\<leftrightarrow> \<^bold>\<not>(\<psi> \<prec>\<^sub>A\<^sub>A \<phi>)\<rfloor>"  by blast
lemma "\<lfloor>(\<phi> \<prec>\<^sub>A\<^sub>A \<psi>) \<^bold>\<leftrightarrow> \<^bold>\<not>(\<psi> \<preceq>\<^sub>E\<^sub>E \<phi>)\<rfloor>"  nitpick oops (*countermodel*)
lemma "\<lfloor>(\<phi> \<prec>\<^sub>A\<^sub>A \<psi>) \<^bold>\<rightarrow> \<^bold>\<not>(\<psi> \<preceq>\<^sub>E\<^sub>E \<phi>)\<rfloor>"  by blast (* only this direction holds*)
lemma "is_total SBR \<longrightarrow> \<lfloor>(\<phi> \<prec>\<^sub>A\<^sub>A \<psi>) \<^bold>\<leftrightarrow> \<^bold>\<not>(\<psi> \<preceq>\<^sub>E\<^sub>E \<phi>)\<rfloor>"  by blast
(* verify p.97-98 *)
lemma monotonicity:  "\<lfloor>((\<phi> \<preceq>\<^sub>E\<^sub>E \<psi>) \<^bold>\<and> \<^bold>A(\<phi>\<^bold>\<rightarrow>\<xi>)) \<^bold>\<rightarrow> (\<xi> \<preceq>\<^sub>E\<^sub>E \<psi>)\<rfloor>" by blast
lemma reducibility:
         "\<lfloor>(((\<phi> \<preceq>\<^sub>E\<^sub>E \<psi>) \<^bold>\<and> \<alpha>) \<preceq>\<^sub>E\<^sub>E \<beta>) \<^bold>\<leftrightarrow> ((\<phi> \<preceq>\<^sub>E\<^sub>E \<psi>) \<^bold>\<and> (\<alpha> \<preceq>\<^sub>E\<^sub>E \<beta>))\<rfloor>" by blast
lemma reflexivity:   "\<lfloor>\<phi> \<^bold>\<rightarrow> (\<phi> \<preceq>\<^sub>E\<^sub>E \<phi>)\<rfloor>" using rBR by blast
(*The condition below is supposed to enforce totality of the preference
   relation. However there are countermodels. See p.98?*)
lemma "is_total SBR \<longrightarrow>
       \<lfloor>((\<phi> \<preceq>\<^sub>E\<^sub>E \<phi>)\<^bold>\<and>(\<psi> \<preceq>\<^sub>E\<^sub>E \<psi>)) \<^bold>\<rightarrow> ((\<phi> \<preceq>\<^sub>E\<^sub>E \<psi>)\<^bold>\<or>(\<psi> \<preceq>\<^sub>E\<^sub>E \<phi>))\<rfloor>"  by auto
lemma "\<lfloor>((\<phi> \<preceq>\<^sub>E\<^sub>E \<phi>) \<^bold>\<and> (\<psi> \<preceq>\<^sub>E\<^sub>E \<psi>)) \<^bold>\<rightarrow> ((\<phi> \<preceq>\<^sub>E\<^sub>E \<psi>) \<^bold>\<or> (\<psi> \<preceq>\<^sub>E\<^sub>E \<phi>))\<rfloor>
       \<longrightarrow> is_total SBR" nitpick oops (*countermodel -- error in paper?*)
lemma "is_total SBR \<longrightarrow>
       \<lfloor>((\<phi> \<^bold>\<preceq>\<^sub>E\<^sub>E \<phi>) \<^bold>\<and> (\<psi> \<^bold>\<preceq>\<^sub>E\<^sub>E \<psi>)) \<^bold>\<rightarrow> ((\<phi> \<^bold>\<preceq>\<^sub>E\<^sub>E \<psi>) \<^bold>\<or> (\<psi> \<^bold>\<preceq>\<^sub>E\<^sub>E \<phi>))\<rfloor>" by auto
lemma "\<lfloor>((\<phi> \<^bold>\<preceq>\<^sub>E\<^sub>E \<phi>) \<^bold>\<and> (\<psi> \<^bold>\<preceq>\<^sub>E\<^sub>E \<psi>)) \<^bold>\<rightarrow> ((\<phi> \<^bold>\<preceq>\<^sub>E\<^sub>E \<psi>) \<^bold>\<or> (\<psi> \<^bold>\<preceq>\<^sub>E\<^sub>E \<phi>))\<rfloor>
       \<longrightarrow> is_total SBR" nitpick oops (*countermodel -- error in paper?*)

end


(*  Title:      ZF/UNITY/Distributor.thy
    Author:     Sidi O Ehmety, Cambridge University Computer Laboratory
    Copyright   2002  University of Cambridge

A multiple-client allocator from a single-client allocator:
Distributor specification.
*)

theory Distributor imports AllocBase Follows  Guar GenPrefix begin

text{*Distributor specification (the number of outputs is Nclients)*}

text{*spec (14)*}

definition
  distr_follows :: "[i, i, i, i =>i] =>i"  where
    "distr_follows(A, In, iIn, Out) ==
     (lift(In) IncreasingWrt prefix(A)/list(A)) \<inter>
     (lift(iIn) IncreasingWrt prefix(nat)/list(nat)) \<inter>
     Always({s \<in> state. \<forall>elt \<in> set_of_list(s`iIn). elt < Nclients})
         guarantees
         (\<Inter>n \<in> Nclients.
          lift(Out(n))
              Fols
          (%s. sublist(s`In, {k \<in> nat. k<length(s`iIn) & nth(k, s`iIn) = n}))
          Wrt prefix(A)/list(A))"

definition
  distr_allowed_acts :: "[i=>i]=>i"  where
    "distr_allowed_acts(Out) ==
     {D \<in> program. AllowedActs(D) =
     cons(id(state), \<Union>G \<in> (\<Inter>n\<in>nat. preserves(lift(Out(n)))). Acts(G))}"

definition
  distr_spec :: "[i, i, i, i =>i]=>i"  where
    "distr_spec(A, In, iIn, Out) ==
     distr_follows(A, In, iIn, Out) \<inter> distr_allowed_acts(Out)"

locale distr =
  fixes In  --{*items to distribute*}
    and iIn --{*destinations of items to distribute*}
    and Out --{*distributed items*}
    and A   --{*the type of items being distributed *}
    and D
 assumes
     var_assumes [simp]:  "In \<in> var & iIn \<in> var & (\<forall>n. Out(n):var)"
 and all_distinct_vars:   "\<forall>n. all_distinct([In, iIn, Out(n)])"
 and type_assumes [simp]: "type_of(In)=list(A) &  type_of(iIn)=list(nat) &
                          (\<forall>n. type_of(Out(n))=list(A))"
 and default_val_assumes [simp]:
                         "default_val(In)=Nil &
                          default_val(iIn)=Nil &
                          (\<forall>n. default_val(Out(n))=Nil)"
 and distr_spec:  "D \<in> distr_spec(A, In, iIn, Out)"

lemma (in distr) In_value_type [simp,TC]: "s \<in> state ==> s`In \<in> list(A)"
apply (unfold state_def)
apply (drule_tac a = In in apply_type, auto)
done

lemma (in distr) iIn_value_type [simp,TC]:
     "s \<in> state ==> s`iIn \<in> list(nat)"
apply (unfold state_def)
apply (drule_tac a = iIn in apply_type, auto)
done

lemma (in distr) Out_value_type [simp,TC]:
     "s \<in> state ==> s`Out(n):list(A)"
apply (unfold state_def)
apply (drule_tac a = "Out (n)" in apply_type)
apply auto
done

lemma (in distr) D_in_program [simp,TC]: "D \<in> program"
apply (cut_tac distr_spec)
apply (auto simp add: distr_spec_def distr_allowed_acts_def)
done

lemma (in distr) D_ok_iff:
     "G \<in> program ==>
        D ok G \<longleftrightarrow> ((\<forall>n \<in> nat. G \<in> preserves(lift(Out(n)))) & D \<in> Allowed(G))"
apply (cut_tac distr_spec)
apply (auto simp add: INT_iff distr_spec_def distr_allowed_acts_def
                      Allowed_def ok_iff_Allowed)
apply (drule safety_prop_Acts_iff [THEN [2] rev_iffD1])
apply (auto intro: safety_prop_Inter)
done

lemma (in distr) distr_Increasing_Out:
"D \<in> ((lift(In) IncreasingWrt prefix(A)/list(A)) \<inter>
      (lift(iIn) IncreasingWrt prefix(nat)/list(nat)) \<inter>
      Always({s \<in> state. \<forall>elt \<in> set_of_list(s`iIn). elt<Nclients}))
      guarantees
          (\<Inter>n \<in> Nclients. lift(Out(n)) IncreasingWrt
                            prefix(A)/list(A))"
apply (cut_tac D_in_program distr_spec)
apply (simp (no_asm_use) add: distr_spec_def distr_follows_def)
apply (auto intro!: guaranteesI intro: Follows_imp_Increasing_left
            dest!: guaranteesD)
done

lemma (in distr) distr_bag_Follows_lemma:
"[| \<forall>n \<in> nat. G \<in> preserves(lift(Out(n)));
   D \<squnion> G \<in> Always({s \<in> state.
          \<forall>elt \<in> set_of_list(s`iIn). elt < Nclients}) |]
  ==> D \<squnion> G \<in> Always
          ({s \<in> state. msetsum(%n. bag_of (sublist(s`In,
                       {k \<in> nat. k < length(s`iIn) &
                          nth(k, s`iIn)= n})),
                         Nclients, A) =
              bag_of(sublist(s`In, length(s`iIn)))})"
apply (cut_tac D_in_program)
apply (subgoal_tac "G \<in> program")
 prefer 2 apply (blast dest: preserves_type [THEN subsetD])
apply (erule Always_Diff_Un_eq [THEN iffD1])
apply (rule state_AlwaysI [THEN Always_weaken], auto)
apply (rename_tac s)
apply (subst bag_of_sublist_UN_disjoint [symmetric])
   apply (simp (no_asm_simp) add: nat_into_Finite)
  apply blast
 apply (simp (no_asm_simp))
apply (simp add: set_of_list_conv_nth [of _ nat])
apply (subgoal_tac
       "(\<Union>i \<in> Nclients. {k\<in>nat. k < length(s`iIn) & nth(k, s`iIn) = i}) =
        length(s`iIn) ")
apply (simp (no_asm_simp))
apply (rule equalityI)
apply (force simp add: ltD, safe)
apply (rename_tac m)
apply (subgoal_tac "length (s ` iIn) \<in> nat")
apply typecheck
apply (subgoal_tac "m \<in> nat")
apply (drule_tac x = "nth(m, s`iIn) " and P = "%elt. ?X (elt) \<longrightarrow> elt<Nclients" in bspec)
apply (simp add: ltI)
apply (simp_all add: Ord_mem_iff_lt)
apply (blast dest: ltD)
apply (blast intro: lt_trans)
done

theorem (in distr) distr_bag_Follows:
 "D \<in> ((lift(In) IncreasingWrt prefix(A)/list(A)) \<inter>
       (lift(iIn) IncreasingWrt prefix(nat)/list(nat)) \<inter>
        Always({s \<in> state. \<forall>elt \<in> set_of_list(s`iIn). elt < Nclients}))
      guarantees
       (\<Inter>n \<in> Nclients.
        (%s. msetsum(%i. bag_of(s`Out(i)),  Nclients, A))
        Fols
        (%s. bag_of(sublist(s`In, length(s`iIn))))
        Wrt MultLe(A, r)/Mult(A))"
apply (cut_tac distr_spec)
apply (rule guaranteesI, clarify)
apply (rule distr_bag_Follows_lemma [THEN Always_Follows2])
apply (simp add: D_ok_iff, auto)
apply (rule Follows_state_ofD1)
apply (rule Follows_msetsum_UN)
   apply (simp_all add: nat_into_Finite bag_of_multiset [of _ A])
apply (auto simp add: distr_spec_def distr_follows_def)
apply (drule guaranteesD, assumption)
apply (simp_all cong add: Follows_cong
                add: refl_prefix
                   mono_bag_of [THEN subset_Follows_comp, THEN subsetD,
                                unfolded metacomp_def])
done

end


section \<open>Nondeterministic Büchi Automata\<close>

theory NBA
imports "../Nondeterministic"
begin

  datatype ('label, 'state) nba = nba
    (alphabet: "'label set")
    (initial: "'state set")
    (transition: "'label \<Rightarrow> 'state \<Rightarrow> 'state set")
    (accepting: "'state pred")

  global_interpretation nba: automaton nba alphabet initial transition accepting
    defines path = nba.path and run = nba.run and reachable = nba.reachable and nodes = nba.nodes
    by unfold_locales auto
  global_interpretation nba: automaton_run nba alphabet initial transition accepting "\<lambda> P w r p. infs P (p ## r)"
    defines language = nba.language
    by standard

  abbreviation target where "target \<equiv> nba.target"
  abbreviation states where "states \<equiv> nba.states"
  abbreviation trace where "trace \<equiv> nba.trace"
  abbreviation successors where "successors \<equiv> nba.successors TYPE('label)"

  instantiation nba :: (type, type) order
  begin

    definition less_eq_nba :: "('a, 'b) nba \<Rightarrow> ('a, 'b) nba \<Rightarrow> bool" where
      "A \<le> B \<equiv> alphabet A \<le> alphabet B \<and> initial A \<le> initial B \<and>
        transition A \<le> transition B \<and> accepting A \<le> accepting B"
    definition less_nba :: "('a, 'b) nba \<Rightarrow> ('a, 'b) nba \<Rightarrow> bool" where
      "less_nba A B \<equiv> A \<le> B \<and> A \<noteq> B"

    instance by (intro_classes) (auto simp: less_eq_nba_def less_nba_def nba.expand)

  end

  lemma nodes_mono: "mono nodes"
  proof
    fix A B :: "('label, 'state) nba"
    assume 1: "A \<le> B"
    have 2: "alphabet A \<subseteq> alphabet B" using 1 unfolding less_eq_nba_def by auto
    have 3: "initial A \<subseteq> initial B" using 1 unfolding less_eq_nba_def by auto
    have 4: "transition A a p \<subseteq> transition B a p" for a p using 1 unfolding less_eq_nba_def le_fun_def by auto
    have 5: "p \<in> nodes B" if "p \<in> nodes A" for p using that 2 3 4 by induct fastforce+
    show "nodes A \<subseteq> nodes B" using 5 by auto
  qed

  lemma language_mono: "mono language"
  proof
    fix A B :: "('label, 'state) nba"
    assume 1: "A \<le> B"
    have 2: "alphabet A \<subseteq> alphabet B" using 1 unfolding less_eq_nba_def by auto
    have 3: "initial A \<subseteq> initial B" using 1 unfolding less_eq_nba_def by auto
    have 4: "transition A a p \<subseteq> transition B a p" for a p using 1 unfolding less_eq_nba_def le_fun_def by auto
    have 5: "accepting A p \<Longrightarrow> accepting B p" for p using 1 unfolding less_eq_nba_def by auto
    have 6: "run B wr p" if "run A wr p" for wr p using that 2 4 by coinduct auto
    have 7: "infs (accepting B) w" if "infs (accepting A) w" for w using infs_mono that 5 by metis
    show "language A \<subseteq> language B" using 3 6 7 by blast
  qed

  lemma simulation_language:
    assumes "alphabet A \<subseteq> alphabet B"
    assumes "\<And> p. p \<in> initial A \<Longrightarrow> \<exists> q \<in> initial B. (p, q) \<in> R"
    assumes "\<And> a p p' q. p' \<in> transition A a p \<Longrightarrow> (p, q) \<in> R \<Longrightarrow> \<exists> q' \<in> transition B a q. (p', q') \<in> R"
    assumes "\<And> p q. (p, q) \<in> R \<Longrightarrow> accepting A p \<Longrightarrow> accepting B q"
    shows "language A \<subseteq> language B"
  proof
    fix w
    assume 1: "w \<in> language A"
    obtain r p where 2: "p \<in> initial A" "run A (w ||| r) p" "infs (accepting A) (p ## r)" using 1 by rule
    define P where "P n q \<equiv> (target (stake n (w ||| r)) p, q) \<in> R" for n q
    obtain q where 3: "q \<in> initial B" "(p, q) \<in> R" using assms(2) 2(1) by auto
    obtain ws where 4:
      "run B ws q" "\<And> i. P (0 + i) (target (stake i ws) q)" "\<And> i. fst (ws !! i) = w !! (0 + i)"
    proof (rule nba.invariant_run_index)
      have "stake k (w ||| r) @- (w !! k, target (stake (Suc k) (w ||| r)) p) ##
        sdrop (Suc k) (w ||| r) = w ||| r" for k
        by (metis id_stake_snth_sdrop snth_szip sscan_snth szip_smap_snd nba.trace_alt_def)
      also have "run A \<dots> p" using 2(2) by this
      finally show "\<exists> a. (fst a \<in> alphabet B \<and> snd a \<in> transition B (fst a) q) \<and>
        P (Suc n) (snd a) \<and> fst a = w !! n" if "P n q" for n q
        using assms(1, 3) that unfolding P_def by fastforce
      show "P 0 q" unfolding P_def using 3(2) by auto
    qed rule
    obtain s where 5: "ws = w ||| s" using 4(3) by (metis add.left_neutral eqI_snth snth_smap szip_smap)
    show "w \<in> language B"
    proof
      show "q \<in> initial B" using 3(1) by this
      show "run B (w ||| s) q" using 4(1) unfolding 5 by this
      have 6: "(\<lambda> a b. (a, b) \<in> R) \<le> (\<lambda> a b. accepting A a \<longrightarrow> accepting B b)" using assms(4) by auto
      have 7: "stream_all2 (\<lambda> p q. (p, q) \<in> R) (trace (w ||| r) p) (trace (w ||| s) q)"
        using 4(2) unfolding P_def 5 by (simp add: stream_rel_snth del: stake.simps(2))
      have 8: "stream_all2 (\<lambda> a b. accepting A a \<longrightarrow> accepting B b) r s"
        using stream.rel_mono 6 7 unfolding nba.trace_alt_def by auto
      show "infs (accepting B) (q ## s)" using infs_mono_strong 8 2(3) by simp
    qed
  qed

end


theory Union_Find_Time_alpha_verification
  imports
    Union_Find_Time_alpha_abstract_analysis Union_Find_Time_alpha_fix
begin

no_notation Ref_Time.update ("_ := _" 62)

(* TODO: MOVE *)

  lemma per_union_impl: "(i,j)\<in>R \<Longrightarrow> (i,j)\<in>per_union R a b"
    by (auto simp: per_union_def)

subsubsection\<open>uf_init_lemmas\<close>

definition is_uf :: "(nat\<times>nat) set \<Rightarrow> uf \<Rightarrow> assn" where
  "is_uf R u \<equiv> case u of (s,p) \<Rightarrow>
  \<exists>\<^sub>Al rkl. p\<mapsto>\<^sub>al * s\<mapsto>\<^sub>arkl
    * \<up>(ufa_\<alpha> l = R \<and> length rkl = length l \<and> invar_rank l rkl)
    * $(\<Phi> l rkl * 4)"

lemma of_list_rule':
    "<$ (1 + n)> Array_Time.of_list [0..<n] <\<lambda>r. r \<mapsto>\<^sub>a [0..<n]>"
  by (sep_auto heap: of_list_rule[of "[0..<n]", simplified])

lemma \<Phi>_init_value: "\<Phi> [0..<n] (replicate n 0) = 2*n"
    by (simp add: \<phi>_def rankr_def \<rho>_def alphar_r)

definition uf_init_time :: "nat \<Rightarrow> nat" where "uf_init_time n \<equiv> 4*(2*n+3+2*n)"

lemma uf_init_bound[asym_bound]: "uf_init_time \<in> \<Theta>(\<lambda>n. n)"
  unfolding uf_init_time_def by auto2

lemmas \<Phi>_simp[simp del]
lemma uf_init_rule':
    "<$(uf_init_time n)> uf_init n <is_uf {(i,i) |i. i<n}  >\<^sub>t"
  unfolding uf_init_time_def uf_init_def is_uf_def
  apply (sep_auto heap: of_list_rule' eintros del: exI)
  apply(rule exI[where x="[0..<n]"])
  apply(rule exI[where x="replicate n 0"])
  by (sep_auto simp add: ufa_init_correct ufa_init_invar_rank \<Phi>_init_value)

subsubsection\<open>uf_rep_of lemmas\<close>

lemma uf_rep_of_rule: "\<lbrakk>ufa_invar l; i<length l\<rbrakk> \<Longrightarrow>
  <p\<mapsto>\<^sub>al * $(height_of l i + 2)> uf_rep_of p i <\<lambda>r. p\<mapsto>\<^sub>al * \<up>(r=rep_of l i)>\<^sub>t"
  by (induct rule: rep_of_induct)
     (sep_auto simp: uf_rep_of.simps rep_of_step rep_of_refl height_of_step)+

subsubsection\<open>uf_compress lemmas\<close>

lemma compress_invar_rank':
  assumes "invar_rank l rkl" "i<length l" "u=rep_of l i"
  shows "invar_rank (l[i := u]) rkl"
  by (metis assms(1,2,3) compress_evolution invar_rank_evolution list_update_id rep_of_refl)

lemma uf_compress_rule_explicit:
  assumes "invar_rank l rkl" "i<length l" "ci=rep_of l i" "bw_ipc l i d l'"
  shows "<p\<mapsto>\<^sub>al * $(1+d*3)>
           uf_compress i ci p
        <\<lambda>_. (p\<mapsto>\<^sub>al' * \<up>(invar_rank l' rkl \<and> length l' = length l
                        \<and> (\<forall>i<length l. rep_of l' i = rep_of l i)) )>\<^sub>t"
  using assms(4,1-3)
proof (induct rule: bw_ipc.induct)
  case (BWIPCBase x l)
  hence "x = rep_of l x" using rep_of_refl by auto
  with BWIPCBase show ?case by (sep_auto simp: uf_compress.simps)
next
  case (BWIPCStep x y l i l')
  hence "y<length l" unfolding ufa_\<beta>_start_def by fast
  have "ufa_invar l" using invar_rank_ufa_invarI[OF BWIPCStep(4)] .
  hence "ci<length l" using BWIPCStep rep_of_bound by auto
  have "(x,y)\<in> (ufa_\<beta>_start l)\<^sup>*" using BWIPCStep by blast
  have "y = l!x" using BWIPCStep(1) unfolding ufa_\<beta>_start_def by blast
  have "rep_of l y = ci"
    using rep_of_invar_along_path[OF \<open>ufa_invar l\<close> \<open>ci<length l\<close> \<open>y<length l\<close> \<open>x<length l\<close>
        \<open>ci=rep_of l x\<close> \<open>(x,y)\<in> (ufa_\<beta>_start l)\<^sup>*\<close>] by blast
  have ipcx: "bw_ipc l x (Suc i) (l'[x := rep_of l x])" using  bw_ipc.intros(2)[OF BWIPCStep(1,2)] .
  have IH: "<p \<mapsto>\<^sub>a l * $ (1 + i * 3)>
              uf_compress (l!x) (rep_of l x) p
           <\<lambda>r. p \<mapsto>\<^sub>a l' * \<up> (invar_rank l' rkl \<and> length l' = length l
                               \<and> (\<forall>i<length l. rep_of l' i = rep_of l i))>\<^sub>t"
    using BWIPCStep(3)[OF \<open>invar_rank l rkl\<close> \<open>y<length l\<close>  \<open>rep_of l y = ci\<close>[symmetric]]
           \<open>ci = rep_of l x\<close> \<open>y = l!x\<close> by blast
  show ?case
  proof (cases "x = ci")
    case True
    hence "x = l!x"
      using \<open>ci = rep_of l x\<close> BWIPCStep.prems(2) \<open>ufa_invar l\<close> rep_of_min by fastforce
    then have "bw_ipc l x 0 l" by (rule bw_ipc.intros)
    hence " Suc i = 0"
      using bw_ipc_root_unique  \<open>x = l!x\<close> \<open>bw_ipc l x (Suc i) (l'[x := rep_of l x])\<close>   by auto
    then show ?thesis by simp
  next
    case False
    thus ?thesis
      apply (subst uf_compress.simps)
      by (sep_auto heap: IH intro: compress_invar_rank' dest: invar_rank_ufa_invarI
          simp: \<open>x<length l\<close> \<open>ci = rep_of l x\<close> ufa_compress_rep_of )
  qed
qed

subsubsection\<open>uf_rep_of_c lemmas\<close>

lemma uf_rep_of_c_rule_explicit:
  assumes "invar_rank l rkl" "i<length l" "bw_ipc l i d l'"
  shows"<p\<mapsto>\<^sub>al * $(4+d*4)>
             uf_rep_of_c p i
        <\<lambda>r. p\<mapsto>\<^sub>al'
    * \<up>(r=rep_of l i \<and> invar_rank l' rkl
       \<and> length l' = length l
       \<and> (\<forall>i<length l. rep_of l' i = rep_of l i))>\<^sub>t"
proof -
  have "ufa_invar l" using invar_rank_ufa_invarI[OF assms(1)] .
  show ?thesis unfolding uf_rep_of_c_def
    apply (subst height_of_ipc_equiv[OF assms(3) \<open>ufa_invar l\<close> assms(2)])
    using assms \<open>ufa_invar l\<close>
    apply (sep_auto heap: uf_rep_of_rule)
     apply (subst height_of_ipc_equiv[OF assms(3) \<open>ufa_invar l\<close> assms(2), symmetric])
     apply (sep_auto heap: uf_compress_rule_explicit[where d = d])
    by sep_auto
qed

definition uf_rep_of_c_time where "uf_rep_of_c_time n = 8 * \<alpha>\<^sub>r (n + (\<rho> - 1))"

lemma uf_rep_of_c_rule: "\<lbrakk>invar_rank l rkl; i<length l\<rbrakk> \<Longrightarrow>
  <p\<mapsto>\<^sub>al * $(4* \<Phi> l rkl + uf_rep_of_c_time (length l))> uf_rep_of_c p i <\<lambda>r.\<exists>\<^sub>A l'. p\<mapsto>\<^sub>al'
    *$(4* \<Phi> l' rkl) * \<up>(r=rep_of l i \<and> invar_rank l' rkl
       \<and> length l = length l'  \<and> ufa_\<alpha> l = ufa_\<alpha> l'
       \<and> (\<forall>i<length l. rep_of l' i = rep_of l i))>\<^sub>t"
proof goal_cases
  case 1
  obtain d l' where bw: "bw_ipc l i d l'" " \<Phi> l' rkl + d < \<Phi> l rkl + 2 * \<alpha>\<^sub>r (length l + (\<rho> - 1))"
    using amortized_cost_of_iterated_path_compression_global[OF 1(1,2)] by blast
  hence potentialjump: "4*\<Phi> l rkl + uf_rep_of_c_time (length l) \<ge> 4*\<Phi> l' rkl + d*4 + 4"
    unfolding uf_rep_of_c_time_def by fastforce
  have sep: "4 * \<Phi> l rkl + uf_rep_of_c_time (length l) =
           4 * \<Phi> l' rkl + d * 4 + 4 + (4 * \<Phi> l rkl + uf_rep_of_c_time (length l)
           - (4 * \<Phi> l' rkl + d * 4 + 4))"
    using add_diff_inverse potentialjump by simp
  show ?case
    apply (subst sep)
    using 1 bw by (sep_auto heap: uf_rep_of_c_rule_explicit[where d=d] intro!: ufa_\<alpha>I)
qed

\<comment>\<open>lemma "(\<lambda>n. \<alpha> (n+1)) \<in> \<Theta>(\<lambda>n. \<alpha> n)"

lemma "(\<lambda>x. 20  + 8 * real (\<alpha> (x + 1)))
  \<in> \<Theta>(\<lambda>x. real (\<alpha> x))" unfolding \<rho>_def apply auto2

lemma uf_rep_of_c_time2_asym: "uf_rep_of_c_time2 \<in> \<Theta>(\<lambda>n. \<alpha> n)"
  unfolding uf_rep_of_c_time2_def using alphar_one[OF \<rho>_gt_0 ] \<rho>_def apply simp
  apply auto2 \<close>

subsubsection\<open>uf_cmp lemmas\<close>

definition uf_cmp_time where "uf_cmp_time n \<equiv> 2 * uf_rep_of_c_time n + 2"

lemma uf_cmp_rule: assumes "invar_rank l rkl" "i<length l" "j<length l"
  shows "<p\<mapsto>\<^sub>al * s\<mapsto>\<^sub>arkl* $(\<Phi> l rkl * 4 + uf_cmp_time (length l) )>
          uf_cmp (s,p) i j
        <\<lambda>r.\<exists>\<^sub>A l'. p\<mapsto>\<^sub>al' * s\<mapsto>\<^sub>arkl * $(\<Phi> l' rkl * 4)
             * \<up>((r\<longleftrightarrow>(rep_of l i = rep_of l j)) \<and> invar_rank l' rkl
                  \<and> length l' = length l  \<and> (\<forall>i<length l. rep_of l' i = rep_of l i))>\<^sub>t"
    using assms
    by (sep_auto simp: uf_cmp_time_def uf_cmp_def
                 heap: uf_rep_of_c_rule[where rkl=rkl])

lemma ufa_\<alpha>_out_of_bounds: "i \<ge> length l \<or> j \<ge> length l \<Longrightarrow> (i, j) \<in> ufa_\<alpha> l = False"
      using leD ufa_\<alpha>_lenD by force

lemma uf_cmp_rule_out_of_bounds: assumes "invar_rank l rkl" "i \<ge> length l \<or> j \<ge> length l"
  shows "<p\<mapsto>\<^sub>al * s\<mapsto>\<^sub>arkl* $(\<Phi> l rkl * 4 + uf_cmp_time (length l) )>
    uf_cmp (s,p) i j
  <\<lambda>r. p\<mapsto>\<^sub>al * s\<mapsto>\<^sub>arkl * $(\<Phi> l rkl * 4) * \<up>((\<not> r) \<and> invar_rank l rkl)>\<^sub>t"
  using assms by (sep_auto simp: uf_cmp_def uf_cmp_time_def)

lemma uf_cmp_rule_abstract:
  "<is_uf R u * $(uf_cmp_time (card (Domain R)))> uf_cmp u i j <\<lambda>r. is_uf R u * \<up>(r\<longleftrightarrow>(i,j)\<in>R)>\<^sub>t"
  apply (sep_auto split: prod.splits simp: is_uf_def)
  subgoal for s p l rkl
    apply (cases "i< length l \<and> j < length l")
    subgoal by (sep_auto heap: uf_cmp_rule simp: ufa_\<alpha>_def)
    subgoal by (sep_auto heap: uf_cmp_rule_out_of_bounds simp: ufa_\<alpha>_out_of_bounds)
    done
  done

subsubsection\<open>uf_union_lemmas\<close>

definition "uf_union_time n = 13 + uf_rep_of_c_time n * 2"

definition uf_union_snd :: "nat array \<Rightarrow> nat array \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow>  nat \<Rightarrow> nat \<Rightarrow> uf Heap" where
  "uf_union_snd r p ci cj i j \<equiv> do {
    if (ci=cj) then return (r,p)
    else do {
      ri \<leftarrow> Array_Time.nth r ci;
      rj \<leftarrow> Array_Time.nth r cj;
      if ri<rj then do {
        Array_Time.upd ci cj p;
         return (r,p)
      } else do {
        Array_Time.upd cj ci p;
        if (ri=rj) then do {
            Array_Time.upd ci (ri+1) r;
            return (r,p)
        } else return (r,p)
      }
    }
  }"

lemma uf_union_parts: "uf_union u i j \<equiv> do {
    let (r,p)=u;
    ci \<leftarrow> uf_rep_of_c p i;
    cj \<leftarrow> uf_rep_of_c p j;
    uf_union_snd r p ci cj i j
  }" unfolding uf_union_def uf_union_snd_def by simp

lemma ufa_union_rep_of: assumes "ufa_invar l" "i<length l" "j<length l"
  shows "ufa_union l i j = ufa_union l (rep_of l i) (rep_of l j)"
proof -
  have sub1: "rep_of l (rep_of l i) = rep_of l i" using assms using rep_of_idem by blast
  have sub2: "rep_of l (rep_of l j) = rep_of l j" using assms using rep_of_idem by blast
  show ?thesis apply (subst sub1) apply (subst sub2) ..
qed

lemma per_union_same :
  "i < length l'' \<Longrightarrow> j < length l''
     \<Longrightarrow> rep_of l'' i = rep_of l'' j  \<Longrightarrow> invar_rank l'' rkl
     \<Longrightarrow>  (aa, bb) \<in> per_union (ufa_\<alpha> l'') i j \<Longrightarrow> (aa, bb) \<in> ufa_\<alpha> l''"
  by (metis invar_rank_ufa_invarI list_update_id rep_of_bound rep_of_path_iff ufa_union_correct)

lemma EvUnion':
  assumes "x<length l" "y<length l" "x=l!x" "y=l!y" "x\<noteq>y"
    "newl = (union_by_rank_l l rkl x y)" "newrkl = (union_by_rank_rkl rkl x y)"
  shows "evolution l rkl newl newrkl"
  unfolding assms(6,7) apply(rule EvUnion) by fact+

lemma per_union_union_by_rank_l:
  assumes "ufa_invar l" "i < length l" "j < length l"
  shows "ufa_\<alpha> (union_by_rank_l l rkl (rep_of l i) (rep_of l j))
        = per_union (ufa_\<alpha> l) i j"
  using assms
  unfolding union_by_rank_l_def
  by (auto simp: ufa_union_rep_of[symmetric] ufa_union_correct intro: rep_of_bound)

lemma
  fixes l rkl i j
  defines "rkl' \<equiv> union_by_rank_rkl rkl (rep_of l i) (rep_of l j)" and
    "l' \<equiv> union_by_rank_l l rkl (rep_of l i) (rep_of l j)"
  assumes
    "length rkl = length l" "invar_rank l rkl"
    "i < length l" "j < length l"
    "rep_of l i \<noteq> rep_of l j"
  shows uf_union_snd_over_aprox:
    "p \<mapsto>\<^sub>a l' * r \<mapsto>\<^sub>a rkl' * true * $ (\<Phi> l rkl * 4 + 8)
       \<Longrightarrow>\<^sub>A p \<mapsto>\<^sub>a l' * r \<mapsto>\<^sub>a rkl' * true * $ (\<Phi> l' rkl' * 4)"
proof -
  have "ufa_invar l" using invar_rank_ufa_invarI assms by auto

  have ineq: "\<Phi> l' rkl'\<le> \<Phi> l rkl + 2"
    unfolding rkl'_def l'_def
    apply(rule potential_increase_during_link)
    using assms
    by (auto intro: invar_rank_ufa_invarI rep_of_bound rep_of_min[symmetric])
  then have ineq: "\<Phi> l' rkl' * 4 \<le> \<Phi> l rkl * 4 + 8"
    by linarith
  from le_Suc_ex[OF ineq] obtain R where
    R: "\<Phi> l rkl * 4 + 8 = \<Phi> l' rkl' * 4 + R"
    by blast
  show ?thesis
    apply(subst R) unfolding l'_def rkl'_def by(sep_auto)
qed

lemma uf_union_snd_rule:
  fixes l rkl i j
  defines "rkl' \<equiv> (if rep_of l i = rep_of l j then rkl else union_by_rank_rkl rkl (rep_of l i) (rep_of l j))"
    and   "l' \<equiv> (if rep_of l i = rep_of l j then l else union_by_rank_l l rkl (rep_of l i) (rep_of l j))"
  assumes "length rkl = length l" "invar_rank l rkl " "i<length l" "j<length l"
        "rep_of l i = ci" "rep_of l j = cj"
  shows "<p \<mapsto>\<^sub>a l * r \<mapsto>\<^sub>a rkl * $(\<Phi> l rkl * 4 + 13)>
      uf_union_snd r p ci cj i j
     <\<lambda>(r',p'). p' \<mapsto>\<^sub>a l' * r' \<mapsto>\<^sub>a rkl' * $ (\<Phi> l' rkl' * 4)
          * \<up> (ufa_\<alpha> l' = per_union (ufa_\<alpha> l) i j \<and> length rkl = length l' \<and> invar_rank l' rkl')>\<^sub>t"
  unfolding uf_union_snd_def uf_union_time_def
  using assms
  apply sep_auto
  subgoal
    by (simp add: union_by_rank_l_def per_union_impl)
  subgoal for l' la h
    by (auto simp: per_union_same)
  subgoal by sep_auto
  subgoal
    apply(cases "rkl ! rep_of l i" "rkl ! rep_of l j" rule: linorder_cases)
    subgoal (* rank of i's representant < rank of j's representant *)
      apply(sep_auto intro: rep_of_bound invar_rank_ufa_invarI)
      subgoal  apply(subst per_union_union_by_rank_l[symmetric])
        by (auto  intro: rep_of_bound invar_rank_ufa_invarI)
      subgoal  apply(subst per_union_union_by_rank_l)
        by (auto  intro: rep_of_bound invar_rank_ufa_invarI)
      subgoal
        apply(rule invar_rank_evolution)
         apply simp
        apply(rule EvUnion'[where x="rep_of l i" and y="rep_of l j"])
        by (auto intro: invar_rank_ufa_invarI rep_of_bound rep_of_min[symmetric]
            simp: union_by_rank_l_def union_by_rank_rkl_def
            ufa_union_rep_of  )
      subgoal
        apply(rule ent_trans[where Q="p \<mapsto>\<^sub>a union_by_rank_l l rkl (rep_of l i) (rep_of l j)
                                     * r \<mapsto>\<^sub>a union_by_rank_rkl rkl (rep_of l i) (rep_of l j)
                                     * true * $ (\<Phi> l rkl * 4 + 8)"] )
        subgoal apply (sep_auto simp: union_by_rank_rkl_def union_by_rank_l_def intro: invar_rank_ufa_invarI )
          apply(subst ufa_union_rep_of[symmetric])
             apply (auto intro: invar_rank_ufa_invarI)
          by (sep_auto)
        subgoal by (rule uf_union_snd_over_aprox)
        done
      subgoal by sep_auto
      done
    subgoal (* rank of i's representant = rank of j's representant *)
      apply(sep_auto intro: rep_of_bound invar_rank_ufa_invarI)
      subgoal  apply(subst per_union_union_by_rank_l[symmetric])
        by (auto  intro: rep_of_bound invar_rank_ufa_invarI)
      subgoal  apply(subst per_union_union_by_rank_l)
        by (auto  intro: rep_of_bound invar_rank_ufa_invarI)
      subgoal
        apply(rule invar_rank_evolution)
         apply simp
        apply(rule EvUnion'[where x="rep_of l i" and y="rep_of l j"])
        by (auto intro: invar_rank_ufa_invarI rep_of_bound rep_of_min[symmetric]
            simp: union_by_rank_l_def union_by_rank_rkl_def
            ufa_union_rep_of  )
      subgoal
        apply(rule ent_trans[where Q="p \<mapsto>\<^sub>a union_by_rank_l l rkl (rep_of l i) (rep_of l j)
                                     * r \<mapsto>\<^sub>a union_by_rank_rkl rkl (rep_of l i) (rep_of l j)
                                     * true * $ (\<Phi> l rkl * 4 + 8)"] )
        subgoal apply (sep_auto simp: union_by_rank_rkl_def union_by_rank_l_def )
          apply(subst ufa_union_rep_of[symmetric])
             apply (auto intro: invar_rank_ufa_invarI)
          by (sep_auto)
        subgoal by (rule uf_union_snd_over_aprox)
        done
      subgoal by sep_auto
      subgoal by sep_auto
      done
    subgoal (* rank of i's representant > rank of j's representant *)
      apply(sep_auto intro: rep_of_bound invar_rank_ufa_invarI)
      subgoal  apply(subst per_union_union_by_rank_l[symmetric])
        by (auto  intro: rep_of_bound invar_rank_ufa_invarI)
      subgoal  apply(subst per_union_union_by_rank_l)
        by (auto  intro: rep_of_bound invar_rank_ufa_invarI)
      subgoal
        apply(rule invar_rank_evolution)
         apply simp
        apply(rule EvUnion'[where x="rep_of l i" and y="rep_of l j"])
        by (auto intro: invar_rank_ufa_invarI rep_of_bound rep_of_min[symmetric]
            simp: union_by_rank_l_def union_by_rank_rkl_def
            ufa_union_rep_of  )
      subgoal
        apply(rule ent_trans[where Q="p \<mapsto>\<^sub>a union_by_rank_l l rkl (rep_of l i) (rep_of l j)
                                     * r \<mapsto>\<^sub>a union_by_rank_rkl rkl (rep_of l i) (rep_of l j)
                                     * true * $ (\<Phi> l rkl * 4 + 8)"] )
        subgoal apply (sep_auto simp: union_by_rank_rkl_def union_by_rank_l_def )
          apply(subst ufa_union_rep_of[symmetric])
             apply (auto intro: invar_rank_ufa_invarI)
          by (sep_auto)
        subgoal by (rule uf_union_snd_over_aprox)
        done
      done
    done
  done

lemma uf_union_rule: "\<lbrakk>i\<in>Domain R; j\<in> Domain R\<rbrakk>
  \<Longrightarrow> <is_uf R u * $(uf_union_time (card (Domain R)))>
         uf_union u i j <is_uf (per_union R i j)>\<^sub>t"
  unfolding uf_union_time_def is_uf_def
  apply (sep_auto split: prod.splits)
  subgoal for r p _ _ l rkl
    apply(drule ufa_\<alpha>_lenD(1))
    apply(drule ufa_\<alpha>_lenD(1))
    by (sep_auto simp: uf_union_parts heap: uf_rep_of_c_rule[where rkl=rkl] uf_union_snd_rule )
  done

end


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

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

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

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

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

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

section "Example: Quicksort on Heap Lists"

theory Quicksort
imports "../Vcg" "../HeapList" "~~/src/HOL/Library/Permutation"
begin

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

record 'g vars = "'g state" +
  p_'    :: "ref"
  q_'    :: "ref"
  le_'   :: "ref"
  gt_'   :: "ref"
  hd_'   :: "ref"
  tl_'   :: "ref"

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

  append_spec:
   "\<forall>\<sigma> Ps Qs.
     \<Gamma>\<turnstile> \<lbrace>\<sigma>. List \<acute>p \<acute>next Ps \<and>  List \<acute>q \<acute>next Qs \<and> set Ps \<inter> set Qs = {}\<rbrace>
           \<acute>p :== PROC append(\<acute>p,\<acute>q)
         \<lbrace>List \<acute>p \<acute>next (Ps@Qs) \<and> (\<forall>x. x\<notin>set Ps \<longrightarrow> \<acute>next x = \<^bsup>\<sigma>\<^esup>next x)\<rbrace>"

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

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

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

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

lemma perm_set_eq:
  assumes perm: "xs <~~> ys"
  shows "set xs = set ys"
  using perm
  by induct auto

lemma perm_Cons_eq [iff]: "x#xs <~~> x#ys = (xs <~~> ys)"
  by auto

lemma perm_app_Cons_eq1 : "xs@y#ys <~~> zs = (y#xs@ys <~~> zs)"
proof -
  have app_Cons: "xs@y#ys <~~> y#xs@ys"
    by (rule perm_sym, rule perm_append_Cons)
  show ?thesis
  proof
    assume "xs@y#ys <~~> zs"
    with app_Cons [THEN perm_sym]
    show "y#xs@ys <~~> zs"
      by (rule perm.trans)
  next
    assume " y#xs@ys <~~> zs"
    with app_Cons
    show "xs@y#ys <~~> zs"
      by (rule perm.trans)
  qed
qed

lemma perm_app_Cons_eq2 : "zs <~~> xs@y#ys = (zs <~~> y#xs@ys)"
proof -
  have "xs@y#ys <~~> zs = (y#xs@ys <~~> zs)"
    by (rule perm_app_Cons_eq1)
  thus ?thesis
    by (iprover intro: perm_sym)
qed

lemmas perm_app_Cons_simps = perm_app_Cons_eq1 [THEN sym]
                             perm_app_Cons_eq2 [THEN sym]

lemma sorted_append[simp]:
 "sorted le (xs@ys) = (sorted le xs \<and> sorted le ys \<and>
                       (\<forall>x \<in> set xs. \<forall>y \<in> set ys. le x y))"
by (induct xs, auto)

lemma perm_append_blocks:
  assumes ws_ys: "ws <~~> ys"
  assumes xs_zs: "xs <~~> zs"
  shows "ws@xs <~~> ys@zs"
using ws_ys
proof (induct)
  case (swap l x y)
  from xs_zs
  show "(l # x # y) @ xs <~~> (x # l # y) @ zs"
  by (induct) auto
qed (insert xs_zs , auto)

procedures quickSort(p|p) =
 "IF \<acute>p=Null THEN SKIP
  ELSE \<acute>tl :== \<acute>p\<rightarrow>\<acute>next;;
       \<acute>le :== Null;;
       \<acute>gt :== Null;;
       WHILE \<acute>tl\<noteq>Null DO
         \<acute>hd :== \<acute>tl;;
         \<acute>tl :== \<acute>tl\<rightarrow>\<acute>next;;
         IF \<acute>hd\<rightarrow>\<acute>cont \<le> \<acute>p\<rightarrow>\<acute>cont
         THEN \<acute>hd\<rightarrow>\<acute>next :== \<acute>le;;
              \<acute>le :== \<acute>hd
         ELSE \<acute>hd\<rightarrow>\<acute>next :== \<acute>gt;;
              \<acute>gt :== \<acute>hd
         FI
       OD;;
       \<acute>le :== CALL quickSort(\<acute>le);;
       \<acute>gt :== CALL quickSort(\<acute>gt);;
       \<acute>p\<rightarrow>\<acute>next :== \<acute>gt;;
       \<acute>le :== CALL append(\<acute>le,\<acute>p);;
       \<acute>p :== \<acute>le
  FI"

  quickSort_spec:
  "\<forall>\<sigma> Ps. \<Gamma>\<turnstile> \<lbrace>\<sigma>. List \<acute>p \<acute>next Ps\<rbrace> \<acute>p :== PROC quickSort(\<acute>p)
       \<lbrace>(\<exists>sortedPs. List \<acute>p \<acute>next sortedPs \<and>
        sorted (op \<le>) (map \<^bsup>\<sigma>\<^esup>cont sortedPs) \<and>
        Ps <~~> sortedPs) \<and>
        (\<forall>x. x\<notin>set Ps \<longrightarrow> \<acute>next x = \<^bsup>\<sigma>\<^esup>next x)\<rbrace>"

  quickSort_modifies:
  "\<forall>\<sigma>. \<Gamma>\<turnstile> {\<sigma>} \<acute>p :== PROC quickSort(\<acute>p) {t. t may_only_modify_globals \<sigma> in [next]}"

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

lemma (in quickSort_impl) quickSort_spec:
shows
  "\<forall>\<sigma> Ps. \<Gamma>\<turnstile> \<lbrace>\<sigma>. List \<acute>p \<acute>next Ps\<rbrace>
                  \<acute>p :== PROC quickSort(\<acute>p)
                \<lbrace>(\<exists>sortedPs. List \<acute>p \<acute>next sortedPs \<and>
                 sorted (op \<le>) (map \<^bsup>\<sigma>\<^esup>cont sortedPs) \<and>
                 Ps <~~> sortedPs) \<and>
                 (\<forall>x. x\<notin>set Ps \<longrightarrow> \<acute>next x = \<^bsup>\<sigma>\<^esup>next x)\<rbrace>"
apply (hoare_rule HoarePartial.ProcRec1)
apply (hoare_rule anno =
 "IF \<acute>p=Null THEN SKIP
  ELSE \<acute>tl :== \<acute>p\<rightarrow>\<acute>next;;
       \<acute>le :== Null;;
       \<acute>gt :== Null;;
       WHILE \<acute>tl\<noteq>Null
       INV \<lbrace> (\<exists>les grs tls. List \<acute>le \<acute>next les \<and> List \<acute>gt \<acute>next grs \<and>
               List \<acute>tl \<acute>next tls \<and>
               Ps <~~> \<acute>p#tls@les@grs \<and>
               distinct(\<acute>p#tls@les@grs) \<and>
               (\<forall>x\<in>set les. x\<rightarrow>\<acute>cont \<le> \<acute>p\<rightarrow>\<acute>cont) \<and>
               (\<forall>x\<in>set grs. \<acute>p\<rightarrow>\<acute>cont < x\<rightarrow>\<acute>cont)) \<and>
               \<acute>p=\<^bsup>\<sigma>\<^esup>p \<and>
               \<acute>cont=\<^bsup>\<sigma>\<^esup>cont \<and>
               List \<^bsup>\<sigma>\<^esup>p \<^bsup>\<sigma>\<^esup>next Ps \<and>
               (\<forall>x. x\<notin>set Ps \<longrightarrow> \<acute>next x = \<^bsup>\<sigma>\<^esup>next x)\<rbrace>
       DO
         \<acute>hd :== \<acute>tl;;
         \<acute>tl :== \<acute>tl\<rightarrow>\<acute>next;;
         IF \<acute>hd\<rightarrow>\<acute>cont \<le> \<acute>p\<rightarrow>\<acute>cont
         THEN \<acute>hd\<rightarrow>\<acute>next :== \<acute>le;;
              \<acute>le :== \<acute>hd
         ELSE \<acute>hd\<rightarrow>\<acute>next :== \<acute>gt;;
              \<acute>gt :== \<acute>hd
         FI
       OD;;
       \<acute>le :== CALL quickSort(\<acute>le);;
       \<acute>gt :== CALL quickSort(\<acute>gt);;
       \<acute>p\<rightarrow>\<acute>next :== \<acute>gt;;
       \<acute>le :== CALL append(\<acute>le,\<acute>p);;
       \<acute>p :== \<acute>le
  FI" in HoarePartial.annotateI)
apply vcg
apply   fastforce
apply  clarsimp
apply  (rule conjI)
apply   clarify
apply   (rule conjI)
apply    (rule_tac x="tl#les" in exI)
apply    simp
apply    (rule_tac x="grs" in exI)
apply    simp
apply    (rule_tac x="ps" in exI)
apply    simp
apply    (erule perm.trans)
apply    simp
apply    (simp add: perm_app_Cons_simps)
apply   (simp add: perm_set_eq)
apply  clarify
apply  (rule conjI)
apply   (rule_tac x="les" in exI)
apply   simp
apply   (rule_tac x="tl#grs" in exI)
apply   simp
apply   (rule_tac x="ps" in exI)
apply   simp
apply   (erule perm.trans)
apply   simp
apply   (simp add: perm_app_Cons_simps)
apply  (simp add: perm_set_eq)
apply clarsimp
apply (rule_tac ?x=grs in exI)
apply (rule conjI)
apply  (erule heap_eq_ListI1)
apply  clarify
apply  (erule_tac x=x in allE)back
apply  blast
apply clarsimp
apply (rule_tac x="sortedPs" in exI)
apply (rule conjI)
apply  (erule heap_eq_ListI1)
apply  (clarsimp)
apply  (erule_tac x=x in allE) back back
apply  (fast dest!: perm_set_eq)
apply (rule_tac x="p#sortedPsa" in exI)
apply (rule conjI)
apply  (fastforce dest!: perm_set_eq)
apply (rule conjI)
apply  (force dest!: perm_set_eq)
apply clarsimp
apply (rule conjI)
apply  (fastforce dest!: perm_set_eq)
apply (rule conjI)
apply  (fastforce dest!: perm_set_eq)
apply (rule conjI)
apply  (erule perm.trans)
apply  (simp add:  perm_app_Cons_simps list_all_iff)
apply  (fastforce intro!: perm_append_blocks)
apply clarsimp
apply (erule_tac x=x in allE)+
apply (force dest!: perm_set_eq)
done

end


(*
 * Copyright 2016, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(NICTA_GPL)
 *)

theory CogentMonad
imports Main
begin

text {*

  A non-deterministic monad. The result is a set of values "results" and a
  failure flag "mayFail". (Note: this is not the same as the non-determistic
  state monad in l4.verified. It does not model state.)

  Each element in the set is a potential result of the
  computation. The "mayFail" flag is @{const True} if there is an execution path
  in the computation that may have failed. Conversely, if "mayFail" is
  @{const False}, none of the computations resulting in the returned
  set can have failed.

*}

type_synonym 'a cogent_monad = "'a set"

text {*
  The definition of fundamental monad functions @{text return} and
  @{text bind}. The monad function @{text "return x"} does not change
  the  state, does not fail, and returns @{text "x"}.
*}

definition
  return :: "'a \<Rightarrow> 'a cogent_monad" where
  "return a \<equiv>  {a}"

text {*
  The monad function @{text "bind f g"}, also written @{text "f >>= g"},
  is the execution of @{term f} followed by the execution of @{text g}.
  The function @{text g} takes the result value \emph{and} the result
  state of @{text f} as parameter. The definition says that the result of
  the combined operation is the union of the set of sets that is created
  by @{text g} applied to the result sets of @{text f}. The combined
  operation may have failed, if @{text f} may have failed or @{text g} may
  have failed on any of the results of @{text f}.
*}

definition
  bind :: "'a cogent_monad \<Rightarrow> ('a \<Rightarrow> 'b cogent_monad) \<Rightarrow> 'b cogent_monad" (infixl ">>=" 60) where
  "m >>= f \<equiv> \<Union> (f ` m)"

subsection "Monad laws"

lemma "return a >>= f = f a"
  by (auto simp: return_def bind_def)

lemma "m >>= return = m"
  by (auto simp: return_def bind_def)

lemma "(m >>= f) >>= g = m >>= (\<lambda>x. f x >>= g)"
  by (auto simp: bind_def)

subsection "Nondeterminism"

text {*
  Basic nondeterministic functions. @{text "select A"} chooses an element
  of the set @{text A}, does not change the state, and does not fail
  (even if the set is empty). *}

definition
  select :: "'a set \<Rightarrow> 'a cogent_monad" where
  "select A \<equiv> A"

text {*  @{text "f OR g"} executes @{text f} or
  executes @{text g}. It retuns the union of results of @{text f} and
  @{text g}, and may have failed if either may have failed.
*}
definition
  alternative :: "'a cogent_monad \<Rightarrow> 'a cogent_monad \<Rightarrow> 'a cogent_monad"
where
  "alternative m n \<equiv>  m \<union> n"

lemmas monadic_simps = return_def alternative_def select_def bind_def

notation (xsymbols)  alternative (infixl "\<sqinter>" 20)

text {* We use @{text K_bind} to syntactically indicate the
  case where the return argument of the left side of a @{term bind}
  is ignored *}
definition
  K_bind [iff]: "K_bind \<equiv> \<lambda>x y. x"

nonterminal
  dobinds and dobind and nobind

syntax
  "_dobind"    :: "[pttrn, 'a] => dobind"             ("(_ <-/ _)" 10)
  ""           :: "dobind => dobinds"                 ("_")
  "_nobind"    :: "'a => dobind"                      ("_")
  "_dobinds"   :: "[dobind, dobinds] => dobinds"      ("(_);//(_)")

  "_do"        :: "[dobinds, 'a] => 'a"               ("(do (_);//   (_)//od)" 100)
syntax (xsymbols)
  "_dobind"    :: "[pttrn, 'a] => dobind"             ("(_ \<leftarrow>/ _)" 10)

translations
  "_do (_dobinds b bs) e"  == "_do b (_do bs e)"
  "_do (_nobind b) e"      == "b >>= (CONST K_bind e)"
  "do x <- a; e od"        == "a >>= (\<lambda>x. e)"

value "do x \<leftarrow> do x \<leftarrow> { (1::nat),2,3 };
                 return (x+1)
       od ;
         return (66 :: nat)
       od"

end


theory Semantics_Stateful
imports Semantics
begin

section\<open>Semantics Stateful\<close>

subsection\<open>Model 1 -- Curried Stateful Matcher\<close>

text\<open>Processing a packet with state can be modeled as follows:
  The state is @{term \<sigma>}.
  The primitive matcher @{term \<gamma>\<^sub>\<sigma>} is a curried function where the first argument is the state and
  it returns a stateless primitive matcher, i.e. @{term "\<gamma> = (\<gamma>\<^sub>\<sigma> \<sigma>)"}.
  With this stateless primitive matcher @{term \<gamma>}, the @{const iptables_bigstep} semantics are executed.
  As entry point, the iptables built-in chains @{term "''INPUT''"}, @{term "''OUTPUT''"}, and @{term "''FORWARD''"} with their
  default-policy (@{const Accept} or @{const Drop} are valid for iptables) are chosen.
  The semantics must yield a @{term "Decision X"}.
  Due to the default-policy, this is always the case if the ruleset is well-formed.
  When a decision is made, the state @{term \<sigma>} is updated.\<close>

inductive semantics_stateful ::
  "'a ruleset \<Rightarrow>
   ('\<sigma> \<Rightarrow> ('a, 'p) matcher) \<Rightarrow> \<comment> \<open>matcher, first parameter is the state\<close>
   ('\<sigma> \<Rightarrow> final_decision \<Rightarrow> 'p \<Rightarrow> '\<sigma>) \<Rightarrow> \<comment> \<open>state update function after firewall has decision for a packet\<close>
   '\<sigma> \<Rightarrow> \<comment> \<open>Starting state. constant\<close>
   (string \<times> action) \<Rightarrow> \<comment> \<open>The chain and default policy the firewall evaluates. For example ''FORWARD'', Drop\<close>
   'p list \<Rightarrow> \<comment> \<open>packets to be processed\<close>
   ('p \<times> final_decision) list \<Rightarrow> \<comment> \<open>packets which have been processed and their decision. ordered the same as the firewall processed them. oldest packet first\<close>
   '\<sigma> \<Rightarrow> \<comment> \<open>final state\<close>
   bool" for \<Gamma> and \<gamma>\<^sub>\<sigma> and state_update and \<sigma>\<^sub>0 where
  \<comment> \<open>A list of packets @{term ps} waiting to be processed. Nothing has happened, start and final state are the same, the list of processed packets is empty.\<close>
  "semantics_stateful \<Gamma> \<gamma>\<^sub>\<sigma> state_update \<sigma>\<^sub>0 (built_in_chain, default_policy) ps [] \<sigma>\<^sub>0" |

  \<comment> \<open>Processing one packet\<close>
  "semantics_stateful \<Gamma> \<gamma>\<^sub>\<sigma> state_update \<sigma>\<^sub>0 (built_in_chain, default_policy) (p#ps) ps_processed \<sigma>' \<Longrightarrow>
   \<Gamma>,(\<gamma>\<^sub>\<sigma> \<sigma>'),p\<turnstile> \<langle>[Rule MatchAny (Call built_in_chain), Rule MatchAny default_policy],Undecided\<rangle> \<Rightarrow> Decision X \<Longrightarrow>
    semantics_stateful \<Gamma> \<gamma>\<^sub>\<sigma> state_update \<sigma>\<^sub>0 (built_in_chain, default_policy) ps (ps_processed@[(p, X)]) (state_update \<sigma>' X p)"

lemma semantics_stateful_intro_process_one: "semantics_stateful \<Gamma> \<gamma>\<^sub>\<sigma> state_upate \<sigma>\<^sub>0 (built_in_chain, default_policy) (p#ps) ps_processed_old \<sigma>_old \<Longrightarrow>
       \<Gamma>,\<gamma>\<^sub>\<sigma> \<sigma>_old,p\<turnstile> \<langle>[Rule MatchAny (Call built_in_chain), Rule MatchAny default_policy], Undecided\<rangle> \<Rightarrow> Decision X \<Longrightarrow>
       \<sigma>' = state_upate \<sigma>_old X p \<Longrightarrow>
       ps_processed = ps_processed_old@[(p, X)] \<Longrightarrow>
       semantics_stateful \<Gamma> \<gamma>\<^sub>\<sigma> state_upate \<sigma>\<^sub>0 (built_in_chain, default_policy) ps ps_processed \<sigma>'"
  by(auto intro: semantics_stateful.intros)

lemma semantics_stateful_intro_start: "\<sigma>\<^sub>0 = \<sigma>' \<Longrightarrow> ps_processed = [] \<Longrightarrow>
       semantics_stateful \<Gamma> \<gamma>\<^sub>\<sigma> state_upate \<sigma>\<^sub>0 (built_in_chain, default_policy) ps ps_processed \<sigma>'"
  by(auto intro: semantics_stateful.intros)

text\<open>Example below\<close>

subsection\<open>Model 2 -- Packets Tagged with State Information\<close>

text\<open>In this model, the matcher is completely stateless but packets are previously tagged with
      (static) stateful information.\<close>

inductive semantics_stateful_packet_tagging ::
   "'a ruleset \<Rightarrow>
    ('a, 'ptagged) matcher \<Rightarrow>
    ('\<sigma> \<Rightarrow> 'p \<Rightarrow> 'ptagged) \<Rightarrow> \<comment> \<open>taggs the packet accordig to the current state before processing by firewall\<close>
    ('\<sigma> \<Rightarrow> final_decision \<Rightarrow> 'p \<Rightarrow> '\<sigma>) \<Rightarrow> \<comment> \<open>state updater\<close>
    '\<sigma> \<Rightarrow> \<comment> \<open>Starting state. constant\<close>
    (string \<times> action) \<Rightarrow>
    'p list \<Rightarrow> \<comment> \<open>packets to be processed\<close>
    ('p \<times> final_decision) list \<Rightarrow> \<comment> \<open>packets which have been processed\<close>
    '\<sigma> \<Rightarrow> \<comment> \<open>final state\<close>
    bool" for \<Gamma> and \<gamma> and packet_tagger and state_update and \<sigma>\<^sub>0 where
  "semantics_stateful_packet_tagging \<Gamma> \<gamma> packet_tagger state_update \<sigma>\<^sub>0 (built_in_chain, default_policy) ps [] \<sigma>\<^sub>0" |

  "semantics_stateful_packet_tagging \<Gamma> \<gamma> packet_tagger state_update \<sigma>\<^sub>0 (built_in_chain, default_policy) (p#ps) ps_processed \<sigma>' \<Longrightarrow>
   \<Gamma>,\<gamma>,(packet_tagger \<sigma>' p)\<turnstile> \<langle>[Rule MatchAny (Call built_in_chain), Rule MatchAny default_policy],Undecided\<rangle> \<Rightarrow> Decision X \<Longrightarrow>
    semantics_stateful_packet_tagging \<Gamma> \<gamma> packet_tagger state_update \<sigma>\<^sub>0 (built_in_chain, default_policy) ps (ps_processed@[(p, X)]) (state_update \<sigma>' X p)"

lemma semantics_stateful_packet_tagging_intro_start: "\<sigma>\<^sub>0 = \<sigma>' \<Longrightarrow> ps_processed = [] \<Longrightarrow>
       semantics_stateful_packet_tagging \<Gamma> \<gamma> packet_tagger state_upate \<sigma>\<^sub>0 (built_in_chain, default_policy) ps ps_processed \<sigma>'"
  by(auto intro: semantics_stateful_packet_tagging.intros)

lemma semantics_stateful_packet_tagging_intro_process_one:
      "semantics_stateful_packet_tagging \<Gamma> \<gamma> packet_tagger state_upate \<sigma>\<^sub>0 (built_in_chain, default_policy) (p#ps) ps_processed_old \<sigma>_old \<Longrightarrow>
       \<Gamma>,\<gamma>,(packet_tagger \<sigma>_old p)\<turnstile> \<langle>[Rule MatchAny (Call built_in_chain), Rule MatchAny default_policy], Undecided\<rangle> \<Rightarrow> Decision X \<Longrightarrow>
       \<sigma>' = state_upate \<sigma>_old X p \<Longrightarrow>
       ps_processed = ps_processed_old@[(p, X)] \<Longrightarrow>
       semantics_stateful_packet_tagging \<Gamma> \<gamma> packet_tagger state_upate \<sigma>\<^sub>0 (built_in_chain, default_policy) ps ps_processed \<sigma>'"
  by(auto intro: semantics_stateful_packet_tagging.intros)

lemma semantics_bigstep_state_vs_tagged:
  assumes "\<forall>m::'m. stateful_matcher' \<sigma> m p = stateful_matcher_tagged' m (packet_tagger' \<sigma> p)"
  shows "\<Gamma>,stateful_matcher' \<sigma>,p\<turnstile> \<langle>rs, Undecided\<rangle> \<Rightarrow> t \<longleftrightarrow>
         \<Gamma>,stateful_matcher_tagged',packet_tagger' \<sigma> p\<turnstile> \<langle>rs, Undecided\<rangle> \<Rightarrow> t"
proof -
  { fix m::"'m match_expr"
   from assms have
    "matches (stateful_matcher' \<sigma>) m p \<longleftrightarrow> matches stateful_matcher_tagged' m (packet_tagger' \<sigma> p)"
      by(induction m) (simp_all)
  } note matches_stateful_matcher_stateful_matcher_tagged=this

  show ?thesis (is "?lhs \<longleftrightarrow> ?rhs")
  proof
    assume ?lhs
    thus ?rhs
     proof(induction rs Undecided t rule: iptables_bigstep_induct)
     case (Seq _ _ _ t)
       thus ?case
         apply(cases t)
          apply (simp add: seq)
         apply(auto simp add: decision seq dest: decisionD)
         done
     qed(auto intro: iptables_bigstep.intros simp add: matches_stateful_matcher_stateful_matcher_tagged)
  next
    assume ?rhs
    thus ?lhs
     proof(induction rs Undecided t rule: iptables_bigstep_induct)
     case (Seq _ _ _ t)
       thus ?case
         apply(cases t)
          apply (simp add: seq)
         apply(auto  simp add: decision seq dest: decisionD)
         done
     qed(auto intro: iptables_bigstep.intros simp add: matches_stateful_matcher_stateful_matcher_tagged)
  qed
qed

text\<open>Both semantics are equal\<close>
theorem semantics_stateful_vs_tagged:
  assumes "\<forall>m \<sigma> p. stateful_matcher' \<sigma> m p = stateful_matcher_tagged' m (packet_tagger' \<sigma> p)"
  shows "semantics_stateful rs stateful_matcher' state_update' \<sigma>\<^sub>0 start ps ps_processed \<sigma>' =
       semantics_stateful_packet_tagging rs stateful_matcher_tagged' packet_tagger' state_update' \<sigma>\<^sub>0 start ps ps_processed \<sigma>'"
  proof -
   from semantics_bigstep_state_vs_tagged[of stateful_matcher' _ _ stateful_matcher_tagged' packet_tagger'] assms
     have vs_tagged:
     "rs,stateful_matcher' \<sigma>',p\<turnstile> \<langle>[Rule MatchAny (Call built_in_chain), Rule MatchAny default_policy], Undecided\<rangle> \<Rightarrow> t \<longleftrightarrow>
      rs,stateful_matcher_tagged',packet_tagger' \<sigma>' p\<turnstile> \<langle>[Rule MatchAny (Call built_in_chain), Rule MatchAny default_policy], Undecided\<rangle> \<Rightarrow> t"
      for t p \<sigma>' built_in_chain default_policy by blast
   from assms have stateful_matcher_eq:
    "(\<lambda>a b. stateful_matcher_tagged' a (packet_tagger' \<sigma>' b)) = stateful_matcher' \<sigma>'" for \<sigma>' by presburger
  show ?thesis (is "?lhs \<longleftrightarrow> ?rhs")
    proof
      assume ?lhs thus ?rhs
        proof(induction rule: semantics_stateful.induct)
        case 1 thus ?case by(auto intro: semantics_stateful_packet_tagging_intro_start)[1]
        next
        case (2 built_in_chain default_policy p ps  ps_processed \<sigma>')
          from 2 have
            "semantics_stateful_packet_tagging rs stateful_matcher_tagged' packet_tagger' state_update' \<sigma>\<^sub>0 (built_in_chain, default_policy) (p # ps) ps_processed \<sigma>'"
            by blast
          with 2(2,3) show ?case
          apply -
          apply(rule semantics_stateful_packet_tagging_intro_process_one)
             apply(simp_all add: vs_tagged)
          done
       qed
    next
      assume ?rhs thus ?lhs
      proof(induction rule: semantics_stateful_packet_tagging.induct)
        case 1 thus ?case by(auto intro: semantics_stateful_intro_start)
        next
        case (2 built_in_chain default_policy p ps ps_processed \<sigma>') thus ?case
           apply -
           apply(rule semantics_stateful_intro_process_one)
              apply(simp_all add: stateful_matcher_eq vs_tagged)
           done
      qed
    qed
  qed

text\<open>Examples\<close>
context
begin
subsection\<open>Example: Conntrack with curried matcher\<close>
  text\<open>We illustrate stateful semantics with a simple example. We allow matching on the states New
  and Established. In addition, we introduce a primitive match to match on outgoing ssh packets (dst port = 22).
  The state is managed in a state table where accepted connections are remembered.\<close>

  text\<open>SomePacket with source and destination port or something we don't know about\<close>
  private datatype packet = SomePacket "nat \<times> nat" | OtherPacket

  private datatype primitive_matches = New | Established | IsSSH

  text\<open>In the state, we remember the packets which belong to an established connection.\<close>
  private datatype conntrack_state = State "packet set"

  text\<open>The stateful primitive matcher: It is given the current state table.
    If match on @{const Established}, the packet must be known in the state table.
    If match on @{const New}, the packet must not be in the state table.
    If match on @{const IsSSH}, the dst port of the packet must be 22.\<close>
  private fun stateful_matcher :: "conntrack_state \<Rightarrow> (primitive_matches, packet) matcher" where
    "stateful_matcher (State state_table) = (\<lambda>m p. m = Established \<and> p \<in> state_table \<or>
                                           m = New \<and> p \<notin> state_table \<or>
                                           m = IsSSH \<and> (\<exists>dst_port. p = SomePacket (22, dst_port)))"

  text\<open>Connections are always bi-directional.\<close>
  private fun reverse_direction :: "packet \<Rightarrow> packet" where
    "reverse_direction OtherPacket = OtherPacket" |
    "reverse_direction (SomePacket (src, dst)) = SomePacket (dst,src)"

  text\<open>If a packet is accepted, the state for its bi-directional connection is saved in the state table.\<close>
  private fun state_update' :: "conntrack_state \<Rightarrow> final_decision \<Rightarrow> packet \<Rightarrow> conntrack_state" where
    "state_update' (State state_table) FinalAllow p = State (state_table \<union> {p, reverse_direction p})" |
    "state_update' (State state_table) FinalDeny p = State state_table"

  text\<open>Allow everything that is established and allow new ssh connections.
    Drop everything else (default policy, see below)\<close>
  private definition "ruleset == [''INPUT'' \<mapsto> [Rule (Match Established) Accept, Rule (MatchAnd (Match IsSSH) (Match New)) Accept]]"

  text\<open>The @{const ruleset} does not allow @{const OtherPacket}\<close>
  lemma "semantics_stateful ruleset stateful_matcher state_update' (State {}) (''INPUT'', Drop) []
    [(OtherPacket, FinalDeny)] (State {})"
    unfolding ruleset_def
    apply(rule semantics_stateful_intro_process_one)
        apply(simp_all)
       apply(rule semantics_stateful_intro_start)
        apply(simp_all)
     apply(rule seq_cons)
      apply(rule call_result)
        apply(simp_all)
      apply(rule seq_cons)
       apply(auto intro: iptables_bigstep.intros)
    done

  text\<open>The @{const ruleset} allows ssh packets, i.e. any packets with destination port 22 in the @{const New} rule.
        The state is updated such that everything which belongs to the connection will now be accepted.\<close>
  lemma "semantics_stateful ruleset stateful_matcher state_update' (State {}) (''INPUT'', Drop)
          []
          [(SomePacket (22, 1024), FinalAllow)]
          (State {SomePacket (1024, 22), SomePacket (22, 1024)})"
    unfolding ruleset_def
    apply(rule semantics_stateful_intro_process_one)
        apply(simp_all)
       apply(rule semantics_stateful_intro_start)
        apply(simp_all)
     apply(rule seq_cons)
      apply(rule call_result)
        apply(simp_all)
      apply(rule seq_cons)
       apply(auto intro: iptables_bigstep.intros)
    done

  text\<open>If we continue with this state, answer packets are now allowed\<close>
  lemma "semantics_stateful ruleset stateful_matcher state_update' (State {}) (''INPUT'', Drop)
          []
          [(SomePacket (22, 1024), FinalAllow), (SomePacket (1024, 22), FinalAllow)]
          (State {SomePacket (1024, 22), SomePacket (22, 1024)})"
    unfolding ruleset_def
    apply(rule semantics_stateful_intro_process_one)
        apply(simp_all)
      apply(rule semantics_stateful_intro_process_one)
         apply(simp_all)
        apply(rule semantics_stateful_intro_start)
         apply(simp_all)
      apply(rule seq_cons, rule call_result, simp_all, rule seq_cons)
        apply(auto intro: iptables_bigstep.intros)
    apply(rule seq_cons, rule call_result, simp_all, rule seq_cons)
      apply(auto intro: iptables_bigstep.intros)
    done

  text\<open>In contrast, without having previously established a state, answer packets are prohibited\<close>
  text\<open>If we continue with this state, answer packets are now allowed\<close>
  lemma "semantics_stateful ruleset stateful_matcher state_update' (State {}) (''INPUT'', Drop)
          []
          [(SomePacket (1024, 22), FinalDeny), (SomePacket (22, 1024), FinalAllow), (SomePacket (1024, 22), FinalAllow)]
          (State {SomePacket (1024, 22), SomePacket (22, 1024)})"
    unfolding ruleset_def
    apply(rule semantics_stateful_intro_process_one)
        apply(simp_all)
      apply(rule semantics_stateful_intro_process_one)
         apply(simp_all)
       apply(rule semantics_stateful_intro_process_one)
          apply(simp_all)
        apply(rule semantics_stateful_intro_start)
         apply(simp_all)
       apply(rule seq_cons, rule call_result, simp_all, rule seq_cons, auto intro: iptables_bigstep.intros)+
    done

subsection\<open>Example: Conntrack with packet tagging\<close>

  datatype packet_tag = TagNew | TagEstablished
  datatype packet_tagged = SomePacket_tagged "nat \<times> nat \<times> packet_tag" | OtherPacket_tagged packet_tag

  fun get_packet_tag :: "packet_tagged \<Rightarrow> packet_tag" where
    "get_packet_tag (SomePacket_tagged (_,_, tag)) = tag" |
    "get_packet_tag (OtherPacket_tagged tag) = tag"

  definition stateful_matcher_tagged :: "(primitive_matches, packet_tagged) matcher" where
    "stateful_matcher_tagged \<equiv> \<lambda>m p. m = Established \<and> (get_packet_tag p = TagEstablished) \<or>
                                           m = New \<and> (get_packet_tag p = TagNew) \<or>
                                           m = IsSSH \<and> (\<exists>dst_port tag. p = SomePacket_tagged (22, dst_port, tag))"

  fun calculate_packet_tag :: "conntrack_state \<Rightarrow> packet \<Rightarrow> packet_tag" where
    "calculate_packet_tag (State state_table) p = (if p \<in> state_table then TagEstablished else TagNew)"

  fun packet_tagger :: "conntrack_state \<Rightarrow> packet \<Rightarrow> packet_tagged" where
    "packet_tagger \<sigma> (SomePacket (s,d)) = (SomePacket_tagged (s,d, calculate_packet_tag \<sigma> (SomePacket (s,d))))" |
    "packet_tagger \<sigma> OtherPacket = (OtherPacket_tagged (calculate_packet_tag \<sigma> OtherPacket))"

  text\<open>If a packet is accepted, the state for its bi-directional connection is saved in the state table.\<close>
  fun state_update_tagged :: "conntrack_state \<Rightarrow> final_decision \<Rightarrow> packet \<Rightarrow> conntrack_state" where
    "state_update_tagged (State state_table) FinalAllow p = State (state_table \<union> {p, reverse_direction p})" |
    "state_update_tagged (State state_table) FinalDeny p = State state_table"

  text\<open>Both semantics are equal\<close>
  lemma "semantics_stateful rs stateful_matcher state_update' \<sigma>\<^sub>0 start ps ps_processed \<sigma>' =
    semantics_stateful_packet_tagging rs stateful_matcher_tagged packet_tagger state_update' \<sigma>\<^sub>0 start ps ps_processed \<sigma>'"
    apply(rule semantics_stateful_vs_tagged)
    apply(intro allI, rename_tac m \<sigma> p)
    apply(case_tac \<sigma>)
    apply(case_tac p)
     apply(simp_all add: stateful_matcher_tagged_def)
    apply force
    done
end

end


(* Teorema de Cantor *)

(*<*)
theory TeoremaCantor
imports Main "HOL-Library.LaTeXsugar" "HOL-Library.OptionalSugar"
begin
(*>*)

section \<open>Teorema de Cantor\<close>
subsection \<open>Demostración en lenguaje natural \<close>

text \<open> El siguiente teorema, denominado  teorema de Cantor por el matemático
  Georg Cantor, es un resultado importante de la teoría de conjuntos.

  Para la exposición del teorema vamos a definir una serie de conceptos:

    \begin{definicion}[Conjunto Potencia]
 El conjunto potencia de un conjunto  $A$  $(\mathcal{P}(A))$ es el
conjunto formado  por todos los subconjuntos de $A$.
 \end{definicion}

    \begin{definicion}[Cardinal]
 El cardinal de un conjunto $A$ (denotado $\# A$) es el número de
      elementos del propio conjunto.
  \end{definicion}

  El enunciado original del teorema es el siguiente :

  \begin {teorema}
    El cardinal del conjunto potencia de cualquier conjunto A es
    estrictamente mayor que el cardinal de A, o lo que es lo mismo,
    $\# \mathcal{P}(A) > \# A.$
  \end {teorema}

   El enunciado del teorema lo podemos reformular como sigue:
  \begin{teorema}
    Dado un conjunto $A$, $\nexists  f : A \longrightarrow \mathcal{P}(A)$
    sobreyectiva.
  \end{teorema}

  \begin{demostracion}
  La prueba se va a realizar por reducción al absurdo.

  Supongamos que $\exists f : A \longrightarrow \mathcal{P}(A)$
  sobreyectiva, es decir, $\forall B \in \mathcal{P}(A) ,  \exists x \in
  A$ tal que $B = f(x)$.

  En particular, tomemos el conjunto
  $$B = \{ x \in A : x \notin f(x) \}$$
  y supongamos que $\exists a \in A : B = f(a)$, ya que $B$ es un
  subconjunto de A. Luego podemos distinguir dos casos :

  $1.$ Si $a \in B.$
  Entonces por definición del conjunto $B$ se tiene que
  $a \notin B$, luego se llega a una contradicción.

  $2.$ Si $a \notin B.$
  Entonces por definición de B se tiene que $a \in B$, luego se ha
  llegado a otra contradicción.

  En los dos casos se ha llegado a una contradicción, por lo que no
  existe $a$ y $f$ no es sobreyectiva.
  \end{demostracion}
\<close>

subsection \<open>Especificación en Isabelle/HOL\<close>

text \<open>Para la especificación del teorema en Isabelle, primero debemos
  notar que
  $$f :: \, 'a \Rightarrow \,'a \: set$$
  significa que es una función de tipos, donde $'a$ significa un tipo y
  para poder denotar el conjunto potencia tenemos que poner $'a \ set$
  que significa que es de un tipo formado por conjuntos del tipo $'a$.

  El enunciado del teorema es el siguiente :
\<close>

theorem Cantor: "\<nexists>f :: 'a \<Rightarrow> 'a set. \<forall>A. \<exists>x. A = f x"
  oops

text \<open>A continuación presentaremos diferentes formas de demostración del
  teorema. \<close>

subsection \<open>Demostración detallada \<close>

text \<open>La primera es la demostración detallada del teorema: \<close>

theorem
  "\<nexists>f :: 'a \<Rightarrow> 'a set. \<forall>B. \<exists>x. B = f x"
proof (rule notI)
  assume "\<exists>f :: 'a \<Rightarrow> 'a set. \<forall>A. \<exists>x. A = f x"
  then obtain f :: "'a \<Rightarrow> 'a set" where Hf: "\<forall>A. \<exists>x. A = f x"
    by (rule exE)
  let ?B = "{x. x \<notin> f x}"
  from Hf obtain "\<exists>x. ?B = f x "
    by (rule allE)
  then obtain a where Ha: "?B = f a"
    by (rule exE)
  show False
  proof (cases "a \<in> ?B")
    assume "a \<in> ?B"
    then have "a \<notin> f a"
      by (rule CollectD)
    moreover
    have "a \<in> f a"
      using \<open>a \<in> ?B\<close>
      by (simp only: Ha)
    ultimately show False
      by (rule notE)
  next
    assume "a \<notin> ?B"
    with Ha have "a \<notin> f a"
      by (rule subst)
    moreover
    have "a \<in> f a"
    proof (rule ccontr)
      assume "a \<notin> f a"
      then have "a \<in> ?B"
        by (rule CollectI)
      with \<open>a \<notin> ?B\<close> show False
        by (rule notE)
    qed
    ultimately show False
      by (rule notE)
  qed
qed

subsection \<open>Demostración automática \<close>

text \<open> La demostración automática del teorema es: \<close>

theorem Cantor:
  "\<nexists>f :: 'a \<Rightarrow> 'a set. \<forall>B. \<exists>x. B = f x"
  by best

(*<*) end (*>*)


(*<*)
theory FaultModelling

imports ModeCondition ConditionalMode ConditionalModePredicate

begin
(*>*)
(* O Conteúdo deste diretório foi obtido através dos comandos:
isabelle mkroot -d fault-modelling-theory/
e
isabelle build -D fault-modelling-theory/
text {* First test: @{term "MCVar v\<^sub>1"} and @{term "MCNot (MCVar A)"} *}
*)

type_synonym 'PortName CInput = 'PortName
type_synonym 'PortName COutput = 'PortName

type_synonym  ('pin, 'pout) Connections = "'pin \<rightharpoonup> 'pout"

type_synonym ('a, 'FMode, 'pin) PortValuation =
  "'pin \<Rightarrow> ('a, 'FMode, 'pin) ConditionalMode"

(* outputs -. ConditionalMode*)
type_synonym ('a, 'FMode, 'pin, 'pout) Component =
  "('a, 'FMode, 'pin) PortValuation \<Rightarrow> ('pout \<rightharpoonup> ('a, 'FMode, 'pin) ConditionalMode)"

primrec list_of_maps_to_map :: "('a \<rightharpoonup> 'b) list \<Rightarrow> ('a \<rightharpoonup> 'b)"
where
  "list_of_maps_to_map [] = Map.empty" |
  "list_of_maps_to_map (l # ls) = l ++ (list_of_maps_to_map ls)"

primrec convert_elems :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b list"
where
  "convert_elems [] _ = []" |
  "convert_elems (l # ls) f = (f l) # (convert_elems ls f)"

definition SystemComponents :: "
  (('vb, 'FMode, 'pin, 'pout) Component) list \<Rightarrow> ('vb, 'FMode, 'pin, 'pout) Component"
where
  "SystemComponents cs \<equiv> \<lambda> pv. fold (\<lambda> c1 c2. (c1 pv) ++ c2) cs Map.empty"

definition SystemPortValuation :: "
  ('pin, 'pout) Connections \<Rightarrow>
  ('a, 'FMode, 'pin, 'pout) Component \<Rightarrow>
  ('a, 'FMode, 'pin) PortValuation
  "
where
  "SystemPortValuation A c \<equiv>
  (
    \<lambda> pin.
    (
      case (A pin) of
        None \<Rightarrow> CVC (VarMode pin) |
        (Some pout) \<Rightarrow>
        (
          case (c (\<lambda> x. CVC (VarMode x))  pout) of
            None \<Rightarrow> CVC (VarMode pin) |
            (Some vo) \<Rightarrow> vo
        )
    )
  )"

definition fun_upd_fun :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool)  \<Rightarrow> ('a \<Rightarrow> 'b)"
where
  "fun_upd_fun f1 f2 g \<equiv> \<lambda> a. let b1 = f1 a in let b2 = f2 a in if g b1 b2 then b1 else b2"

fun is_ValuesVar :: "('vb, 'FMode, 'pin) ConditionalMode \<Rightarrow> bool"
where
  "is_ValuesVar (CVC (VarMode x)) = True" |
  "is_ValuesVar _ = False"

(* Lista de componentes e conexões*)
definition System :: "
  ('pin, 'pout) Connections \<Rightarrow>
  ('a, 'FMode, 'pin, 'pout) Component list \<Rightarrow>
  ('a, 'FMode, 'pin, 'pout) Component"
where
  "System A cs \<equiv>
  (
    let C = SystemComponents cs in
    let pv = SystemPortValuation A C in
    (\<lambda> xpv.
      let mpout = C (fun_upd_fun pv xpv (\<lambda> b1 b2. \<not> is_ValuesVar b1 )) in
      (\<lambda> pout. mpout pout)
    )
  )"

(*

definition ValidConnections :: "('vb, 'FMode) System \<Rightarrow> bool"  where
  "ValidConnections S \<equiv>
    (dom (SystemConnections S) \<subseteq> SystemComponentsInputs S \<and>
    ran (SystemConnections S) \<subseteq> SystemComponentsOutputs S)"

definition ValidPortIndex :: "('vb, 'FMode) System \<Rightarrow> ComponentPort \<Rightarrow> (('vb, 'FMode) Component \<Rightarrow> nat) \<Rightarrow> bool"
where
  "ValidPortIndex S cp f \<equiv>
    let (c,i) = cp
    in c < length (SystemComponents S) \<and> i < f (SystemComponent S c)"

(*TODO: cpin pertence às conexões união com os *)
definition ValidComponents :: "('vb, 'FMode) System \<Rightarrow> bool" where
  "ValidComponents S \<equiv>
    (fst S) \<noteq> [] \<and>
    (dom (SystemConnections S) \<subseteq> SystemComponentsInputs S) \<and>
    (ran (SystemConnections S) \<subseteq> SystemComponentsOutputs S)"

definition ValidSystem :: "('vb, 'FMode) System \<Rightarrow> bool"
where
  "ValidSystem S \<equiv> ValidConnections S \<and> ValidComponents S"

definition SystemInputs :: "('vb, 'FMode) System \<Rightarrow> ComponentPort set" where
  "SystemInputs S \<equiv> { ii. ii \<in> SystemComponentsInputs S \<and> (ii \<notin> dom (SystemConnections S)) }"

definition SystemOutputs :: "('vb, 'FMode) System \<Rightarrow> ComponentPort set" where
  "SystemOutputs S \<equiv> { oi. oi \<in> SystemComponentsOutputs S \<and> (oi \<notin> ran (SystemConnections S)) }"

lemma SystemInputs_ComponentInputs : "ValidSystem S \<Longrightarrow> SystemInputs S \<subseteq> SystemComponentsInputs S"
using SystemInputs_def SystemComponentsInputs_def ValidSystem_def
apply (auto simp add: SystemInputs_def)
done

lemma SystemOutputs_ComponentOutputs : "ValidSystem S \<Longrightarrow>
  SystemOutputs S \<subseteq> SystemComponentsOutputs S"
apply (auto simp add: SystemOutputs_def)
done

lemma inputs_completeness1: "
  \<lbrakk>
    ValidSystem (Cs,A);
    (m, i) \<in> SystemComponentsInputs (Cs,A);
    (m, i) \<notin> dom A
  \<rbrakk> \<Longrightarrow> (m, i) \<in> SystemInputs (Cs,A)"
apply (auto simp add: ValidSystem_def ValidConnections_def ValidComponents_def)
apply (auto simp add: SystemComponentsInputs_def SystemInputs_def)
apply (auto simp add: SystemConnections_def)
done

lemma inputs_completeness2: "
  \<lbrakk>
    ValidSystem (Cs,A);
    (m, i) \<in> SystemComponentsInputs (Cs,A);
    (m, i) \<notin> SystemInputs (Cs,A)
  \<rbrakk> \<Longrightarrow> (m, i) \<in> dom A"
apply (auto simp add: ValidSystem_def ValidConnections_def ValidComponents_def)
apply (auto simp add: SystemComponentsInputs_def SystemInputs_def)
apply (auto simp add: SystemConnections_def)
done

lemma inputs_completeness3: "
  \<lbrakk>
    ValidSystem (Cs,A);
    (m, i) \<in> SystemComponentsInputs (Cs,A)
  \<rbrakk> \<Longrightarrow> (m, i) \<in> (SystemInputs (Cs,A) \<union> dom A)"
apply (auto simp add: ValidSystem_def ValidConnections_def ValidComponents_def)
apply (auto simp add: SystemComponentsInputs_def SystemInputs_def)
apply (auto simp add: SystemConnections_def)
done

lemma outputs_completeness1: "
  \<lbrakk>
    ValidSystem (Cs,A);
    (m, oi) \<in> SystemComponentsOutputs (Cs,A);
    (m, oi) \<notin> ran A
  \<rbrakk> \<Longrightarrow> (m, oi) \<in> SystemOutputs (Cs,A)"
apply (auto simp add: ValidSystem_def ValidConnections_def ValidComponents_def)
apply (auto simp add: SystemComponentsOutputs_def SystemOutputs_def)
apply (auto simp add: ComponentOutputPortIndexes_def NumberOfOutputs_def)
apply (auto simp add: SystemConnections_def)
done

lemma outputs_completeness2: "
  \<lbrakk>
  ValidSystem (Cs,A);
  (m, oi) \<in> SystemComponentsOutputs (Cs,A);
  (m, oi) \<notin> SystemOutputs (Cs,A)
  \<rbrakk> \<Longrightarrow> (m, oi) \<in> ran A"
apply (auto simp add: ValidSystem_def ValidConnections_def ValidComponents_def)
apply (auto simp add: SystemComponentsOutputs_def SystemOutputs_def)
apply (auto simp add: ComponentOutputPortIndexes_def NumberOfOutputs_def)
apply (auto simp add: SystemConnections_def)
done

lemma outputs_completeness3: "
  \<lbrakk>
    ValidSystem (Cs,A);
    (m, oi) \<in> SystemComponentsOutputs (Cs,A)
  \<rbrakk> \<Longrightarrow> (m, oi) \<in> (SystemOutputs (Cs,A) \<union> ran A)"
apply (auto simp add: ValidSystem_def ValidConnections_def ValidComponents_def)
apply (auto simp add: SystemComponentsOutputs_def SystemOutputs_def)
apply (auto simp add: ComponentOutputPortIndexes_def NumberOfOutputs_def)
apply (auto simp add: SystemConnections_def)
done

theorem io_completeness: "
  \<lbrakk>
  ValidSystem (Cs,A);
  (mi, ini) \<in> SystemComponentsInputs (Cs,A);
  (mo, oi) \<in> SystemComponentsOutputs (Cs,A)
  \<rbrakk> \<Longrightarrow>
  (mi, ini) \<in> (SystemInputs (Cs,A) \<union> dom A) \<and>
  (mo, oi) \<in> (SystemOutputs (Cs,A) \<union> ran A)"
apply (auto simp add: ValidSystem_def ValidConnections_def ValidComponents_def)
apply (auto simp add: SystemComponentsOutputs_def SystemOutputs_def)
apply (auto simp add: ComponentOutputPortIndexes_def NumberOfOutputs_def)
apply (auto simp add: SystemComponentsInputs_def SystemInputs_def)
apply (auto simp add: SystemConnections_def)
done

*)
end