(*
 * Copyright 2016, NTU
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * Author: Zhe Hou.
 *)

text {* Miscellaneous definitions. *}
theory Misc
  imports Main
begin

text {* Some utility functions and lemmas. *}

lemma list_mem_range: "List.member l e \<Longrightarrow> \<exists>i. (0 \<le> i \<and> i < List.length l \<and> (l!i) = e)"
  by (meson in_set_conv_nth in_set_member not_le not_less0)

lemma list_mem_range_rev: "\<exists>i. (0 \<le> i \<and> i < List.length l \<and> (l!i) = e) \<Longrightarrow>
  List.member l e"
  by (meson List.member_def nth_mem)

text {* Test if x is before y in the list l. *}

definition list_before:: "'a \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> bool" where
"list_before x l y \<equiv> \<exists>i j. 0 \<le> i \<and> i < length l \<and> 0 \<le> j \<and> j < length l \<and>
  (l!i) = x \<and> (l!j) = y \<and> i < j"

value "{1::nat,2,3,4}"

text {* A  version of list_before for code export. *}

text {* Given a list l and a member e, return the sublist l' of l
after the first occurrence of e. *}

primrec sublist_after:: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"sublist_after e [] = []"
|"sublist_after e (x#t) = (if e = x then t else sublist_after e t)"

definition list_before2:: "'a \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> bool" where
"list_before2 x l y \<equiv> List.member (sublist_after x l) y"

definition list_before3:: "'a \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> bool" where
"list_before3 x l y \<equiv> length (takeWhile (\<lambda>e. e\<noteq>x) l) \<noteq> length l \<and>
                       List.member (drop ((length (takeWhile (\<lambda>e. e\<noteq>x) l)) + 1) l) y "

lemma all_drop_eq:
assumes a0:"n\<le>j" and
        a1:"j<length l"
      shows "l!j = (drop n l)!(j-n)"
  using a0 a1 by (simp add: a0 less_or_eq_imp_le)

lemma length_take_while:"i<length l \<Longrightarrow>
       Suc (length (takeWhile (\<lambda>e. e \<noteq> l ! i) l)) \<le> (i + 1)"
  by (metis (full_types) Suc_eq_plus1_left add.commute nat_add_left_cancel_less not_le_imp_less
            nth_mem set_takeWhileD takeWhile_nth)

lemma suc_length_take_while_less_j:
 assumes a0: "j < length l" and
     a1:"x = l ! i" and
     a2:"i < j" and a3:"y = l ! j"
   shows "Suc (length (takeWhile (\<lambda>e. e \<noteq> l ! i) l))\<le>j"
proof-
  have i_l:"i< length l" using a0 a2 by auto
  thus ?thesis using a2 length_take_while[OF i_l] by auto
qed

lemma list_before_code1:
  assumes a0:"length (takeWhile (\<lambda>e. e \<noteq> x) l) \<noteq> length l" and
         a1: "List.member (drop (Suc (length (takeWhile (\<lambda>e. e \<noteq> x) l))) l) y"
  shows "\<exists>i<length l. \<exists>j<length l. l ! i = x \<and> l ! j = y \<and> i < j"
proof-
  have len_take_while:"length (takeWhile (\<lambda>e. e \<noteq> x) l) < length l"
    using a0
    by (simp add: le_neq_implies_less length_takeWhile_le)
  then have "l!(length (takeWhile (\<lambda>e. e \<noteq> x) l)) = x"
    using nth_length_takeWhile by auto
  moreover obtain j where j:"l!j = y \<and> j< length l \<and> length (takeWhile (\<lambda>e. e \<noteq> x) l)< j "
    using a1 len_take_while calculation
    by (smt Suc_leI le_add_diff_inverse length_drop lessI less_imp_le_nat list_mem_range
            nat_add_left_cancel_less nth_drop trans_less_add1)
   ultimately show ?thesis  using len_take_while by fastforce
qed

lemma list_before_code2:"j < length l \<Longrightarrow>
       x = l ! i \<Longrightarrow> i < j \<Longrightarrow> y = l ! j \<Longrightarrow>
       length (takeWhile (\<lambda>e. e \<noteq> l ! i) l) = length l \<Longrightarrow> False"
  by (metis (full_types) dual_order.strict_trans nth_equalityI
        nth_mem takeWhile_eq_all_conv takeWhile_nth)

lemma list_before_code3:
 assumes a0:"j < length l" and
    a1:"x = l ! i" and
    a2:"i < j" and a3:"y = l ! j"
   shows "List.member (drop (Suc (length (takeWhile (\<lambda>e. e \<noteq> l ! i) l))) l) (l ! j)"
proof-
  have f1:"Suc (length (takeWhile (\<lambda>e. e \<noteq> l ! i) l))\<le>j"
    using suc_length_take_while_less_j[OF a0 a1 a2 a3] by auto
  thus ?thesis using a0 all_drop_eq[OF f1 a0]
    by (metis diff_less_mono length_drop member_def nth_mem)
qed

lemma list_before_code_equal: "list_before3 x l y = list_before x l y"
  unfolding list_before3_def list_before_def
    by (auto elim: list_before_code1 list_before_code2 list_before_code3 )

