(* Author: Andreas Lochbihler and Tobias Nipkow *)

section "Trie"

theory Trie
imports "HOL-Library.AList"
begin

(* A truly generic Trie would be parameterized by the data type for mappings
in each node. For this purpose the mapping type needs to become a bnf.

import "HOL-Library.Mapping"

lift_definition all_mapping :: "('b \<Rightarrow> bool) \<Rightarrow> ('a, 'b) mapping \<Rightarrow> bool"
is "\<lambda>p m. \<forall>a b. m a = Some b \<longrightarrow> p b" .

lemma all_mapping_cong [fundef_cong]:
  "m = n \<Longrightarrow> (\<And>x y. Mapping.lookup n x = Some y \<Longrightarrow> p y = q y) \<Longrightarrow> all_mapping p m = all_mapping q n"
by transfer auto

lift_definition set_mapping :: "('a,'b)mapping \<Rightarrow> 'b set" is "\<lambda>f. Union(set_option ` range f)" .

lift_definition rel_mapping :: "('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('a,'b)mapping \<Rightarrow> ('a,'c)mapping \<Rightarrow> bool"
  is "\<lambda>r. rel_fun (=) (rel_option r)" .

bnf "('a,'b)mapping"
  map: "Mapping.map id"
  sets: set_mapping
  bd: "BNF_Cardinal_Arithmetic.csum (card_of (UNIV::'a set)) natLeq"
  wits: Mapping.empty
  rel: rel_mapping
proof-
  case goal1 show ?case by(rule Mapping.map.id)
next
  case goal2 show ?case by transfer (simp add: fun_eq_iff option.map_comp)
next
  case goal3 thus ?case by transfer (auto simp: fun_eq_iff intro: option.map_cong)
next
  case goal4 thus ?case by transfer (auto simp: fun_eq_iff)
next
  case goal5 thus ?case
    by (simp add: Field_card_of Field_natLeq card_of_card_order_on csum_def)
next
  case goal6 thus ?case
    by (simp add: cinfinite_csum natLeq_cinfinite)
next
  case goal7 thus ?case
    apply transfer
    apply(rule ordLeq_transitive[OF comp_single_set_bd[where fset=set_option and gset=range, of natLeq "BNF_Cardinal_Arithmetic.csum (card_of (UNIV::'d set)) natLeq"]])
    apply (rule natLeq_Card_order)
    apply(rename_tac opt)
    apply(case_tac opt)
    apply (simp add: card_of_empty1 natLeq_Well_order)
    using Card_order_singl_ordLeq Field_natLeq natLeq_Card_order apply fastforce
    apply(rule ordLeq_transitive[OF card_of_image])
    apply (simp add: card_of_Card_order ordLeq_csum1)
    apply(rule cprod_cinfinite_bound)
    apply(rule ordLeq_refl)
    apply (rule Card_order_csum)
    apply (simp add: natLeq_Card_order ordLeq_csum2)
    apply (rule Card_order_csum)
    apply (rule natLeq_Card_order)
    using Cinfinite_csum natLeq_Card_order natLeq_cinfinite by blast
next
  case goal8 thus ?case apply(rule predicate2I) apply transfer
    by(auto simp: option.rel_compp rel_fun_def)
next
  case goal9 show ?case
    unfolding OO_Grp_alt fun_eq_iff
    apply transfer
    apply safe
    apply(rename_tac f g)
    apply(rule_tac x = "\<lambda>x. case (f x, g x) of (Some u,Some v) \<Rightarrow> Some(u,v) | _ \<Rightarrow> None" in exI)
    apply(auto simp: fun_eq_iff rel_fun_def elim!: Option.option.rel_cases split: option.splits)
    apply (metis option.rel_inject(2))
    apply (metis rel_option_None1)
    apply(auto simp add: option.rel_map subset_eq intro!: rel_option_reflI split: prod.splits)
    done
next
  case goal10 thus ?case by transfer simp
qed
*)

datatype ('k, 'v) trie =
  Trie "'v option"  "('k * ('k,'v)trie) list"

lemma trie_induct [case_names Trie, induct type]:
  "(\<And>vo kvs. (\<And>k t. (k, t) \<in> set kvs \<Longrightarrow> P t) \<Longrightarrow> P (Trie vo kvs)) \<Longrightarrow> P t"
by induction_schema (pat_completeness, lexicographic_order)

definition empty_trie :: "('k, 'v) trie" where
"empty_trie = Trie None []"

fun is_empty_trie :: "('k, 'v) trie \<Rightarrow> bool" where
"is_empty_trie (Trie v m) = (v = None \<and> m = [])"

fun lookup_trie :: "('k, 'v) trie \<Rightarrow> 'k list \<Rightarrow> 'v option" where
"lookup_trie (Trie v m) [] = v" |
"lookup_trie (Trie v m) (k#ks) =
   (case map_of m k of
      None \<Rightarrow> None |
      Some st \<Rightarrow> lookup_trie st ks)"

fun update_with_trie ::
  "'k list \<Rightarrow> ('v option \<Rightarrow> 'v) \<Rightarrow> ('k, 'v) trie \<Rightarrow> ('k, 'v) trie" where
"update_with_trie []     f (Trie v ps)  = Trie (Some(f v)) ps" |
"update_with_trie (k#ks) f (Trie v ps) =
  Trie v (AList.update_with_aux empty_trie k (update_with_trie ks f) ps)"

text\<open>The function argument \<open>f\<close> of @{const update_with_trie}
does not return an optional value because @{const None} could break the invariant
that no empty tries are contained in a trie because @{const AList.update_with_aux}
cannot recognise and remove empty tries.
Therefore the delete function is implemented separately rather than via
@{const update_with_trie}.

Do not use @{const update_with_trie} if most of the calls do not change
the entry (because of the garbage this creates); use @{const lookup_trie} possibly
followed by \<open>update_trie\<close>. This shortcoming could be addressed if
\<open>f\<close> indicated that the entry is unchanged, eg by @{const None}.\<close>

definition update_trie :: "'k list \<Rightarrow> 'v \<Rightarrow> ('k, 'v) trie \<Rightarrow> ('k, 'v) trie" where
"update_trie ks v = update_with_trie ks (%_. v)"

lemma update_trie_induct:
  "\<lbrakk>\<And>v ps. P [] (Trie v ps); \<And>k ks v ps. (\<And>x. P ks x) \<Longrightarrow> P (k#ks) (Trie v ps)\<rbrakk> \<Longrightarrow> P xs t"
by induction_schema (pat_completeness, lexicographic_order)

lemma update_trie_Nil[simp]: "update_trie [] v (Trie vo ts) = Trie (Some v) ts"
by(simp add: update_trie_def)

lemma update_trie_Cons[simp]: "update_trie (k#ks) v (Trie vo ts) =
  Trie vo (AList.update_with_aux (Trie None []) k (update_trie ks v) ts)"
by(simp add: update_trie_def empty_trie_def)

(* A simple implementation of delete; does not shrink the trie!
definition delete_trie :: "'k list \<Rightarrow> ('k, 'v) trie \<Rightarrow> ('k, 'v) trie" where
"delete_trie ks t = update_with_trie ks (\<lambda>_. None) t"
*)

fun delete_trie :: "'key list \<Rightarrow> ('key, 'val) trie \<Rightarrow> ('key, 'val) trie"
where
"delete_trie [] (Trie vo ts) = Trie None ts" |
"delete_trie (k#ks) (Trie vo ts) =
   (case map_of ts k of
      None \<Rightarrow> Trie vo ts |
      Some t \<Rightarrow> let t' = delete_trie ks t
                in if is_empty_trie t'
                   then Trie vo (AList.delete_aux k ts)
                   else Trie vo (AList.update k t' ts))"

fun all_trie :: "('v \<Rightarrow> bool) \<Rightarrow> ('k, 'v) trie \<Rightarrow> bool" where
"all_trie p (Trie v ps) =
  ((case v of None \<Rightarrow> True | Some v \<Rightarrow> p v) \<and> (\<forall>(k,t) \<in> set ps. all_trie p t))"

fun invar_trie :: "('key, 'val) trie \<Rightarrow> bool" where
"invar_trie (Trie vo kts) =
  (distinct (map fst kts) \<and>
   (\<forall>(k, t) \<in> set kts. \<not> is_empty_trie t \<and> invar_trie t))"

subsection \<open>Empty trie\<close>

lemma invar_empty [simp]: "invar_trie empty_trie"
by(simp add: empty_trie_def)

lemma is_empty_conv: "is_empty_trie ts \<longleftrightarrow> ts = Trie None []"
by(cases ts)(simp)

subsection \<open>@{const lookup_trie}\<close>

lemma lookup_empty [simp]: "lookup_trie empty_trie = Map.empty"
proof
  fix ks show "lookup_trie empty_trie ks = Map.empty ks"
    by(cases ks)(auto simp add: empty_trie_def)
qed

lemma lookup_empty' [simp]: "lookup_trie (Trie None []) ks = None"
by(simp add: lookup_empty[unfolded empty_trie_def])

lemma lookup_update:
  "lookup_trie (update_trie ks v t) ks' = (if ks = ks' then Some v else lookup_trie t ks')"
proof(induct ks t arbitrary: ks' rule: update_trie_induct)
  case (1 vo ts ks')
  show ?case by(fastforce simp add: neq_Nil_conv dest: not_sym)
next
  case (2 k ks vo ts ks')
  show ?case by(cases ks')(auto simp add: map_of_update_with_aux 2 split: option.split)
qed

lemma lookup_update':
  "lookup_trie (update_trie ks v t) = (lookup_trie t)(ks \<mapsto> v)"
by(rule ext)(simp add: lookup_update)

lemma lookup_eq_Some_iff:
assumes invar: "invar_trie ((Trie vo kvs) :: ('key, 'val) trie)"
shows "lookup_trie (Trie vo kvs) ks = Some v \<longleftrightarrow>
    (ks = [] \<and> vo = Some v) \<or>
    (\<exists>k t ks'. ks = k # ks' \<and>
        (k, t) \<in> set kvs \<and> lookup_trie t ks' = Some v)"
proof (cases ks)
  case Nil thus ?thesis by simp
next
  case (Cons k ks')
  note ks_eq[simp] = Cons
  show ?thesis
  proof (cases "map_of kvs k")
    case None thus ?thesis
      apply (simp)
      apply (auto simp add: map_of_eq_None_iff image_iff Ball_def)
    done
  next
    case (Some t') note map_eq = this
    from invar have dist_kvs: "distinct (map fst kvs)" by simp

    from map_of_eq_Some_iff[OF dist_kvs, of k] map_eq
    show ?thesis by simp metis
  qed
qed

lemma lookup_eq_None_iff:
assumes invar: "invar_trie ((Trie vo kvs) :: ('key, 'val) trie)"
shows "lookup_trie (Trie vo kvs) ks = None \<longleftrightarrow>
    (ks = [] \<and> vo = None) \<or>
    (\<exists>k ks'. ks = k # ks' \<and> (\<forall>t. (k, t) \<in> set kvs \<longrightarrow> lookup_trie t ks' = None))"
using lookup_eq_Some_iff[of vo kvs ks, OF invar]
  apply (cases ks)
    apply auto[]
  apply (auto split: option.split)
    apply (metis option.simps(3) weak_map_of_SomeI)
    apply (metis option.exhaust)
    apply (metis option.exhaust)
done

lemma update_not_empty: "\<not> is_empty_trie (update_trie ks v t)"
apply(cases t)
apply(rename_tac kvs)
apply(cases ks)
apply(case_tac [2] kvs)
apply (auto)
done

lemma invar_trie_update: "invar_trie t \<Longrightarrow> invar_trie (update_trie ks v t)"
by(induct ks t rule: update_trie_induct)(auto simp add: set_update_with_aux update_not_empty split: option.splits)

lemma is_empty_lookup_empty:
  "invar_trie t \<Longrightarrow> is_empty_trie t \<longleftrightarrow> lookup_trie t = Map.empty"
proof(induct t)
  case (Trie vo kvs)
  thus ?case
    apply(cases kvs)
    apply(auto simp add: fun_eq_iff elim: allE[where x="[]"])
    apply(erule meta_allE)+
    apply(erule meta_impE)
    apply(rule disjI1)
    apply(fastforce intro: exI[where x="a # b" for a b])+
    done
qed

lemma lookup_update_with_trie:
  "lookup_trie (update_with_trie ks f t) ks' =
  (if ks' = ks then Some(f(lookup_trie t ks')) else lookup_trie t ks')"
proof(induction ks t arbitrary: ks' rule: update_trie_induct)
  case 1 thus ?case by(auto simp add: neq_Nil_conv)
next
  have *: "\<And>xs y ys. (xs \<noteq> y#ys) = (xs = [] \<or> (\<exists>x zs. xs = x#zs \<and> (x \<noteq> y \<or> zs \<noteq> ys)))"
    by auto (metis neq_Nil_conv)
  case 2
  thus ?case by(auto simp: * map_of_update_with_aux split: option.split)
qed

subsection \<open>@{const delete_trie}\<close>

lemma delete_eq_empty_lookup_other_fail:
  "\<lbrakk> delete_trie ks t = Trie None []; ks' \<noteq> ks \<rbrakk> \<Longrightarrow> lookup_trie t ks' = None"
proof(induct ks t arbitrary: ks' rule: delete_trie.induct)
  case 1 thus ?case by(auto simp add: neq_Nil_conv)
next
  case (2 k ks vo ts)
  show ?case
  proof(cases "map_of ts k")
    case (Some t)
    show ?thesis
    proof(cases ks')
      case (Cons k' ks'')
      show ?thesis
      proof(cases "k' = k")
        case False
        from Some Cons "2.prems"(1) have "AList.delete_aux k ts = []"
          by(clarsimp simp add: Let_def split: if_split_asm)
        with False have "map_of ts k' = None"
          by(cases "map_of ts k'")(auto dest: map_of_SomeD simp add: delete_aux_eq_Nil_conv)
        thus ?thesis using False Some Cons "2.prems"(1) by simp
      next
        case True
        with Some "2.prems" Cons show ?thesis
          by(clarsimp simp add: "2.hyps" Let_def is_empty_conv split: if_split_asm)
      qed
    qed(insert Some "2.prems"(1), simp add: Let_def split: if_split_asm)
  next
    case None thus ?thesis using "2.prems"(1) by simp
  qed
qed

lemma lookup_delete: "invar_trie t \<Longrightarrow>
  lookup_trie (delete_trie ks t) ks' =
  (if ks = ks' then None else lookup_trie t ks')"
proof(induct ks t arbitrary: ks' rule: delete_trie.induct)
  case 1 show ?case by(fastforce dest: not_sym simp add: neq_Nil_conv)
next
  case (2 k ks vo ts)
  show ?case
  proof(cases ks')
    case Nil thus ?thesis by(simp split: option.split add: Let_def)
  next
    case [simp]: (Cons k' ks'')
    show ?thesis
    proof(cases "k' = k")
      case False thus ?thesis using "2.prems"
        by(auto simp add: Let_def update_conv' map_of_delete_aux split: option.split)
    next
      case [simp]: True
      show ?thesis
      proof(cases "map_of ts k")
        case None thus ?thesis by simp
      next
        case (Some t)
        thus ?thesis
        proof(cases "is_empty_trie (delete_trie ks t)")
          case True
          with Some "2.prems" show ?thesis
            by(auto simp add: map_of_delete_aux is_empty_conv dest: delete_eq_empty_lookup_other_fail)
        next
          case False
          thus ?thesis using Some 2 by(auto simp add: update_conv')
        qed
      qed
    qed
  qed
qed

lemma lookup_delete':
  "invar_trie t \<Longrightarrow> lookup_trie (delete_trie ks t) = (lookup_trie t)(ks := None)"
by(rule ext)(simp add: lookup_delete)

lemma invar_trie_delete:
  "invar_trie t \<Longrightarrow> invar_trie (delete_trie ks t)"
proof(induct ks t rule: delete_trie.induct)
  case 1 thus ?case by simp
next
  case (2 k ks vo ts)
  show ?case
  proof(cases "map_of ts k")
    case None
    thus ?thesis using "2.prems" by simp
  next
    case (Some t)
    with "2.prems" have "invar_trie t" by auto
    with Some have "invar_trie (delete_trie ks t)" by(rule 2)
    from "2.prems" Some have distinct: "distinct (map fst ts)" "\<not> is_empty_trie t" by auto
    show ?thesis
    proof(cases "is_empty_trie (delete_trie ks t)")
      case True
      { fix k' t'
        assume k't': "(k', t') \<in> set (AList.delete_aux k ts)"
        with distinct have "map_of (AList.delete_aux k ts) k' = Some t'" by simp
        hence "map_of ts k' = Some t'" using distinct
          by (auto
            simp del: map_of_eq_Some_iff
            simp add: map_of_delete_aux
            split: if_split_asm)
        with "2.prems" have "\<not> is_empty_trie t' \<and> invar_trie t'" by auto }
      with "2.prems" have "invar_trie (Trie vo (AList.delete_aux k ts))" by auto
      thus ?thesis using True Some by(simp)
    next
      case False
      { fix k' t'
        assume k't':"(k', t') \<in> set (AList.update k (delete_trie ks t) ts)"
        hence "map_of (AList.update k (delete_trie ks t) ts) k' = Some t'"
          using "2.prems" by(auto simp add: distinct_update)
        hence eq: "((map_of ts)(k \<mapsto> delete_trie ks t)) k' = Some t'" unfolding update_conv .
        have "\<not> is_empty_trie t' \<and> invar_trie t'"
        proof(cases "k' = k")
          case True
          with eq have "t' = delete_trie ks t" by simp
          with \<open>invar_trie (delete_trie ks t)\<close> False
          show ?thesis by simp
        next
          case False
          with eq distinct have "(k', t') \<in> set ts" by simp
          with "2.prems" show ?thesis by auto
        qed }
      thus ?thesis using Some "2.prems" False by(auto simp add: distinct_update)
    qed
  qed
qed

subsection \<open>@{const update_with_trie}\<close>

(* FIXME mv *)
lemma nonempty_update_with_aux: "AList.update_with_aux v k f ps \<noteq> []"
by (induction ps) auto

lemma nonempty_update_with_trie: "\<not> is_empty_trie (update_with_trie ks f t)"
by(induction ks t rule: update_trie_induct)
  (auto simp: nonempty_update_with_aux)

lemma invar_update_with_trie:
  "invar_trie t \<Longrightarrow> invar_trie (update_with_trie ks f t)"
by(induction ks f t rule: update_with_trie.induct)
  (auto simp: set_update_with_aux nonempty_update_with_trie
     split: option.split prod.splits)

subsection \<open>Domain of a trie\<close>

lemma dom_lookup:
  "dom (lookup_trie (Trie vo kts)) =
  (\<Union>k\<in>dom (map_of kts). Cons k ` dom (lookup_trie (the (map_of kts k)))) \<union>
  (if vo = None then {} else {[]})"
unfolding dom_def
apply(rule sym)
apply(safe)
  apply simp
 apply(clarsimp simp add: if_split_asm)
apply(case_tac x)
apply(auto split: option.split_asm)
done

lemma finite_dom_lookup:
  "finite (dom (lookup_trie t))"
proof(induct t)
  case (Trie vo kts)
  have "finite (\<Union>k\<in>dom (map_of kts). Cons k ` dom (lookup_trie (the (map_of kts k))))"
  proof(rule finite_UN_I)
    show "finite (dom (map_of kts))" by(rule finite_dom_map_of)
  next
    fix k
    assume "k \<in> dom (map_of kts)"
    then obtain v where "(k, v) \<in> set kts" "map_of kts k = Some v" by(auto dest: map_of_SomeD)
    hence "finite (dom (lookup_trie (the (map_of kts k))))" by simp(rule Trie)
    thus "finite (Cons k ` dom (lookup_trie (the (map_of kts k))))" by(rule finite_imageI)
  qed
  thus ?case by(simp add: dom_lookup)
qed

lemma dom_lookup_empty_conv: "invar_trie t \<Longrightarrow> dom (lookup_trie t) = {} \<longleftrightarrow> is_empty_trie t"
proof(induct t)
  case (Trie vo kvs)
  show ?case
  proof
    assume dom: "dom (lookup_trie (Trie vo kvs)) = {}"
    have "vo = None"
    proof(cases vo)
      case (Some v)
      hence "[] \<in> dom (lookup_trie (Trie vo kvs))" by auto
      with dom have False by simp
      thus ?thesis ..
    qed
    moreover have "kvs = []"
    proof(cases kvs)
      case (Cons kt kvs')
      with \<open>invar_trie (Trie vo kvs)\<close>
      have "\<not> is_empty_trie (snd kt)" "invar_trie (snd kt)" by auto
      from Cons have "(fst kt, snd kt) \<in> set kvs" by simp
      hence "dom (lookup_trie (snd kt)) = {} \<longleftrightarrow> is_empty_trie (snd kt)"
        using \<open>invar_trie (snd kt)\<close> by(rule Trie)
      with \<open>\<not> is_empty_trie (snd kt)\<close> have "dom (lookup_trie (snd kt)) \<noteq> {}" by simp
      with dom Cons have False by(auto simp add: dom_lookup)
      thus ?thesis ..
    qed
    ultimately show "is_empty_trie (Trie vo kvs)" by simp
  next
    assume "is_empty_trie (Trie vo kvs)"
    thus "dom (lookup_trie (Trie vo kvs)) = {}"
      by(simp add: lookup_empty[unfolded empty_trie_def])
  qed
qed

subsection \<open>Range of a trie\<close>

lemma ran_lookup_Trie: "invar_trie (Trie vo ps) \<Longrightarrow>
  ran (lookup_trie (Trie vo ps)) =
  (case vo of None \<Rightarrow> {} | Some v \<Rightarrow> {v}) \<union> (UN (k,t) : set ps. ran(lookup_trie t))"
by(auto simp add: ran_def lookup_eq_Some_iff split: prod.splits option.split)

lemma all_trie_eq_ran:
  "invar_trie t \<Longrightarrow> all_trie P t = (\<forall>x \<in> ran(lookup_trie t). P x)"
by(induction P t rule: all_trie.induct)
  (auto simp add: ran_lookup_Trie split: prod.splits option.split)

end


section "Auxilliary Lemmas"
theory Kruskal_Misc
  imports
    "Collections.Partial_Equivalence_Relation"
    "Automatic_Refinement.Misc"
begin

lemma card2_get2: assumes "card x = 2"
  obtains a b where  "x = {a, b}" "a \<noteq> b"
proof -
  from assms have [simp,intro!]: "finite x" apply(rule_tac ccontr) by auto
  from assms obtain a where ax: "a \<in> x"
    by fastforce
  with assms  have "card (x - {a}) = 1" by fastforce
  then obtain b where "x - {a} = {b}" "a \<noteq> b"
    by (metis Diff_cancel Diff_idemp card_1_singletonE insert_not_empty)
  with that ax show ?thesis by blast
qed

subsection "Lemmas on equivalence relations"

lemma equiv_sym: "equiv V R \<Longrightarrow> (x,y)\<in>R \<Longrightarrow> (y,x)\<in>R"
  by (metis equiv_def symD)

lemma equiv_trans: "equiv V R \<Longrightarrow> (x,y)\<in>R \<Longrightarrow> (y,z)\<in>R \<Longrightarrow> (x,z)\<in>R"
  by (metis equiv_def transD)

lemma equiv_trans_sym:
  "\<lbrakk> equiv V R; (a,b)\<in>R; (c,b)\<in>R \<rbrakk> \<Longrightarrow> (a,c)\<in>R"
  "\<lbrakk> equiv V R; (a,b)\<in>R; (a,c)\<in>R \<rbrakk> \<Longrightarrow> (b,c)\<in>R"
  apply (metis equiv_sym equiv_trans)+
  done

lemma union_equiv:
  "equiv V R \<Longrightarrow> equiv V (per_union R a b)"
  apply (rule equivI)
  unfolding per_union_def
  subgoal unfolding equiv_def refl_on_def by auto
  subgoal apply (rule symI) by (auto dest: equiv_sym)
  subgoal apply (rule transI) by (auto dest: equiv_trans equiv_trans_sym)
  done

lemma equiv_mono: "E'\<subseteq>E \<Longrightarrow> equiv E R1 \<Longrightarrow> equiv E' (R1 \<inter> E'\<times>E')"
  apply(rule equivI)
  subgoal unfolding equiv_def
    by (simp add: refl_on_def subset_iff)
  subgoal unfolding equiv_def
    by (metis mem_Sigma_iff symI sym_Int)
  subgoal unfolding equiv_def using trans_Restr by fastforce
  done

lemma unify2EquivClasses_alt:
  assumes "R``{x} \<noteq> R``{y}" and inV: "y\<in>V" "x\<in>V" and "R\<subseteq>V\<times>V"
   and eq: "equiv V R" and [simp]: "finite V"
  shows "Suc (card (quotient V (per_union R x y))) = card (quotient V R)"
proof -

  from eq have Rtrancl: "R\<^sup>+ = R" by (auto elim: equivE)
  from \<open>equiv V R\<close> have sym: "sym R" unfolding equiv_def by auto

  let ?R' = "per_union R x y"

  \<comment> \<open> the equivalence classes not contining x and y, stay unchanged when performing @{term per_union} \<close>
  have "\<And>z. z \<in> V \<Longrightarrow> z \<notin> R `` {x} \<Longrightarrow> z \<notin> R `` {y} \<Longrightarrow> per_union R x y `` {z} = R `` {z}"
    using sym by(auto simp: sym_def per_union_def)
  then have K: "(\<Union>x \<in> (V-(R``{x})-(R``{y})). {?R'``{x}}) = (\<Union>x \<in> (V-(R``{x})-(R``{y})). {R``{x}})"
    by auto

  have R_respect: "(\<lambda>x. {R `` {x}}) respects R"
    unfolding congruent_def using eq equiv_class_eq_iff by fastforce+

  have R'_respect: "(\<lambda>xa. {?R' `` {xa}}) respects R"
    unfolding congruent_def per_union_def
      using eq equiv_class_eq_iff by force+

  \<comment> \<open>some facts about the equivalence class of x, before and after the @{term per_union} operation\<close>
  have xdrin: "(R``{x}) \<subseteq> V" using assms(4) by auto
  have x1: "(\<Union>x \<in> (R``{x}). {?R'``{x}}) = {?R'``{x}}"
    apply(rule UN_equiv_class) by fact+
  have x2: "(\<Union>x \<in> (R``{x}). {R``{x}}) = {R``{x}}"
    apply(rule UN_equiv_class) by fact+

  \<comment> \<open>some facts about the equivalence class of y, before and after the @{term per_union} operation\<close>
  have ydrin: "(R``{y}) \<subseteq> V" using assms(4) by auto
  have y1: "(\<Union>x \<in> (R``{y}). {?R'``{x}}) = {?R'``{y}}"
    apply(rule UN_equiv_class) by fact+
  have y2: "(\<Union>x \<in> (R``{y}). {R``{x}}) = {R``{y}}"
    apply(rule UN_equiv_class) by fact+

  have z: "(y,x)\<in>?R'" unfolding per_union_def using sym sym_def
    using assms(2) assms(3) eq eq_equiv_class by fastforce
  have bla: "?R'``{y} = ?R'``{x}"
    apply(rule equiv_class_eq)
     apply(rule union_equiv)
     apply fact
    by fact

  let ?Vm = "(\<Union>x \<in> (V-(R``{x})-(R``{y})). {R``{x}})"

  \<comment> \<open>now consider the set of quotients wrt. the relation after the @{term per_union}\<close>
  have "quotient V ?R' = (\<Union>x \<in> V. {?R'``{x}})" unfolding quotient_def by auto
  also  \<comment> \<open>decompose it into the quotients for elements equivalent to x, y in R, and the rest\<close>
  have "\<dots> = (\<Union>x \<in> (V-(R``{x})-(R``{y})). {?R'``{x}})
             \<union> (\<Union>x \<in> (R``{y}). {?R'``{x}}) \<union> (\<Union>x \<in> (R``{x}). {?R'``{x}})"
    using xdrin ydrin by auto
  also  \<comment> \<open>for the elements equivalent to x and y in R the quotient is
            the quotient containing x and y respectively \<close>
  have "\<dots> = (\<Union>x \<in> (V-(R``{x})-(R``{y})). {?R'``{x}}) \<union> {?R'``{y}} \<union> {?R'``{x}}" using x1 y1 by auto
  also  \<comment> \<open>which is after uniting them, the same quotient \<close>
  have "\<dots> = (\<Union>x \<in> (V-(R``{x})-(R``{y})). {R``{x}}) \<union> {?R'``{y}}" using K bla by auto
  also
  have "\<dots> = insert (?R'``{y}) ?Vm" by auto
  finally have leftside: "quotient V ?R' = insert (?R'``{y}) ?Vm" .

  have notin: "?R'``{y} \<notin> ?Vm"
    apply (auto simp: per_union_def)
    by (metis (no_types, lifting) Image_singleton_iff UnI1 assms(2) eq equiv_class_self local.sym symE)

  have o: "card (quotient V ?R') = Suc (card ?Vm)"
    unfolding leftside apply(rule card_insert_disjoint)
     using notin by auto

  \<comment> \<open>now consider the set of quotients wrt. the relation before the @{term per_union}\<close>
  have "quotient V R = (\<Union>x \<in> V. {R``{x}})" unfolding quotient_def by auto
  also \<comment> \<open>decompose it into the quotients for elements equivalent to x, y in R, and the rest\<close>
  have "\<dots> = (\<Union>x \<in> (V-(R``{x})-(R``{y})). {R``{x}})
           \<union> (\<Union>x \<in> (R``{y}). {R``{x}}) \<union> (\<Union>x \<in> (R``{x}). {R``{x}})"
    using xdrin ydrin by auto
  also \<comment> \<open>for the elements equivalent to x and y in R the quotient is
            the quotient containing x and y respectively \<close>
  have "\<dots> = (\<Union>x \<in> (V-(R``{x})-(R``{y})). {R``{x}}) \<union> {R``{y}} \<union> {R``{x}}" using x2 y2 by auto
  also \<comment> \<open> these are two distinct quotients  \<close>
  have "\<dots> = insert (R``{y}) (insert (R``{x}) ?Vm)" by auto
  finally have ii: "quotient V R = insert (R``{y}) (insert (R``{x}) ?Vm)" .

  have "R``{x} \<notin> ?Vm"
    using eq equiv_class_self by fastforce
  have "R``{y} \<notin> ?Vm"
    using eq equiv_class_self by fastforce
  with assms(1)
  have "R``{y} \<notin> (insert (R``{x}) ?Vm)" by blast
  have "card (quotient V R) = Suc (card (insert (R``{x}) ?Vm))" apply(simp only: ii) apply(rule card_insert_disjoint)
     apply simp
    apply fact done
  also have "card (insert (R``{x}) ?Vm) = Suc (card ?Vm)" apply(rule card_insert_disjoint)
     apply simp
    apply fact done
  finally have a: "card (quotient V R) = Suc (Suc (card ?Vm))" by auto

  from a o show ?thesis by auto
qed

subsection "On the pigeon hole principle"

subsection "On sorting and \<open>max_node\<close>"

definition edges_less_eq :: "('a \<times> 'w::{linorder, ordered_comm_monoid_add} \<times> 'a) \<Rightarrow> ('a \<times> 'w \<times> 'a) \<Rightarrow> bool"
  where "edges_less_eq a b \<equiv> fst(snd a) \<le> fst(snd b)"

definition "sort_edges \<equiv> quicksort_by_rel edges_less_eq []"

definition "max_node l \<equiv> Max (insert 0 (fst`set l \<union> (snd o snd)`set l))"

lemma max_node_impl[code]: "max_node l = fold (\<lambda>(u,_,w) x. max u (max w x)) l 0"
proof -
  have "fold (\<lambda>(u,_,w) x. max u (max w x)) l a = Max (insert a (fst`set l \<union> (snd o snd)`set l))" for a
    apply (induction l arbitrary: a)
     apply (auto simp:  )
    subgoal for a b l aa
      apply (cases l)
      by (auto simp: ac_simps)
    done
  thus ?thesis unfolding max_node_def by auto
qed

definition "is_linorder_rel R \<equiv> (\<forall>x y. R x y \<or> R y x) \<and> (\<forall>x y z. R x y \<longrightarrow> R y z \<longrightarrow> R x z)"

lemma edges_less_eq_linorder: "is_linorder_rel edges_less_eq"
  unfolding edges_less_eq_def is_linorder_rel_def
  by (metis linear order_trans)

lemma sort_edges_correct: "sorted_wrt edges_less_eq (quicksort_by_rel edges_less_eq [] l)"
  by (metis (no_types, hide_lams) edges_less_eq_linorder is_linorder_rel_def sorted_wrt_quicksort_by_rel)

lemma distinct_mset_eq:"distinct a \<Longrightarrow> mset a = mset b \<Longrightarrow> distinct b"
  by (metis card_distinct distinct_card set_mset_mset size_mset)

lemma quicksort_by_rel_distinct: "distinct l \<Longrightarrow> distinct (quicksort_by_rel edges_less_eq [] l)"
  by (auto intro: distinct_mset_eq)

end


section "Priority Queues Based on Braun Trees"

theory Priority_Queue_Braun
imports
  "HOL-Library.Tree_Multiset"
  "HOL-Library.Pattern_Aliases"
  "HOL-Data_Structures.Priority_Queue_Specs"
  "HOL-Data_Structures.Braun_Tree"
begin

subsection "Introduction"

text\<open>Braun, Rem and Hoogerwoord \cite{BraunRem,Hoogerwoord} used
specific balanced binary trees, often called Braun trees (where in
each node with subtrees $l$ and $r$, $size(r) \le size(l) \le
size(r)+1$), to implement flexible arrays. Paulson \cite{Paulson}
(based on code supplied by Okasaki)
implemented priority queues via Braun trees. This theory verifies
Paulsons's implementation, with small simplifications.\<close>

text \<open>Direct proof of logarithmic height. Also follows from the fact that Braun
trees are balanced (proved in the base theory).\<close>

lemma height_size_braun: "braun t \<Longrightarrow> 2 ^ (height t) \<le> 2 * size t + 1"
proof(induction t)
  case (Node t1)
  show ?case
  proof (cases "height t1")
    case 0 thus ?thesis using Node by simp
  next
    case (Suc n)
    hence "2 ^ n \<le> size t1" using Node by simp
    thus ?thesis using Suc Node by(auto simp: max_def)
  qed
qed simp

subsection "Get Minimum"

lemma get_min: "\<lbrakk> heap h;  h \<noteq> Leaf \<rbrakk> \<Longrightarrow> value h = Min_mset (mset_tree h)"
by (auto simp add: eq_Min_iff neq_Leaf_iff)

subsection \<open>Insertion\<close>

hide_const (open) insert

fun insert :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"insert a Leaf = Node Leaf a Leaf" |
"insert a (Node l x r) =
 (if a < x then Node (insert x r) a l else Node (insert a r) x l)"

value "fold insert [0::int,1,2,3,-55,-5] Leaf"

lemma size_insert[simp]: "size(insert x t) = size t + 1"
by(induction t arbitrary: x) auto

lemma mset_insert: "mset_tree(insert x t) = {#x#} + mset_tree t"
by(induction t arbitrary: x) (auto simp: ac_simps)

lemma set_insert[simp]: "set_tree(insert x t) = {x} \<union> (set_tree t)"
by(induction t arbitrary: x) auto

lemma braun_insert: "braun t \<Longrightarrow> braun(insert x t)"
by(induction t arbitrary: x) auto

lemma heap_insert: "heap t \<Longrightarrow> heap(insert x t)"
by(induction t arbitrary: x) (auto  simp add: ball_Un)

subsection \<open>Deletion\<close>

text \<open>Slightly simpler definition of @{text del_left}
which avoids the need to appeal to the Braun invariant.\<close>

fun del_left :: "'a tree \<Rightarrow> 'a * 'a tree" where
"del_left (Node Leaf x r) = (x,r)" |
"del_left (Node l x r) = (let (y,l') = del_left l in (y,Node r x l'))"

lemma del_left_mset_plus:
  "del_left t = (x,t') \<Longrightarrow> t \<noteq> Leaf
  \<Longrightarrow> mset_tree t = {#x#} + mset_tree t'"
  by (induction t arbitrary: x t' rule: del_left.induct;
    auto split: prod.splits)

lemma del_left_mset:
  "del_left t = (x,t') \<Longrightarrow> t \<noteq> Leaf
  \<Longrightarrow> x \<in># mset_tree t \<and> mset_tree t' = mset_tree t - {#x#}"
by (simp add: del_left_mset_plus)

lemma del_left_set:
  "del_left t = (x,t') \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> set_tree t = {x} \<union> set_tree t'"
by(simp add: del_left_mset_plus flip: set_mset_tree)

lemma del_left_heap:
  "del_left t = (x,t') \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> heap t \<Longrightarrow> heap t'"
  by (induction t arbitrary: x t' rule: del_left.induct;
    fastforce split: prod.splits dest: del_left_set[THEN equalityD2])

lemma del_left_size:
  "del_left t = (x,t') \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> size t = size t' + 1"
  by(induction t arbitrary: x t' rule: del_left.induct;
    auto split: prod.splits)

lemma del_left_braun:
  "del_left t = (x,t') \<Longrightarrow> braun t \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> braun t'"
  by(induction t arbitrary: x t' rule: del_left.induct;
    auto split: prod.splits dest: del_left_size)

context includes pattern_aliases
begin

text \<open>Slightly simpler definition: \<open>_\<close> instead of @{const Leaf} because of Braun invariant.\<close>

function (sequential) sift_down :: "'a::linorder tree \<Rightarrow> 'a \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"sift_down Leaf a _ = Node Leaf a Leaf" |
"sift_down (Node Leaf x _) a Leaf =
  (if a \<le> x then Node (Node Leaf x Leaf) a Leaf
   else Node (Node Leaf a Leaf) x Leaf)" |
"sift_down (Node l1 x1 r1 =: t1) a (Node l2 x2 r2 =: t2) =
  (if a \<le> x1 \<and> a \<le> x2
   then Node t1 a t2
   else if x1 \<le> x2 then Node (sift_down l1 a r1) x1 t2
        else Node t1 x2 (sift_down l2 a r2))"
by pat_completeness auto
termination
by (relation "measure (%(l,a,r). size l + size r)") auto

end

lemma size_sift_down:
  "braun(Node l a r) \<Longrightarrow> size(sift_down l a r) = size l + size r + 1"
by(induction l a r rule: sift_down.induct) (auto simp: Let_def)

lemma braun_sift_down:
  "braun(Node l a r) \<Longrightarrow> braun(sift_down l a r)"
by(induction l a r rule: sift_down.induct) (auto simp: size_sift_down Let_def)

lemma mset_sift_down:
  "braun(Node l a r) \<Longrightarrow> mset_tree(sift_down l a r) = {#a#} + (mset_tree l + mset_tree r)"
by(induction l a r rule: sift_down.induct) (auto simp: ac_simps Let_def)

lemma set_sift_down: "braun(Node l a r)
  \<Longrightarrow> set_tree(sift_down l a r) = {a} \<union> (set_tree l \<union> set_tree r)"
by(drule arg_cong[where f=set_mset, OF mset_sift_down]) (simp)

lemma heap_sift_down:
  "braun(Node l a r) \<Longrightarrow> heap l \<Longrightarrow> heap r \<Longrightarrow> heap(sift_down l a r)"
by (induction l a r rule: sift_down.induct) (auto simp: set_sift_down ball_Un Let_def)

fun del_min :: "'a::linorder tree \<Rightarrow> 'a tree" where
"del_min Leaf = Leaf" |
"del_min (Node Leaf x r) = Leaf" |
"del_min (Node l x r) = (let (y,l') = del_left l in sift_down r y l')"

lemma braun_del_min: "braun t \<Longrightarrow> braun(del_min t)"
apply(cases t rule: del_min.cases)
  apply simp
 apply simp
apply (fastforce split: prod.split intro!: braun_sift_down
  dest: del_left_size del_left_braun)
done

lemma heap_del_min: "heap t \<Longrightarrow> braun t \<Longrightarrow> heap(del_min t)"
apply(cases t rule: del_min.cases)
  apply simp
 apply simp
apply (fastforce split: prod.split intro!: heap_sift_down
  dest: del_left_size del_left_braun del_left_heap)
done

lemma mset_del_min: assumes "braun t" "t \<noteq> Leaf"
shows "mset_tree(del_min t) = mset_tree t - {#value t#}"
proof(cases t rule: del_min.cases)
  case 1 with assms show ?thesis by simp
next
  case 2 with assms show ?thesis by (simp)
next
  case [simp]: (3 ll b lr a r)
  have "mset_tree(sift_down r y l') = mset_tree t - {#a#}"
    if del: "del_left (Node ll b lr) = (y,l')" for y l'
    using assms del_left_mset[OF del] del_left_size[OF del]
      del_left_braun[OF del] del_left_mset_plus[OF del]
    apply (subst mset_sift_down)
    apply (auto simp: ac_simps del_left_mset_plus[OF del])
    done
  thus ?thesis by(auto split: prod.split)
qed

text \<open>Last step: prove all axioms of the priority queue specification:\<close>

interpretation braun: Priority_Queue
where empty = Leaf and is_empty = "\<lambda>h. h = Leaf"
and insert = insert and del_min = del_min
and get_min = "value" and invar = "\<lambda>h. braun h \<and> heap h"
and mset = mset_tree
proof(standard, goal_cases)
  case 1 show ?case by simp
next
  case 2 show ?case by simp
next
  case 3 show ?case by(simp add: mset_insert)
next
  case 4 thus ?case by(simp add: mset_del_min)
next
  case 5 thus ?case using get_min mset_tree.simps(1) by blast
next
  case 6 thus ?case by(simp)
next
  case 7 thus ?case by(simp add: heap_insert braun_insert)
next
  case 8 thus ?case by(simp add: heap_del_min braun_del_min)
qed

end


theory Sound
imports op HHL
begin

(*The definition for the soundness of sequtial process*)
definition Valid :: "fform => proc => fform => fform => bool" ("Valid _ _ _ _")
where "Valid p Q q H =
         (ALL f d f' d'. (evalP (Q, f, d) = (Skip, f', d')) --> evalF (last(f(d)), p)
           --> (evalF (last(f'(d')), q) & ievalF (f', H, d, d')))"

(*The definition for the soundness of parallel process*)
definition ValidP :: "fform => fform => proc => proc => fform => fform => fform => fform => bool"
("ValidP _ _ _ _ _ _ _ _")
where "ValidP p1 p2 P Q q1 q2 H1 H2 =
         (ALL f g f' g' d d1 d2. (evalPP (P||Q,f,g,d) = (Skip,f',g',d1,d2))
            --> evalF (last(f(d)), p1) --> evalF (last(g(d)), p2)
              --> (evalF (last(f'(d1)), q1) & evalF (last(g'(d2)), q2) &
                     ievalF (f', H1, d, d1)& ievalF (g', H2, d, d2)))"

(*soundness for consequence rule of sequtial*)
lemma ConsequenceS_sound: "Valid px P qx Hx
        --> (ALL f1 d1. evalF (last(f1(d1)),(p [-->] px)))
        --> (ALL f1 d1. evalF (last(f1(d1)),(qx [-->] q)))
        --> (ALL f1 d1 d2. ievalF (f1,(Hx [-->] H),d1,d2))
        --> Valid p P q H"
apply (simp add: Imply_eval)
apply (unfold Valid_def,auto)
apply (subgoal_tac "evalF(last(f'(d')), qx)",auto)
apply (subgoal_tac "evalF(last(f(d)), px)",auto)
apply (subgoal_tac "ievalF(f', Hx, d, d')",auto)
apply (subgoal_tac "evalF(last(f(d)), px)",auto)
done

(*soundness for consequence rule of parallel*)
lemma ConsequenceP_sound: "ValidP px py Px Py qx qy Hx Hy
        --> (ALL f1 d1. evalF (last(f1(d1)),(p [-->] px)))
        --> (ALL f1 d1. evalF (last(f1(d1)),(r [-->] py)))
        --> (ALL f1 d1. evalF (last(f1(d1)),(qx [-->] q)))
        --> (ALL f1 d1. evalF (last(f1(d1)),(qy [-->] s)))
        --> (ALL f1 d1 d2. ievalF (f1,(Hx [-->] H),d1,d2))
        --> (ALL f1 d1 d2. ievalF (f1,(Hy [-->] G),d1,d2))
        --> ValidP p r Px Py q s H G"
apply (simp add: Imply_eval)
apply (unfold ValidP_def,auto)
apply blast
apply (subgoal_tac "evalF(last(g'(d2)), qy)",auto)
apply (subgoal_tac "evalF(last(f(d)), px)",auto)
apply (subgoal_tac "evalF(last(g(d)), py)",auto)
apply (subgoal_tac "ievalF(f', Hx, d, d1)",auto)
apply (subgoal_tac "evalF(last(f(d)), px)",auto)
apply (subgoal_tac "evalF(last(g(d)), py)",auto)
apply (subgoal_tac "ievalF(g', Hy, d, d2)",auto)
apply (subgoal_tac "evalF(last(f(d)), px)",auto)
apply (subgoal_tac "evalF(last(g(d)), py)",auto)
done

(*The following rules from substR_fact1 to substR are for syntatical substitution,
  and are used for proving soundness of assignment rule and communiction rule.*)
lemma substR_fact1 : " ALL f. evalE(f, substE([(RVar x, e)], v))
        = evalE(%y i. if y = x & i = R then evalE(f, e) else f(y, i), v)"
apply (induct v, auto)
apply (case_tac "evalE(%y i. if y = x & i = R then evalE(f, e) else f(y, i), v1)", auto)+
done

lemma substR_fact2: "substE([], e) = e"
apply (induct "e", auto)
done

lemma substR_fact3: "substF([], q) = q"
apply (induct "q", auto)
apply (simp add:substR_fact2)+
done

lemma substR_fact4: " ~ inPairForm([(RVar x, e)], WALL list q)
        ==> ((substF([(RVar x, e)], WALL list q)) = (WALL list (substF ([(RVar x, e)], q))))"
apply (simp add:inPairForm_def)
done

lemma substR_fact5 : "~inExp(list, e)
        ==> ALL f v. evalE(f, e) = evalE(%a i. if a = list then RR(v) else f(a, i), e)"
apply (induct e, auto)
apply (case_tac "evalE(f, e1)", auto)+
done

lemma substR_ALL : " [| ~ inPairForm([(RVar x, e)], q)
        ==> ALL f. evalF(f, substF([(RVar x, e)], q))
                 = evalF(%y i. if y = x & i = R then evalE(f, e) else f(y, i), q);
        ~ inPairForm([(RVar x, e)], WALL list q ) |]
        ==> ALL f. evalF(f, substF([(RVar x, e)], WALL list q ))
                 = evalF(%y i. if y = x & i = R then evalE(f, e) else f(y, i), WALL list q )"
apply (rule allI)
apply (cut_tac x = x and e = e and q = q and list = "list" in substR_fact4, simp)
apply (subgoal_tac "evalF(f, substF([(RVar x, e)], WALL list q ))
         = evalF (f, (WALL list substF([(RVar x, e)], q)))")
defer apply simp
apply (subgoal_tac "evalF(f, substF([(RVar x, e)], WALL list q ))
         = (ALL (v::real). (evalF((%a. %i. (if (a=list) then (RR (v)) else (f(a, i))))
              , substF([(RVar x, e)], q))))")
defer apply simp
apply (subgoal_tac "evalF(%y i. if y = x & i = R  then evalE(f, e) else f(y, i), WALL list q) =
         (let f1 = (%y i. if y = x & i = R  then evalE(f, e) else f(y, i)) in
         (ALL (v::real). (evalF((%a. %i. (if (a=list) then (RR (v)) else (f1(a, i)))), q))))")
defer apply simp
apply (subgoal_tac "~ inPairForm([(RVar x, e)], q)")
defer apply simp
apply (subgoal_tac "ALL v. let f2 = %a i. if a = list then RR(v) else f(a, i) in
         (evalF(f2, substF([(RVar x, e)], q))
         = evalF(%y i. if y = x & i = R  then evalE(f2, e) else f2(y, i), q))")
defer apply simp
apply (subgoal_tac "(let f1 = %y i. if y = x & i = R  then evalE(f, e) else f(y, i) in
         ALL v. evalF(%a i. if a = list then RR(v) else f1(a, i), q)) =
         (ALL v. let f2 = %a i. if a = list then RR(v) else f(a, i) in
           evalF(%y i. if y = x & i = R  then evalE(f2, e) else f2(y, i), q))", simp)
apply (subgoal_tac "~x=list")
apply (simp add:Let_def)
apply (subgoal_tac "ALL v t. evalE(f, e) = evalE(%a i. if a = list then RR(v) else f(a, i), e)")
apply (subgoal_tac "ALL v. (%a i. if a = list then RR(v) else if a = x & i = R then evalE(f, e) else f(a, i))
         = (%y i. if y = x & i = R  then evalE(%a i. if a = list then RR(v) else f(a, i), e)
         else if y = list then RR(v) else f(y, i))", simp)
apply (simp add:fun_eq_iff)
apply (cut_tac list = "list" and e =  e in substR_fact5, auto)
done

lemma substR_fact6: " ~ inPairForm([(RVar x, e)], WEX list q) ==>
        ((substF([(RVar x, e)], WEX list q)) = (WEX list (substF ([(RVar x, e)], q))))"
apply (simp add:inPairForm_def)
done

lemma substR_EX : "[| ~ inPairForm([(RVar x, e)], q)
        ==> ALL f. evalF(f, substF([(RVar x, e)], q))
                 = evalF(%y i. if y = x & i = R then evalE(f, e) else f(y, i), q);
        ~ inPairForm([(RVar x, e)], WEX list q) |]
        ==> ALL f. evalF(f, substF([(RVar x, e)], WEX list q))
                 = evalF(%y i. if y = x & i = R then evalE(f, e) else f(y, i), WEX list q)"
apply (rule allI)
apply (cut_tac x = x and e = e and q = q and list = "list" in substR_fact6, simp)
apply (subgoal_tac "evalF(f, substF([(RVar x, e)], WEX list q ))
                  = evalF ( f, (WEX list substF([(RVar x, e)], q)))")
defer apply simp
apply (subgoal_tac "evalF(f, substF([(RVar x, e)], WEX list q ))
         = (EX (v::real). (evalF((%a. %i. (if (a=list) then (RR (v)) else (f(a, i))))
              , substF([(RVar x, e)], q))))")
defer apply simp
apply (subgoal_tac "evalF(%y i. if y = x & i = R  then evalE(f, e) else f(y, i), WEX list q)
         = (let f1 = (%y i. if y = x & i = R  then evalE(f, e) else f(y, i)) in
             (EX (v::real) .  (evalF((%a. %i. (if (a=list) then (RR (v)) else (f1(a, i)))), q))))")
defer apply simp
apply (subgoal_tac "~ inPairForm([(RVar x, e)], q)")
defer apply simp
apply (subgoal_tac "EX v. let f2 = %a i. if a = list then RR(v) else f(a, i) in
         (evalF(f2, substF([(RVar x, e)], q))
         = evalF(%y i. if y = x & i = R  then evalE(f2, e) else f2(y, i), q))")
defer apply simp
apply (subgoal_tac "(let f1 = %y i. if y = x & i = R  then evalE(f, e) else f(y, i)
         in EX v. evalF(%a i. if a = list then RR(v) else f1(a, i), q)) =
         (EX v. let f2 = %a i. if a = list then RR(v) else f(a, i)
         in  evalF(%y i. if y = x & i = R  then evalE(f2, e) else f2(y, i), q))", simp)
apply (subgoal_tac "~x=list")
apply (simp add:Let_def)
apply (subgoal_tac "ALL v. evalE(f, e) = evalE(%a i. if a = list then RR(v) else f(a, i), e)")
apply (subgoal_tac "ALL v. (%a i. if a = list then RR(v) else if a = x & i = R   then evalE(f, e) else f(a, i))
         = (%y i. if y = x & i = R then evalE(%a i. if a = list then RR(v) else f(a, i), e)
           else if y = list then RR(v) else f(y, i))", auto)
apply (simp add:fun_eq_iff)
apply (cut_tac list = "list" and e =  e in substR_fact5, auto)
done

(*lemma used for proving the soundness of assignment rule and communication rule.
  This lemma means that the substitution for a variable is equivlant to change the state.*)
lemma substR: "~inPairForm ([(RVar x, e)], q) ==> ALL f. evalF(f, substF([(RVar x, e)], q)) =
              evalF(%y i. if y = x & i = R then evalE(f, e) else f(y, i), q)"
apply (induct q)
apply simp
apply simp
defer defer defer
apply simp
apply simp
apply simp
apply simp
apply simp
defer defer
apply (simp add:substF_def)
apply (cut_tac x = x and e=e and v = "exp1" in substR_fact1)
apply (cut_tac x = x and e=e and v = "exp2" in substR_fact1)
apply (rule allI)
apply (case_tac "evalE(%y i. if y = x & i = R then evalE(f, e) else f(y, i), exp1)")
apply simp
apply simp
apply simp
apply simp
apply (simp add:substF_def)
apply (cut_tac  x = x and e=e and v = "exp1" in substR_fact1)
apply (cut_tac  x = x and e=e and v = "exp2" in substR_fact1)
apply (rule allI)
apply (case_tac "evalE(%y i. if y = x & i = R then evalE(f, e) else f(y, i), exp1)")
apply simp
apply simp
apply simp
apply simp
apply (simp add:substF_def)
apply (cut_tac  x = x and e=e and v = "exp1" in substR_fact1)
apply (cut_tac  x = x and e=e and v = "exp2" in substR_fact1)
apply (rule allI)
apply (case_tac "evalE(%y i. if y = x & i = R then evalE(f, e) else f(y, i), exp1)")
apply simp
apply simp
apply simp
apply simp
apply (cut_tac x =  x and e = e and q = q and list = "list" in substR_ALL, simp)
apply simp
apply simp
apply (cut_tac x =  x and e = e and q = q and list = "list" in substR_EX, auto)
done

(*soundness for assign rule of real variable, others are in the end of this file*)
lemma AssignR_sound: "~inPairForm ([(RVar x, e)], q) &
        (ALL f. evalF (f, p [-->] (substF ([((RVar (x)), e)]) (q))))
        &   (ALL f d1 d2. ievalF (f, (l [=] (Real 0)) [-->] G, d1, d2)) --> Valid p (RVar (x)):=e q G"
apply (simp add:Imply_eval)
apply (unfold Valid_def, auto)
(*1st*)
apply (cut_tac x = "x" and e = "e" and f = "f" and d = "d" in assignR,auto)
apply (cut_tac x = x and e = e and q = q  in substR,auto)
(*2nd*)
apply (cut_tac x = "x" and e = "e" and f = "f" and d = "d" in assignR,simp)
apply (subgoal_tac "ievalF(f', l [=] Real 0, d', d')",auto)
apply (cut_tac L=0 in L_eval,auto)
done

(*soundness for continue rule*)
lemma continue_sound: "(ALL f1 d1 d2. evalF (last(f1(d1)),Init [-->] F))
        & (ALL f1 d1 d2. evalF (last(f1(d1)),((p [&] close(F) [&] close([~]b)) [-->] q)))
        & (ALL f1 d1 d2. ievalF (f1,((((l [=] Real 0) [|] (high (close(F) [&] p [&] close(b)))) [&] Rg) [-->] G),d1,d2))
        & (disj (p, F))
        --> Valid (Init [&] p) (<F&&b> : Rg) q G"
apply (unfold Valid_def, auto)
(*1st*)
apply (cut_tac F = F and b = b and  Rg = "Rg" and f = f and d = d and f' = "f'" and d' = "d'" in continue, auto)
apply (subgoal_tac "evalF(last(f'(d')), p) & evalF(last(f'(d')), close(F)) & evalF(last(f'(d')), NotForm(b))",auto)
apply (cut_tac f = "last(f'(d'))" and b = d and c = "d'" and p = F in close_fact1, auto)
apply (cut_tac f = "last(f'(d'))" and b = d and c = "d'" and p = b in close_fact2, auto)
(*2nd*)
apply (simp add:Imply_eval And_eval Or_eval)
apply (cut_tac F = F and b = b and  Rg = "Rg" and f = f and d = d and f' = "f'" and d' = "d'" in continue, auto)
apply (subgoal_tac "( ((ievalF(f', (l [=] Real 0), d, d')) | (ievalF(f', (high (close(F) [&] p [&] close(b))), d, d')) ) &
             (ievalF(f', Rg, d, d')) ) --> (ievalF(f',G,d,d'))")
prefer 2
apply simp
apply (subgoal_tac "( ((ievalF(f', (l [=] Real 0), d, d')) | (ievalF(f', (high (close(F) [&] p [&] close(b))), d, d')) ) &
             (ievalF(f', Rg, d, d')) )",simp)
apply auto
apply (case_tac "d=d'",auto)
apply (cut_tac L=0 in L_eval,auto)
apply (subgoal_tac "ievalF(f', high (close(F) [&] p [&] close(b)), d, d')",simp)
apply (simp add: high_eval And_eval,auto)
apply (subgoal_tac "evalFP(f', F [&] b, ka)",auto)
apply (simp add: evalFP_def And_eval)
apply (rule allI)
apply (subgoal_tac "inList(s, f'(ka)) --> evalF(s, F) & evalF(s, b)")
defer
apply blast
apply (rule impI)
apply (subgoal_tac "evalF(s, F) & evalF(s, b)")
defer
apply blast
apply (rule conjI)
apply (cut_tac s=s and p=F in close_fact3,simp)
apply assumption
apply (rule conjI)
defer
apply (cut_tac s=s and p=b in close_fact3,simp)
apply assumption
apply blast
done

(*soundness for sequence rule*)
lemma Sequence_sound: "(Valid p P m H
        & Valid m Q q G)
        --> Valid p (P;(m,H);Q) q H[^]G"
apply (simp add:Valid_def, auto)
apply (cut_tac P = P and mid = "(m, H)" and Q = Q and f = f and
               d = d and F = "f'" and D = "d'" in sequence, auto)
apply blast
apply (cut_tac P = P and mid = "(m, H)" and Q = Q and f = f and
               d = d and F = "f'" and D = "d'" in sequence, auto)
apply (cut_tac f = "f'" and P = H and Q = G and c = d and d = "d'" in chop_eval1, auto)
apply blast
done

(*soundness for condition rule in case b is false,
  later it is used to prove the soundness of condition rule*)
lemma ConditionF_sound: "(ALL f1 d1 d2. evalF (last(f1(d1)),(p [-->] [~] b))
        & evalF (last(f1(d1)),(p [-->] q))
        & ievalF (f1,((l [=] Real 0) [-->] G),d1,d2))
        --> Valid p (IF b P) q G"
apply (simp add:Imply_eval)
apply (simp add:Valid_def, auto)
apply (simp add:conditionF)+
apply (subgoal_tac " ievalF(f', l[=]Real 0, d', d')",auto)
apply (simp add:L_eval)
done

(*soundness for condition rule in case b is true,
  later it is used to prove the soundness of condition rule*)
lemma ConditionT_sound: "(ALL f1 d1 d2. evalF (last(f1(d1)),(p [-->] b))
        & Valid p P q G)
        --> Valid p (IF b P) q G"
apply (simp add:Imply_eval)
apply (simp add:Valid_def, auto)
apply (cut_tac f = f and be = b and d = d and P = P and f' = "f'" and d' = "d'" in conditionT, auto)
apply (blast)
apply (cut_tac f = f and be = b and d = d and P = P and f' = "f'" and d' = "d'" in conditionT, auto)
apply blast
done

(*soundness for condition rule*)
lemma Condition_sound: "(Valid (p [&] b) (IF b P) q G
        & Valid (p [&] ([~]b)) (IF b P) q G)
        --> Valid p (IF b P) q G"
apply (simp add:Valid_def, auto)
apply blast+
done

(*soundness for nondeterministic rule of real variable*)
lemma NondeterministicR_sound: "Valid (p [&] b) P q G
        --> Valid p (NON R x : b P) q G"
apply (simp add:Valid_def,auto)
apply (cut_tac f = f and d = d and b = b and x = x and P = P and f' = "f'" and d' = "d'" in nondeterR, auto)+
done

(*soundness for nondeterministic rule of string variable*)
lemma NondeterministicS_sound: "Valid (p [&] b) P q G
        --> Valid p (NON S x : b P) q G"
apply (simp add:Valid_def,auto)
apply (cut_tac f = f and d = d and b = b and x = x and P = P and f' = "f'" and d' = "d'" in nondeterS, auto)+
done

(*soundness for nondeterministic rule of bool variable*)
lemma NondeterministicB_sound: "Valid (p [&] b) P q G
        --> Valid p (NON B x : b P) q G"
apply (simp add:Valid_def,auto)
apply (cut_tac f = f and d = d and b = b and x = x and P = P and f' = "f'" and d' = "d'" in nondeterB, auto)+
done

(*soundness for communication rule of real variable, others are in the end of this file.*)
lemma CommR_sound: "(ValidP px py Px Py qx qy Hx Hy)
        --> ~inPairForm([(RVar x, e)], ry)
        --> (ALL f g d. EX F G Da Db. evalPP(Px||Py,f,g,d) = (Skip,F,G,Da,Db))
        --> (ALL f1 d1. evalF (last(f1(d1)),(qx [-->] rx) [&] (qy [-->] (substF ([(RVar(x), e)]) (ry)))))
        --> (ALL f1 d1 d2. ievalF (f1,((Hx [^] (high (qx))) [-->] Gx) [&] ((Hy [^] (high(qy))) [-->] Gy),d1,d2))
        --> (ALL f1 f2 d1 d2. (ievalF(f1,(Hx[^](high (qx))),d1,d2) & ievalF(f2,Hy[^](l[=]Real 0),d1,d2)) |
                (ievalF(f2,(Hy[^](high (qy))),d1,d2) & ievalF(f1,Hx,d1,d2)) -->
                (ievalF(f1,H,d1,d2) & ievalF(f2,H,d1,d2)))
        --> ValidP px py (Px;m;ch!!e) (Py;M;ch??(RVar(x))) rx ry (Gx[&]H) (Gy[&]H)"
apply (simp add:Imply_eval And_eval)
apply (unfold ValidP_def,auto)
(*Proving for the 1st postcondition*)
apply (subgoal_tac "EX F G Da Db. evalPP(Px||Py, f, g, d) = (Skip, F, G, Da, Db)")
prefer 2
apply simp
apply (erule exE)+
apply (subgoal_tac "evalF(last(F(Da)), qx) & evalF(last(G(Db)), qy) & ievalF(F, Hx, d, Da) & ievalF(G, Hy, d, Db)")
prefer 2
apply simp
apply (cut_tac Px=Px and Py=Py and f=f and g=g and d=d and ch=ch and e=e and x=x and
               F=F and G=G and Da=Da and Db=Db and m=m and M=M in communicationR,auto)
(*Proving for the 2nd postcondition*)
apply (subgoal_tac "EX F G Da Db. evalPP(Px||Py, f, g, d) = (Skip, F, G, Da, Db)")
prefer 2
apply simp
apply (erule exE)+
apply (subgoal_tac "evalF(last(F(Da)), qx) & evalF(last(G(Db)), qy) & ievalF(F, Hx, d, Da) & ievalF(G, Hy, d, Db)")
prefer 2
apply simp
apply (cut_tac Px=Px and Py=Py and f=f and g=g and d=d and ch=ch and e=e and x=x and
               F=F and G=G and Da=Da and Db=Db and m=m and M=M in communicationR,auto)
apply (case_tac "Db < Da",auto)
apply (cut_tac x = x and e = e and q = ry in substR,auto)
apply (subgoal_tac "evalF(last(G(Db)), substF([(RVar x, e)], ry))")
prefer 2
apply (subgoal_tac "evalF(last(G(Db)), qy) --> evalF(last(G(Db)), substF([(RVar x, e)], ry))",simp)
apply blast
apply (cut_tac x=x and e=e and q=ry in substR,auto)
(*Proving for the 1st history, it is a conjunction of two formulae Gx and H*)
(*Start to prove Gx*)
apply (subgoal_tac "EX F G Da Db. evalPP(Px||Py, f, g, d) = (Skip, F, G, Da, Db)")
prefer 2
apply simp
apply (erule exE)+
apply (simp add:And_eval Imply_eval)
apply (subgoal_tac "ievalF(f', Hx [^] high qx, d, d1)")
apply simp
prefer 2
apply (cut_tac Px=Px and Py=Py and f=f and g=g and d=d and ch=ch and e=e and x=x and
               F=F and G=G and Da=Da and Db=Db and m=m and M=M in communicationR,auto)
(*start for the 1st case "Da < Db"*)
apply (cut_tac f = "%t. if Da < t & t <= Db then [last(F(Da))] else F(t)" and
               P = Hx and Q = "high qx" and c = d and d = Db in chop_eval1, auto)
apply (cut_tac x=Da in exI,auto)
apply (subgoal_tac "ievalF(%t. if Da < t & t <= Db then [last(F(Da))] else F(t), Hx, d, Da)
             = ievalF(F,Hx,d,Da)",simp)
apply (subgoal_tac "evalPP(Px||Py, f, g, d) = (Skip, F, G, Da, Db) -->
             evalF(last(f(d)), px) --> evalF(last(g(d)), py) -->
             evalF(last(F(Da)), qx) & evalF(last(G(Db)), qy) & ievalF(F, Hx, d, Da) & ievalF(G, Hy, d, Db)",simp)
apply blast
apply (cut_tac c=d and d=Da and f="%t. if Da < t & t <= Db then [last(F(Da))] else F(t)" and
               g=F and P=Hx in chop_interval,auto)
apply (cut_tac f="%t. if Da < t & t <= Db then [last(F(Da))] else F(t)" and P=qx and c=Da and d=Db in high_eval,auto)
apply (subgoal_tac "evalPP(Px||Py, f, g, d) = (Skip, F, G, Da, Db) -->
             evalF(last(f(d)), px) --> evalF(last(g(d)), py) -->
             evalF(last(F(Da)), qx) & evalF(last(G(Db)), qy) & ievalF(F, Hx, d, Da) & ievalF(G, Hy, d, Db)",simp)
prefer 2
apply blast
apply (simp add: evalFP_def)
(*start for the 2nd case "Db < Da"*)
apply (cut_tac f = F and P = Hx and Q = "high qx" and c = d and d = Da in chop_eval1, auto)
apply (cut_tac x=Da in exI,auto)
apply (subgoal_tac "evalPP(Px||Py, f, g, d) = (Skip, F, G, Da, Db) -->
             evalF(last(f(d)), px) --> evalF(last(g(d)), py) -->
             evalF(last(F(Da)), qx) & evalF(last(G(Db)), qy) & ievalF(F, Hx, d, Da) & ievalF(G, Hy, d, Db)",simp)
apply blast
apply (simp add: high_eval,auto)
(*start for the 2nd case "Db = Da"*)
apply (cut_tac f = F and P = Hx and Q = "high qx" and c = d and d = Da in chop_eval1, auto)
apply (cut_tac x=Da in exI,auto)
apply blast
apply (subgoal_tac "evalPP(Px||Py, f, g, d) = (Skip, F, G, Da, Db) -->
             evalF(last(f(d)), px) --> evalF(last(g(d)), py) -->
             evalF(last(F(Da)), qx) & evalF(last(G(Db)), qy) & ievalF(F, Hx, d, Da) & ievalF(G, Hy, d, Db)",simp)
prefer 2
apply blast
apply (cut_tac f=F and P=qx and c=Da and d=Da in high_eval,auto) (*end for Gx*)
(*For proving H, we first prove "(Hy[^] high (qy))"*)
apply (subgoal_tac "ievalF(g', (Hy [^] high(qy)), d, d1)")
prefer 2
apply (cut_tac Px=Px and Py=Py and f=f and g=g and d=d and ch=ch and e=e and x=x and
               F=F and G=G and Da=Da and Db=Db and m=m and M=M in communicationR,auto) (*1*)
(*start for the 1st case "Db < Da"*)
apply (cut_tac f = "%t. if t = Da
                      then [last(G(Db)),
                            %y i. if y = x & i = R then evalE(last(G(Db)), e) else last(G(Db), y, i)]
                      else if t < Da & Db < t then [last(G(Db))] else G(t)" and P = Hy and Q = "high qy" and
               c = d and d = Da in chop_eval1, auto)
apply (cut_tac x=Db in exI,auto) (*1a*)
apply (subgoal_tac "ievalF(%t. if t = Da
                      then [last(G(Db)),
                            %y i. if y = x & i = R then evalE(last(G(Db)), e) else last(G(Db), y, i)]
                      else if t < Da & Db < t then [last(G(Db))] else G(t),Hy, d, Db)
             = ievalF(G,Hy,d,Db)",simp)
apply (subgoal_tac "evalPP(Px||Py, f, g, d) = (Skip, F, G, Da, Db) -->
             evalF(last(f(d)), px) --> evalF(last(g(d)), py) -->
             evalF(last(F(Da)), qx) & evalF(last(G(Db)), qy) & ievalF(F, Hx, d, Da) & ievalF(G, Hy, d, Db)",simp)
apply blast
apply (cut_tac c=d and d=Db and f="%t. if t = Da
                      then [last(G(Db)),
                            %y i. if y = x & i = R then evalE(last(G(Db)), e) else last(G(Db), y, i)]
                      else if t < Da & Db < t then [last(G(Db))] else G(t)" and
               g=G and P=Hy in chop_interval,simp)
apply (cut_tac f = "%t. if t = Db then []
                      else if t = Da
                           then [last(G(Db)),
                                 %y i. if y = x & i = R then evalE(last(G(Db)), e) else last(G(Db), y, i)]
                           else if t < Da & Db < t then [last(G(Db))] else G(t)" and P = "high qy" and
               Q = "l [=] Real 0" and c = Db and d = Da in chop_eval,simp)
apply (cut_tac f="%t. if t = Da
                      then [last(G(Db)),
                            %y i. if y = x & i = R then evalE(last(G(Db)), e) else last(G(Db), y, i)]
                      else if t < Da & Db < t then [last(G(Db))] else G(t)" and
               P=qy and c=Db and d=Da in high_eval,auto)
apply (simp add: evalFP_def)
apply (subgoal_tac "evalPP(Px||Py, f, g, d) = (Skip, F, G, Da, Db) -->
             evalF(last(f(d)), px) --> evalF(last(g(d)), py) -->
             evalF(last(F(Da)), qx) & evalF(last(G(Db)), qy) & ievalF(F, Hx, d, Da) & ievalF(G, Hy, d, Db)",simp)
apply blast
(*start for the 2nd case "Db >= Da"*)
apply (simp add: chop_eval)
apply (cut_tac x=Db in exI,auto)
apply (cut_tac x="G(Db)" in exI,auto)
apply (cut_tac c=d and d=Db and f="%t. if t = Db then G(Db)
                      else if t = Db
                           then G(Db) @
                                [%y i. if y = x & i = R then evalE(last(G(Db)), e) else last(G(Db), y, i)]
                           else G(t)" and
               g=G and P=Hy in chop_interval,auto)
apply (subgoal_tac "evalPP(Px||Py, f, g, d) = (Skip, F, G, Da, Db) -->
             evalF(last(f(d)), px) --> evalF(last(g(d)), py) -->
             evalF(last(F(Da)), qx) & evalF(last(G(Db)), qy) & ievalF(F, Hx, d, Da) & ievalF(G, Hy, d, Db)",simp)
apply blast
apply (cut_tac f="%t. if t = Db
                      then [%y i. if y = x & i = R then evalE(last(G(Db)), e) else last(G(Db), y, i)]
                      else if t = Db
                           then G(Db) @
                                [%y i. if y = x & i = R then evalE(last(G(Db)), e) else last(G(Db), y, i)]
                           else G(t)" and P=qy and c=Db and d=Db in high_eval,auto)
(*start for H*)
apply (subgoal_tac "ievalF(g', Hy[^](l[=]Real 0), d, d1) | ievalF(f', Hx, d, d1)",auto)
apply (cut_tac Px=Px and Py=Py and f=f and g=g and d=d and ch=ch and e=e and x=x and
               F=F and G=G and Da=Da and Db=Db and m=m and M=M in communicationR,auto)
(*start for the 1st case Db < Da*)
apply (subgoal_tac "ievalF(F, Hx, d, Da)")
apply blast
apply (subgoal_tac "evalPP(Px||Py, f, g, d) = (Skip, F, G, Da, Db) -->
             evalF(last(f(d)), px) --> evalF(last(g(d)), py) -->
             evalF(last(F(Da)), qx) & evalF(last(G(Db)), qy) & ievalF(F, Hx, d, Da) & ievalF(G, Hy, d, Db)",simp)
apply blast
(*start for the 2nd case Db >= Da*)
apply (case_tac "d=Db",auto) (*2a*)
apply (simp add: chop_eval)
apply (cut_tac x=Db in exI,auto)
apply (cut_tac x="G(Db)" in exI,auto)
apply (cut_tac c=Db and d=Db and f="%t. if t = Db then G(Db)
                      else if t = Db
                           then G(Db) @
                                [%y i. if y = x & i = R then evalE(last(G(Db)), e) else last(G(Db), y, i)]
                           else G(t)" and
               g=G and P=Hy in chop_interval,auto)
apply (subgoal_tac "evalPP(Px||Py, f, g, Db) = (Skip, F, G, Da, Db) -->
             evalF(last(f(Db)), px) --> evalF(last(g(Db)), py) -->
             evalF(last(F(Da)), qx) & evalF(last(G(Db)), qy) & ievalF(F, Hx, Db, Da) & ievalF(G, Hy, Db, Db)",simp)
apply blast
apply (cut_tac L=0 in L_eval,auto) (*2b*)
apply (cut_tac f = "%t. if t = Db
                      then G(Db) @
                           [%y i. if y = x & i = R then evalE(last(G(Db)), e) else last(G(Db), y, i)]
                      else G(t)" and P = Hy and Q = "l [=] Real 0" and c = d and d = Db in chop_eval, auto)
apply (cut_tac x=Db in exI,auto)
apply (cut_tac x="G(Db)" in exI,auto)
apply (subgoal_tac "evalPP(Px||Py, f, g, d) = (Skip, F, G, Da, Db) -->
             evalF(last(f(d)), px) --> evalF(last(g(d)), py) -->
             evalF(last(F(Da)), qx) & evalF(last(G(Db)), qy) & ievalF(F, Hx, d, Da) & ievalF(G, Hy, d, Db)",simp)
prefer 2
apply blast
apply (cut_tac c=d and d=Db and f="%t. if t = Db then G(Db)
                      else if t = Db
                           then G(Db) @
                                [%y i. if y = x & i = R then evalE(last(G(Db)), e) else last(G(Db), y, i)]
                           else G(t)" and
               g=G and P=Hy in chop_interval,auto)
apply (cut_tac L=0 in L_eval,auto)
apply (cut_tac x=Db in exI,auto)
apply (cut_tac x="G(Db)" in exI,auto)
apply (subgoal_tac "evalPP(Px||Py, f, g, d) = (Skip, F, G, Da, Db) -->
             evalF(last(f(d)), px) --> evalF(last(g(d)), py) -->
             evalF(last(F(Da)), qx) & evalF(last(G(Db)), qy) & ievalF(F, Hx, d, Da) & ievalF(G, Hy, d, Db)",simp)
prefer 2
apply blast
apply (cut_tac c=d and d=Db and f="%t. if t = Db then G(Db)
                      else if t = Db
                           then G(Db) @
                                [%y i. if y = x & i = R then evalE(last(G(Db)), e) else last(G(Db), y, i)]
                           else G(t)" and
               g=G and P=Hy in chop_interval,auto)
apply (cut_tac L=0 in L_eval,auto)
(*Proving for the 1st history, it is a conjunction of two formulae Gx and H*)
(*Start to prove Gx*)
apply (subgoal_tac "EX F G Da Db. evalPP(Px||Py, f, g, d) = (Skip, F, G, Da, Db)")
prefer 2
apply simp
apply (erule exE)+
apply (simp add:And_eval Imply_eval)
apply (subgoal_tac "ievalF(g', (Hy [^] high(qy)), d, d2)")
prefer 2
apply (cut_tac Px=Px and Py=Py and f=f and g=g and d=d and ch=ch and e=e and x=x and
               F=F and G=G and Da=Da and Db=Db and m=m and M=M in communicationR,auto) (*1*)
(*start for the 1st case "Db < Da"*)
apply (cut_tac f = "%t. if t = Da
                      then [last(G(Db)),
                            %y i. if y = x & i = R then evalE(last(G(Db)), e) else last(G(Db), y, i)]
                      else if t < Da & Db < t then [last(G(Db))] else G(t)" and P = Hy and Q = "high qy" and
               c = d and d = Da in chop_eval1, auto)
apply (cut_tac x=Db in exI,auto) (*1a*)
apply (subgoal_tac "ievalF(%t. if t = Da
                      then [last(G(Db)),
                            %y i. if y = x & i = R then evalE(last(G(Db)), e) else last(G(Db), y, i)]
                      else if t < Da & Db < t then [last(G(Db))] else G(t),Hy, d, Db)
             = ievalF(G,Hy,d,Db)",simp)
apply (subgoal_tac "evalPP(Px||Py, f, g, d) = (Skip, F, G, Da, Db) -->
             evalF(last(f(d)), px) --> evalF(last(g(d)), py) -->
             evalF(last(F(Da)), qx) & evalF(last(G(Db)), qy) & ievalF(F, Hx, d, Da) & ievalF(G, Hy, d, Db)",simp)
apply blast
apply (cut_tac c=d and d=Db and f="%t. if t = Da
                      then [last(G(Db)),
                            %y i. if y = x & i = R then evalE(last(G(Db)), e) else last(G(Db), y, i)]
                      else if t < Da & Db < t then [last(G(Db))] else G(t)" and
               g=G and P=Hy in chop_interval,simp)
apply (cut_tac f = "%t. if t = Db then []
                      else if t = Da
                           then [last(G(Db)),
                                 %y i. if y = x & i = R then evalE(last(G(Db)), e) else last(G(Db), y, i)]
                           else if t < Da & Db < t then [last(G(Db))] else G(t)" and P = "high qy" and
               Q = "l [=] Real 0" and c = Db and d = Da in chop_eval,simp)
apply (cut_tac f="%t. if t = Da
                      then [last(G(Db)),
                            %y i. if y = x & i = R then evalE(last(G(Db)), e) else last(G(Db), y, i)]
                      else if t < Da & Db < t then [last(G(Db))] else G(t)" and
               P=qy and c=Db and d=Da in high_eval,auto)
apply (simp add: evalFP_def)
apply (subgoal_tac "evalPP(Px||Py, f, g, d) = (Skip, F, G, Da, Db) -->
             evalF(last(f(d)), px) --> evalF(last(g(d)), py) -->
             evalF(last(F(Da)), qx) & evalF(last(G(Db)), qy) & ievalF(F, Hx, d, Da) & ievalF(G, Hy, d, Db)",simp)
apply blast
(*start for the 2nd case "Db >= Da"*)
apply (simp add: chop_eval)
apply (cut_tac x=Db in exI,auto)
apply (cut_tac x="G(Db)" in exI,auto)
apply (cut_tac c=d and d=Db and f="%t. if t = Db then G(Db)
                      else if t = Db
                           then G(Db) @
                                [%y i. if y = x & i = R then evalE(last(G(Db)), e) else last(G(Db), y, i)]
                           else G(t)" and
               g=G and P=Hy in chop_interval,auto)
apply (subgoal_tac "evalPP(Px||Py, f, g, d) = (Skip, F, G, Da, Db) -->
             evalF(last(f(d)), px) --> evalF(last(g(d)), py) -->
             evalF(last(F(Da)), qx) & evalF(last(G(Db)), qy) & ievalF(F, Hx, d, Da) & ievalF(G, Hy, d, Db)",simp)
apply blast
apply (cut_tac f="%t. if t = Db
                      then [%y i. if y = x & i = R then evalE(last(G(Db)), e) else last(G(Db), y, i)]
                      else if t = Db
                           then G(Db) @
                                [%y i. if y = x & i = R then evalE(last(G(Db)), e) else last(G(Db), y, i)]
                           else G(t)" and P=qy and c=Db and d=Db in high_eval,auto)
(*For proving H, we first prove "(Hx[^] high (qx))"*)
apply (subgoal_tac "ievalF(f', Hx [^] high qx, d, d2)")
prefer 2
apply (cut_tac Px=Px and Py=Py and f=f and g=g and d=d and ch=ch and e=e and x=x and
               F=F and G=G and Da=Da and Db=Db and m=m and M=M in communicationR,auto)
(*start for the 1st case "Da < Db"*)
apply (cut_tac f = "%t. if Da < t & t <= Db then [last(F(Da))] else F(t)" and
               P = Hx and Q = "high qx" and c = d and d = Db in chop_eval1, auto)
apply (cut_tac x=Da in exI,auto)
apply (subgoal_tac "ievalF(%t. if Da < t & t <= Db then [last(F(Da))] else F(t), Hx, d, Da)
             = ievalF(F,Hx,d,Da)",simp)
apply (subgoal_tac "evalPP(Px||Py, f, g, d) = (Skip, F, G, Da, Db) -->
             evalF(last(f(d)), px) --> evalF(last(g(d)), py) -->
             evalF(last(F(Da)), qx) & evalF(last(G(Db)), qy) & ievalF(F, Hx, d, Da) & ievalF(G, Hy, d, Db)",simp)
apply blast
apply (cut_tac c=d and d=Da and f="%t. if Da < t & t <= Db then [last(F(Da))] else F(t)" and
               g=F and P=Hx in chop_interval,auto)
apply (cut_tac f="%t. if Da < t & t <= Db then [last(F(Da))] else F(t)" and P=qx and c=Da and d=Db in high_eval,auto)
apply (subgoal_tac "evalPP(Px||Py, f, g, d) = (Skip, F, G, Da, Db) -->
             evalF(last(f(d)), px) --> evalF(last(g(d)), py) -->
             evalF(last(F(Da)), qx) & evalF(last(G(Db)), qy) & ievalF(F, Hx, d, Da) & ievalF(G, Hy, d, Db)",simp)
prefer 2
apply blast
apply (simp add: evalFP_def)
(*start for the 2nd case "Db < Da"*)
apply (cut_tac f = F and P = Hx and Q = "high qx" and c = d and d = Da in chop_eval1, auto)
apply (cut_tac x=Da in exI,auto)
apply (subgoal_tac "evalPP(Px||Py, f, g, d) = (Skip, F, G, Da, Db) -->
             evalF(last(f(d)), px) --> evalF(last(g(d)), py) -->
             evalF(last(F(Da)), qx) & evalF(last(G(Db)), qy) & ievalF(F, Hx, d, Da) & ievalF(G, Hy, d, Db)",simp)
apply blast
apply (simp add: high_eval,auto)
(*start for the 2nd case "Db = Da"*)
apply (cut_tac f = F and P = Hx and Q = "high qx" and c = d and d = Da in chop_eval1, auto)
apply (cut_tac x=Da in exI,auto)
apply blast
apply (subgoal_tac "evalPP(Px||Py, f, g, d) = (Skip, F, G, Da, Db) -->
             evalF(last(f(d)), px) --> evalF(last(g(d)), py) -->
             evalF(last(F(Da)), qx) & evalF(last(G(Db)), qy) & ievalF(F, Hx, d, Da) & ievalF(G, Hy, d, Db)",simp)
prefer 2
apply blast
apply (cut_tac f=F and P=qx and c=Da and d=Da in high_eval,auto) (*end for Gx*)
(*start for H*)
apply (subgoal_tac "ievalF(g', Hy[^](l[=]Real 0), d, d2) | ievalF(f', Hx, d, d2)",auto)
apply (cut_tac Px=Px and Py=Py and f=f and g=g and d=d and ch=ch and e=e and x=x and
               F=F and G=G and Da=Da and Db=Db and m=m and M=M in communicationR,auto)
(*start for the 1st case Db < Da*)
apply (subgoal_tac "ievalF(F, Hx, d, Da)")
apply blast
apply (subgoal_tac "evalPP(Px||Py, f, g, d) = (Skip, F, G, Da, Db) -->
             evalF(last(f(d)), px) --> evalF(last(g(d)), py) -->
             evalF(last(F(Da)), qx) & evalF(last(G(Db)), qy) & ievalF(F, Hx, d, Da) & ievalF(G, Hy, d, Db)",simp)
apply blast
(*start for the 2nd case Db >= Da*)
apply (case_tac "d=Db",auto) (*2a*)
apply (simp add: chop_eval)
apply (cut_tac x=Db in exI,auto)
apply (cut_tac x="G(Db)" in exI,auto)
apply (cut_tac c=Db and d=Db and f="%t. if t = Db then G(Db)
                      else if t = Db
                           then G(Db) @
                                [%y i. if y = x & i = R then evalE(last(G(Db)), e) else last(G(Db), y, i)]
                           else G(t)" and
               g=G and P=Hy in chop_interval,auto)
apply (subgoal_tac "evalPP(Px||Py, f, g, Db) = (Skip, F, G, Da, Db) -->
             evalF(last(f(Db)), px) --> evalF(last(g(Db)), py) -->
             evalF(last(F(Da)), qx) & evalF(last(G(Db)), qy) & ievalF(F, Hx, Db, Da) & ievalF(G, Hy, Db, Db)",simp)
apply blast
apply (cut_tac L=0 in L_eval,auto) (*2b*)
apply (cut_tac f = "%t. if t = Db
                      then G(Db) @
                           [%y i. if y = x & i = R then evalE(last(G(Db)), e) else last(G(Db), y, i)]
                      else G(t)" and P = Hy and Q = "l [=] Real 0" and c = d and d = Db in chop_eval, auto)
apply (cut_tac x=Db in exI,auto)
apply (cut_tac x="G(Db)" in exI,auto)
apply (subgoal_tac "evalPP(Px||Py, f, g, d) = (Skip, F, G, Da, Db) -->
             evalF(last(f(d)), px) --> evalF(last(g(d)), py) -->
             evalF(last(F(Da)), qx) & evalF(last(G(Db)), qy) & ievalF(F, Hx, d, Da) & ievalF(G, Hy, d, Db)",simp)
prefer 2
apply blast
apply (cut_tac c=d and d=Db and f="%t. if t = Db then G(Db)
                      else if t = Db
                           then G(Db) @
                                [%y i. if y = x & i = R then evalE(last(G(Db)), e) else last(G(Db), y, i)]
                           else G(t)" and
               g=G and P=Hy in chop_interval,auto)
apply (cut_tac L=0 in L_eval,auto)
apply (cut_tac x=Db in exI,auto)
apply (cut_tac x="G(Db)" in exI,auto)
apply (subgoal_tac "evalPP(Px||Py, f, g, d) = (Skip, F, G, Da, Db) -->
             evalF(last(f(d)), px) --> evalF(last(g(d)), py) -->
             evalF(last(F(Da)), qx) & evalF(last(G(Db)), qy) & ievalF(F, Hx, d, Da) & ievalF(G, Hy, d, Db)",simp)
prefer 2
apply blast
apply (cut_tac c=d and d=Db and f="%t. if t = Db then G(Db)
                      else if t = Db
                           then G(Db) @
                                [%y i. if y = x & i = R then evalE(last(G(Db)), e) else last(G(Db), y, i)]
                           else G(t)" and
               g=G and P=Hy in chop_interval,auto)
apply (cut_tac L=0 in L_eval,auto)
done

(*soundness for 1st paralle rule*)
lemma Parallel1_sound: "ValidP px py Px Py qx qy Hx Hy
        --> Valid qx Qx rx Gx
        --> Valid qy Qy ry Gy
        --> ValidP px py (Px; m; Qx) (Py; M; Qy) rx ry (Hx [^] Gx) (Hy [^] Gy)"
apply (simp add: ValidP_def Valid_def)
apply auto
(*1st*)
apply (cut_tac Px=Px and Py=Py and Qx=Qx and Qy=Qy and f=f and g=g and d=d and f'=f' and
               g'=g' and d'=d1 and D'=d2 and f''=f'' and g''=g'' and d''=d'' and D''=D'' and
               m=m and M=M in parallelN2,auto)
apply (subgoal_tac "evalP(Qx, f'', d'') = (Skip, f', d1) --> evalF(last(f''(d'')), qx) --> evalF(last(f'(d1)), rx)")
apply blast
apply auto
(*2nd*)
apply (cut_tac Px=Px and Py=Py and Qx=Qx and Qy=Qy and f=f and g=g and d=d and f'=f' and
               g'=g' and d'=d1 and D'=d2 and f''=f'' and g''=g'' and d''=d'' and D''=D'' and
               m=m and M=M in parallelN2,auto)
apply (subgoal_tac "evalP(Qy, f'', d'') = (Skip, g', d2) --> evalF(last(f''(d'')), qy) --> evalF(last(g'(d2)), ry)")
apply blast
apply auto
(*3rd*)
apply (cut_tac Px=Px and Py=Py and Qx=Qx and Qy=Qy and f=f and g=g and d=d and f'=f' and
               g'=g' and d'=d1 and D'=d2 and f''=f'' and g''=g'' and d''=d'' and D''=D'' and
               m=m and M=M in parallelN2,auto)
apply (subgoal_tac "ievalF(f', Hx, d, d'') & ievalF(f', Gx, d'', d1)",auto)
apply (cut_tac f=f' and P=Hx and Q=Gx and c=d and d=d1 in chop_eval1,auto)
apply (subgoal_tac "evalPP(Px||Py, f, g, d) = (Skip, f'', g'', d'', D'') -->
             evalF(last(f(d)), px) --> evalF(last(g(d)), py) --> ievalF(f'', Hx, d, d'')")
apply blast
apply auto
apply (subgoal_tac "evalP(Qx, f'', d'') = (Skip, f', d1) -->
             evalF(last(f''(d'')), qx) --> evalF(last(f'(d1)), rx) & ievalF(f', Gx, d'', d1)")
apply blast
apply auto
(*4th*)
apply (cut_tac Px=Px and Py=Py and Qx=Qx and Qy=Qy and f=f and g=g and d=d and f'=f' and
               g'=g' and d'=d1 and D'=d2 and f''=f'' and g''=g'' and d''=d'' and D''=D'' and
               m=m and M=M and H=Hx and G=Hy in parallelN2,auto)
apply (subgoal_tac "ievalF(g', Hy, d, D'') & ievalF(g', Gy, D'', d2)",auto)
apply (cut_tac f=g' and P=Hy and Q=Gy and c=d and d=d2 in chop_eval1,auto)
apply (subgoal_tac "evalPP(Px||Py, f, g, d) = (Skip, f'', g'', d'', D'') -->
             evalF(last(f(d)), px) --> evalF(last(g(d)), py) --> ievalF(g'', Hy, d, D'')")
apply blast
apply auto
apply (subgoal_tac "evalP(Qy, g'', D'') = (Skip, g', d2) -->
             evalF(last(g''(D'')), qy) --> evalF(last(g'(d2)), ry) & ievalF(g', Gy, D'', d2)")
apply blast
apply auto
done

(*soundness for 2nd paralle rule*)
lemma Parallel2_sound: "Valid px Px qx Hx
        --> Valid py Py qy Hy
        --> ValidP px py Px Py qx qy Hx Hy"
apply (simp add: ValidP_def Valid_def)
apply auto
apply (cut_tac P=Px and Q=Py and d'="d1" and d''=d2 in parallelN1,auto)
apply (cut_tac P=Px and Q=Py and f=f and g=g and d=d and f'="f'" and g'=g'
           and d'="d1" and d''=d2 in parallelN1,auto)
apply (subgoal_tac "evalP(Py, g, d) = (Skip, g', d2) --> evalF(last(g(d)), py) --> evalF(last(g'(d2)), qy) & ievalF(g', Hy, d, d2)")
apply blast
apply auto
apply (cut_tac P=Px and Q=Py and d'="d1" and d''=d2 in parallelN1,auto)
apply (cut_tac P=Px and Q=Py and f=f and g=g and d=d and f'="f'" and g'=g'
           and d'="d1" and d''=d2 in parallelN1,auto)
apply (subgoal_tac "evalP(Py, g, d) = (Skip, g', d2) --> evalF(last(g(d)), py) --> evalF(last(g'(d2)), qy) & ievalF(g', Hy, d, d2)")
apply blast
apply auto
done

(*assists for proving the soundness of repetition rule*)
lemma Repetition_assist1: "[| ALL f1 d1 d2. ievalF(f1, Hx [^] Hx, d1, d2) --> ievalF(f1, Hx, d1, d2);
          ievalF(F(Suc(na)), l [=] Real 0 [|] Hx, D(0), D(na)) &
          ievalF(F(Suc(na)), l [=] Real 0 [|] Hx, D(na), D(Suc(na))) |]
            ==> ievalF(F(Suc(na)), l [=] Real 0 [|] Hx, D(0), D(Suc(na)))"
apply (simp add: Or_eval L_eval,auto)
apply (subgoal_tac "ievalF(F(Suc(na)), Hx [^] Hx, D(0), D(Suc(na))) --> ievalF(F(Suc(na)), Hx, D(0), D(Suc(na)))",auto)
apply (subgoal_tac "ievalF(F(Suc(na)), Hx [^] Hx, D(0), D(Suc(na)))",simp)
apply (rule chop_eval1,auto)
done

(*soundness for repetition rule*)
lemma Repetition_sound: "Valid px Px px Hx
        --> (ALL f1 d1 d2. ievalF (f1,(Hx [^] Hx [-->] Hx),d1,d2))
        --> Valid px (Px*) px ((l [=] Real 0) [|] Hx)"
apply (simp add: Imply_eval)
apply (unfold Valid_def,auto)
(*1st*)
apply (cut_tac P = Px and f = f and d = d and f' = "f'" and d' = "d'" and F=F and D=D and
               H = "l [=] Real 0 [|] Hx" in repetition,auto)
apply (subgoal_tac "(ALL k<n. evalP(Px, F(k), D(k)) = (Skip, F(Suc(k)), D(Suc(k)))) --> evalF(last(F(n)(D(n))), px)")
apply blast
apply (induct_tac n,auto)
(*2nd*)
apply (cut_tac P = Px and f = f and d = d and f' = "f'" and d' = "d'" and F=F and D=D and
               H = "l [=] Real 0 [|] Hx" in repetition,auto)
apply (subgoal_tac "(ALL k<n. evalP(Px, F(k), D(k)) = (Skip, F(Suc(k)), D(Suc(k))) &
                    (ievalF(F(k), l [=] Real 0 [|] Hx, D(0), D(k)) -->
                    ievalF(F(Suc(k)), l [=] Real 0 [|] Hx, D(0), D(k))))
                      --> evalF(last(F(n)(D(n))), px) & ievalF(F(n), l [=] Real 0 [|] Hx, D(0), D(n))")
apply blast
apply (induct_tac n,auto)
apply (simp add: Or_eval,auto)
apply (cut_tac f="F(0)" and L=0 and c="D(0)" and d="D(0)" in L_eval,auto)
apply (subgoal_tac "ievalF(F(Suc(na)), l [=] Real 0 [|] Hx, D(0), D(na)) &
               ievalF(F(Suc(na)), l [=] Real 0 [|] Hx, D(na), D(Suc(na)))")
apply (rule Repetition_assist1,auto)
apply (subgoal_tac "ievalF(F(Suc(na)), Hx, D(na), D(Suc(na)))")
apply (cut_tac f="F(Suc(na))" and F="l [=] Real 0" and G="Hx" and c="D(na)" and d="D(Suc(na))" in Or_eval,auto)
done

end


theory test1
imports Main
begin

context comm_monoid_add
begin

sublocale bigvee: comm_monoid_set HOL.disj False
  defines bigvee = bigvee.F and bigvee' = bigvee.G
  by standard auto

abbreviation bigvee'' :: \<open>bool set \<Rightarrow> bool\<close> ("\<Or>")
  where "\<Or> \<equiv> bigvee (\<lambda>x. x)"

sublocale bigwedge: comm_monoid_set HOL.conj True
  defines bigwedge = bigwedge.F and bigwedge' = bigwedge.G
  by standard auto

abbreviation bigwedge'' :: \<open>bool set \<Rightarrow> bool\<close> ("\<And>")
  where "\<And> \<equiv> bigwedge (\<lambda>x. x)"

end
syntax
  "_bigwedge" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b::comm_monoid_add"  ("(2\<And>(_/\<in>_)./ _)" [0, 51, 10] 10)
translations \<comment> \<open>Beware of argument permutation!\<close>
  "\<And>i\<in>A. b" \<rightleftharpoons> "CONST bigwedge (\<lambda>i. b) A"

syntax
  "_bigvee" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b::comm_monoid_add"  ("(2\<Or>(_/\<in>_)./ _)" [0, 51, 10] 10)
translations \<comment> \<open>Beware of argument permutation!\<close>
  "\<Or>i\<in>A. b" \<rightleftharpoons> "CONST bigvee (\<lambda>i. b) A"

instantiation bool :: comm_monoid_add
begin
definition zero_bool where
[simp]: \<open>zero_bool = False\<close>
definition plus_bool where
[simp]: \<open>plus_bool = (\<or>)\<close>
instance
  by standard auto
end
thm bigvee_def

lemma \<open>finite A \<Longrightarrow> (\<Or>i\<in>A. f i) \<longleftrightarrow> (\<exists>i \<in> A. f i)\<close>
  apply (induction rule: finite_induct)
  apply (auto simp: )
  done

lemma \<open>finite A \<Longrightarrow> (\<And>i\<in>A. f i) \<longleftrightarrow> A = {} \<or> (\<forall>i \<in> A. f i)\<close>
  apply (induction rule: finite_induct)
  apply (auto simp: )
  done

lemma \<open>infinite A \<Longrightarrow> (\<And>i\<in>A. f i) \<longleftrightarrow> True\<close>
  by auto
(*
lemma test1:
  \<open>(\<And>j\<in>L. \<And>u\<in>U. \<And>t\<in>T. \<And>l\<in>L. \<And>l\<^sub>1\<in>L\<^sub>1. \<not>P j u t l\<^sub>1) \<or>
   (\<Or>i\<in>I. \<Or>v\<in>V. \<And>k\<in>K. \<Or>h\<in>H. Q i \<or> k h) \<Longrightarrow>
   (\<Or>i\<in>I. \<Or>v\<in>V. \<And>k\<in>K. \<Or>h\<in>H. Q i \<or> k h) \<or> (\<And>j\<in>J. \<And>u\<in>U. \<And>t\<in>T. \<And>l\<^sub>1\<in>L\<^sub>1. \<not>P j u t l\<^sub>1)\<close>
  apply auto
*)
theorem test2:
\<open>((\<And>l\<in>L.\<And>j\<in>L.\<And>u\<in>U.\<And>t\<in>T. \<not>P j u t l) \<or> (\<Or>h\<in>H.\<Or>i\<in>I.\<Or>v\<in>V.\<And>k\<in>K. (Q i v k h \<and> (\<And>h\<^sub>1\<in>H\<^sub>1. \<not>Q i v k h\<^sub>1))))
\<and> (\<Or>l\<in>L.\<Or>h\<in>H.((\<And>j\<in>L.\<And>u\<in>U.\<And>t\<in>T.\<And>l\<^sub>1\<in>L\<^sub>1. \<not>P j u t l\<^sub>1) \<and> (\<Or>i\<in>I.\<Or>v\<in>V.\<And>k\<in>K.\<And>h\<^sub>1\<in>H\<^sub>1. \<not>Q i v k h\<^sub>1)))
\<Longrightarrow> \<Or>l\<in>L.\<Or>h\<in>H.(\<And>j\<in>L.\<And>u\<in>U.\<And>t\<in>T.( P j u t l \<longrightarrow> (\<Or>i\<in>I.\<Or>v\<in>V.\<And>k\<in>K. Q i v k h)) \<and> (\<And>l\<^sub>1\<in>L\<^sub>1. \<not>P j u t l\<^sub>1) \<and> (\<Or>i\<in>I.\<Or>v\<in>V.\<And>k\<in>K.\<And>h\<^sub>1\<in>H\<^sub>1. \<not>Q i v k h\<^sub>1))\<close>
using [[simp_trace]]
  apply auto


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_ISortCount
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun insert :: "int => int list => int list" where
"insert x (nil2) = cons2 x (nil2)"
| "insert x (cons2 z xs) =
     (if x <= z then cons2 x (cons2 z xs) else cons2 z (insert x xs))"

fun isort :: "int list => int list" where
"isort (nil2) = nil2"
| "isort (cons2 y xs) = insert y (isort xs)"

fun count :: "'a => 'a list => int" where
"count x (nil2) = 0"
| "count x (cons2 z ys) =
     (if (x = z) then 1 + (count x ys) else count x ys)"

theorem property0 :
  "((count x (isort xs)) = (count x xs))"
  oops

end


(*<*)(*:maxLineLen=68:*)
theory dAutomaton_comp
  imports dAutomaton_causal (*SPF_comp*)
begin
(*>*)
section \<open>Automaton Composition\<close>

subsection \<open>Composition of strong automatons\<close>

subsubsection \<open>Definition\<close>

(*TODO?:'incomp = ('in1 \<union> 'in2), 'outcomp = ('out1 \<union> 'out2),'buf = ('out1 \<union> 'out2) - ('in1 \<union> 'in2)*)

fun compTransition::"('s1::type \<Rightarrow> 'in1\<^sup>\<surd> \<Rightarrow> ('s1 \<times> 'out1\<^sup>\<surd>)) \<Rightarrow> ('s2::type \<Rightarrow> 'in2\<^sup>\<surd> \<Rightarrow> ('s2 \<times> 'out2\<^sup>\<surd>)) \<Rightarrow> (('s1\<times>'s2 \<times>'buf\<^sup>\<surd>) \<Rightarrow> 'incomp\<^sup>\<surd> \<Rightarrow> (('s1\<times>'s2 \<times>'buf\<^sup>\<surd>) \<times> 'outcomp\<^sup>\<surd>))"where
"compTransition t1 t2 (s1,s2,buf) sbe = (let (s1o,sbe1o) = (t1 s1 (sbeUnion sbe buf));
                                             (s2o,sbe2o) = (t2 s2 (sbeUnion sbe buf))  in
                                        ((s1o,s2o, sbeUnion sbe1o sbe2o), sbeUnion sbe1o sbe2o))"
text\<open>The function @{term compTransition} maps two Transitoinfunctions to there equivalent composed
     Transitionfunction.\<close>

(*TODO:'incomp = ('in1 \<union> 'in2), 'outcomp = ('out1 \<union> 'out2), 'buf = ('out1 \<union> 'out2) - ('in1 \<union> 'in2)*)
definition daComp::"('s1::type,'in1,'out1)dAutomaton_strong \<Rightarrow> ('s2::type,'in2,'out2)dAutomaton_strong \<Rightarrow> (('s1\<times>'s2\<times>'buf\<^sup>\<surd>),'incomp,'outcomp)dAutomaton_strong" where
"daComp \<equiv> \<lambda>aut1 aut2. (| dawTransition = compTransition (dawTransition aut1) (dawTransition aut2),
                        dawInitState =((dawInitState aut1),(dawInitState aut2), sbeUnion (dasInitOut aut1)(dasInitOut aut2)),
                        dasInitOut = sbeUnion(dasInitOut aut1) (dasInitOut aut2) |)"
text\<open>@{term daComp} composes two strong automatons. The State of the composed automaton has an
     \<open>sbElem\<close> as a buffer. The buffer contains all elements on the internal channels of the
     automatons.\<close>

subsubsection\<open>Strong composition lemmas \<close>

lemma final_eval_autcomp:"semantik_strong(daComp aut1 aut2) \<sqsubseteq> spfcomp_s\<cdot>(semantik_strong aut1)\<cdot>(semantik_strong aut2)"
  oops

(*TODO: something else than Rep_spfs_fun\<cdot>(semantik_strong..) *)
lemma final_eval_autcomp_eq:assumes "sbLen sb = \<infinity>"
                            shows"(Rep_spfs_fun\<cdot>(semantik_strong(daComp aut1 aut2)))\<cdot>sb
                                  = Rep_spfs_fun\<cdot>((spfcomp_s\<cdot>(semantik_strong aut1))\<cdot>(semantik_strong aut2))\<cdot>sb"
  oops

(*<*)
end
(*>*)


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_60
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
"x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun last :: "Nat list => Nat" where
"last (nil2) = Z"
| "last (cons2 z (nil2)) = z"
| "last (cons2 z (cons2 x2 x3)) = last (cons2 x2 x3)"

theorem property0 :
  "((case ys of
         nil2 => True
         | cons2 y z => False) ==>
      ((last (x xs ys)) = (last ys)))"nitpick
  oops

end


theory IICF_List
imports
  "../../Sepref"
  "List-Index.List_Index"
begin

lemma param_index[param]:
  "\<lbrakk>single_valued A; single_valued (A\<inverse>)\<rbrakk> \<Longrightarrow> (index,index) \<in> \<langle>A\<rangle>list_rel \<rightarrow> A \<rightarrow> nat_rel"
  unfolding index_def[abs_def] find_index_def
  apply (subgoal_tac "(((=), (=)) \<in> A \<rightarrow> A \<rightarrow> bool_rel)")
  apply parametricity
  by (simp add: pres_eq_iff_svb)

(* TODO: Move? *)
subsection \<open>Swap two elements of a list, by index\<close>

definition "swap l i j \<equiv> l[i := l!j, j:=l!i]"
lemma swap_nth[simp]: "\<lbrakk>i < length l; j<length l; k<length l\<rbrakk> \<Longrightarrow>
  swap l i j!k = (
    if k=i then l!j
    else if k=j then l!i
    else l!k
  )"
  unfolding swap_def
  by auto

lemma swap_set[simp]: "\<lbrakk> i < length l; j<length l \<rbrakk> \<Longrightarrow> set (swap l i j) = set l"
  unfolding swap_def
  by auto

lemma swap_multiset[simp]: "\<lbrakk> i < length l; j<length l \<rbrakk> \<Longrightarrow> mset (swap l i j) = mset l"
  unfolding swap_def
  by (auto simp: mset_swap)

lemma swap_length[simp]: "length (swap l i j) = length l"
  unfolding swap_def
  by auto

lemma swap_same[simp]: "swap l i i = l"
  unfolding swap_def by auto

lemma distinct_swap[simp]:
  "\<lbrakk>i<length l; j<length l\<rbrakk> \<Longrightarrow> distinct (swap l i j) = distinct l"
  unfolding swap_def
  by auto

lemma map_swap: "\<lbrakk>i<length l; j<length l\<rbrakk>
  \<Longrightarrow> map f (swap l i j) = swap (map f l) i j"
  unfolding swap_def
  by (auto simp add: map_update)

lemma swap_param[param]: "\<lbrakk> i<length l; j<length l; (l',l)\<in>\<langle>A\<rangle>list_rel; (i',i)\<in>nat_rel; (j',j)\<in>nat_rel\<rbrakk>
  \<Longrightarrow> (swap l' i' j', swap l i j)\<in>\<langle>A\<rangle>list_rel"
  unfolding swap_def
  by parametricity

lemma swap_param_fref: "(uncurry2 swap,uncurry2 swap) \<in>
  [\<lambda>((l,i),j). i<length l \<and> j<length l]\<^sub>f (\<langle>A\<rangle>list_rel \<times>\<^sub>r nat_rel) \<times>\<^sub>r nat_rel \<rightarrow> \<langle>A\<rangle>list_rel"
  apply rule apply clarsimp
  unfolding swap_def
  apply parametricity
  by simp_all

lemma param_list_null[param]: "(List.null,List.null) \<in> \<langle>A\<rangle>list_rel \<rightarrow> bool_rel"
proof -
  have 1: "List.null = (\<lambda>[] \<Rightarrow> True | _ \<Rightarrow> False)"
    apply (rule ext) subgoal for l by (cases l) (auto simp: List.null_def)
    done
  show ?thesis unfolding 1 by parametricity
qed

subsection \<open>Operations\<close>

sepref_decl_op list_empty: "[]" :: "\<langle>A\<rangle>list_rel" .
context notes [simp] = eq_Nil_null begin
  sepref_decl_op list_is_empty: "\<lambda>l. l=[]" :: "\<langle>A\<rangle>list_rel \<rightarrow>\<^sub>f bool_rel" .
end
sepref_decl_op list_replicate: replicate :: "nat_rel \<rightarrow> A \<rightarrow> \<langle>A\<rangle>list_rel" .
definition op_list_copy :: "'a list \<Rightarrow> 'a list" where [simp]:  "op_list_copy l \<equiv> l"
sepref_decl_op (no_def) list_copy: "op_list_copy" :: "\<langle>A\<rangle>list_rel \<rightarrow> \<langle>A\<rangle>list_rel" .
sepref_decl_op list_prepend: "(#)" :: "A \<rightarrow> \<langle>A\<rangle>list_rel \<rightarrow> \<langle>A\<rangle>list_rel" .
sepref_decl_op list_append: "\<lambda>xs x. xs@[x]" :: "\<langle>A\<rangle>list_rel \<rightarrow> A \<rightarrow> \<langle>A\<rangle>list_rel" .
sepref_decl_op list_concat: "(@)" :: "\<langle>A\<rangle>list_rel \<rightarrow> \<langle>A\<rangle>list_rel \<rightarrow> \<langle>A\<rangle>list_rel" .
sepref_decl_op list_length: length :: "\<langle>A\<rangle>list_rel \<rightarrow> nat_rel" .
sepref_decl_op list_get: nth :: "[\<lambda>(l,i). i<length l]\<^sub>f \<langle>A\<rangle>list_rel \<times>\<^sub>r nat_rel \<rightarrow> A" .
sepref_decl_op list_set: list_update :: "[\<lambda>((l,i),_). i<length l]\<^sub>f (\<langle>A\<rangle>list_rel \<times>\<^sub>r nat_rel) \<times>\<^sub>r A \<rightarrow> \<langle>A\<rangle>list_rel" .
context notes [simp] = eq_Nil_null begin
  sepref_decl_op list_hd: hd :: "[\<lambda>l. l\<noteq>[]]\<^sub>f \<langle>A\<rangle>list_rel \<rightarrow> A" .
  sepref_decl_op list_tl: tl :: "[\<lambda>l. l\<noteq>[]]\<^sub>f \<langle>A\<rangle>list_rel \<rightarrow> \<langle>A\<rangle>list_rel" .
  sepref_decl_op list_last: last :: "[\<lambda>l. l\<noteq>[]]\<^sub>f \<langle>A\<rangle>list_rel \<rightarrow> A" .
  sepref_decl_op list_butlast: butlast :: "[\<lambda>l. l\<noteq>[]]\<^sub>f \<langle>A\<rangle>list_rel \<rightarrow> \<langle>A\<rangle>list_rel" .
end
sepref_decl_op list_contains: "\<lambda>x l. x\<in>set l" :: "A \<rightarrow> \<langle>A\<rangle>list_rel \<rightarrow> bool_rel"
  where "single_valued A" "single_valued (A\<inverse>)" .
sepref_decl_op list_swap: swap :: "[\<lambda>((l,i),j). i<length l \<and> j<length l]\<^sub>f (\<langle>A\<rangle>list_rel \<times>\<^sub>r nat_rel) \<times>\<^sub>r nat_rel \<rightarrow> \<langle>A\<rangle>list_rel" .
sepref_decl_op list_rotate1: rotate1 :: "\<langle>A\<rangle>list_rel \<rightarrow> \<langle>A\<rangle>list_rel" .
sepref_decl_op list_rev: rev :: "\<langle>A\<rangle>list_rel \<rightarrow> \<langle>A\<rangle>list_rel" .
sepref_decl_op list_index: index :: "\<langle>A\<rangle>list_rel \<rightarrow> A \<rightarrow> nat_rel"
  where "single_valued A" "single_valued (A\<inverse>)" .

subsection \<open>Patterns\<close>

text \<open>Standard preconditions are preserved by list-relation. These lemmas are used for
  simplification of preconditions after composition.\<close>
lemma list_rel_pres_neq_nil[fcomp_prenorm_simps]: "(x',x)\<in>\<langle>A\<rangle>list_rel \<Longrightarrow> x'\<noteq>[] \<longleftrightarrow> x\<noteq>[]" by auto
lemma list_rel_pres_length[fcomp_prenorm_simps]: "(x',x)\<in>\<langle>A\<rangle>list_rel \<Longrightarrow> length x' = length x" by (rule list_rel_imp_same_length)

locale list_custom_empty =
  fixes rel empty and op_custom_empty :: "'a list"
  assumes customize_hnr_aux: "(uncurry0 empty,uncurry0 (RETURN (op_list_empty::'a list))) \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a rel"
  assumes op_custom_empty_def: "op_custom_empty = op_list_empty"
begin
  sepref_register op_custom_empty :: "'c list"

  lemma fold_custom_empty:
    "[] = op_custom_empty"
    "op_list_empty = op_custom_empty"
    "mop_list_empty = RETURN op_custom_empty"
    unfolding op_custom_empty_def by simp_all

  lemmas custom_hnr[sepref_fr_rules] = customize_hnr_aux[folded op_custom_empty_def]
end

lemma gen_mop_list_swap: "mop_list_swap l i j = do {
    xi \<leftarrow> mop_list_get l i;
    xj \<leftarrow> mop_list_get l j;
    l \<leftarrow> mop_list_set l i xj;
    l \<leftarrow> mop_list_set l j xi;
    RETURN l
  }"
  unfolding mop_list_swap_def
  by (auto simp: pw_eq_iff refine_pw_simps swap_def)

end