(*
lemma sublist_after_emp: "\<not> (List.member l x) \<Longrightarrow> sublist_after x l = []"
proof (induction l)
  case Nil
  then show ?case
    by simp
next
  case (Cons a l)
  then show ?case
    proof (cases "x = a")
      case True
      then have "List.member (a#l) x"
        by (simp add: member_rec(1))
      then show ?thesis
        using Cons by auto
    next
      case False
      then have "sublist_after x (a # l) = sublist_after x l"
        by simp
      then show ?thesis
        using Cons
        by (simp add: member_rec(1))
    qed
  qed

lemma sublist_after_mem: "List.member l x \<Longrightarrow> sublist_after x (l@l') = (sublist_after x l)@l'"
proof (induction l)
  case Nil
  then show ?case
    by (simp add: member_rec(2))
next
  case (Cons a l)
  then show ?case
  proof (cases "a = x")
    case True
    then have "sublist_after x ((a # l) @ l') = l@l'"
      by simp
    from True have "sublist_after x (a # l) @ l' = l@l'"
      by simp
    then show ?thesis
      using Cons
      using \<open>sublist_after x ((a # l) @ l') = l @ l'\<close> by auto
  next
    case False
    then have f1: "sublist_after x ((a # l) @ l') = sublist_after x (l @ l')"
      by auto
    from False have f2: "sublist_after x (a # l) @ l' = sublist_after x l @ l'"
      by auto
    from Cons(2) False have f3: "List.member l x"
      by (simp add: member_rec(1))
    from Cons f1 f2 f3 show ?thesis
      by auto
  qed
qed

lemma sublist_after_extend: "List.member (sublist_after x l) y \<Longrightarrow>
  List.member (sublist_after x l@l') y"
proof (induction l' rule: rev_induct)
  case Nil
  then show ?case
    by simp
next
  case (snoc w ws)
  then have f1: "List.member (sublist_after x l @ ws) y"
    by auto
  then have f1_1: "List.member ((sublist_after x l @ ws)@[w]) y"
    by (metis UnCI in_set_member set_append)
  from snoc(2) have f2: "List.member l x"
    using member_rec(2) sublist_after_emp by fastforce
  from f1_1 f2 show ?case
    using sublist_after_mem by auto
qed

lemma sublist_after_extend2: "List.member (sublist_after x l) y \<Longrightarrow>
  List.member (sublist_after x (l@l')) y"
proof (induction l' rule: rev_induct)
  case Nil
  then show ?case
    by simp
next
  case (snoc w ws)
  then have f1: "List.member (sublist_after x (l @ ws)) y"
    by auto
  then have f1_1: "List.member ((sublist_after x (l @ ws))@[w]) y"
    by (metis UnCI in_set_member set_append)
  from snoc(2) have f2: "List.member l x"
    using member_rec(2) sublist_after_emp by fastforce
  from f1_1 f2 show ?case
    by (simp add: sublist_after_mem)
qed

lemma list_before2_extend: "list_before2 e1 l e2 \<Longrightarrow> list_before2 e1 (l@l') e2"
  unfolding list_before2_def
  by (simp add: sublist_after_extend2)
*)

lemma list_before_extend: "list_before e1 l e2 \<Longrightarrow> list_before e1 (l@l') e2"
proof -
  assume a1: "list_before e1 l e2"
  obtain nn :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> nat" and nna :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> nat" where
    "\<forall>x0 x1 x2. (\<exists>v3 v4. 0 \<le> v3 \<and> v3 < length x1 \<and> 0 \<le> v4 \<and> v4 < length x1 \<and> x1 ! v3 = x2 \<and> x1 ! v4 = x0 \<and> v3 < v4) = (0 \<le> nn x0 x1 x2 \<and> nn x0 x1 x2 < length x1 \<and> 0 \<le> nna x0 x1 x2 \<and> nna x0 x1 x2 < length x1 \<and> x1 ! nn x0 x1 x2 = x2 \<and> x1 ! nna x0 x1 x2 = x0 \<and> nn x0 x1 x2 < nna x0 x1 x2)"
  by moura
  then have f2: "\<forall>a as aa. (\<not> list_before a as aa \<or> 0 \<le> nn aa as a \<and> nn aa as a < length as \<and> 0 \<le> nna aa as a \<and> nna aa as a < length as \<and> as ! nn aa as a = a \<and> as ! nna aa as a = aa \<and> nn aa as a < nna aa as a) \<and> (list_before a as aa \<or> (\<forall>n na. \<not> 0 \<le> n \<or> \<not> n < length as \<or> \<not> 0 \<le> na \<or> \<not> na < length as \<or> as ! n \<noteq> a \<or> as ! na \<noteq> aa \<or> \<not> n < na))"
    by (meson list_before_def)
  then have f3: "0 \<le> nn e2 l e1 \<and> nn e2 l e1 < length l \<and> 0 \<le> nna e2 l e1 \<and> nna e2 l e1 < length l \<and> l ! nn e2 l e1 = e1 \<and> l ! nna e2 l e1 = e2 \<and> nn e2 l e1 < nna e2 l e1"
    using a1 by presburger
  then have f4: "nn e2 l e1 < length (l @ l')"
    by simp
    have f5: "nna e2 l e1 < length (l @ l')"
      using f3 by simp
    have f6: "(l @ l') ! nn e2 l e1 = e1"
      using f3 by (simp add: nth_append)
    have "(l @ l') ! nna e2 l e1 = e2"
      using f3 by (metis nth_append)
  then show ?thesis
    using f6 f5 f4 f3 f2 by meson
qed

lemma list_before_extend2:
  assumes a1: "List.member l e1"
  and a2: "\<not>(List.member l e2)"
  and a3: "List.member (l@l') e2"
shows "list_before e1 (l@l') e2"
proof -
  from a1 obtain i where f1: "i < length l \<and> (l!i) = e1"
    by (meson list_mem_range)
  from a2 have f2: "\<not>(\<exists>k. k < length l \<and> (l!k) = e2)"
    by (meson in_set_member nth_mem)
  then have f3: "\<not>(\<exists>k. k < length l \<and> ((l@l')!k) = e2)"
    by (metis nth_append)
  from a3 obtain j where f4: "j < length (l@l') \<and> ((l@l')!j) = e2"
    by (meson list_mem_range)
  from f3 f4 have f5: "j \<ge> length l"
    using not_le by blast
  from f1 have f6: "i < length l \<and> ((l@l')!i) = e1"
    by (simp add: nth_append)
  show ?thesis unfolding list_before_def using f4 f5 f6
    by (metis (no_types, lifting) dual_order.strict_trans le0 less_le_trans)
qed

lemma list_before_extend2':
  assumes a1: "List.member l e1"
  and a2: "List.member l' e2"
shows "list_before e1 (l@l') e2"
proof -
  from a1 obtain i where  f0:"i < length l \<and> (l!i) = e1"
    by (meson list_mem_range)
  then have f1:"i<length l + length l' \<and> (l @ l') ! i = e1"
    by (meson nth_append trans_less_add1 list_mem_range)
  from a2 obtain j where f2: "j < length l' \<and> (l'!j) = e2"
    by (meson list_mem_range)
  then have "j+length l < length l + length l'" by auto
  moreover have "(l @ l') ! (j+length l) = e2" using f2
    by (metis add.commute nth_append_length_plus)
  moreover have "i<(j+length l)" using f1
    by (simp add: f0 trans_less_add2)
  ultimately show ?thesis using f1 unfolding list_before_def
    by (metis length_append less_eq_nat.simps(1))
qed

lemma list_elements_before: "List.member l e1 \<Longrightarrow> List.member l e2 \<Longrightarrow>  e1 \<noteq> e2 \<Longrightarrow>
  list_before e1 l e2 \<or> list_before e2 l e1"
  apply auto
  unfolding list_before_def apply simp
  using list_mem_range
  by (metis linorder_neqE_nat)

lemma dist_elem_not_before: "List.member l e1 \<Longrightarrow> List.member l e2 \<Longrightarrow> e1 \<noteq> e2
  \<Longrightarrow> \<not> (list_before e1 l e2) \<Longrightarrow> list_before e2 l e1"
  using list_elements_before by fastforce

text {* Define a list without repeating members. *}

(*
definition non_repeat_list:: "'a list \<Rightarrow> bool" where
"non_repeat_list l \<equiv>
  \<forall>i j. (0 \<le> i \<and> i < List.length l \<and> 0 \<le> j \<and> j < List.length l \<and> i \<noteq> j) \<longrightarrow>
        (l!i \<noteq> l!j)"
*)

definition non_repeat_list:: "'a list \<Rightarrow> bool" where
"non_repeat_list l \<equiv> distinct l"

text {* Get the position of a member in a non-repeating list. *}

definition non_repeat_list_pos:: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
"non_repeat_list_pos x l \<equiv> THE n. non_repeat_list l \<and> n < length l \<and> (l!n) = x"

text {* A new version of non_repeat_list_post that is used to code export. *}

primrec non_repeat_list_pos2:: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
"non_repeat_list_pos2 x [] = 0"
|"non_repeat_list_pos2 x (a#al) = (if x = a then 0 else 1 + (non_repeat_list_pos2 x al))"

(* Zhe: non_repeat_list_pos2 and non_repeat_list_pos are actually different when
x is not in l! I'm not sure what value would non_repeat_list_pos return when
x is not in l. *)
lemma non_repeat_list_code_equal: "non_repeat_list_pos2 x l = non_repeat_list_pos x l"
sorry

lemma non_repeat_list_emp: "non_repeat_list []"
  unfolding non_repeat_list_def
  by auto

lemma non_repeat_list_pos_rel: "non_repeat_list l \<Longrightarrow> List.member l x \<Longrightarrow> List.member l y \<Longrightarrow>
 x \<noteq> y \<Longrightarrow> list_before x l y \<or> list_before y l x"
  unfolding non_repeat_list_def list_before_def
  by (metis le_neq_implies_less list_mem_range not_le)

(*
  apply auto
  by (metis in_set_conv_nth member_def nat_neq_iff)
*)

lemma non_repeat_list_extend: "non_repeat_list l \<Longrightarrow> \<not> (List.member l x) \<Longrightarrow>
 non_repeat_list (l@[x])"
  using non_repeat_list_def
  by (simp add: member_def non_repeat_list_def)

(*
proof (auto simp add: non_repeat_list_def)
  fix i :: nat and j :: nat
  assume a1: "\<not> List.member l x"
  assume a2: "i \<noteq> j"
  assume a3: "i < Suc (length l)"
  assume a4: "j < Suc (length l)"
  assume a5: "(l @ [x]) ! i = (l @ [x]) ! j"
  assume a6: "\<forall>i j. i < length l \<and> j < length l \<and> i \<noteq> j \<longrightarrow> l ! i \<noteq> l ! j"
  have f7: "\<And>n as. \<not> n < length as \<or> List.member as (as ! n::'a)"
    by (metis in_set_member nth_mem)
  then have "length l = i"
    using a6 a5 a4 a3 a2 a1 by (metis (no_types) less_Suc_eq nth_append nth_append_length)
  then show False
    using f7 a5 a4 a2 a1 by (metis (no_types) less_Suc_eq nth_append nth_append_length)
qed
*)

lemma non_repeat_list_sublist_mem: "non_repeat_list (l1@[x]@l2) \<Longrightarrow> \<not> (List.member l1 x)"
  unfolding non_repeat_list_def
  by (simp add: in_set_member non_repeat_list_def)
(*
proof -
  assume "\<forall>i j. 0 \<le> i \<and> i < length (l1 @ [x] @ l2) \<and> 0 \<le> j \<and> j < length (l1 @ [x] @ l2) \<and> i \<noteq> j \<longrightarrow> (l1 @ [x] @ l2) ! i \<noteq> (l1 @ [x] @ l2) ! j"
  then have "distinct (l1 @ [x] @ l2)"
    by (meson distinct_conv_nth less_eq_nat.simps(1))
  then show ?thesis
  by (simp add: in_set_member)
qed
*)

lemma non_repeat_list_pos_unique: "non_repeat_list l \<Longrightarrow>
0 \<le> i \<and> i < length l \<Longrightarrow> 0 \<le> j \<and> j < length l \<Longrightarrow> l!i = l!j \<Longrightarrow> i = j"
  unfolding non_repeat_list_def
  by (simp add: nth_eq_iff_index_eq)
(*
  by auto
*)

lemma non_repeat_list_sublist: "non_repeat_list l \<Longrightarrow> l1@l2 = l \<Longrightarrow> non_repeat_list l1"
  unfolding non_repeat_list_def
  using distinct_append by blast

(*  by (metis length_append nth_append trans_less_add1) *)

lemma non_repeat_list_before: "non_repeat_list l \<Longrightarrow> list_before e1 l e2 \<Longrightarrow>
  \<not>(list_before e2 l e1)"
  unfolding non_repeat_list_def list_before_def
  using nth_eq_iff_index_eq by fastforce
(*
  apply auto
  by (metis less_asym' less_trans) *)

text {* l1 is a sublist of l2. *}

definition is_sublist:: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
"is_sublist l1 l2 \<equiv> \<exists>l. l1@l = l2"

text {* A new version of is_sublist for code export. *}

definition is_sublist2:: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
"is_sublist2 l1 l2 \<equiv> take (length l1) l2 = l1"

lemma is_sublist_code_equal: "is_sublist2 l1 l2 = is_sublist l1 l2"
  unfolding is_sublist2_def is_sublist_def
  by (metis append_eq_conv_conj append_take_drop_id)

lemma is_sublist_id: "is_sublist l l"
  unfolding is_sublist_def
  by auto

lemma sublist_element: "is_sublist l1 l2 \<Longrightarrow> i < List.length l1 \<Longrightarrow> l1!i = l2!i"
  unfolding is_sublist_def
  by (metis nth_append)

lemma sublist_member:
  assumes a1: "is_sublist l1 l2"
  and a2: " List.member l1 e"
shows "List.member l2 e"
proof -
  from a2 obtain i where f1: "i < List.length l1 \<and> l1!i = e"
    by (meson list_mem_range)
  then have f2: "l2!i = e"
    using a1 sublist_element by fastforce
  from f1 a1 have "i < List.length l2"
    unfolding is_sublist_def
    by auto
  then have "i < List.length l2 \<and> l2!i = e"
    using f2 by auto
  then show ?thesis
    by (meson member_def nth_mem)
qed

lemma sublist_repeat: "is_sublist l1 l2 \<Longrightarrow> \<not> (non_repeat_list l1) \<Longrightarrow> \<not> (non_repeat_list l2)"
  unfolding is_sublist_def non_repeat_list_def
  apply auto
  done
(*  by (metis nth_append trans_less_add1)    *)

text {* Given an item and a list, return the sub-list that
is before the item in the list.
If the item in not in the list, return []. *}

primrec find_sub_list_before:: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"find_sub_list_before e [] acc = []"
|"find_sub_list_before e (x#xs) acc = (if e = x then acc else find_sub_list_before e xs (acc@[x]))"

definition sub_list_before:: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"sub_list_before e l = find_sub_list_before e l []"

lemma set_eq: "(\<forall>x. (x \<in> s1) = (x \<in> s2)) \<Longrightarrow> s1 = s2"
  by blast

lemma "distinct l \<Longrightarrow>
       z\<subseteq>{x. list_before x l y} \<Longrightarrow>
       z\<noteq>{} \<Longrightarrow>
       \<exists>x\<in>z. (\<forall>x'\<in>z. x'\<noteq>x \<longrightarrow> list_before x' l x) "

text {* Equality for comprenhensive sets on list elements *}

definition set_list_P::"'a list \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a set"
  where
"set_list_P xs P \<equiv> set (filter P xs)"

definition exists_list::"'a list  \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
  where
"exists_list xs P\<equiv> ((set_list_P xs P) \<noteq> {})"

definition forall_list::"'a list  \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
  where
"forall_list xs P \<equiv> (-(set_list_P xs P) = {})"

definition THE_list::"'a list \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a"
  where
"THE_list xs P \<equiv> if (card (set_list_P xs P) = 1) then (filter P xs)!0
                 else undefined"

lemma subset_P_xs_eq_set_P_list_P:"{a. P a} \<subseteq> (set xs) \<Longrightarrow>
       {a. P a} = (set_list_P xs P)"
  unfolding set_list_P_def
  by auto

lemma exists_list:
  "{a. P a} \<subseteq> (set xs) \<Longrightarrow>
   (\<exists>x. P x) = exists_list xs P"
  using subset_P_xs_eq_set_P_list_P
  unfolding exists_list_def by fastforce

lemma forall_list:
  "{a. P a} \<subseteq> (set xs) \<Longrightarrow>
   (\<forall>x. P x) = forall_list xs P"
  using subset_P_xs_eq_set_P_list_P unfolding forall_list_def
  by blast

lemma finite_P:
     "P x \<Longrightarrow> \<forall>y y'. P y \<and> P y' \<longrightarrow> y = y' \<Longrightarrow>
      finite {a. P a}"
  using nat_seg_image_imp_finite
  by (metis Collect_mem_eq Collect_mono finite.insertI finite_subset insertCI)

 lemma card_P:
 "P x \<Longrightarrow> \<forall>y y'. P y \<and> P y' \<longrightarrow> y = y' \<Longrightarrow>
  card {a. P a} = Suc 0"
   using is_singleton_altdef
   by (metis (full_types) One_nat_def empty_Collect_eq is_singletonI' mem_Collect_eq)

lemma THE_list:
  "{a. P a} \<subseteq> (set xs) \<Longrightarrow>
   Ex1 P \<Longrightarrow>
   (THE x. P x) = THE_list xs P"
  using  the1_equality[of P]  subset_P_xs_eq_set_P_list_P[of P xs] card_P
  unfolding THE_list_def
  by (metis (mono_tags, lifting) One_nat_def card_length le_numeral_extra(2) mem_Collect_eq neq0_conv nth_mem set_list_P_def)

end


(*  Title:      HOL/Analysis/Metric_Arith.thy
    Author:     Maximilian Schäffeler (port from HOL Light)
*)

chapter \<open>Functional Analysis\<close>

section\<^marker>\<open>tag unimportant\<close> \<open>A decision procedure for metric spaces\<close>

theory Metric_Arith
  imports HOL.Real_Vector_Spaces
begin

text\<^marker>\<open>tag unimportant\<close> \<open>
A port of the decision procedure ``Formalization of metric spaces in HOL Light''
@{cite "DBLP:journals/jar/Maggesi18"} for the type class @{class metric_space},
with the \<open>Argo\<close> solver as backend.
\<close>

named_theorems metric_prenex
named_theorems metric_nnf
named_theorems metric_unfold
named_theorems metric_pre_arith

lemmas pre_arith_simps =
  max.bounded_iff max_less_iff_conj
  le_max_iff_disj less_max_iff_disj
  simp_thms HOL.eq_commute
declare pre_arith_simps [metric_pre_arith]

lemmas unfold_simps =
  Un_iff subset_iff disjoint_iff_not_equal
  Ball_def Bex_def
declare unfold_simps [metric_unfold]

declare HOL.nnf_simps(4) [metric_prenex]

lemma imp_prenex [metric_prenex]:
  "\<And>P Q. (\<exists>x. P x) \<longrightarrow> Q \<equiv> \<forall>x. (P x \<longrightarrow> Q)"
  "\<And>P Q. P \<longrightarrow> (\<exists>x. Q x) \<equiv> \<exists>x. (P \<longrightarrow> Q x)"
  "\<And>P Q. (\<forall>x. P x) \<longrightarrow> Q \<equiv> \<exists>x. (P x \<longrightarrow> Q)"
  "\<And>P Q. P \<longrightarrow> (\<forall>x. Q x) \<equiv> \<forall>x. (P \<longrightarrow> Q x)"
  by simp_all

lemma ex_prenex [metric_prenex]:
  "\<And>P Q. (\<exists>x. P x) \<and> Q \<equiv> \<exists>x. (P x \<and> Q)"
  "\<And>P Q. P \<and> (\<exists>x. Q x) \<equiv> \<exists>x. (P \<and> Q x)"
  "\<And>P Q. (\<exists>x. P x) \<or> Q \<equiv> \<exists>x. (P x \<or> Q)"
  "\<And>P Q. P \<or> (\<exists>x. Q x) \<equiv> \<exists>x. (P \<or> Q x)"
  "\<And>P. \<not>(\<exists>x. P x) \<equiv> \<forall>x. \<not>P x"
  by simp_all

lemma all_prenex [metric_prenex]:
  "\<And>P Q. (\<forall>x. P x) \<and> Q \<equiv> \<forall>x. (P x \<and> Q)"
  "\<And>P Q. P \<and> (\<forall>x. Q x) \<equiv> \<forall>x. (P \<and> Q x)"
  "\<And>P Q. (\<forall>x. P x) \<or> Q \<equiv> \<forall>x. (P x \<or> Q)"
  "\<And>P Q. P \<or> (\<forall>x. Q x) \<equiv> \<forall>x. (P \<or> Q x)"
  "\<And>P. \<not>(\<forall>x. P x) \<equiv> \<exists>x. \<not>P x"
  by simp_all

lemma nnf_thms [metric_nnf]:
  "(\<not> (P \<and> Q)) = (\<not> P \<or> \<not> Q)"
  "(\<not> (P \<or> Q)) = (\<not> P \<and> \<not> Q)"
  "(P \<longrightarrow> Q) = (\<not> P \<or> Q)"
  "(P = Q) \<longleftrightarrow> (P \<or> \<not> Q) \<and> (\<not> P \<or> Q)"
  "(\<not> (P = Q)) \<longleftrightarrow> (\<not> P \<or> \<not> Q) \<and> (P \<or> Q)"
  "(\<not> \<not> P) = P"
  by blast+

lemmas nnf_simps = nnf_thms linorder_not_less linorder_not_le
declare nnf_simps[metric_nnf]

lemma ball_insert: "(\<forall>x\<in>insert a B. P x) = (P a \<and> (\<forall>x\<in>B. P x))"
  by blast

lemma Sup_insert_insert:
  fixes a::real
  shows "Sup (insert a (insert b s)) = Sup (insert (max a b) s)"
  by (simp add: Sup_real_def)

lemma real_abs_dist: "\<bar>dist x y\<bar> = dist x y"
  by simp

lemma maxdist_thm [THEN HOL.eq_reflection]:
  assumes "finite s" "x \<in> s" "y \<in> s"
  defines "\<And>a. f a \<equiv> \<bar>dist x a - dist a y\<bar>"
  shows "dist x y = Sup (f ` s)"
proof -
  have "dist x y \<le> Sup (f ` s)"
  proof -
    have "finite (f ` s)"
      by (simp add: \<open>finite s\<close>)
    moreover have "\<bar>dist x y - dist y y\<bar> \<in> f ` s"
      by (metis \<open>y \<in> s\<close> f_def imageI)
    ultimately show ?thesis
      using le_cSup_finite by simp
  qed
  also have "Sup (f ` s) \<le> dist x y"
    using \<open>x \<in> s\<close> cSUP_least[of s f] abs_dist_diff_le
    unfolding f_def
    by blast
  finally show ?thesis .
qed

theorem metric_eq_thm [THEN HOL.eq_reflection]:
  "x \<in> s \<Longrightarrow> y \<in> s \<Longrightarrow> x = y \<longleftrightarrow> (\<forall>a\<in>s. dist x a = dist y a)"
  by auto

ML_file "metric_arith.ML"

method_setup metric = \<open>
  Scan.succeed (SIMPLE_METHOD' o Metric_Arith.metric_arith_tac)
\<close> "prove simple linear statements in metric spaces (\<forall>\<exists>\<^sub>p fragment)"

end


theory Type_Soundness
  imports Typing
begin

context sat_general
begin

lemma safe_neg_eq:
  "safe_formula (Formula.Neg (Formula.Eq x1 x2)) \<Longrightarrow> safe_formula  (Formula.Eq x1 x2) \<or>
  (Formula.sat \<sigma> V v i  (Formula.Neg (Formula.Eq x1 x2)) \<longleftrightarrow> sat' \<sigma> V v i  (Formula.Neg (Formula.Eq x1 x2))) "
  by (cases x1; cases x2) auto

lemma foldl_sound:
  assumes  " \<forall>x\<in>set (x22). ty_of x = t" "ty_of x21 = t"
  shows
    "foldl undef_min x21 x22 = foldl min x21 x22"
    "foldl undef_max x21 x22 = foldl max x21 x22"
    "t \<in> numeric_ty \<Longrightarrow> foldl undef_plus x21 x22 = foldl (+) x21 x22 \<and> ty_of (foldl (+) x21 x22 ) = t"

proof -
  from assms(1-2)
  have minmax:"foldl undef_min x21 x22 = foldl min x21 x22 \<and> foldl undef_max x21 x22 = foldl max x21 x22"
  proof (induction x22 arbitrary: x21 t)
    case (Cons a x22)
    then show ?case using undef_less_eq_sound
      by (cases x21; cases a; simp add: min_def undef_min_def max_def undef_max_def) fastforce+
  qed auto
  from this show "foldl undef_min x21 x22 = foldl min x21 x22" by auto
  from minmax show "foldl undef_max x21 x22 = foldl max x21 x22" by auto
next
  assume "t \<in> numeric_ty"
  from this assms show "foldl undef_plus x21 x22 = foldl (+) x21 x22 \<and> ty_of (foldl (+) x21 x22 ) = t"
  proof (induction x22 arbitrary: x21 t)
  case (Cons a x22)
  then show ?case using undef_plus_sound
    apply (cases x21; cases a; auto simp add: numeric_ty_def)
    using ty_of.simps by presburger+
  qed auto
qed

lemma eval_agg_op_sound:
  assumes
    "M={(x, ecard Zs) | x Zs. Zs =
      {zs. length zs = length tys \<and> Formula.sat \<sigma> V (zs @ v) i \<phi> \<and> Formula.eval_trm (zs @ v) f = x} \<and> Zs \<noteq> {}}"
    "S, E \<turnstile> formula.Agg y (agg_op,d) tys f \<phi> "
    "wty_envs S \<sigma> V"
    "fv_trm f \<subseteq> fv \<phi>"
    "safe_formula \<phi>"
  shows "eval_agg_op (agg_op,d) M = eval_agg_op' (agg_op,d) M"
proof -
  from assms(2) obtain t where t_def: "agg_env E tys  \<turnstile> f :: t" and t_wty:"t \<in> agg_trm_type agg_op" by cases auto
  have fv_wty: "y\<in>fv_trm f \<Longrightarrow> length zs = length tys \<Longrightarrow> Formula.sat \<sigma> V (zs @ v) i \<phi> \<Longrightarrow> ty_of ((zs @ v) ! y) = agg_env E tys y" for y zs
    apply (rule ty_of_sat_safe)
    using assms by (auto elim: wty_formula.cases)
  then have wty_M: "\<forall>(x,card) \<in>  M . ty_of x = t"
    using assms(1) t_def by (auto dest!: ty_of_eval_trm)
  have "finite_multiset M \<Longrightarrow>set (flatten_multiset M) \<subseteq> fst ` M"
    apply (rule set_of_flatten_multiset)
    using finite_set apply (auto simp add: assms(1))
    using finite_fst by (auto simp add: finite_multiset_def assms(1))
  then have wty_flatten: "finite_multiset M \<Longrightarrow> \<forall>x \<in> set (flatten_multiset M). ty_of x = t"
    using wty_M by fastforce
  have avg: "finite_multiset M \<Longrightarrow> flatten_multiset M = x21 # x22 \<Longrightarrow> agg_op = Formula.Agg_Avg \<Longrightarrow>
          double_of_event_data_agg (foldl (+) x21 x22) = undef_double_of_event_data_agg (foldl undef_plus x21 x22)" for x21 x22
  proof -
    assume assm: "finite_multiset M" "flatten_multiset M = x21 # x22" "agg_op = Formula.Agg_Avg"
    have foldl_plus: "foldl undef_plus x21 x22 = foldl (+) x21 x22"
      apply (rule  conjE[OF foldl_sound(3)]) using wty_flatten t_wty assm by auto
    have foldl_ty: "ty_of (foldl (+) x21 x22) \<in> numeric_ty "
      apply (rule conjE[OF  foldl_sound(3)]) using assm wty_flatten t_wty by auto
    show ?thesis apply (auto simp: foldl_plus) apply (cases "foldl (+) x21 x22") using  undef_double_of_event_data_agg_sound foldl_ty by (auto simp add: numeric_ty_def)
  qed
  have med:"finite_multiset M \<Longrightarrow> flatten_multiset M = xs \<Longrightarrow> agg_op = Formula.Agg_Med \<Longrightarrow> i< length xs \<Longrightarrow>
    double_of_event_data_agg (xs!i) = undef_double_of_event_data_agg (xs!i) " for xs i
    using t_wty wty_flatten undef_double_of_event_data_agg_sound nth_mem[where ?n=i and ?xs=xs] by (cases "xs!i")  (auto simp add: numeric_ty_def split:ty.splits)
  then show ?thesis
    apply (cases agg_op) using wty_flatten t_wty avg apply (auto simp:Let_def split: list.splits bool.splits)
    using foldl_sound  apply presburger+
    by (metis div2_less_self in_set_conv_nth list.set_intros(2))
qed

next
  case (And_constraint \<phi> \<psi>)
  have phi_eq: "Formula.sat \<sigma> V v i \<phi> = sat' \<sigma> V v i \<phi>" using And_constraint by (auto elim: wty_formula.cases)
  have psi_wty: "S, E \<turnstile> \<psi>" using And_constraint(7) by (auto elim: wty_formula.cases)
  show ?case using phi_eq And_constraint(5,8) psi_wty
    by (cases \<psi> rule: is_constraint.cases) (auto simp add: undef_less_eq_sound undef_less_def less_event_data_def dest: poly_value_of  elim!: wty_formula.cases)
next
  case (And_Not \<phi> \<psi>)
  have "S, E \<turnstile> \<psi>" using And_Not.prems(1) by (auto elim: wty_formula.cases)
  then show ?case using And_Not by (auto elim: wty_formula.cases)
next
  case (Ands l pos neg)
  have pos_IH: "\<phi> \<in> set pos \<Longrightarrow> S, E \<turnstile> \<phi> \<Longrightarrow> (\<forall>y\<in>fv \<phi>. ty_of (v ! y) = E y)  \<Longrightarrow>  wty_envs S \<sigma> V
\<Longrightarrow>  Formula.sat \<sigma> V v i \<phi> = sat' \<sigma> V v i \<phi>" for \<phi> using Ands.IH(1) Ball_set_list_all   by (smt (verit, best))
  have pos_case: "\<phi> \<in> set pos \<Longrightarrow>  Formula.sat \<sigma> V v i \<phi> = sat' \<sigma> V v i \<phi> " for \<phi> using Ands pos_IH by (auto elim: wty_formula.cases)
  have neg_IH: "\<phi> \<in> set (map remove_neg neg) \<Longrightarrow> S, E \<turnstile> \<phi> \<Longrightarrow> (\<forall>y\<in>fv \<phi>. ty_of (v ! y) = E y) \<Longrightarrow>  wty_envs S \<sigma> V
\<Longrightarrow>  Formula.sat \<sigma> V v i \<phi> = sat' \<sigma> V v i \<phi>" for \<phi> using Ands.IH(2) Ball_set_list_all
    by (smt (verit, best))
  have "\<phi> \<in> set ( neg) \<Longrightarrow> S, E \<turnstile> \<phi> \<and> (\<forall>y\<in>fv \<phi>. ty_of (v ! y) = E y)" for \<phi> using Ands by (auto elim: wty_formula.cases)
  then have "\<phi> \<in> set ( map remove_neg neg) \<Longrightarrow> S, E \<turnstile> \<phi> \<and> (\<forall>y\<in>fv \<phi>. ty_of (v ! y) = E y)" for \<phi>
    apply (auto simp add: Formula.nfv_def )
    subgoal for x by (cases x) (auto elim: wty_formula.cases) done
  then have remove_neg_case: "\<phi> \<in> set (map remove_neg neg) \<Longrightarrow>  Formula.sat \<sigma> V v i \<phi> = sat' \<sigma> V v i \<phi> " for \<phi> using Ands.prems(3) neg_IH by auto
  have remove_neg_sat: " (Formula.sat \<sigma> V v i \<phi> = sat' \<sigma> V v i \<phi> )= ( Formula.sat \<sigma> V v i (remove_neg \<phi>) = sat' \<sigma> V v i (remove_neg \<phi>))  "
    for \<phi>  by (cases \<phi>)  auto
   have neg_case: "\<phi> \<in> set neg\<Longrightarrow>  Formula.sat \<sigma> V v i \<phi> = sat' \<sigma> V v i \<phi>" for \<phi>
    using  remove_neg_case[of "remove_neg \<phi>"]  by ( auto simp add:  remove_neg_sat[of \<phi>] )
  then show ?case using pos_case neg_case Ands(1) by auto
next
  case (Exists t \<phi>)
  {
    fix za
    assume assm: "Formula.sat \<sigma> V (za # v) i \<phi>"
    from Exists.prems(1) have wty: "S, case_nat t E \<turnstile> \<phi>" by cases
    have "0 \<in> fv \<phi> \<Longrightarrow> ty_of za = t"
      using ty_of_sat_safe[where ?E="case_nat t E" and ?S=S and ?\<phi>=\<phi> and ?v="za#v" and ?V=V and ?i=i and ?\<sigma>=\<sigma> and ?x=0]
      Exists(1,6) assm wty by auto
    then have "\<forall>y\<in>fv \<phi>. ty_of ((za # v) ! y) = (case y of 0 \<Rightarrow> t | Suc x \<Rightarrow> E x)" using  Exists.prems(2)   by (auto simp add:  fvi_Suc split: nat.splits )
    from this  have "local.sat' \<sigma> V (za # v) i \<phi>" using Exists.IH[of S "case_nat t E" "za#v" V i] Exists(6) wty assm by auto
  } moreover {
    fix za
    assume assm: "sat' \<sigma> V (za # v) i \<phi>"
    from Exists.prems(1) have wty: "S, case_nat t E \<turnstile> \<phi>" by cases
    have "0 \<in> fv \<phi> \<Longrightarrow> ty_of za = t"
      using ty_of_sat'_safe[where ?E="case_nat t E" and ?S=S and ?\<phi>=\<phi> and ?v="za#v" and ?V=V and ?i=i and ?\<sigma>=\<sigma> and ?x=0]
      Exists(1,6) assm wty by auto
    then have "\<forall>y\<in>fv \<phi>. ty_of ((za # v) ! y) = (case y of 0 \<Rightarrow> t | Suc x \<Rightarrow> E x)" using  Exists.prems(2)   by (auto simp add:  fvi_Suc split: nat.splits )
    from this  have "Formula.sat \<sigma> V (za # v) i \<phi>" using Exists.IH[of S "case_nat t E" "za#v" V i] Exists(6) wty assm by auto
  }
  ultimately show ?case by auto
next
  case (Agg y \<omega> tys f \<phi>)
  have phi_wty: "S, agg_env E tys \<turnstile> \<phi>" using Agg.prems(1) by (auto elim: wty_formula.cases)
  have phi_case: "length zs = length tys \<Longrightarrow> Formula.sat \<sigma> V (zs @ v) i \<phi> =  sat' \<sigma> V (zs @ v) i \<phi>" for zs
  proof -
    assume len_zs:"length zs = length tys"
    {
      assume sat: " Formula.sat \<sigma> V (zs @ v) i \<phi>"
      have fv_wty: "y \<in> fv \<phi> \<Longrightarrow> ty_of ((zs @ v) ! y) = agg_env E tys y" for y
        using ty_of_sat_safe Agg(4,8) sat len_zs phi_wty  by  (auto simp add: Formula.nfv_def)
      have " Formula.sat \<sigma> V (zs @ v) i \<phi> = sat' \<sigma> V (zs @ v) i \<phi> "
        using phi_wty Agg(4,5,8) len_zs fv_wty by auto
    } moreover{
      assume sat':"sat' \<sigma> V (zs @ v) i \<phi>"
      have fv_wty: "y \<in> fv \<phi> \<Longrightarrow> ty_of ((zs @ v) ! y) = agg_env E tys y" for y
        using ty_of_sat'_safe Agg(4,8) sat' len_zs phi_wty by  (auto simp add: Formula.nfv_def)
      have " Formula.sat \<sigma> V (zs @ v) i \<phi> = sat' \<sigma> V (zs @ v) i \<phi> "
        using phi_wty Agg(4,5,8) len_zs fv_wty by auto
    }
    ultimately show ?thesis by auto
  qed
  have "Formula.eval_trm (zs @ v) f = eval_trm' (zs @ v) f"  if a1:"Formula.sat \<sigma> V (zs @ v) i \<phi>" and a2:"length zs = length tys" for zs
  proof -
    have fv_wty: "y\<in>fv_trm f \<Longrightarrow> ty_of ((zs @ v) ! y) = agg_env E tys y" for y
      using ty_of_sat_safe  Agg(3,4,8) a1 a2 phi_wty by auto
    show ?thesis using Agg.prems(1) fv_wty by (auto dest: eval_trm_sound elim: wty_formula.cases)
  qed
  then have
 "{(x, ecard Zs) | x Zs. Zs = {zs. length zs = length tys \<and> Formula.sat \<sigma> V (zs @ v) i \<phi> \<and> Formula.eval_trm (zs @ v) f = x} \<and> Zs \<noteq> {}}
= {(x, ecard Zs) | x Zs. Zs = {zs. length zs = length tys \<and> sat' \<sigma> V (zs @ v) i \<phi> \<and> eval_trm' (zs @ v) f = x} \<and> Zs \<noteq> {}}"
    using phi_case  by (smt (z3) Collect_cong)
  moreover obtain agg_op d where omega_def:"\<omega> = (agg_op,d)" using Agg.prems(1) by cases auto
  moreover have eval_agg_op_case: "M = {(x, ecard Zs) | x Zs. Zs = {zs. length zs = length tys \<and> Formula.sat \<sigma> V (zs @ v) i \<phi> \<and> Formula.eval_trm (zs @ v) f = x} \<and> Zs \<noteq> {}}
 \<Longrightarrow> eval_agg_op (agg_op,d) M = eval_agg_op' (agg_op,d) M" for M
    apply (rule eval_agg_op_sound) using omega_def Agg(3,4,6,8) by auto
  ultimately show ?case by auto
next
  case (Since \<phi> I \<psi>)
  have phi_eq: "Formula.sat \<sigma> V v i \<phi> = sat' \<sigma> V v i \<phi>" for i using Since by (auto elim: wty_formula.cases)
  have psi_eq: "Formula.sat \<sigma> V v i \<psi> = sat' \<sigma> V v i \<psi>" for i  using Since by (auto elim: wty_formula.cases)
  show ?case by (auto simp add: phi_eq psi_eq)
next
  case (Not_Since \<phi> I \<psi>)
  have phi_eq: "Formula.sat \<sigma> V v i \<phi> = sat' \<sigma> V v i \<phi>" for i apply (rule Not_Since.IH(1)) using Not_Since by (auto elim: wty_formula.cases)
  have psi_eq: "Formula.sat \<sigma> V v i \<psi> = sat' \<sigma> V v i \<psi>" for i  using Not_Since by (auto elim: wty_formula.cases)
  show ?case by (auto simp add: phi_eq psi_eq)
next
  case (Until \<phi> I \<psi>)
  have phi_eq: "Formula.sat \<sigma> V v i \<phi> = sat' \<sigma> V v i \<phi>" for i using Until by (auto elim: wty_formula.cases)
  have psi_eq: "Formula.sat \<sigma> V v i \<psi> = sat' \<sigma> V v i \<psi>" for i  using Until by (auto elim: wty_formula.cases)
  show ?case by (auto simp add: phi_eq psi_eq)
next
  case (Not_Until \<phi> I \<psi>)
  have phi_eq: "Formula.sat \<sigma> V v i \<phi> = sat' \<sigma> V v i \<phi>" for i apply (rule Not_Until.IH(1)) using Not_Until by (auto elim: wty_formula.cases)
  have psi_eq: "Formula.sat \<sigma> V v i \<psi> = sat' \<sigma> V v i \<psi>" for i  using Not_Until by (auto elim: wty_formula.cases)
  show ?case by (auto simp add: phi_eq psi_eq)
next
  case (MatchP I r)
  from  MatchP(1) have "safe_regex Past Strict r \<or>safe_regex Past Lax r " by auto
  from this have atms_safe: " \<phi> \<in> regex.atms r \<Longrightarrow> safe_formula \<phi> \<or> (\<exists> \<psi>. \<phi> = Formula.Neg \<psi> \<and> safe_formula \<psi>)" for \<phi>
    using case_NegE  by (induction r) auto
  have atms_regex_atms: " \<phi> \<in> atms r \<or> ( \<exists> \<psi>. \<phi> = Formula.Neg \<psi> \<and>  \<psi>\<in> atms r)" if assm: " \<phi> \<in> regex.atms r" for \<phi>
    using assm atms_safe apply (induction r) by auto
  from MatchP(4) have  " (\<phi> \<in> atms r \<Longrightarrow>\<forall>y\<in>fv \<phi>. ty_of (v ! y) = E y)" for \<phi>
    apply auto apply (induction r)
        apply (auto) subgoal for x y apply (cases "safe_formula x") by (auto split: formula.splits  ) done
  from this  MatchP have IH: "\<phi>\<in>atms r \<Longrightarrow>Formula.sat \<sigma> V v i5 \<phi> = sat' \<sigma> V v i5 \<phi>" for \<phi> i5
    using match_safe_wty_nfv[of \<phi> r I S E] by auto
  have other_IH: "\<phi> \<in> regex.atms r \<Longrightarrow> Formula.sat \<sigma> V v i5 \<phi> = sat' \<sigma> V v i5 \<phi>" for \<phi> i5
    using atms_regex_atms[of \<phi>] IH by auto
  then show ?case  using match_cong[OF refl other_IH, where ?r=r] by auto
next
  case (MatchF I r)
  from  MatchF(1) have "safe_regex Futu Strict r \<or>safe_regex Futu Lax r " by auto
  from this have atms_safe: " \<phi> \<in> regex.atms r \<Longrightarrow> safe_formula \<phi> \<or> (\<exists> \<psi>. \<phi> = Formula.Neg \<psi> \<and> safe_formula \<psi>)" for \<phi>
    using case_NegE  by (induction r) auto
  have atms_regex_atms: " \<phi> \<in> atms r \<or> ( \<exists> \<psi>. \<phi> = Formula.Neg \<psi> \<and>  \<psi>\<in> atms r)" if assm: " \<phi> \<in> regex.atms r" for \<phi>
    using assm atms_safe apply (induction r) by auto
  from MatchF(4) have  " (\<phi> \<in> atms r \<Longrightarrow>\<forall>y\<in>fv \<phi>. ty_of (v ! y) = E y)" for \<phi> apply auto apply (induction r )
        apply (auto) subgoal for x y apply (cases "safe_formula x") by (auto split: formula.splits  ) done
  from this  MatchF have IH: "\<phi>\<in>atms r \<Longrightarrow>Formula.sat \<sigma> V v i5 \<phi> = sat' \<sigma> V v i5 \<phi>" for \<phi> i5
    using match_safe_wty_nfv[of \<phi> r I S E] by auto
  have other_IH: "\<phi> \<in> regex.atms r \<Longrightarrow> Formula.sat \<sigma> V v i5 \<phi> = sat' \<sigma> V v i5 \<phi>" for \<phi> i5
    using atms_regex_atms[of \<phi>] IH by auto
  then show ?case using match_cong[OF refl other_IH, where ?r=r] by auto
next
  case (LetPast p \<phi> \<psi>)
  obtain E' where
    psi_wty: "S((p, Formula.nfv \<phi>) \<mapsto> tabulate E' 0 (Formula.nfv \<phi>)), E \<turnstile> \<psi>" and
    phi_wty: "S((p, Formula.nfv \<phi>) \<mapsto> tabulate E' 0 (Formula.nfv \<phi>)), E' \<turnstile> \<phi>" using LetPast.prems(1) by cases auto
  have wtyenv: "x \<in> \<Gamma> \<sigma> i \<Longrightarrow> (case x of (p, xs) \<Rightarrow> (p, length xs) \<notin> dom V \<longrightarrow> (case S (p, length xs) of None \<Rightarrow> False | Some ts \<Rightarrow> wty_tuple ts xs))" for x i
    using LetPast.prems(3) by (auto simp add: wty_envs_def wty_event_def wty_tuple_def)
  let ?V' = "(V((p, Formula.nfv \<phi>) \<mapsto> letpast_sat (\<lambda>X v i. sat' \<sigma> (V((p, Formula.nfv \<phi>) \<mapsto> X)) v i \<phi>)))"
  let ?V'' = "(V((p, Formula.nfv \<phi>) \<mapsto> letpast_sat (\<lambda>X v i. Formula.sat \<sigma> (V((p, Formula.nfv \<phi>) \<mapsto> X)) v i \<phi>)))"
  have wty_envs: "wty_envs (S((p, Formula.nfv \<phi>) \<mapsto> tabulate E' 0 (Formula.nfv \<phi>))) \<sigma> ?V'"
    using wty_envs_update[OF LetPast(3) LetPast(9) phi_wty LetPast(2)] ty_of_sat'_safe[OF LetPast(3)] by blast
  then have wty_envs': "wty_envs (S((p, Formula.nfv \<phi>) \<mapsto> tabulate E' 0 (Formula.nfv \<phi>))) \<sigma>
 (V((p, Formula.nfv \<phi>) \<mapsto> \<lambda>w j. j < i \<and> letpast_sat (\<lambda>X v i. sat' \<sigma> (V((p, Formula.nfv \<phi>) \<mapsto> X)) v i \<phi>) w j))" for i
    unfolding wty_envs_def by(auto simp:domI)
  have "(letpast_sat (\<lambda>X v i. sat' \<sigma> (V((p, Formula.nfv \<phi>) \<mapsto> X)) v i \<phi>)) v i =
        (letpast_sat (\<lambda>X v i. Formula.sat \<sigma> (V((p, Formula.nfv \<phi>) \<mapsto> X)) v i \<phi>)) v i" for v i
  proof(induction i arbitrary: v rule:less_induct)
    case (less x)
    then show ?case
    proof -
      assume "(\<And>y v. y < x \<Longrightarrow>
          letpast_sat (\<lambda>X v i. sat' \<sigma> (V((p, Formula.nfv \<phi>) \<mapsto> X)) v i \<phi>) v y =
          letpast_sat (\<lambda>X v i. Formula.sat \<sigma> (V((p, Formula.nfv \<phi>) \<mapsto> X)) v i \<phi>) v y)"
      then have eq: "(\<lambda>w j. j < x \<and> letpast_sat (\<lambda>X v i. sat' \<sigma> (V((p, Formula.nfv \<phi>) \<mapsto> X)) v i \<phi>) w j) =
             (\<lambda>w j. j < x \<and> letpast_sat (\<lambda>X v i. Formula.sat \<sigma> (V((p, Formula.nfv \<phi>) \<mapsto> X)) v i \<phi>) w j)"
        by auto
      {
        assume sat: "(letpast_sat (\<lambda>X v i. sat' \<sigma> (V((p, Formula.nfv \<phi>) \<mapsto> X)) v i \<phi>)) v x"
        have *: "Formula.sat \<sigma> (V((p, Formula.nfv \<phi>) \<mapsto> \<lambda>w j. j < x \<and> letpast_sat (\<lambda>X v i. Formula.sat \<sigma> (V((p, Formula.nfv \<phi>) \<mapsto> X)) v i \<phi>) w j)) v x \<phi>"
          using iffD1[OF letpast_sat.simps sat] LetPast(5)[OF phi_wty _ wty_envs', of v x x]
          ty_of_sat'_safe[OF LetPast(3) phi_wty wty_envs' iffD1[OF letpast_sat.simps sat]] unfolding eq by blast
        have "letpast_sat (\<lambda>X v i. Formula.sat \<sigma> (V((p, Formula.nfv \<phi>) \<mapsto> X)) v i \<phi>) v x"
          using iffD1[OF letpast_sat.simps[of "(\<lambda>X v i. Formula.sat \<sigma> (V((p, Formula.nfv \<phi>) \<mapsto> X)) v i \<phi>)", symmetric], OF *] by auto
      } moreover {
        assume sat: "letpast_sat (\<lambda>X v i. Formula.sat \<sigma> (V((p, Formula.nfv \<phi>) \<mapsto> X)) v i \<phi>) v x"
        have *: "sat' \<sigma> (V((p, Formula.nfv \<phi>) \<mapsto> \<lambda>w j. j < x \<and> letpast_sat (\<lambda>X v i. sat' \<sigma> (V((p, Formula.nfv \<phi>) \<mapsto> X)) v i \<phi>) w j)) v x \<phi>"
          using ty_of_sat_safe[OF LetPast(3) phi_wty wty_envs', of x, unfolded eq, OF iffD1[OF letpast_sat.simps sat]]
            iffD1[OF letpast_sat.simps sat] LetPast(5)[OF phi_wty _ wty_envs', of v x x]  unfolding eq by blast
        have "(letpast_sat (\<lambda>X v i. sat' \<sigma> (V((p, Formula.nfv \<phi>) \<mapsto> X)) v i \<phi>)) v x"
          using iffD1[OF letpast_sat.simps[of "(\<lambda>X v i. sat' \<sigma> (V((p, Formula.nfv \<phi>) \<mapsto> X)) v i \<phi>)", symmetric], OF *] by auto
      } ultimately show ?thesis by fastforce
    qed
  qed
  then have V_eq: "?V' = ?V''" by force
  have "Formula.sat \<sigma> ?V' v i \<psi> = sat' \<sigma> ?V' v i \<psi>" unfolding V_eq[symmetric]
  proof -
    {
      assume sat: " Formula.sat \<sigma> ?V' v i \<psi>"
      have "Formula.sat \<sigma> ?V' v i \<psi> = sat' \<sigma> ?V' v i \<psi>"
        using ty_of_sat_safe[OF LetPast(4) psi_wty wty_envs sat] LetPast(6)[OF psi_wty _ wty_envs] by blast
    } moreover {
      assume sat': "sat' \<sigma> ?V' v i \<psi>"
      have " Formula.sat \<sigma> ?V' v i \<psi> = sat' \<sigma> ?V' v i \<psi>"
        using ty_of_sat'_safe[OF LetPast(4) psi_wty wty_envs sat'] LetPast(6)[OF psi_wty _ wty_envs] by blast
    } ultimately show ?thesis by auto
  qed
  then have "Formula.sat \<sigma> ?V'' v i \<psi> = sat' \<sigma> ?V' v i \<psi>" unfolding V_eq[symmetric] by auto
  then show ?case by(auto simp:Let_def)
next
  case (TP t)
  then show ?case by(auto simp:trm.is_Var_def trm.is_Const_def)
next
  case (TS t)
  then show ?case by(auto simp:trm.is_Var_def trm.is_Const_def)
qed (auto elim: wty_formula.cases split: nat.splits)

lemma soundness2: (*Theorem 3.12*)
  assumes
    "safe_formula \<phi>"
    "S,E \<turnstile> \<phi>"
    "wty_envs S \<sigma> V"
  shows "Formula.sat \<sigma> V v i \<phi> \<longleftrightarrow> sat' \<sigma> V v i \<phi>"
  using  soundness[OF assms(1-2) _ assms(3)]
    ty_of_sat_safe[OF assms(1-3), of v i]
    ty_of_sat'_safe[OF assms(1-3), of v i]
  by auto
end
end


(*  Title:      ZF/Coind/Types.thy
    Author:     Jacob Frost, Cambridge University Computer Laboratory
    Copyright   1995  University of Cambridge
*)

theory Types imports Language begin

consts
  Ty :: i               (* Datatype of types *)
  TyConst :: i          (* Abstract type of type constants *)

datatype
  "Ty" = t_const ("tc \<in> TyConst")
       | t_fun ("t1 \<in> Ty","t2 \<in> Ty")

(* Definition of type environments and associated operators *)

consts
  TyEnv :: i

datatype
  "TyEnv" = te_emp
          | te_owr ("te \<in> TyEnv","x \<in> ExVar","t \<in> Ty")

consts
  te_dom :: "i => i"
  te_app :: "[i,i] => i"

primrec (*domain of the type environment*)
  "te_dom (te_emp) = 0"
  "te_dom (te_owr(te,x,v)) = te_dom(te) \<union> {x}"

primrec (*lookup up identifiers in the type environment*)
  "te_app (te_emp,x) = 0"
  "te_app (te_owr(te,y,t),x) = (if x=y then t else te_app(te,x))"

inductive_cases te_owrE [elim!]: "te_owr(te,f,t) \<in> TyEnv"

(*redundant??*)
lemma te_app_owr1: "te_app(te_owr(te,x,t),x) = t"
by simp

(*redundant??*)
lemma te_app_owr2: "x \<noteq> y ==> te_app(te_owr(te,x,t),y) = te_app(te,y)"
by auto

lemma te_app_owr [simp]:
     "te_app(te_owr(te,x,t),y) = (if x=y then t else te_app(te,y))"
by auto

lemma te_appI:
     "[| te \<in> TyEnv; x \<in> ExVar; x \<in> te_dom(te) |] ==> te_app(te,x) \<in> Ty"
apply (erule_tac P = "x \<in> te_dom (te) " in rev_mp)
apply (erule TyEnv.induct, auto)
done

end


theory FL_Bisimilarity_Implies_Equivalence
imports
  FL_Logical_Equivalence
begin

section \<open>\texorpdfstring{$F/L$}{F/L}-Bisimilarity Implies Logical Equivalence\<close>

context indexed_effect_nominal_ts
begin

  lemma FL_bisimilarity_implies_equivalence_Act:
    assumes "f \<in>\<^sub>f\<^sub>s F"
    and "bn \<alpha> \<sharp>* (F, f)"
    and "x \<in> \<A>[L (\<alpha>, F, f)]"
    and "\<And>P Q. P \<sim>\<cdot>[L (\<alpha>, F, f)] Q \<Longrightarrow> P \<Turnstile> x \<longleftrightarrow> Q \<Turnstile> x"
    and "P \<sim>\<cdot>[F] Q"
    and "P \<Turnstile> Act f \<alpha> x"
    shows "Q \<Turnstile> Act f \<alpha> x"
  proof -
    have "finite (supp (\<langle>f\<rangle>Q, F, f))"
      by (fact finite_supp)
    with \<open>P \<Turnstile> Act f \<alpha> x\<close> obtain \<alpha>' x' P' where eq: "Act f \<alpha> x = Act f \<alpha>' x'" and trans: "\<langle>f\<rangle>P \<rightarrow> \<langle>\<alpha>',P'\<rangle>" and valid: "P' \<Turnstile> x'" and fresh: "bn \<alpha>' \<sharp>* (\<langle>f\<rangle>Q, F, f)"
      by (metis FL_valid_Act_strong)

    from \<open>P \<sim>\<cdot>[F] Q\<close> and \<open>f \<in>\<^sub>f\<^sub>s F\<close> and fresh and trans obtain Q' where trans': "\<langle>f\<rangle>Q \<rightarrow> \<langle>\<alpha>',Q'\<rangle>" and bisim': "P' \<sim>\<cdot>[L (\<alpha>',F,f)] Q'"
      by (metis FL_bisimilar_simulation_step)

    from eq obtain p where p_\<alpha>: "\<alpha>' = p \<bullet> \<alpha>" and p_x: "x' = p \<bullet> x"
        and fresh_p: "(supp x - bn \<alpha>) \<sharp>* p \<and> (supp \<alpha> - bn \<alpha>) \<sharp>* p"
        and supp_p: "supp p \<subseteq> bn \<alpha> \<union> p \<bullet> bn \<alpha>"
      by (metis Act_eq_iff_perm_renaming)

    from valid and p_x have "-p \<bullet> P' \<Turnstile> x"
      by (metis permute_minus_cancel(2) FL_valid_eqvt)

    moreover from fresh and p_\<alpha> have "(p \<bullet> bn \<alpha>) \<sharp>* (F, f)"
      by (simp add: bn_eqvt fresh_star_Pair)
    with \<open>bn \<alpha> \<sharp>* (F, f)\<close> and supp_p have "supp (F, f) \<sharp>* p"
      by (meson UnE fresh_def fresh_star_def subsetCE)
    then have "supp F \<sharp>* p" and "supp f \<sharp>* p"
      by (simp add: fresh_star_Un supp_Pair)+

    with bisim' and p_\<alpha> have "(-p \<bullet> P') \<sim>\<cdot>[L (\<alpha>, F, f)] (-p \<bullet> Q')"
      by (metis FL_bisimilar_eqvt L_eqvt' permute_minus_cancel(2) supp_perm_eq)

    ultimately have "-p \<bullet> Q' \<Turnstile> x"
      using \<open>\<And>P Q. P \<sim>\<cdot>[L (\<alpha>, F, f)] Q \<Longrightarrow> P \<Turnstile> x \<longleftrightarrow> Q \<Turnstile> x\<close> by metis

    with p_x have "Q' \<Turnstile> x'"
      by (metis permute_minus_cancel(1) FL_valid_eqvt)

    with eq and trans' show "Q \<Turnstile> Act f \<alpha> x"
      unfolding FL_valid_Act by metis
  qed

  theorem FL_bisimilarity_implies_equivalence: assumes "P \<sim>\<cdot>[F] Q" shows "FL_logically_equivalent F P Q"
  unfolding FL_logically_equivalent_def proof
    fix x :: "('idx, 'pred, 'act, 'effect) formula"
    show "x \<in> \<A>[F] \<longrightarrow> P \<Turnstile> x \<longleftrightarrow> Q \<Turnstile> x"
    proof
      assume "x \<in> \<A>[F]" then show "P \<Turnstile> x \<longleftrightarrow> Q \<Turnstile> x"
      using assms proof (induction x arbitrary: P Q)
        case Conj then show ?case
          by simp
      next
        case Not then show ?case
          by simp
      next
        case Pred then show ?case
          by (metis FL_bisimilar_is_L_bisimulation is_L_bisimulation_def symp_def FL_valid_Pred)
      next
        case Act then show ?case
          by (metis FL_bisimilar_symp FL_bisimilarity_implies_equivalence_Act sympE)
      qed
    qed
  qed

end

end


section "Packed Traces without Failures"
theory packed_no_fails
imports packed_traces ignore_fails
begin

text \<open>
 To show that a program is correct, we only have to consider packed transactions without crashes.
\<close>
text_raw \<open>\DefineSnippet{show_programCorrect_noTransactionInterleaving}{\<close>
theorem show_programCorrect_noTransactionInterleaving:
  assumes packedTracesCorrect:
    "\<And>trace s. \<lbrakk>
      initialState program ~~ trace \<leadsto>* s;
      packed_trace trace;
      \<And>s. (s, ACrash) \<notin> set trace
    \<rbrakk> \<Longrightarrow> traceCorrect trace"
shows "programCorrect program"
text_raw \<open>}%EndSnippet\<close>

  unfolding programCorrect_def proof -
  text "We only have to consider traces without ACrash actions"
  show "\<forall>trace\<in>traces program. traceCorrect trace"
  proof (subst can_ignore_fails, clarsimp)
    text "Let tr be some trace such that program executes trace to s."
    fix tr
    assume is_trace: "tr \<in> traces program"
      and noFail: "\<forall>s. (s, ACrash) \<notin> set tr"

    from is_trace
    obtain s where steps: "initialState program ~~ tr \<leadsto>* s"
      by (auto simp add: traces_def)

    show "traceCorrect tr"
    proof (rule ccontr)
      assume "\<not> traceCorrect tr"
      with noFail steps
      obtain tr'' s''
        where "initialState program ~~ tr'' \<leadsto>* s''"
          and "packed_trace tr''"
          and "\<not>traceCorrect tr''"
          and "\<forall>s. (s, ACrash) \<notin> set tr''"
        using pack_incorrect_trace
        by blast
      then show False
        using packedTracesCorrect by blast
    qed
  qed
qed

end


theory draft
  imports Tensor_Product

begin

unbundle bounded_notation

lemma htensorOp_existence:
  \<open>\<exists> H :: ('a::chilbert_space, 'b::chilbert_space) bounded \<Rightarrow> ('c::chilbert_space, 'd::chilbert_space) bounded \<Rightarrow>
    ('a \<otimes>\<^sub>h 'c,  'b \<otimes>\<^sub>h 'd) bounded. (
    \<forall> S T. \<forall> x y. (H S T) *\<^sub>v (x \<otimes>\<^sub>h y) = (S *\<^sub>v x) \<otimes>\<^sub>h (T *\<^sub>v y) \<and>
    norm (H S T) \<le> norm S * norm T)\<close>
  sorry

definition htensorOp :: \<open>('a::chilbert_space, 'b::chilbert_space) bounded
 \<Rightarrow> ('c::chilbert_space, 'd::chilbert_space ) bounded
 \<Rightarrow> (('a \<otimes>\<^sub>h 'c),  ('b \<otimes>\<^sub>h 'd)) bounded\<close> (infixl "\<otimes>\<^sub>H" 70)
  where \<open>htensorOp = (SOME H :: ('a, 'b) bounded \<Rightarrow> ('c, 'd) bounded \<Rightarrow>
    ('a \<otimes>\<^sub>h 'c,  'b \<otimes>\<^sub>h 'd) bounded. (
    \<forall> S T. \<forall> x y. (H S T) *\<^sub>v (x \<otimes>\<^sub>h y) = (S *\<^sub>v x) \<otimes>\<^sub>h (T *\<^sub>v y) \<and>
    norm (H S T) \<le> norm S * norm T
))\<close>

lemma htensorOp_I1:
  fixes S::\<open>('a::chilbert_space, 'b::chilbert_space) bounded\<close> and
    T::\<open>('c::chilbert_space, 'd::chilbert_space) bounded\<close>
  shows \<open>(S \<otimes>\<^sub>H T) *\<^sub>v (x \<otimes>\<^sub>h y) = (S *\<^sub>v x) \<otimes>\<^sub>h (T *\<^sub>v y)\<close>
proof-
  define P::\<open>(('a, 'b) bounded \<Rightarrow> ('c, 'd) bounded \<Rightarrow> ('a \<otimes>\<^sub>h 'c,  'b \<otimes>\<^sub>h 'd) bounded) \<Rightarrow> bool\<close> where
    \<open>P H = (\<forall> S T. (\<forall> x y. (H S T) *\<^sub>v (x \<otimes>\<^sub>h y) = (S *\<^sub>v x)\<otimes>\<^sub>h(T *\<^sub>v y)) \<and>
        norm (H S T) \<le> norm S * norm T)\<close> for H
  have  \<open>\<exists> H. P H\<close>
    unfolding P_def
    using htensorOp_existence
    by auto
  hence  \<open>P (\<lambda> S T. S \<otimes>\<^sub>H T)\<close>
    by (smt someI_ex htensorOp_def P_def)
      (* > 1 s *)
  thus ?thesis
    by (simp add: P_def)
qed

lemma htensorOp_I2:
  fixes S::\<open>('a::chilbert_space, 'b::chilbert_space) bounded\<close> and
    T::\<open>('c::chilbert_space, 'd::chilbert_space) bounded\<close>
  shows \<open>norm (S \<otimes>\<^sub>H T) \<le> norm S * norm T\<close>
proof-
  define P::\<open>(('a, 'b) bounded \<Rightarrow> ('c, 'd) bounded \<Rightarrow> ('a \<otimes>\<^sub>h 'c,  'b \<otimes>\<^sub>h 'd) bounded) \<Rightarrow> bool\<close> where
    \<open>P H = (\<forall> S T. (\<forall> x y. (H S T) *\<^sub>v (x \<otimes>\<^sub>h y) = (S *\<^sub>v x)\<otimes>\<^sub>h(T *\<^sub>v y)) \<and>
        norm (H S T) \<le> norm S * norm T)\<close> for H
  have  \<open>\<exists> H. P H\<close>
    unfolding P_def
    using htensorOp_existence
    by auto
  hence  \<open>P (\<lambda> S T. S \<otimes>\<^sub>H T)\<close>
    by (smt someI_ex htensorOp_def P_def)
      (* > 1 s *)
  thus ?thesis
    by (simp add: P_def)
qed

unbundle no_bounded_notation

end


theory prop_47
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a Tree = Leaf | Node "'a Tree" "'a" "'a Tree"
  datatype Nat = Z | S "Nat"
  fun mirror :: "'a Tree => 'a Tree" where
  "mirror (Leaf) = Leaf"
  | "mirror (Node l y r) = Node (mirror r) y (mirror l)"
  fun max2 :: "Nat => Nat => Nat" where
  "max2 (Z) y = y"
  | "max2 (S z) (Z) = S z"
  | "max2 (S z) (S x2) = S (max2 z x2)"
  fun height :: "'a Tree => Nat" where
  "height (Leaf) = Z"
  | "height (Node l y r) = S (max2 (height l) (height r))"
  (*hipster mirror max2 height *)

(*hipster mirror
lemma lemma_ta []: "mirror (mirror x2) = x2"
by (hipster_induct_schemes mirror.simps)*)

lemma lemma_a [thy_expl]: "max2 x x = x"
by (hipster_induct_schemes max2.simps)

lemma lemma_aa [thy_expl]: "max2 x Z = x"
by (hipster_induct_schemes max2.simps)

lemma lemma_ab [thy_expl]: "max2 x (max2 x y) = max2 x y"
by (hipster_induct_schemes max2.simps)

lemma lemma_ac [thy_expl]: "max2 x (max2 y x) = max2 y x"
by (hipster_induct_schemes max2.simps)

lemma lemma_ad [thy_expl]: "max2 (max2 x y) x = max2 x y"
by (hipster_induct_schemes max2.simps)

lemma lemma_ae [thy_expl]: "max2 (S x) y = max2 y (S x)"
by (hipster_induct_schemes max2.simps)

lemma lemma_af [thy_expl]: "max2 x y = max2 y x"
by (hipster_induct_schemes max2.simps)

(*hipster height*)
  theorem x0 :
    "(height (mirror b)) = (height b)"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


(* 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_weird_nat_add3_assoc3
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun add3 :: "Nat => Nat => Nat => Nat" where
"add3 (Z) (Z) z = z"
| "add3 (Z) (S x3) z = plus (S Z) (add3 Z x3 z)"
| "add3 (S x2) y z = plus (S Z) (add3 x2 y z)"

theorem property0 :
  "((add3 x1 (add3 x2 x3 x4) x5) = (add3 x1 x2 (add3 x3 x4 x5)))"
  oops

end


theory temp
  imports Main "/Volumes/Setup/Isabelle/Isabelle-Code/September/libs_functions"
begin

value "(
(\<forall>connector\<in>set Connector.\<forall>sync_list\<in>set (fst connector).\<forall>sync\<in>set sync_list. (P ((fst sync), (snd sync)) \<longrightarrow>
      ((\<exists>trig_list\<in>set(snd connector).\<exists>trig\<in>set trig_list. \<forall>t_elm\<in>set trig. (Q ((fst t_elm), (snd t_elm))
      \<and> (\<forall>h \<in> set (lookup_3 (fst t_elm) test_triggers) - {snd t_elm}. \<not>Q ((fst t_elm), h)) ))
      \<and> (\<forall>sync_1\<in>set(fst connector)-{sync_list}.\<exists>s_elm_1\<in>set(sync_1). P ((fst s_elm_1), (snd s_elm_1))
      \<and> (\<forall>l \<in> set (lookup_3 (fst s_elm_1) test_synchron) - {snd s_elm_1}. \<not>P ((fst s_elm_1), l)))
    )
))\<and> (\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<forall>l \<in> set (snd t).(P ((fst t), l) \<longrightarrow> (\<forall>l1 \<in> set (snd t) - {l}. \<not>P ((fst t), l1))))
\<and> (\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<forall>h \<in> set (snd k).(Q ((fst k), h) \<longrightarrow> (\<forall>h1 \<in> set (snd k) - {h}. \<not>Q ((fst k), h1))))
)"

value "(\<forall>connector\<in>set Connector.\<exists>trig_list\<in>set(snd connector).\<exists>trig\<in>set trig_list. \<forall>t_elm\<in>set trig. (Q ((fst t_elm), (snd t_elm)) \<and> (\<forall>h \<in> set (lookup_3 (fst t_elm) test_triggers) - {snd t_elm}. \<not>Q ((fst t_elm), h)) ))"

value "(\<forall>connector\<in>set Connector.\<exists>trig_list\<in>set(snd connector).\<exists>trig\<in>set trig_list. \<forall>t_elm\<in>set trig. (Q ((fst t_elm), (snd t_elm))))"

lemma test_Q: "(\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<forall>h \<in> set (snd k).(Q ((fst k), h) \<longrightarrow> (\<forall>h1 \<in> set (snd k) - {h}. \<not>Q ((fst k), h1))))
\<Longrightarrow>
(
(\<forall>connector\<in>set Connector.\<exists>trig_list\<in>set(snd connector).\<exists>trig\<in>set trig_list. \<forall>t_elm\<in>set trig. (Q ((fst t_elm), (snd t_elm)) \<and> (\<forall>h \<in> set (lookup_3 (fst t_elm) test_triggers) - {snd t_elm}. \<not>Q ((fst t_elm), h)) )) \<longleftrightarrow> (\<forall>connector\<in>set Connector.\<exists>trig_list\<in>set(snd connector).\<exists>trig\<in>set trig_list. \<forall>t_elm\<in>set trig. (Q ((fst t_elm), (snd t_elm))))
)"
  sledgehammer

end


theory sort_StoogeSortPermutes
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype ('a, 'b) Pair2 = Pair "'a" "'b"

datatype Nat = Z | S "Nat"

fun ztake :: "int => 'a list => 'a list" where
"ztake x y =
   (if x = 0 then Nil2 else
      case y of
        | Nil2 => y
        | Cons2 z xs => Cons2 z (ztake (x - 1) xs)
      end)"

fun zlength :: "'a list => int" where
"zlength (Nil2) = 0"
| "zlength (Cons2 y xs) = 1 + (zlength xs)"

fun zdrop :: "int => 'a list => 'a list" where
"zdrop x y =
   (if x = 0 then y else
      case y of
        | Nil2 => y
        | Cons2 z xs => zdrop (x - 1) xs
      end)"

fun zsplitAt :: "int => 'a list =>
                 (('a list), ('a list)) Pair2" where
"zsplitAt x y = Pair (ztake x y) (zdrop x y)"

fun sort2 :: "int => int => int list" where
"sort2 x y =
   (if x <= y then Cons2 x (Cons2 y (Nil2)) else
      Cons2 y (Cons2 x (Nil2)))"

fun count :: "int => int list => Nat" where
"count x (Nil2) = Z"
| "count x (Cons2 z xs) =
     (if x = z then S (count x xs) else count x xs)"

fun append :: "'a list => 'a list => 'a list" where
"append (Nil2) y = y"
| "append (Cons2 z xs) y = Cons2 z (append xs y)"

fun reverse :: "'t list => 't list" where
"reverse (Nil2) = Nil2"
| "reverse (Cons2 y xs) = append (reverse xs) (Cons2 y (Nil2))"

function stooge1sort2 :: "int list => int list"
         and stoogesort :: "int list => int list"
         and stooge1sort1 :: "int list => int list" where
"stooge1sort2 x =
   case zsplitAt (div (zlength x) 3) (reverse x) of
     | Pair ys zs =>
         case zsplitAt (div (zlength x) 3) (reverse x) of
           | Pair xs zs2 => append (stoogesort zs) (reverse xs)
         end
   end"
| "stoogesort (Nil2) = Nil2"
| "stoogesort (Cons2 y (Nil2)) = Cons2 y (Nil2)"
| "stoogesort (Cons2 y (Cons2 y2 (Nil2))) = sort2 y y2"
| "stoogesort (Cons2 y (Cons2 y2 (Cons2 x3 x4))) =
     stooge1sort2
       (stooge1sort1 (stooge1sort2 (Cons2 y (Cons2 y2 (Cons2 x3 x4)))))"
| "stooge1sort1 x =
     case zsplitAt (div (zlength x) 3) x of
       | Pair ys zs =>
           case zsplitAt (div (zlength x) 3) x of
             | Pair xs zs2 => append ys (stoogesort zs2)
           end
     end"
by pat_completeness auto

(*hipster ztake
          zlength
          zdrop
          zsplitAt
          sort2
          count
          append
          reverse
          stooge1sort2
          stoogesort
          stooge1sort1 *)

theorem x0 :
  "!! (x :: int) (y :: int list) .
     (count x (stoogesort y)) = (count x y)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


(*  Title:      HOL/Import/HOL_Light_Maps.thy
    Author:     Cezary Kaliszyk, University of Innsbruck
    Author:     Alexander Krauss, QAware GmbH

Based on earlier code by Steven Obua and Sebastian Skalberg
*)

section \<open>Type and constant mappings of HOL Light importer\<close>

theory HOL_Light_Maps
imports Import_Setup
begin

lemma [import_const T]:
  "True = ((\<lambda>p :: bool. p) = (\<lambda>p. p))"
  by simp

lemma [import_const "/\\"]:
  "(op \<and>) = (\<lambda>p q. (\<lambda>f. f p q :: bool) = (\<lambda>f. f True True))"
  by metis

lemma [import_const "==>"]:
  "(op \<longrightarrow>) = (\<lambda>(p::bool) q::bool. (p \<and> q) = p)"
  by auto

lemma [import_const "!"]:
  "All = (\<lambda>P::'A \<Rightarrow> bool. P = (\<lambda>x::'A. True))"
  by auto

lemma [import_const "?"]:
  "Ex = (\<lambda>P::'A \<Rightarrow> bool. All (\<lambda>q::bool. (All (\<lambda>x::'A::type. (P x) \<longrightarrow> q)) \<longrightarrow> q))"
  by auto

lemma [import_const "\\/"]:
  "(op \<or>) = (\<lambda>p q. \<forall>r. (p \<longrightarrow> r) \<longrightarrow> (q \<longrightarrow> r) \<longrightarrow> r)"
  by auto

lemma [import_const F]:
  "False = (\<forall>p. p)"
  by auto

lemma [import_const "~"]:
  "Not = (\<lambda>p. p \<longrightarrow> False)"
  by simp

lemma [import_const "?!"]:
  "Ex1 = (\<lambda>P::'A \<Rightarrow> bool. Ex P \<and> (\<forall>x y. P x \<and> P y \<longrightarrow> x = y))"
  by auto

lemma [import_const "_FALSITY_"]: "False = False"
  by simp

lemma hl_ax1: "\<forall>t::'A \<Rightarrow> 'B. (\<lambda>x. t x) = t"
  by metis

lemma hl_ax2: "\<forall>P x::'A. P x \<longrightarrow> P (Eps P)"
  by (auto intro: someI)

lemma [import_const COND]:
  "If = (\<lambda>t (t1 :: 'A) t2. SOME x. (t = True \<longrightarrow> x = t1) \<and> (t = False \<longrightarrow> x = t2))"
  unfolding fun_eq_iff by auto

lemma [import_const o]:
  "(op \<circ>) = (\<lambda>(f::'B \<Rightarrow> 'C) g x::'A. f (g x))"
  unfolding fun_eq_iff by simp

lemma [import_const I]: "id = (\<lambda>x::'A. x)"
  by auto

lemma [import_type 1 one_ABS one_REP]:
  "type_definition Rep_unit Abs_unit (Collect (\<lambda>b. b))"
  by (metis (full_types) Collect_cong singleton_conv2 type_definition_unit)

lemma [import_const one]: "() = (SOME x::unit. True)"
  by auto

lemma [import_const mk_pair]:
  "Pair_Rep = (\<lambda>(x::'A) (y::'B) (a::'A) b::'B. a = x \<and> b = y)"
  by (simp add: Pair_Rep_def fun_eq_iff)

lemma [import_type prod ABS_prod REP_prod]:
  "type_definition Rep_prod Abs_prod (Collect (\<lambda>x::'A \<Rightarrow> 'B \<Rightarrow> bool. \<exists>a b. x = Pair_Rep a b))"
  using type_definition_prod[unfolded Product_Type.prod_def] by simp

lemma [import_const ","]: "Pair = (\<lambda>(x::'A) y::'B. Abs_prod (Pair_Rep x y))"
  by (metis Pair_def)

lemma [import_const FST]:
  "fst = (\<lambda>p::'A \<times> 'B. SOME x::'A. \<exists>y::'B. p = (x, y))"
  by auto

lemma [import_const SND]:
  "snd = (\<lambda>p::'A \<times> 'B. SOME y::'B. \<exists>x::'A. p = (x, y))"
  by auto

lemma CURRY_DEF[import_const CURRY]:
  "curry = (\<lambda>(f::'A \<times> 'B \<Rightarrow> 'C) x y. f (x, y))"
  using curry_def .

lemma [import_const ONE_ONE : inj]:
  "inj = (\<lambda>(f::'A \<Rightarrow> 'B). \<forall>x1 x2. f x1 = f x2 \<longrightarrow> x1 = x2)"
  by (auto simp add: fun_eq_iff inj_on_def)

lemma [import_const ONTO : surj]:
  "surj = (\<lambda>(f::'A \<Rightarrow> 'B). \<forall>y. \<exists>x. y = f x)"
  by (auto simp add: fun_eq_iff)

lemma hl_ax3: "\<exists>f::ind \<Rightarrow> ind. inj f \<and> \<not> surj f"
  by (rule_tac x="Suc_Rep" in exI)
     (metis Suc_Rep_inject' injI Suc_Rep_not_Zero_Rep surjD)

import_type_map num : nat
import_const_map "_0" : zero_class.zero
import_const_map SUC : Suc

lemma NOT_SUC: "\<forall>n. Suc n \<noteq> 0"
  by simp

lemma SUC_INJ: "\<forall>m n. (Suc m = Suc n) = (m = n)"
  by simp

lemma num_INDUCTION:
  "\<forall>P. P 0 \<and> (\<forall>n. P n \<longrightarrow> P (Suc n)) \<longrightarrow> (\<forall>n. P n)"
  by (auto intro: nat.induct)

lemma [import_const NUMERAL]: "id = (\<lambda>x :: nat. x)"
  by auto

definition [simp]: "bit0 n = 2 * n"

lemma [import_const BIT0]:
  "bit0 = (SOME fn. fn (id 0) = id 0 \<and> (\<forall>n. fn (Suc n) = Suc (Suc (fn n))))"
  apply (auto intro!: some_equality[symmetric])
  apply (auto simp add: fun_eq_iff)
  apply (induct_tac x)
  apply auto
  done

definition [import_const BIT1, simp]:
  "bit1 = (\<lambda>x. Suc (bit0 x))"

definition [simp]: "pred n = n - 1"

lemma PRE[import_const PRE : pred]:
  "pred (id (0::nat)) = id (0::nat) \<and> (\<forall>n::nat. pred (Suc n) = n)"
  by simp

lemma ADD[import_const "+" : plus]:
  "(\<forall>n :: nat. (id 0) + n = n) \<and> (\<forall>m n. (Suc m) + n = Suc (m + n))"
  by simp

lemma MULT[import_const "*" : times]:
  "(\<forall>n :: nat. (id 0) * n = id 0) \<and> (\<forall>m n. (Suc m) * n = (m * n) + n)"
  by simp

lemma EXP[import_const EXP : power]:
  "(\<forall>m. m ^ (id 0) = id (bit1 0)) \<and> (\<forall>(m :: nat) n. m ^ (Suc n) = m * (m ^ n))"
  by simp

lemma LE[import_const "<=" : less_eq]:
  "(\<forall>m :: nat. m \<le> (id 0) = (m = id 0)) \<and> (\<forall>m n. m \<le> (Suc n) = (m = Suc n \<or> m \<le> n))"
  by auto

lemma LT[import_const "<" : less]:
  "(\<forall>m :: nat. m < (id 0) = False) \<and> (\<forall>m n. m < (Suc n) = (m = n \<or> m < n))"
  by auto

lemma DEF_GE[import_const ">=" : greater_eq]:
  "(op \<ge>) = (\<lambda>x y :: nat. y \<le> x)"
  by simp

lemma DEF_GT[import_const ">" : greater]:
  "(op >) = (\<lambda>x y :: nat. y < x)"
  by simp

lemma DEF_MAX[import_const "MAX"]:
  "max = (\<lambda>x y :: nat. if x \<le> y then y else x)"
  by (auto simp add: max.absorb_iff2 fun_eq_iff)

lemma DEF_MIN[import_const "MIN"]:
  "min = (\<lambda>x y :: nat. if x \<le> y then x else y)"
  by (auto simp add: min.absorb_iff1 fun_eq_iff)

definition even
where
  "even = Parity.even"

lemma EVEN[import_const "EVEN" : even]:
  "even (id 0::nat) = True \<and> (\<forall>n. even (Suc n) = (\<not> even n))"
  by (simp add: even_def)

lemma SUB[import_const "-" : minus]:
  "(\<forall>m::nat. m - (id 0) = m) \<and> (\<forall>m n. m - (Suc n) = pred (m - n))"
  by simp

lemma FACT[import_const "FACT" : fact]:
  "fact (id 0) = id (bit1 0) \<and> (\<forall>n. fact (Suc n) = Suc n * fact n)"
  by simp

import_const_map MOD : modulo
import_const_map DIV : divide

lemma DIVISION_0:
  "\<forall>m n::nat. if n = id 0 then m div n = id 0 \<and> m mod n = m else m = m div n * n + m mod n \<and> m mod n < n"
  by simp

lemmas [import_type sum "_dest_sum" "_mk_sum"] = type_definition_sum[where 'a="'A" and 'b="'B"]
import_const_map INL : Inl
import_const_map INR : Inr

lemma sum_INDUCT:
  "\<forall>P. (\<forall>a :: 'A. P (Inl a)) \<and> (\<forall>a :: 'B. P (Inr a)) \<longrightarrow> (\<forall>x. P x)"
  by (auto intro: sum.induct)

lemma sum_RECURSION:
  "\<forall>Inl' Inr'. \<exists>fn. (\<forall>a :: 'A. fn (Inl a) = (Inl' a :: 'Z)) \<and> (\<forall>a :: 'B. fn (Inr a) = Inr' a)"
  by (intro allI, rule_tac x="case_sum Inl' Inr'" in exI) auto

lemma OUTL[import_const "OUTL" : projl]:
  "Sum_Type.projl (Inl x) = x"
  by simp

lemma OUTR[import_const "OUTR" : projr]:
  "Sum_Type.projr (Inr y) = y"
  by simp

import_type_map list : list
import_const_map NIL : Nil
import_const_map CONS : Cons

lemma list_INDUCT:
  "\<forall>P::'A list \<Rightarrow> bool. P [] \<and> (\<forall>a0 a1. P a1 \<longrightarrow> P (a0 # a1)) \<longrightarrow> (\<forall>x. P x)"
  using list.induct by auto

lemma list_RECURSION:
 "\<forall>nil' cons'. \<exists>fn::'A list \<Rightarrow> 'Z. fn [] = nil' \<and> (\<forall>(a0::'A) a1::'A list. fn (a0 # a1) = cons' a0 a1 (fn a1))"
  by (intro allI, rule_tac x="rec_list nil' cons'" in exI) auto

lemma HD[import_const HD : hd]:
  "hd ((h::'A) # t) = h"
  by simp

lemma TL[import_const TL : tl]:
  "tl ((h::'A) # t) = t"
  by simp

lemma APPEND[import_const APPEND : append]:
  "(\<forall>l::'A list. [] @ l = l) \<and> (\<forall>(h::'A) t l. (h # t) @ l = h # t @ l)"
  by simp

lemma REVERSE[import_const REVERSE : rev]:
  "rev [] = ([] :: 'A list) \<and> rev ((x::'A) # l) = rev l @ [x]"
  by simp

lemma LENGTH[import_const LENGTH : length]:
  "length ([] :: 'A list) = id 0 \<and> (\<forall>(h::'A) t. length (h # t) = Suc (length t))"
  by simp

lemma MAP[import_const MAP : map]:
  "(\<forall>f::'A \<Rightarrow> 'B. map f [] = []) \<and>
       (\<forall>(f::'A \<Rightarrow> 'B) h t. map f (h # t) = f h # map f t)"
  by simp

lemma LAST[import_const LAST : last]:
  "last ((h::'A) # t) = (if t = [] then h else last t)"
  by simp

lemma BUTLAST[import_const BUTLAST : butlast]:
    "butlast [] = ([] :: 't18337 list) \<and>
     butlast ((h :: 't18337) # t) = (if t = [] then [] else h # butlast t)"
  by simp

lemma REPLICATE[import_const REPLICATE : replicate]:
  "replicate (id (0::nat)) (x::'t18358) = [] \<and>
   replicate (Suc n) x = x # replicate n x"
  by simp

lemma NULL[import_const NULL : List.null]:
  "List.null ([]::'t18373 list) = True \<and> List.null ((h::'t18373) # t) = False"
  unfolding null_def by simp

lemma ALL[import_const ALL : list_all]:
  "list_all (P::'t18393 \<Rightarrow> bool) [] = True \<and>
  list_all P (h # t) = (P h \<and> list_all P t)"
  by simp

lemma EX[import_const EX : list_ex]:
  "list_ex (P::'t18414 \<Rightarrow> bool) [] = False \<and>
  list_ex P (h # t) = (P h \<or> list_ex P t)"
  by simp

lemma ITLIST[import_const ITLIST : foldr]:
  "foldr (f::'t18437 \<Rightarrow> 't18436 \<Rightarrow> 't18436) [] b = b \<and>
  foldr f (h # t) b = f h (foldr f t b)"
  by simp

lemma ALL2_DEF[import_const ALL2 : list_all2]:
  "list_all2 (P::'t18495 \<Rightarrow> 't18502 \<Rightarrow> bool) [] (l2::'t18502 list) = (l2 = []) \<and>
  list_all2 P ((h1::'t18495) # (t1::'t18495 list)) l2 =
  (if l2 = [] then False else P h1 (hd l2) \<and> list_all2 P t1 (tl l2))"
  by simp (induct_tac l2, simp_all)

lemma FILTER[import_const FILTER : filter]:
  "filter (P::'t18680 \<Rightarrow> bool) [] = [] \<and>
  filter P ((h::'t18680) # t) = (if P h then h # filter P t else filter P t)"
  by simp

lemma ZIP[import_const ZIP : zip]:
 "zip [] [] = ([] :: ('t18824 \<times> 't18825) list) \<and>
  zip ((h1::'t18849) # t1) ((h2::'t18850) # t2) = (h1, h2) # zip t1 t2"
  by simp

lemma WF[import_const WF : wfP]:
  "\<forall>u. wfP u \<longleftrightarrow> (\<forall>P. (\<exists>x :: 'A. P x) \<longrightarrow> (\<exists>x. P x \<and> (\<forall>y. u y x \<longrightarrow> \<not> P y)))"
proof (intro allI iffI impI wfI_min[to_pred], elim exE wfE_min[to_pred])
  fix x :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and xa :: "'a" and Q
  assume a: "xa \<in> Q"
  assume "\<forall>P. Ex P \<longrightarrow> (\<exists>xa. P xa \<and> (\<forall>y. x y xa \<longrightarrow> \<not> P y))"
  then have "Ex (\<lambda>x. x \<in> Q) \<longrightarrow> (\<exists>xa. (\<lambda>x. x \<in> Q) xa \<and> (\<forall>y. x y xa \<longrightarrow> \<not> (\<lambda>x. x \<in> Q) y))" by auto
  then show "\<exists>z\<in>Q. \<forall>y. x y z \<longrightarrow> y \<notin> Q" using a by auto
next
  fix x P and xa :: 'A and z
  assume "P xa" "z \<in> {a. P a}" "\<And>y. x y z \<Longrightarrow> y \<notin> {a. P a}"
  then show "\<exists>xa. P xa \<and> (\<forall>y. x y xa \<longrightarrow> \<not> P y)" by auto
qed auto

end


(*  Title:      ZF/InfDatatype.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section\<open>Infinite-Branching Datatype Definitions\<close>

theory InfDatatype imports Datatype_ZF Univ Finite Cardinal_AC begin

lemmas fun_Limit_VfromE =
    Limit_VfromE [OF apply_funtype InfCard_csucc [THEN InfCard_is_Limit]]

lemma fun_Vcsucc_lemma:
  assumes f: "f \<in> D -> Vfrom(A,csucc(K))" and DK: "|D| \<le> K" and ICK: "InfCard(K)"
  shows "\<exists>j. f \<in> D -> Vfrom(A,j) & j < csucc(K)"
proof (rule exI, rule conjI)
  show "f \<in> D \<rightarrow> Vfrom(A, \<Union>z\<in>D. \<mu> i. f`z \<in> Vfrom (A,i))"
    proof (rule Pi_type [OF f])
      fix d
      assume d: "d \<in> D"
      show "f ` d \<in> Vfrom(A, \<Union>z\<in>D. \<mu> i. f ` z \<in> Vfrom(A, i))"
        proof (rule fun_Limit_VfromE [OF f d ICK])
          fix x
          assume "x < csucc(K)"  "f ` d \<in> Vfrom(A, x)"
          hence "f`d \<in> Vfrom(A, \<mu> i. f`d \<in> Vfrom (A,i))" using d
            by (fast elim: LeastI ltE)
          also have "... \<subseteq> Vfrom(A, \<Union>z\<in>D. \<mu> i. f ` z \<in> Vfrom(A, i))"
            by (rule Vfrom_mono) (auto intro: d)
          finally show "f`d \<in> Vfrom(A, \<Union>z\<in>D. \<mu> i. f ` z \<in> Vfrom(A, i))" .
        qed
    qed
next
  show "(\<Union>d\<in>D. \<mu> i. f ` d \<in> Vfrom(A, i)) < csucc(K)"
    proof (rule le_UN_Ord_lt_csucc [OF ICK DK])
      fix d
      assume d: "d \<in> D"
      show "(\<mu> i. f ` d \<in> Vfrom(A, i)) < csucc(K)"
        proof (rule fun_Limit_VfromE [OF f d ICK])
          fix x
          assume "x < csucc(K)"  "f ` d \<in> Vfrom(A, x)"
          thus "(\<mu> i. f ` d \<in> Vfrom(A, i)) < csucc(K)"
            by (blast intro: Least_le lt_trans1 lt_Ord)
        qed
    qed
qed

lemma subset_Vcsucc:
     "[| D \<subseteq> Vfrom(A,csucc(K));  |D| \<le> K;  InfCard(K) |]
      ==> \<exists>j. D \<subseteq> Vfrom(A,j) & j < csucc(K)"
by (simp add: subset_iff_id fun_Vcsucc_lemma)

(*Version for arbitrary index sets*)
lemma fun_Vcsucc:
     "[| |D| \<le> K;  InfCard(K);  D \<subseteq> Vfrom(A,csucc(K)) |] ==>
          D -> Vfrom(A,csucc(K)) \<subseteq> Vfrom(A,csucc(K))"
apply (safe dest!: fun_Vcsucc_lemma subset_Vcsucc)
apply (rule Vfrom [THEN ssubst])
apply (drule fun_is_rel)
(*This level includes the function, and is below csucc(K)*)
apply (rule_tac a1 = "succ (succ (j \<union> ja))" in UN_I [THEN UnI2])
apply (blast intro: ltD InfCard_csucc InfCard_is_Limit Limit_has_succ
                    Un_least_lt)
apply (erule subset_trans [THEN PowI])
apply (fast intro: Pair_in_Vfrom Vfrom_UnI1 Vfrom_UnI2)
done

lemma fun_in_Vcsucc:
     "[| f: D -> Vfrom(A, csucc(K));  |D| \<le> K;  InfCard(K);
         D \<subseteq> Vfrom(A,csucc(K)) |]
       ==> f: Vfrom(A,csucc(K))"
by (blast intro: fun_Vcsucc [THEN subsetD])

text\<open>Remove \<open>\<subseteq>\<close> from the rule above\<close>
lemmas fun_in_Vcsucc' = fun_in_Vcsucc [OF _ _ _ subsetI]

(** Version where K itself is the index set **)

lemma Card_fun_Vcsucc:
     "InfCard(K) ==> K -> Vfrom(A,csucc(K)) \<subseteq> Vfrom(A,csucc(K))"
apply (frule InfCard_is_Card [THEN Card_is_Ord])
apply (blast del: subsetI
             intro: fun_Vcsucc Ord_cardinal_le i_subset_Vfrom
                   lt_csucc [THEN leI, THEN le_imp_subset, THEN subset_trans])
done

lemma Card_fun_in_Vcsucc:
     "[| f: K -> Vfrom(A, csucc(K));  InfCard(K) |] ==> f: Vfrom(A,csucc(K))"
by (blast intro: Card_fun_Vcsucc [THEN subsetD])

lemma Limit_csucc: "InfCard(K) ==> Limit(csucc(K))"
by (erule InfCard_csucc [THEN InfCard_is_Limit])

lemmas Pair_in_Vcsucc = Pair_in_VLimit [OF _ _ Limit_csucc]
lemmas Inl_in_Vcsucc = Inl_in_VLimit [OF _ Limit_csucc]
lemmas Inr_in_Vcsucc = Inr_in_VLimit [OF _ Limit_csucc]
lemmas zero_in_Vcsucc = Limit_csucc [THEN zero_in_VLimit]
lemmas nat_into_Vcsucc = nat_into_VLimit [OF _ Limit_csucc]

(*For handling Cardinals of the form  @{term"nat \<union> |X|"} *)

lemmas InfCard_nat_Un_cardinal = InfCard_Un [OF InfCard_nat Card_cardinal]

lemmas le_nat_Un_cardinal =
     Un_upper2_le [OF Ord_nat Card_cardinal [THEN Card_is_Ord]]

lemmas UN_upper_cardinal = UN_upper [THEN subset_imp_lepoll, THEN lepoll_imp_Card_le]

(*The new version of Data_Arg.intrs, declared in Datatype.ML*)
lemmas Data_Arg_intros =
       SigmaI InlI InrI
       Pair_in_univ Inl_in_univ Inr_in_univ
       zero_in_univ A_into_univ nat_into_univ UnCI

(*For most K-branching datatypes with domain Vfrom(A, csucc(K)) *)
lemmas inf_datatype_intros =
     InfCard_nat InfCard_nat_Un_cardinal
     Pair_in_Vcsucc Inl_in_Vcsucc Inr_in_Vcsucc
     zero_in_Vcsucc A_into_Vfrom nat_into_Vcsucc
     Card_fun_in_Vcsucc fun_in_Vcsucc' UN_I

end