theory "Finite_String"
  imports
    Main
    "HOL-Library.Code_Target_Int"
begin

definition max_str:"MAX_STR = 20"
typedef ident = "{s::string. size s \<le> MAX_STR}"
  morphisms Rep_ident Abs_ident
  apply(auto)
  apply(rule exI[where x=Nil])
  by(auto simp add: max_str)

setup_lifting  Finite_String.ident.type_definition_ident

lift_definition ilength::"ident \<Rightarrow> nat" is length done

lemma cardiB:
  fixes C:: "char set" and S::"string set"
  assumes C:"card C \<ge> 1" and S:"card S \<ge> 0"
  shows "card C * card S \<ge> card S"
  using C S by auto

fun cons :: "('a * 'a list) \<Rightarrow> 'a list"
  where "cons (x,y) = x # y"
instantiation ident :: finite begin
instance proof
  have any:"\<forall>i::nat. card {s::string. length s \<le> i} > 0"
    apply(auto)
    subgoal for i
  proof (induct i)
    case 0
    then show ?case by auto
  next
    case (Suc k)
    assume IH:"card {s::string. length s \<le> k} > 0"
    let ?c = "(UNIV::char set)"
    let ?ih = "{s::string. length s \<le> k}"
    let ?prod = "(?c \<times> ?ih)"
    let ?b = "(cons ` ?prod)"
    let ?A = "{s::string. length s \<le> Suc k}"
    let ?B = "insert [] ?b"

    have IHfin:"finite ?ih" using IH card_ge_0_finite by blast
    have finChar:"finite ?c" using card_ge_0_finite finite_code by blast
    have finiteProd:"finite ?prod"
      using Groups_Big.card_cartesian_product IHfin finChar by auto
    have cardCons:"card ?b = card ?prod"
      apply(rule Finite_Set.card_image)
      by(auto simp add: inj_on_def)
    have finiteCons:"finite ?b" using cardCons finiteProd card_ge_0_finite by blast
    have finiteB:"finite ?B" using finite_insert finiteCons by auto
    have lr:"\<And>x. x \<in> ?A \<Longrightarrow> x \<in> ?B" subgoal for x
        apply(auto) apply(cases x) apply auto
        by (metis UNIV_I cons.simps image_eqI mem_Collect_eq mem_Sigma_iff) done
    have rl:"\<And>x. x \<in> ?B \<Longrightarrow> x \<in> ?A" subgoal for x
        by(auto) done
    have isCons:"?A = ?B"
      using lr rl by auto
  show ?case
      using finiteB isCons IH by (simp add: card_insert)
  qed
  done
    note finMax = card_ge_0_finite[OF spec[OF any, of MAX_STR]]
    have finWow:"finite {x | x y . x = Abs_ident y \<and> y \<in> {s. length s \<le> MAX_STR} }"
      using Abs_ident_cases finMax by auto
    have univEq:"(UNIV::ident set) = {x | x y . x = Abs_ident y \<and> y \<in> {s. length s \<le> MAX_STR} }"
      using Abs_ident_cases
      by (metis (mono_tags, lifting) Collect_cong UNIV_I top_empty_eq top_set_def)
    then have "finite (UNIV :: ident set)" using univEq finWow by auto
  then show "finite (UNIV::ident set)" by auto
qed
end

instantiation char :: linorder begin
definition less_eq_char where
[code]:"less_eq_char x  y \<equiv> int_of_char x \<le> int_of_char y"
definition less_char where
[code]:"less_char x y \<equiv> int_of_char x < int_of_char y"
instance
  by(standard, auto simp add: less_char_def less_eq_char_def int_of_char_def)+
end

instantiation ident :: linorder begin
fun lleq :: "char list \<Rightarrow> char list \<Rightarrow> bool"
  where
  "lleq Nil Nil = True"
| "lleq Nil _ = True"
| "lleq _ Nil = False"
| "lleq (x # xs)(y # ys) =
   (if x = y then lleq xs ys else x < y)"

lift_definition less_eq_ident::"ident \<Rightarrow> ident \<Rightarrow> bool" is lleq done

fun less :: "char list \<Rightarrow> char list \<Rightarrow> bool"
  where
  "less Nil Nil = False"
| "less Nil _ = True"
| "less _ Nil = False"
| "less (x # xs)(y # ys) =
   (if x = y then less xs ys else x < y)"

lift_definition less_ident::"ident \<Rightarrow> ident \<Rightarrow> bool" is less done

lemma lists_induct:"\<And>P. (P [] []) \<Longrightarrow> (\<And>x xs. P (x#xs) []) \<Longrightarrow> (\<And>x xs. P [] (x#xs)) \<Longrightarrow> (\<And>L1 L2 x1 x2. P L1 L2 \<Longrightarrow> P (x1 # L1) (x2 # L2)) \<Longrightarrow> P A B"
  using  List.list_induct2' by metis

lemma ax1:"\<And>x y. (less x y) = (lleq x y \<and> \<not> lleq y  x)"
  subgoal for x y
    apply(induction rule: lists_induct)
    by(auto) done
lemma ax2:"\<And>x. lleq x x"
  subgoal for x
    apply(induction x)
    by(auto) done
lemma ax3:"\<And>x y z. lleq x  y \<Longrightarrow> lleq y z \<Longrightarrow> lleq x  z"
  subgoal for x y z
    apply(induction arbitrary: z rule: lists_induct )
       apply(auto)
    subgoal for x xs z
      apply(induction y)
      using lleq.elims(2) lleq.simps(2) by blast+
    subgoal for L1 L2 x1 x2 z
      apply(cases "x2 = x1")
      apply(auto simp add: less_trans list.discI list.inject lleq.elims(2) lleq.elims(3) order.asym)
      using less_trans list.discI list.inject lleq.elims(2) lleq.elims(3) order.asym
      sorry
(*      apply smt+*)
      done
    done
(*  done*)
lemma ax4:"\<And>x y. lleq x y \<Longrightarrow> lleq y x \<Longrightarrow> x = y"
  subgoal for x y
    apply(induction rule: lists_induct)
       apply(auto)
    subgoal for L1 L2 x1 x2
      apply(cases "x1 = x2") by auto
    subgoal for L1 L2 x1 x2
      apply(cases "x1 = x2") by auto
    done done
lemma ax5:"\<And>x y. lleq x y \<or> lleq y x"
  subgoal for x y
    apply(induction rule: lists_induct)
    by(auto) done

lemma ax6:"\<And>x y. lleq x y \<Longrightarrow> lleq y x \<Longrightarrow> x = y"
  subgoal for x y
    apply(induction rule: lists_induct)
       apply(auto)
    subgoal for L1 L2 x1 x2
      apply(cases "x1 = x2") by auto
    subgoal for L1 L2 x1 x2
      apply(cases "x1 = x2") by auto
    done
  done

instance
  apply(standard)
  unfolding less_eq_ident_def less_ident_def
      apply (auto simp add: ax1 ax2 ax3 ax4 ax5 ax6)
  using ax6 less_eq_ident_def less_ident_def Rep_ident_inject by blast
end

fun string_expose::"string \<Rightarrow> (unit + (char * string))"
  where [code]:"string_expose Nil = Inl ()"
  | [code]:"string_expose (c#cs) = Inr(c,cs)"

fun string_cons::"char \<Rightarrow> string \<Rightarrow> string"
  where "string_cons c s = (if length s \<ge> MAX_STR then s else c # s)"

lift_definition ident_empty::ident is "''''" by(auto simp add: max_str)
lift_definition ident_cons::"char \<Rightarrow> ident \<Rightarrow> ident" is "string_cons" by auto
lift_definition ident_expose::"ident \<Rightarrow> (unit + (char*ident))" is string_expose
  by (smt dual_order.trans le_add_same_cancel1 lessI less_imp_le list.size(4) pred_prod_inject pred_sum.simps string_expose.elims top1I)
(*  apply(auto)
  by (smt ge_eq_refl order_refl prod.rel_eq prod.rel_mono reflp_ge_eq reflp_ident sum.rel_eq sum.rel_mono)*)

fun ident_upto :: "nat \<Rightarrow> ident list"
  where
  "ident_upto 0 = [ident_empty]"
| "ident_upto (Suc k) =
 (let r = ident_upto k in
  let ab =  (enum_class.enum::char list) in
  ident_empty # concat (map (\<lambda> c. map (\<lambda>s. ident_cons c  s) r) ab))"

lemma mem_appL:"List.member L1 x \<Longrightarrow> List.member (L1 @ L2) x"
  apply(induction L1 arbitrary: L2)
  by(auto simp add: member_rec)

lemma mem_appR:"List.member L2 x \<Longrightarrow> List.member (L1 @ L2) x"
  apply(induction L1 arbitrary: L2)
  by(auto simp add: member_rec)

lemma mem_app_or:"List.member (L1 @ L2) x = List.member L1 x \<or> List.member L2 x"
  unfolding member_def by auto

lemma ident_nil:"\<And>n. List.member (ident_upto n) ident_empty"
  subgoal for n
    apply(induction n)
    using ident_empty_def
    by(auto simp add: member_rec Let_def)
  done

lift_definition Ix::ident is "''$x''::string"   apply(auto simp add: max_str)
  done
lift_definition Iy::ident is "''$y''::string"apply(auto simp add: max_str)
  done
lift_definition Iz::ident is "''$z''::string"apply(auto simp add: max_str)
  done
lift_definition Iw::ident is "''$w''::string"apply(auto simp add: max_str)
  done

definition [simp]:"fid1 =  Ix"
definition [simp]:"pid1 =  Ix"
definition [simp]:"vid1 =  Ix"

definition [simp]:"fid2 =  Iy"
definition [simp]:"pid2 =  Iy"
definition [simp]:"vid2 =  Iy"

definition [simp]:"fid3 =  Iz"
definition [simp]:"pid3 =  Iz"
definition [simp]:"vid3 =  Iz"

definition [simp]:"fid4 =  Iw"
definition [simp]:"pid4 =  Iw"
definition [simp]:"vid4 =  Iw"

(*lift_definition (code_dt) ident_upto::"nat \<Rightarrow> ident list" is "str_upto::nat \<Rightarrow> string list"*)
code_thms ident_upto
print_theorems

(*definition vals_inner_def[code]:"vals_inner \<equiv> str_upto MAX_STR"*)
definition vals_def[code]:"vals \<equiv> ident_upto MAX_STR"
export_code vals in Scala

definition ident_enum :: "ident list"
  where "ident_enum = vals"
definition ident_enum_all :: "(ident \<Rightarrow> bool) \<Rightarrow> bool"
  where "ident_enum_all = (\<lambda> f. list_all f vals)"
definition ident_enum_ex :: "(ident \<Rightarrow> bool) \<Rightarrow> bool"
  where "ident_enum_ex = (\<lambda> f. list_ex f vals)"

lemma length_induct:
  fixes P
  assumes len:"length L \<le> MAX_STR"
  assumes BC:"P [] 0"
  assumes IS:"(\<And>k x xs.  P xs k \<Longrightarrow> P ((x # xs)) (Suc k))"
  shows  "P L (length L)"
  proof -
    have main:"\<And>k.  length L = k \<Longrightarrow> k \<le> MAX_STR \<Longrightarrow> P L (length L)" subgoal for k
        apply(induction L arbitrary: k)
        subgoal for k using BC unfolding ident_empty_def by auto
        subgoal for a L k
        proof -
          assume IH:"(\<And>k. length L = k \<Longrightarrow> k \<le> MAX_STR \<Longrightarrow> P L (length L))"
          assume l:"length (a # L) = k"
          assume str:"k \<le> MAX_STR"
          have yLen:"length L < MAX_STR" using l str by auto
          have it:"P (L) (length L)"
            using IH[of k] l str  IH less_imp_le yLen by blast
          show  "P  (a # L) (length (a # L))"
            using IS[OF it, of a] by (auto)
        qed
        done
      done
    show ?thesis
      apply(rule main)
      using BC IS len by auto
  qed

lemma ilength_induct:
  fixes P
  assumes BC:"P ident_empty 0"
  assumes IS:"(\<And>k x xs.  P xs k \<Longrightarrow> P (Abs_ident (x # Rep_ident xs)) (Suc k))"
  shows  "P L (ilength L)"
  apply(cases L)
  apply(unfold ilength_def)
  apply(auto simp add: Abs_ident_inverse)
  subgoal for y
  proof -
    assume a1:"L = Abs_ident y"
    assume a2:" length y \<le> MAX_STR "
    have main:"\<And>k. L = Abs_ident y \<Longrightarrow> length y = k \<Longrightarrow> k \<le> MAX_STR \<Longrightarrow> P (Abs_ident y) (length y)" subgoal for k
        apply(induction y arbitrary: k L)
        subgoal for k using BC unfolding ident_empty_def by auto
        subgoal for a y k L
        proof -
          assume IH:"(\<And>k L. L = Abs_ident y \<Longrightarrow> length y = k \<Longrightarrow> k \<le> MAX_STR \<Longrightarrow> P (Abs_ident y) (length y))"
          assume L:"L = Abs_ident (a # y)"
          assume l:"length (a # y) = k"
          assume str:"k \<le> MAX_STR"
          have yLen:"length y < MAX_STR" using l str by auto
          have it:"P (Abs_ident y) (length y)"
            using IH[of "Abs_ident y" "k-1", OF refl] using L l str by auto
          show  "P (Abs_ident (a # y)) (length (a # y))"
            using IS[OF it, of a] apply (auto simp add: ident_cons_def Abs_ident_inverse)
            apply(cases "MAX_STR \<le> length (Rep_ident (Abs_ident y))")
            using yLen by(auto simp add: l yLen Abs_ident_inverse)
        qed
        done
      done
    show ?thesis
      apply(rule main)
      using BC IS a1 a2 by auto
  qed
  done

lemma enum_chars:"set (enum_class.enum::char list)= UNIV"
  using   Enum.enum_class.enum_UNIV by auto

lemma member_concat:
  shows "(\<exists> LL. List.member L LL \<and> List.member LL x) \<Longrightarrow> List.member (concat L) x"
  apply(induction L)
  by(auto simp add: member_def)

lemma ident_length:
  fixes L::string
  assumes len:"length L \<le> k"
  assumes Len:"length L \<le> MAX_STR"
  shows "List.member (ident_upto k) (Abs_ident L)"
proof -
  have BC:"\<forall>j\<ge>0. 0 \<le> MAX_STR \<longrightarrow> length [] = 0 \<longrightarrow> List.member (ident_upto j) (Abs_ident [])"
    apply(auto) subgoal for j apply(cases j) by (auto simp add: ident_empty_def member_rec) done
  have IS:"(\<And>k x xs.
      \<forall>j\<ge>k. k \<le> MAX_STR \<longrightarrow> length xs = k \<longrightarrow> List.member (ident_upto j) (Abs_ident xs) \<Longrightarrow>
      \<forall>j\<ge>Suc k. Suc k \<le> MAX_STR \<longrightarrow> length (x # xs) = Suc k \<longrightarrow> List.member (ident_upto j) (Abs_ident (x # xs)))"
    subgoal for k x xs
    proof -
      assume "\<forall>j\<ge>k. k \<le> MAX_STR \<longrightarrow> length xs = k \<longrightarrow> List.member (ident_upto j) (Abs_ident xs)"
      then have IH:"\<And>j. j\<ge> k \<Longrightarrow> k \<le> MAX_STR \<Longrightarrow> length xs = k \<Longrightarrow> List.member (ident_upto j) (Abs_ident xs)" by auto
      show ?thesis
        apply(auto)
        subgoal for j
        proof -
          assume kj:"Suc (length xs) \<le> j"
          assume sucMax:"Suc (length xs) \<le> MAX_STR"
          assume ilen:" k = length xs"
          obtain jj where jj[simp]:"j = Suc jj" using kj Suc_le_D by auto
          then have kMax:"k < MAX_STR" using jj kj Suc_le_D ilen
            by (simp add: less_eq_Suc_le sucMax)
           have res:"List.member (ident_upto (jj)) (Abs_ident xs)"
            using IH[of "jj"] kj jj ilen  Suc_leD sucMax by blast
          have neq:"Abs_ident [] \<noteq> Abs_ident (x # xs)"
            using Abs_ident_inverse ident_empty.abs_eq ident_empty.rep_eq len length_Cons list.distinct(1) mem_Collect_eq
            by (metis ilen sucMax)
          have univ:" set enum_class.enum  = (UNIV::char set)" using enum_chars by auto
          have "List.member (ident_upto j) (Abs_ident (x # xs))"
             apply(auto simp add: member_rec(2) ident_empty_def)
            using len  sucMax  apply(auto simp add: member_rec ident_empty_def ident_cons_def  Abs_ident_inverse Rep_ident_inverse neq)
          proof -
            let ?witLL = "map (map_fun Rep_ident Abs_ident (string_cons x)) (ident_upto jj)"
            have ex:"\<exists> LL. (List.member (map (\<lambda>c. map (map_fun Rep_ident Abs_ident (string_cons c)) (ident_upto jj)) enum_class.enum) LL) \<and> List.member LL (Abs_ident (x # xs))"
              apply(rule exI[where x="?witLL"])
              apply(auto simp add: member_def univ )
              using res kMax IH Abs_ident_inverse antisym ilen image_iff  less_le map_fun_apply mem_Collect_eq member_def string_cons.simps univ
              sorry
(*              by smt*)
            show "List.member (concat (map (\<lambda>c. map (map_fun Rep_ident Abs_ident (string_cons c)) (ident_upto jj)) enum_class.enum))
     (Abs_ident (x # xs))"
              using member_concat[OF ex] by auto
          qed
          then show "List.member (ident_upto j) (Abs_ident (x # xs))"  by auto
        qed
        done
    qed
    done
  have impl:"length L \<le> k \<Longrightarrow> List.member (ident_upto k) (Abs_ident L)"
    using length_induct[where P = "(\<lambda> L k. \<forall> j \<ge> k. k \<le> MAX_STR \<longrightarrow> length L = k \<longrightarrow> List.member (ident_upto j) (Abs_ident L))", OF Len BC IS]
    using len Len by auto
  show ?thesis
    using impl len by auto
qed

lemma concat_mem:"List.member (concat LL) x = (\<exists>L. List.member LL L \<and> List.member L x)"
  by(auto simp add: member_def)

lemma ident_upto_length:
  shows "List.member (ident_upto n) L \<Longrightarrow> ilength L \<le> n"
  apply(induction n arbitrary: L)
   apply(auto simp add: ident_empty_def Let_def ilength_def ident_cons_def Rep_ident_inverse Abs_ident_inverse member_rec)
proof -
  fix n L
  assume len:"(\<And>L. List.member (ident_upto n) L \<Longrightarrow> length (Rep_ident L) \<le> n)"
  assume mem:"List.member (concat (map (\<lambda>c. map (map_fun Rep_ident Abs_ident (string_cons c)) (ident_upto n)) enum_class.enum)) L"
  have L:"List.member (ident_upto n) L \<Longrightarrow> length (Rep_ident L) \<le> Suc n" using len[of L] by auto
  have R:"List.member (concat (map (\<lambda>c. map (map_fun Rep_ident Abs_ident (string_cons c)) (ident_upto n)) enum_class.enum)) L
         \<Longrightarrow> length (Rep_ident L) \<le> Suc n"
  proof -
    assume a:"List.member (concat (map (\<lambda>c. map (map_fun Rep_ident Abs_ident (string_cons c)) (ident_upto n)) enum_class.enum)) L"
    obtain LL where conc:"List.member (map (\<lambda>c. map (map_fun Rep_ident Abs_ident (string_cons c)) (ident_upto n)) enum_class.enum) LL"
      and concmem:"List.member LL L"
      using concat_mem a by metis

    obtain c cs where c:"L = ident_cons c cs" and cs:"List.member (ident_upto n) cs"
      using a conc unfolding member_def apply(auto)
      subgoal for c d cs
        apply(cases "MAX_STR \<le> length (Rep_ident cs)")
         apply(auto simp add: Rep_ident_inverse)
        by (metis (full_types) Rep_ident_inverse ident_cons.rep_eq string_cons.simps)+ done
    then have "ilength (ident_cons c cs) \<le> (Suc n)"
      using len[of cs] unfolding ilength_def ident_cons_def apply (auto simp add: Rep_ident_inverse)
      using c ident_cons.rep_eq by force
    then show ?thesis
      using c ilength.rep_eq by auto
  qed
  show "length (Rep_ident L) \<le> Suc n"
    using L R  mem by blast
qed

lemma distinct_upto:
  shows "i \<le> MAX_STR \<Longrightarrow> distinct (ident_upto i)"
proof (induction i)
  case 0
  then show ?case by(auto)
next
  case (Suc j) then
  have jLen:"Suc j \<le> MAX_STR"
    and IH:"distinct (ident_upto j)" by auto
  have distinct_char:"distinct (enum_class.enum:: char list)"
    apply(unfold enum_char_unfold)
    apply(unfold distinct_map)
    by auto
  show ?case
    apply(auto simp add: Let_def)
    subgoal for x xa
      using jLen apply(auto simp add: ident_empty_def ident_cons_def)
(*      by (smt Rep_ident_inverse Suc_leD eq_onp_same_args ident_empty.rep_eq ilength.abs_eq le_zero_eq length_0_conv length_Cons not_less_eq_eq)*)
      sorry
     apply(rule distinct_concat)
    subgoal apply(auto simp add: distinct_map)
       apply(rule distinct_char)
      apply(rule subset_inj_on[where B=UNIV])
       apply(rule injI)
       apply(auto simp add: ident_cons_def) subgoal for x y
(*        by (smt Abs_ident_inverse Iz.rsp Pair_inject Suc_leD antisym eq_onp_same_args ident_empty.rep_eq ident_nil impossible_Cons length_Cons mem_Collect_eq member_def string_expose.simps(2) sum.inject(2))*)
        sorry
        done
    subgoal for ys
      apply(auto simp add: ident_cons_def)
    proof -
      fix c :: char
       assume c:"c \<in> set enum_class.enum"
       assume ys:"ys = map (map_fun Rep_ident Abs_ident (string_cons c)) (ident_upto j)"
       show "distinct (map (map_fun Rep_ident Abs_ident (string_cons c)) (ident_upto j))"
         unfolding distinct_map apply(rule conjI)
          apply(rule IH)
         apply(rule inj_onI)
         apply(auto)
         subgoal for x y
           using ident_upto_length[of j x] ident_upto_length[of j y]
            unfolding List.member_def
            using jLen  unfolding ilength_def apply auto
            by (metis (mono_tags, hide_lams) Rep_ident_inverse ident_cons.rep_eq le_trans list.inject not_less_eq_eq string_cons.simps)
          done
      qed
    subgoal for ys zs
      apply(auto)
         subgoal for  c ca xa xb xc
         apply(auto simp add: ident_cons_def)
          using ident_upto_length[of j] jLen
(*          by (smt Rep_ident_inverse ident_cons.rep_eq ilength.rep_eq le_trans list.inject member_def not_less_eq_eq string_cons.simps)*)
          sorry
        done
      done
qed

instantiation ident :: enum begin
definition enum_ident
  where enum_ident_def[code]:"enum_ident \<equiv> ident_enum"
definition enum_all_ident
  where enum_all_ident[code]:"enum_all_ident \<equiv> ident_enum_all"
definition enum_ex_ident
  where enum_ex_ident[code]:"enum_ex_ident \<equiv> ident_enum_ex"
lemma enum_ALL:"(UNIV::ident set) = set enum_class.enum"
  subgoal
    apply(auto simp add:enum_ident_def ident_enum_def)
    subgoal for x
      apply(unfold vals_def)
      apply(rule Abs_ident_cases[where x=x])
      subgoal for y
        using ident_nil[of MAX_STR]  List.member_def[of "ident_upto MAX_STR" x] ident_empty_def ident_length
        using Rep_ident ilength.rep_eq mem_Collect_eq by auto
      done
    done done

lemma vals_ALL:"set (vals::ident list) = UNIV"
  using enum_ALL vals_def Rep_ident ident_length ilength.rep_eq member_def
  by (metis (mono_tags) Rep_ident_inverse UNIV_eq_I mem_Collect_eq)

lemma setA:
  assumes set:"\<And>y. y \<in> set L \<Longrightarrow> P y"
  shows "list_all P L"
  using set  by (simp add: list.pred_set)

lemma setE:
  assumes set:" y \<in> set L"
  assumes P:"P y"
  shows "list_ex P L"
  using set P  list_ex_iff by auto

instance
  apply(standard)
  apply(rule enum_ALL)
  subgoal
    apply (auto simp add: ident_enum_def vals_def enum_ident_def)
    by (auto simp add: distinct_upto)
  subgoal for P
    apply(auto)
    unfolding enum_all_ident ident_enum_all_def enum_ALL vals_ALL
    using setA apply (simp add: list_all_iff vals_ALL)
    by (simp add: setA)
  subgoal for P
    apply(auto)
    unfolding enum_ex_ident ident_enum_ex_def enum_ALL vals_ALL
    using setE apply (simp add: list_ex_iff vals_ALL)
    by (simp add: setE vals_ALL)
  done
end
export_code ident_enum_ex in Scala
instantiation ident :: equal begin
definition equal_ident :: "ident \<Rightarrow> ident \<Rightarrow> bool"
  where [code]:"equal_ident X Y = (X \<le> Y \<and> Y \<le> X)"
instance
  apply(standard)
  by(auto simp add: equal_ident_def)
end

definition "FSENTINEL = ''.''"
definition "CSENTINEL = ''_''"
definition "SSENTINEL = ''$''"
definition "FSENT = hd FSENTINEL"
definition "CSENT = hd CSENTINEL"
definition "SSENT = hd SSENTINEL"

fun args_to_id::"ident \<Rightarrow> (ident + ident) option"
  where "args_to_id z =
      (case (ident_expose z) of
       Inl _ \<Rightarrow> None
     | Inr (x,xs) \<Rightarrow> (if x = FSENT then Some (Inr xs) else if x = SSENT then Some (Inl xs) else None))"

fun debase :: "ident \<Rightarrow> ident"
  where "debase f = ident_cons FSENT f"
fun Debase :: "ident \<Rightarrow> ident"
  where "Debase f = ident_cons SSENT f"
fun rebase :: "ident \<Rightarrow> ident"
  where "rebase f = (case ident_expose f of Inl () \<Rightarrow> f | Inr (c,cs) \<Rightarrow> cs)"
fun is_base :: "ident \<Rightarrow> bool"
  where "is_base f = (case (ident_expose f) of Inl () \<Rightarrow> True | Inr(c,cs) \<Rightarrow> c \<noteq> FSENT)"
fun nonbase :: "ident \<Rightarrow> bool"
  where "nonbase f = (case (ident_expose f) of Inl () \<Rightarrow> False | Inr(c,cs) \<Rightarrow> c = FSENT \<or> c = SSENT)"

lemma nonbase_nonemp:"(nonbase x) \<Longrightarrow> x \<noteq> ident_empty"
  apply(auto simp add: FSENT_def SSENT_def ident_empty_def)
  by (metis (mono_tags, lifting) id_apply ident_empty.rep_eq ident_empty_def ident_expose_def map_fun_apply map_sum.simps(1) old.sum.simps(5) old.unit.case string_expose.simps(1))

lemma nonbase_debase:
  assumes spacious:"MAX_STR > ilength a"
  shows "nonbase (debase a)"
  using spacious
  by(auto simp add: ident_cons_def Rep_ident_inverse ilength_def ident_expose_def Abs_ident_inverse)

lemma nonbase_some:
  assumes nb:"nonbase x"
  obtains inj where "args_to_id x = Some inj"
  using nb apply auto
  apply(cases "ident_expose x")
  apply (simp add: case_unit_Unity)+
  by fastforce

lemma arg_lengthR:
  assumes ai:"args_to_id x = Some(Inr y)"
  shows "ilength y + 1 = ilength x"
  using ai apply(auto)
  apply(cases "ident_expose x")
   apply(auto)
  subgoal for a b
    apply(cases "a = FSENT")
     apply(auto simp add: ilength_def ident_expose_def)
     apply(cases "string_expose (Rep_ident x)")
      apply(auto)
    apply (metis (no_types, lifting) Inl_Inr_False Inr_inject Rep_ident eq_onp_same_args ilength.abs_eq ilength.rep_eq impossible_Cons le_cases le_trans length_Suc_conv mem_Collect_eq snd_conv string_expose.elims)
    apply(cases "a = SSENT")
    by(auto simp add: ilength_def ident_expose_def)
  done

lemma arg_lengthL:
  assumes ai:"args_to_id x = Some(Inl y)"
  shows "ilength y + 1 = ilength x"
  using ai apply(auto)
  apply(cases "ident_expose x")
   apply(auto)
  subgoal for a b
    apply(cases "a = FSENT")
     apply(auto simp add: ilength_def ident_expose_def)
     apply(cases "string_expose (Rep_ident x)")
      apply(auto)
    apply(cases "a = SSENT")
    apply(auto simp add: FSENT_def SSENT_def FSENTINEL_def SSENTINEL_def)
    using Inl_Inr_False Inl_inject Rep_ident eq_onp_same_args ilength.abs_eq ilength.rep_eq impossible_Cons le_cases le_trans length_Suc_conv mem_Collect_eq snd_conv string_expose.elims
    by (metis Inr_inject)
  done
lemma arg_debaseL:
  assumes spacious:"MAX_STR > ilength a"
  assumes ai:"args_to_id x = Some (Inl a)"
  shows "x = Debase a"
proof -
  show ?thesis
  proof (cases "ident_expose x")
    case (Inl c) then have xc:" ident_expose x = Inl c" by auto
    then show ?thesis  apply (auto)
    proof (cases "ident_expose a")
      case (Inl d)
      then show "x = ident_cons SSENT a"
        apply(auto simp add: ident_expose_def ident_cons_def)
        using Inl_Inr_False Rep_ident_inverse ident_empty.abs_eq map_sum.simps(2) nonbase_nonemp
              string_expose.elims ilength.rep_eq spacious apply auto
        using ai xc by auto
    next
      case (Inr e) then have xe:" ident_expose a = Inr e" by auto
      have contra:"ident_expose x = Inl () \<Longrightarrow> False"
         unfolding nonbase.simps
        using case_unit_Unity ai by auto
      from xe show "x = ident_cons SSENT a"
        using xc apply(auto)
        using contra by auto
    qed
  next
    case (Inr b)
    then obtain c cs where cs:"ident_expose x = Inr(c,cs)"
      apply auto
      unfolding ident_expose_def
      using old.prod.exhaust by blast
    have hd:"c = SSENT"
      using ai apply(simp)
      using cs apply(simp)
      apply(cases "c = FSENT") apply(auto)
      apply(cases "c = SSENT") by auto
    then show ?thesis
    proof (cases "ident_expose (debase a)")
      case (Inl e) then have xe:" ident_expose (debase a) = Inl e" by auto
       note nbb = nonbase_debase[of a, OF spacious]
      have contra:"\<And>x. ident_expose (debase a) = Inl x \<Longrightarrow> False"
        using nbb unfolding nonbase.simps
        by (simp add: case_unit_Unity)
      show "?thesis"
        using contra[OF xe] by auto
    next
      case (Inr e) then have xe:" ident_expose (debase a) = Inr e" by auto
      then obtain d ds where ds:"ident_expose (debase a) = Inr(d,ds)"
        apply auto
        using old.prod.exhaust by blast
      from spacious
      have fact:"MAX_STR > length (Rep_ident a)"
        unfolding ilength_def by auto
      have ied:"ident_expose (debase a) = Inr (FSENT, cs)"
        using cs fact ai
        apply(auto simp add:  ident_expose_def ident_cons_def Rep_ident_inverse[of a] Abs_ident_inverse fact)
        using fact apply linarith+
        apply(cases "c = SSENT")
        using hd  by (auto simp add: hd FSENT_def SSENT_def FSENTINEL_def SSENTINEL_def)
        have cd:"cs = ds"
          using ied cs ds by auto
      have "Rep_ident x = SSENT # Rep_ident ds"
        using cs apply(auto simp add: Rep_ident_inverse Abs_ident_inverse cs)
        unfolding ident_expose_def ident_cons_def
        using cs ds
        apply(auto simp add: ident_expose_def ident_cons_def Rep_ident_inverse)
        apply(cases "MAX_STR \<le> length (Rep_ident a)")
        using fact cs apply(auto simp add: Rep_ident_inverse Abs_ident_inverse cs )
        apply(cases "string_expose (Rep_ident x)")
        using cs apply(auto simp add: Rep_ident_inverse Abs_ident_inverse cs )
          apply(cases "Rep_ident x")
         apply(auto simp add: hd)
        subgoal for bb
        using Rep_ident_inverse[of ds] Abs_ident_inverse[of bb]  cd fact apply auto
        by (metis Rep_ident impossible_Cons le_cases le_trans mem_Collect_eq)
      done
      then show "x = Debase a"
        using cs apply(auto simp add: Rep_ident_inverse Abs_ident_inverse cs)
        unfolding ident_expose_def ident_cons_def
        using cs ds
        apply(auto simp add: ident_expose_def ident_cons_def Rep_ident_inverse)
        subgoal using fact by auto
        using cs apply(auto simp add: Rep_ident_inverse Abs_ident_inverse cs )
        apply(cases "string_expose (Rep_ident x)")
        using cs apply(auto simp add: Rep_ident_inverse Abs_ident_inverse cs )
          apply(cases "Rep_ident x")
         apply(auto)
        using Rep_ident_inverse Abs_ident_inverse ds ied
        by metis
    qed
  qed
qed

lemma arg_debaseR:
  assumes spacious:"MAX_STR > ilength a"
  assumes ai:"args_to_id x = Some (Inr a)"
  shows "x = debase a"
proof -
  show ?thesis
  proof (cases "ident_expose x")
    case (Inl c) then have xc:" ident_expose x = Inl c" by auto
    then show ?thesis  apply (auto)
    proof (cases "ident_expose a")
      case (Inl d)
      then show "x = ident_cons FSENT a"
        apply(auto simp add: ident_expose_def ident_cons_def)
        using Inl_Inr_False Rep_ident_inverse ident_empty.abs_eq map_sum.simps(2) nonbase_nonemp
              string_expose.elims ilength.rep_eq spacious apply auto
        using ai xc by auto
    next
      case (Inr e) then have xe:" ident_expose a = Inr e" by auto
      have contra:"ident_expose x = Inl () \<Longrightarrow> False"
         unfolding nonbase.simps
        using case_unit_Unity ai by auto
      from xe show "x = ident_cons FSENT a"
        using xc apply(auto)
        using contra by auto
    qed
  next
    case (Inr b)
    then obtain c cs where cs:"ident_expose x = Inr(c,cs)"
      apply auto
      unfolding ident_expose_def
      using old.prod.exhaust by blast
    have hd:"c = FSENT"
      using ai apply(simp)
      using cs apply(simp)
      apply(cases "c = FSENT") apply(auto)
      apply(cases "c = SSENT") by(auto)
    then show ?thesis
    proof (cases "ident_expose (debase a)")
      case (Inl e) then have xe:" ident_expose (debase a) = Inl e" by auto
       note nbb = nonbase_debase[of a, OF spacious]
      have contra:"\<And>x. ident_expose (debase a) = Inl x \<Longrightarrow> False"
        using nbb unfolding nonbase.simps
        by (simp add: case_unit_Unity)
      show "?thesis"
        using contra[OF xe] by auto
    next
      case (Inr e) then have xe:" ident_expose (debase a) = Inr e" by auto
      then obtain d ds where ds:"ident_expose (debase a) = Inr(d,ds)"
        apply auto
        using old.prod.exhaust by blast
      from spacious
      have fact:"MAX_STR > length (Rep_ident a)"
        unfolding ilength_def by auto
      have ied:"ident_expose (debase a) = Inr (FSENT, cs)"
        using cs  fact ai
        apply(auto simp add:  ident_expose_def ident_cons_def Rep_ident_inverse[of a] Abs_ident_inverse fact)
       using fact apply linarith+
       by (simp add: hd)
        have cd:"cs = ds"
          using ied cs ds by auto
      have "Rep_ident x = FSENT # Rep_ident ds"
        using cs apply(auto simp add: Rep_ident_inverse Abs_ident_inverse cs)
        unfolding ident_expose_def ident_cons_def
        using cs ds
        apply(auto simp add: ident_expose_def ident_cons_def Rep_ident_inverse)
        apply(cases "MAX_STR \<le> length (Rep_ident a)")
        using fact cs apply(auto simp add: Rep_ident_inverse Abs_ident_inverse cs )
        apply(cases "string_expose (Rep_ident x)")
        using cs apply(auto simp add: Rep_ident_inverse Abs_ident_inverse cs )
          apply(cases "Rep_ident x")
         apply(auto simp add: hd)
        subgoal for bb
        using Rep_ident_inverse[of ds] Abs_ident_inverse[of bb]  cd fact apply auto
        by (metis Rep_ident impossible_Cons le_cases le_trans mem_Collect_eq)
      done
      then show "x = debase a"
        using cs apply(auto simp add: Rep_ident_inverse Abs_ident_inverse cs)
        unfolding ident_expose_def ident_cons_def
        using cs ds
        apply(auto simp add: ident_expose_def ident_cons_def Rep_ident_inverse)
        subgoal using fact by auto
        using cs apply(auto simp add: Rep_ident_inverse Abs_ident_inverse cs )
        apply(cases "string_expose (Rep_ident x)")
        using cs apply(auto simp add: Rep_ident_inverse Abs_ident_inverse cs )
          apply(cases "Rep_ident x")
         apply(auto)
        using Rep_ident_inverse Abs_ident_inverse
        by metis
    qed
  qed
qed

end


theory AteProof
imports AteDefs "../Reduction"
begin

context ate_parameters
begin

subsection {* Preliminary Lemmas *}

text {*
  If a process newly decides value @{text v} at some round,
  then it received more than @{text "E - \<alpha>"} messages holding @{text v}
  at this round.
*}

lemma decide_sent_msgs_threshold:
  assumes run: "SHORun Ate_M rho HOs SHOs"
  and comm: "SHOcommPerRd Ate_M (HOs r) (SHOs r)"
  and nvp: "decide (rho r p) \<noteq> Some v"
  and vp: "decide (rho (Suc r) p) = Some v"
  shows "card {qq. sendMsg Ate_M r qq p (rho r qq) = v} > E - \<alpha>"
proof -
  from run obtain \<mu>p
    where mu: "\<mu>p \<in> SHOmsgVectors Ate_M r p (rho r) (HOs r p) (SHOs r p)"
      and nxt: "nextState Ate_M r p (rho r p) \<mu>p (rho (Suc r) p)"
    by (auto simp: SHORun_eq SHOnextConfig_eq)
  from mu
  have "{qq. \<mu>p qq = Some v} - (HOs r p - SHOs r p)
          \<subseteq> {qq. sendMsg Ate_M r qq p (rho r qq) = v}"
       (is "?vrcvdp - ?ahop \<subseteq> ?vsentp")
    by (auto simp: SHOmsgVectors_def)
  hence "card (?vrcvdp - ?ahop) \<le> card ?vsentp"
    and "card (?vrcvdp - ?ahop) \<ge> card ?vrcvdp - card ?ahop"
    by (auto simp: card_mono diff_card_le_card_Diff)
  hence "card ?vsentp \<ge> card ?vrcvdp - card ?ahop" by auto
  moreover
  from nxt nvp vp have "card ?vrcvdp > E"
    by (auto simp: Ate_SHOMachine_def nextState_def Ate_nextState_def)
  moreover
  from comm have "card (HOs r p - SHOs r p) \<le> \<alpha>"
    by (auto simp: Ate_SHOMachine_def Ate_commPerRd_def)
  ultimately
  show ?thesis using Egta by auto
qed

text {*
  If more than @{text "E - \<alpha>"} processes send a value @{text v} to some
  process @{text q} at some round, then @{text q} will receive at least
  @{text "N + 2*\<alpha> - E"} messages holding @{text v} at this round.
*}

lemma other_values_received:
  assumes comm: "SHOcommPerRd Ate_M (HOs r) (SHOs r)"
  and nxt: "nextState Ate_M r q (rho r q) \<mu>q ((rho (Suc r)) q)"
  and muq: "\<mu>q \<in> SHOmsgVectors Ate_M r q (rho r) (HOs r q) (SHOs r q)"
  and vsent: "card {qq. sendMsg Ate_M r qq q (rho r qq) = v} > E - \<alpha>"
             (is "card ?vsent > _")
  shows "card ({qq. \<mu>q qq \<noteq> Some v} \<inter> HOs r q) \<le> N + 2*\<alpha> - E"
proof -
  from nxt muq
  have "({qq. \<mu>q qq \<noteq> Some v} \<inter> HOs r q) - (HOs r q - SHOs r q)
        \<subseteq>  {qq. sendMsg Ate_M r qq q (rho r qq) \<noteq> v}"
    (is "?notvrcvd - ?aho \<subseteq> ?notvsent")
    unfolding SHOmsgVectors_def by auto
  hence "card ?notvsent \<ge> card (?notvrcvd - ?aho)"
    and "card (?notvrcvd - ?aho) \<ge> card ?notvrcvd - card ?aho"
    by (auto simp: card_mono diff_card_le_card_Diff)
  moreover
  from comm have "card ?aho \<le> \<alpha>"
    by (auto simp: Ate_SHOMachine_def Ate_commPerRd_def)
  moreover
  have 1: "card ?notvsent + card ?vsent = card (?notvsent \<union> ?vsent)"
    by (subst card_Un_Int) auto
  have "?notvsent \<union> ?vsent = (UNIV::Proc set)" by auto
  hence "card (?notvsent \<union> ?vsent) = N" by simp
  with 1 vsent have "card ?notvsent \<le>  N - (E + 1 - \<alpha>)" by auto
  ultimately
  show ?thesis using EltN Egta by auto
qed

text {*
  If more than @{text "E - \<alpha>"} processes send a value @{text v} to some
  process @{text q} at some round @{text r}, and if @{text q} receives more than
  @{text T} messages in @{text r}, then @{text v} is the most frequently
  received value by @{text q} in @{text r}.
*}

lemma mostOftenRcvd_v:
  assumes comm: "SHOcommPerRd Ate_M (HOs r) (SHOs r)"
  and nxt: "nextState Ate_M r q (rho r q) \<mu>q ((rho (Suc r)) q)"
  and muq: "\<mu>q \<in> SHOmsgVectors Ate_M r q (rho r) (HOs r q) (SHOs r q)"
  and threshold_T: "card {qq. \<mu>q qq \<noteq> None} > T"
  and threshold_E: "card {qq. sendMsg Ate_M r qq q (rho r qq) = v} > E - \<alpha>"
  shows "mostOftenRcvd \<mu>q = {v}"
proof -
  from muq have hodef:"HOs r q = {qq. \<mu>q qq \<noteq> None}"
    unfolding SHOmsgVectors_def by auto

  from comm nxt muq threshold_E
  have "card ({qq. \<mu>q qq \<noteq> Some v} \<inter> HOs r q) \<le> N + 2*\<alpha> - E"
    (is "card ?heardnotv \<le> _")
    by (rule other_values_received)
  moreover
  have "card ?heardnotv \<ge> T + 1 - card {qq. \<mu>q qq = Some v}"
  proof -
    from muq
    have "?heardnotv = (HOs r q) - {qq. \<mu>q qq = Some v}"
      and "{qq. \<mu>q qq = Some v} \<subseteq> HOs r q"
      unfolding SHOmsgVectors_def by auto
    hence "card ?heardnotv = card (HOs r q) - card {qq. \<mu>q qq = Some v}"
      by (auto simp: card_Diff_subset)
    with hodef threshold_T show ?thesis by auto
  qed
  ultimately
  have "card {qq. \<mu>q qq = Some v} > card ?heardnotv"
    using TNaE by auto
  moreover
  {
    fix w
    assume w: "w \<noteq> v"
    with hodef have "{qq. \<mu>q qq = Some w} \<subseteq> ?heardnotv" by auto
    hence "card {qq. \<mu>q qq = Some w} \<le> card ?heardnotv" by (auto simp: card_mono)
  }
  ultimately
  have "{w. card {qq. \<mu>q qq = Some w} \<ge> card {qq. \<mu>q qq = Some v}} = {v}"
    by force
  thus ?thesis unfolding mostOftenRcvd_def by auto
qed

text {*
  If at some round more than @{text "E - \<alpha>"} processes have their @{text x}
  variable set to @{text v}, then this is also true at next round.
*}

lemma common_x_induct:
  assumes run: "SHORun Ate_M rho HOs SHOs"
  and comm: "SHOcommPerRd Ate_M (HOs (r+k)) (SHOs (r+k))"
  and ih: "card {qq. x (rho (r + k) qq) = v} > E - \<alpha>"
  shows "card {qq. x (rho (r + Suc k) qq) = v} > E - \<alpha>"
proof -
  from ih
  have thrE:"\<forall>pp. card {qq. sendMsg Ate_M (r + k) qq pp (rho (r + k) qq) = v}
                      > E - \<alpha>"
    by (auto simp: Ate_SHOMachine_def Ate_sendMsg_def)

  {
    fix qq
    assume kv:"x (rho (r + k) qq) = v"
    from run obtain \<mu>qq
      where nxt: "nextState Ate_M (r + k) qq (rho (r + k) qq) \<mu>qq ((rho (Suc (r + k))) qq)"
        and muq: "\<mu>qq \<in> SHOmsgVectors Ate_M (r + k) qq (rho (r + k))
                                         (HOs (r + k) qq) (SHOs (r + k) qq)"
      by (auto simp: SHORun_eq SHOnextConfig_eq)

    have "x (rho (r + Suc k) qq) = v"
    proof (cases "card {pp. \<mu>qq pp \<noteq> None} > T")
      case True
      with comm nxt muq thrE have "mostOftenRcvd \<mu>qq = {v}"
        by (auto dest: mostOftenRcvd_v)
      with nxt True show "x (rho (r + Suc k) qq) = v"
        by (auto simp: Ate_SHOMachine_def nextState_def Ate_nextState_def)
    next
      case False
      with nxt have "x (rho (r + Suc k) qq) = x (rho (r + k) qq)"
        by (auto simp: Ate_SHOMachine_def nextState_def Ate_nextState_def)
      with kv show "x (rho (r + Suc k) qq) = v" by simp
    qed
  }
  hence "{qq. x (rho (r + k) qq) = v} \<subseteq> {qq. x (rho (r + Suc k) qq) = v}"
    by auto
  hence "card {qq. x (rho (r + k) qq) = v} \<le> card {qq. x (rho (r + Suc k) qq) = v}"
    by (auto simp: card_mono)
  with ih show ?thesis by auto
qed

text {*
  Whenever some process newly decides value @{text v}, then any
  process that updates its @{text x} variable will set it to @{text v}.
*}
(* The proof mainly relies on lemmas @{text decide_sent_msgs_threshold},
   @{text mostOftenRcvd_v} and @{text common_x_induct}. *)

lemma common_x:
  assumes run: "SHORun Ate_M rho HOs SHOs"
  and comm: "\<forall>r. SHOcommPerRd (Ate_M::(Proc, 'val::linorder pstate, 'val) SHOMachine)
                              (HOs r) (SHOs r)"
  and d1: "decide (rho r p) \<noteq> Some v"
  and d2: "decide (rho (Suc r) p) = Some v"
  and qupdatex: "x (rho (r + Suc k) q) \<noteq> x (rho (r + k) q)"
  shows "x (rho (r + Suc k) q) = v"
proof -
  from comm
  have "SHOcommPerRd (Ate_M::(Proc, 'val::linorder pstate, 'val) SHOMachine)
                     (HOs (r+k)) (SHOs (r+k))" ..
  moreover
  from run obtain \<mu>q
    where nxt: "nextState Ate_M (r+k) q (rho (r+k) q) \<mu>q (rho (r + Suc k) q)"
      and muq: "\<mu>q \<in> SHOmsgVectors Ate_M (r+k) q (rho (r+k))
                                   (HOs (r+k) q) (SHOs (r+k) q)"
    by (auto simp: SHORun_eq SHOnextConfig_eq)
  moreover
  from nxt qupdatex
  have threshold_T: "card {qq. \<mu>q qq \<noteq> None} > T"
    and xsmall: "x (rho (r + Suc k) q) = Min (mostOftenRcvd \<mu>q)"
    by (auto simp: Ate_SHOMachine_def nextState_def Ate_nextState_def)
  moreover
  have "E - \<alpha> < card {qq. x (rho (r + k) qq) = v}"
  proof (induct k)
    from run comm d1 d2
    have "E - \<alpha> < card {qq. sendMsg Ate_M r qq p (rho r qq) = v}"
      by (auto dest: decide_sent_msgs_threshold)
    thus "E - \<alpha> < card {qq. x (rho (r + 0) qq) = v}"
      by (auto simp: Ate_SHOMachine_def Ate_sendMsg_def)
  next
    fix k
    assume "E - \<alpha> < card {qq. x (rho (r + k) qq) = v}"
    with run comm show "E - \<alpha> < card {qq. x (rho (r + Suc k) qq) = v}"
      by (auto dest: common_x_induct)
  qed
  with run
  have "E - \<alpha> < card {qq. sendMsg Ate_M (r+k) qq q (rho (r+k) qq) = v}"
    by (auto simp: Ate_SHOMachine_def Ate_sendMsg_def SHORun_eq SHOnextConfig_eq)
  ultimately
  have "mostOftenRcvd \<mu>q = {v}" by (auto dest:mostOftenRcvd_v)
  with xsmall show ?thesis by auto
qed

text {*
  A process that holds some decision @{text v} has decided @{text v}
  sometime in the past.
*}
lemma decisionNonNullThenDecided:
  assumes run: "SHORun Ate_M rho HOs SHOs"
      and dec: "decide (rho n p) = Some v"
  obtains m where "m < n"
              and "decide (rho m p) \<noteq> Some v"
              and "decide (rho (Suc m) p) = Some v"
proof -
  let "?dec k" = "decide (rho k p)"
  have "(\<forall>m<n. ?dec (Suc m) \<noteq> ?dec m \<longrightarrow> ?dec (Suc m) \<noteq> Some v) \<longrightarrow> ?dec n \<noteq> Some v"
    (is "?P n" is "?A n \<longrightarrow> _")
  proof (induct n)
    from run show "?P 0"
      by (auto simp: Ate_SHOMachine_def SHORun_eq HOinitConfig_eq
                     initState_def Ate_initState_def)
  next
    fix n
    assume ih: "?P n" thus "?P (Suc n)" by force
  qed
  with dec that show ?thesis by auto
qed

subsection {* Proof of Validity *}

text {*
  Validity asserts that if all processes were initialized with the same value,
  then no other value may ever be decided.
*}

theorem ate_validity:
  assumes run: "SHORun Ate_M rho HOs SHOs"
  and comm: "\<forall>r. SHOcommPerRd Ate_M (HOs r) (SHOs r)"
  and initv: "\<forall>q. x (rho 0 q) = v"
  and dp: "decide (rho r p) = Some w"
  shows "w = v"
proof -
  {
    fix r
    have "\<forall>qq. sendMsg Ate_M r qq p (rho r qq) = v"
    proof (induct r)
      from run initv show "\<forall>qq. sendMsg Ate_M 0 qq p (rho 0 qq) = v"
        by (auto simp: SHORun_eq SHOnextConfig_eq Ate_SHOMachine_def Ate_sendMsg_def)
    next
      fix r
      assume ih:"\<forall>qq. sendMsg Ate_M r qq p (rho r qq) = v"

      have "\<forall>qq. x (rho (Suc r) qq) = v"
      proof
        fix qq
        from run obtain \<mu>qq
          where nxt: "nextState Ate_M r qq (rho r qq) \<mu>qq (rho (Suc r) qq)"
            and mu: "\<mu>qq \<in> SHOmsgVectors Ate_M r qq (rho r) (HOs r qq) (SHOs r qq)"
          by (auto simp: SHORun_eq SHOnextConfig_eq)
        from nxt
        have "(card {pp. \<mu>qq pp \<noteq> None} > T \<and> x (rho (Suc r) qq) = Min (mostOftenRcvd \<mu>qq))
            \<or> (card {pp. \<mu>qq pp \<noteq> None} \<le> T \<and> x (rho (Suc r) qq) = x (rho r qq))"
          by (auto simp: Ate_SHOMachine_def nextState_def Ate_nextState_def)
        thus "x (rho (Suc r) qq) = v"
        proof safe
          assume "x (rho (Suc r) qq) = x (rho r qq)"
          with ih show "?thesis"
            by (auto simp: Ate_SHOMachine_def Ate_sendMsg_def)
        next
          assume threshold_T:"T < card {pp. \<mu>qq pp \<noteq> None}"
             and xsmall:"x (rho (Suc r) qq) = Min (mostOftenRcvd \<mu>qq)"

          have "card {pp. \<exists>w. w \<noteq> v \<and> \<mu>qq pp = Some w} \<le> T div 2"
          proof -
            from comm have 1:"card (HOs r qq - SHOs r qq) \<le> \<alpha>"
              by (auto simp: Ate_SHOMachine_def Ate_commPerRd_def)
            moreover
            from mu ih
            have "SHOs r qq \<inter> HOs r qq \<subseteq> {pp. \<mu>qq pp = Some v}"
              and "HOs r qq = {pp. \<mu>qq pp \<noteq> None}"
              by (auto simp: SHOmsgVectors_def Ate_SHOMachine_def Ate_sendMsg_def)
            hence "{pp. \<mu>qq pp \<noteq> None} - {pp. \<mu>qq pp = Some v}
                   \<subseteq> HOs r qq - SHOs r qq"
              by auto
            hence "card ({pp. \<mu>qq pp \<noteq> None} - {pp. \<mu>qq pp = Some v})
                      \<le> card (HOs r qq - SHOs r qq)"
              by (auto simp:card_mono)
            ultimately
            have "card ({pp. \<mu>qq pp \<noteq> None} - {pp. \<mu>qq pp = Some v}) \<le> T div 2"
              using Tge2a by auto
            moreover
            have "{pp. \<mu>qq pp \<noteq> None} - {pp. \<mu>qq pp = Some v}
                  = {pp. \<exists>w. w \<noteq> v \<and> \<mu>qq pp = Some w}" by auto
            ultimately
            show ?thesis by simp
          qed
          moreover
          have "{pp. \<mu>qq pp \<noteq> None}
                = {pp. \<mu>qq pp = Some v} \<union> {pp. \<exists>w. w \<noteq> v \<and> \<mu>qq pp = Some w}"
            and "{pp. \<mu>qq pp = Some v} \<inter> {pp. \<exists>w. w \<noteq> v \<and> \<mu>qq pp = Some w} = {}"
            by auto
          hence "card {pp. \<mu>qq pp \<noteq> None}
                 = card {pp. \<mu>qq pp = Some v} + card {pp. \<exists>w. w \<noteq> v \<and> \<mu>qq pp = Some w}"
            by (auto simp: card_Un_Int)
          moreover
          note threshold_T
          ultimately
          have "card {pp. \<mu>qq pp = Some v} > card {pp. \<exists>w. w \<noteq> v \<and> \<mu>qq pp = Some w}"
            by auto
          moreover
          {
            fix w
            assume "w \<noteq> v"
            hence "{pp. \<mu>qq pp = Some w} \<subseteq> {pp. \<exists>w. w \<noteq> v \<and> \<mu>qq pp = Some w}"
              by auto
            hence "card {pp. \<mu>qq pp = Some w} \<le> card {pp. \<exists>w. w \<noteq> v \<and> \<mu>qq pp = Some w}"
              by (auto simp: card_mono)
          }
          ultimately
          have zz:"\<And>w. w \<noteq> v \<Longrightarrow>
                       card {pp. \<mu>qq pp = Some w} < card {pp. \<mu>qq pp = Some v}"
            by force
          hence "\<And>w. card {pp. \<mu>qq pp = Some v} \<le> card {pp. \<mu>qq pp = Some w}
                      \<Longrightarrow> w = v"
            by force
          with zz have "mostOftenRcvd \<mu>qq = {v}"
            by (force simp: mostOftenRcvd_def)
          with xsmall show "x (rho (Suc r) qq) = v" by auto
        qed
      qed
      thus "\<forall>qq. sendMsg Ate_M (Suc r) qq p (rho (Suc r) qq) = v"
        by (auto simp: Ate_SHOMachine_def Ate_sendMsg_def)
    qed
  }
  note P = this

  from run dp obtain rp
    where rp: "rp < r" "decide (rho rp p) \<noteq> Some w"
              "decide (rho (Suc rp) p) = Some w"
    by (rule decisionNonNullThenDecided)

  from run obtain \<mu>p
    where nxt: "nextState Ate_M rp p (rho rp p) \<mu>p (rho (Suc rp) p)"
      and mu: "\<mu>p \<in> SHOmsgVectors Ate_M rp p (rho rp) (HOs rp p) (SHOs rp p)"
    by (auto simp: SHORun_eq SHOnextConfig_eq)

  {
    fix w
    assume w: "w \<noteq> v"
    from comm have "card (HOs rp p - SHOs rp p) \<le> \<alpha>"
      by (auto simp: Ate_SHOMachine_def Ate_commPerRd_def)
    moreover
    from mu P
    have "SHOs rp p \<inter> HOs rp p \<subseteq> {pp. \<mu>p pp = Some v}"
      and "HOs rp p = {pp. \<mu>p pp \<noteq> None}"
      by (auto simp: SHOmsgVectors_def)
    hence "{pp. \<mu>p pp \<noteq> None} - {pp. \<mu>p pp = Some v}
           \<subseteq> HOs rp p - SHOs rp p"
      by auto
    hence "card ({pp. \<mu>p pp \<noteq> None} - {pp. \<mu>p pp = Some v})
            \<le> card (HOs rp p - SHOs rp p)"
      by (auto simp: card_mono)
    ultimately
    have "card ({pp. \<mu>p pp \<noteq> None} - {pp. \<mu>p pp = Some v}) < E"
      using Egta by auto
    moreover
    from w have "{pp. \<mu>p pp = Some w}
                 \<subseteq> {pp. \<mu>p pp \<noteq> None} - {pp. \<mu>p pp = Some v}"
      by auto
    hence "card {pp. \<mu>p pp = Some w}
             \<le> card ({pp. \<mu>p pp \<noteq> None} - {pp. \<mu>p pp = Some v})"
      by (auto simp: card_mono)
    ultimately
    have "card {pp. \<mu>p pp = Some w} < E" by simp
  }
  hence PP: "\<And>w. card {pp. \<mu>p pp = Some w} \<ge> E \<Longrightarrow> w = v" by force

  from rp nxt mu have "card {q. \<mu>p q = Some w} > E"
    by (auto simp: SHOmsgVectors_def Ate_SHOMachine_def
                   nextState_def Ate_nextState_def)
  with PP show ?thesis by auto
qed

subsection {* Proof of Agreement *}

text {*
  If two processes decide at the some round, they decide the same value.
*}
(* The proof mainly relies on lemma @{text decide_sent_msgs_threshold}. *)

lemma common_decision:
  assumes run: "SHORun Ate_M rho HOs SHOs"
  and comm: "SHOcommPerRd Ate_M (HOs r) (SHOs r)"
  and nvp: "decide (rho r p) \<noteq> Some v"
  and vp: "decide (rho (Suc r) p) = Some v"
  and nwq: "decide (rho r q) \<noteq> Some w"
  and wq: "decide (rho (Suc r) q) = Some w"
  shows "w = v"
proof -
  have gtn: "card {qq. sendMsg Ate_M r qq p (rho r qq) = v}
             + card {qq. sendMsg Ate_M r qq q (rho r qq) = w} > N"
  proof -
    from run comm nvp vp
    have "card {qq. sendMsg Ate_M r qq p (rho r qq) = v} > E - \<alpha>"
      by (rule decide_sent_msgs_threshold)
    moreover
    from run comm nwq wq
    have "card {qq. sendMsg Ate_M r qq q (rho r qq) = w} > E - \<alpha>"
      by (rule decide_sent_msgs_threshold)
    ultimately
    show ?thesis using majE by auto
  qed

  show ?thesis
  proof (rule ccontr)
    assume vw:"w \<noteq> v"
    have "\<forall>qq. sendMsg Ate_M r qq p (rho r qq) = sendMsg Ate_M r qq q (rho r qq)"
      by (auto simp: Ate_SHOMachine_def Ate_sendMsg_def)
    with vw
    have "{qq. sendMsg Ate_M r qq p (rho r qq) = v}
          \<inter> {qq. sendMsg Ate_M r qq q (rho r qq) = w} = {}"
      by auto
    with gtn
    have "card ({qq. sendMsg Ate_M r qq p (rho r qq) = v}
                 \<union> {qq. sendMsg Ate_M r qq q (rho r qq) = w}) > N"
      by (auto simp: card_Un_Int)
    moreover
    have "card ({qq. sendMsg Ate_M r qq p (rho r qq) = v}
                 \<union> {qq. sendMsg Ate_M r qq q (rho r qq) = w}) \<le> N"
      by (auto simp: card_mono)
    ultimately
    show "False" by auto
  qed
qed

text {*
  If process @{text p} decides at step @{text r} and process @{text q} decides
  at some later step @{text "r+k"} then @{text p} and @{text q} decide the
  same value.
*}
(*
  The proof mainly relies on lemmas @{text common_decision}, @{text common_x},
  @{text decide_with_threshold_E}, @{text unique_majority_E_\<alpha>}
  and @{text  decide_sent_msgs_threshold}.
*)

lemma laterProcessDecidesSameValue :
  assumes run: "SHORun Ate_M rho HOs SHOs"
  and comm: "\<forall>r. SHOcommPerRd Ate_M (HOs r) (SHOs r)"
  and nd1: "decide (rho r p) \<noteq> Some v"
  and d1: "decide (rho (Suc r) p) = Some v"
  and nd2: "decide (rho (r+k) q) \<noteq> Some w"
  and d2: "decide (rho (Suc (r+k)) q) = Some w"
  shows "w = v"
proof (rule ccontr)
  assume vdifw:"w \<noteq> v"
  have kgt0: "k > 0"
  proof (rule ccontr)
    assume "\<not> k > 0"
    hence "k = 0" by auto
    with run comm nd1 d1 nd2 d2 have "w = v"
      by (auto dest: common_decision)
    with vdifw show False ..
  qed

  have 1: "{qq. sendMsg Ate_M r qq p (rho r qq) = v}
           \<inter> {qq. sendMsg Ate_M (r+k) qq q (rho (r+k) qq) = w} = {}"
    (is "?sentv \<inter> ?sentw = {}")
  proof (rule ccontr)
    assume "\<not> ?thesis"
    then obtain qq
      where xrv: "x (rho r qq) = v" and rkw: "x (rho (r+k) qq) = w"
      by (auto simp: Ate_SHOMachine_def Ate_sendMsg_def)
    have "\<exists>k' < k. x (rho (r + k') qq) \<noteq> w \<and> x (rho (r + Suc k') qq) = w"
    proof (rule ccontr)
      assume f: "\<not> ?thesis"
      {
        fix k'
        assume kk':"k' < k" hence "x (rho (r + k') qq) \<noteq> w"
        proof (induct k')
          from xrv vdifw
          show "x (rho (r + 0) qq) \<noteq> w" by simp
        next
          fix k'
          assume ih:"k' < k \<Longrightarrow> x (rho (r + k') qq) \<noteq> w"
             and ksk':"Suc k' < k"
          from ksk' have "k' < k" by simp
          with ih f  show "x (rho (r + Suc k') qq) \<noteq> w" by auto
        qed
      }
      with f have "\<forall>k' < k. x (rho (r + Suc k') qq) \<noteq> w" by auto
      moreover
      from kgt0 have "k - 1 < k" and kk:"Suc (k - 1) = k" by auto
      ultimately
      have "x (rho (r + Suc (k - 1)) qq) \<noteq> w" by blast
      with rkw kk show "False" by simp
    qed
    then obtain k'
      where "k' < k"
        and w: "x (rho (r + Suc k') qq) = w"
        and qqupdatex: "x (rho (r + Suc k') qq) \<noteq> x (rho (r + k') qq)"
      by auto
    from run comm nd1 d1 qqupdatex
    have "x (rho (r + Suc k') qq) = v" by (rule common_x)
    with w vdifw show False by simp
  qed
  from run comm nd1 d1 have sentv: "card ?sentv > E - \<alpha>"
    by (auto dest: decide_sent_msgs_threshold)
  from run comm nd2 d2 have "card ?sentw > E - \<alpha>"
    by (auto dest: decide_sent_msgs_threshold)
  with sentv majE have "(card ?sentv) + (card ?sentw) > N"
    by simp
  with 1 vdifw  have 2: "card (?sentv \<union> ?sentw) > N"
    by (auto simp: card_Un_Int)
  have "card (?sentv \<union> ?sentw) \<le> N"
    by (auto simp: card_mono)
  with 2 show "False" by simp
qed

text {*
  The Agreement property is now an immediate consequence.
*}
(*
  The proof mainly relies on lemmas @{text decisionNonNullThenDecided}
  and @{text laterProcessDecidesSameValue}.
*)

theorem ate_agreement:
  assumes run: "SHORun Ate_M rho HOs SHOs"
  and comm: "\<forall>r. SHOcommPerRd Ate_M (HOs r) (SHOs r)"
  and p: "decide (rho m p) = Some v"
  and q: "decide (rho n q) = Some w"
  shows "w = v"
proof -
  from run p obtain k where
    k: "k < m" "decide (rho k p) \<noteq> Some v" "decide (rho (Suc k) p) = Some v"
    by (rule decisionNonNullThenDecided)
  from run q obtain l where
    l: "l < n" "decide (rho l q) \<noteq> Some w" "decide (rho (Suc l) q) = Some w"
    by (rule decisionNonNullThenDecided)
  show ?thesis
  proof (cases "k \<le> l")
    case True
    then obtain i where "l = k+i" by (auto simp add: le_iff_add)
    with run comm k l show ?thesis
      by (auto dest: laterProcessDecidesSameValue)
  next
    case False
    hence "l \<le> k" by simp
    then obtain i where m: "k = l+i" by (auto simp add: le_iff_add)
    with run comm k l show ?thesis
      by (auto dest: laterProcessDecidesSameValue)
  qed
qed

subsection {* Proof of Termination *}

text {*
  We now prove that every process must eventually decide, given the
  global and round-by-round communication predicates.
*}
(* The proof relies on previous lemmas @{text common_x_induct} and @{text mostOftenRcvd_v}. *)

theorem ate_termination:
  assumes run: "SHORun Ate_M rho HOs SHOs"
  and commR: "\<forall>r. (SHOcommPerRd::((Proc, 'val::linorder pstate, 'val) SHOMachine)
                                     \<Rightarrow> (Proc HO) \<Rightarrow> (Proc HO) \<Rightarrow> bool)
                  Ate_M (HOs r) (SHOs r)"
  and commG: "SHOcommGlobal Ate_M HOs SHOs"
  shows "\<exists>r v. decide (rho r p) = Some v"
proof -
  from commG obtain r' \<pi>1 \<pi>2
    where \<pi>ea: "card \<pi>1 > E - \<alpha>"
      and \<pi>t: "card \<pi>2 > T"
      and  hosho: "\<forall>p \<in> \<pi>1. (HOs r' p = \<pi>2 \<and> SHOs r' p \<inter> HOs r' p = \<pi>2)"
    by (auto simp: Ate_SHOMachine_def Ate_commGlobal_def)

  obtain v where
    P1: "\<forall>pp. card {qq. sendMsg Ate_M (Suc r') qq pp (rho (Suc r') qq) = v} > E - \<alpha>"
  proof -
    have "\<forall>p \<in> \<pi>1. \<forall>q \<in> \<pi>1. x (rho (Suc r') p) = x (rho (Suc r') q)"
    proof (clarify)
      fix p q
      assume p: "p \<in> \<pi>1" and q: "q \<in> \<pi>1"

      from run obtain \<mu>p
        where nxtp: "nextState Ate_M r' p (rho r' p) \<mu>p (rho (Suc r') p)"
          and mup: "\<mu>p \<in> SHOmsgVectors Ate_M r' p (rho r') (HOs r' p) (SHOs r' p)"
        by (auto simp: SHORun_eq SHOnextConfig_eq)

      from run obtain \<mu>q
        where nxtq: "nextState Ate_M r' q (rho r' q) \<mu>q (rho (Suc r') q)"
          and muq: "\<mu>q \<in> SHOmsgVectors Ate_M r' q (rho r') (HOs r' q) (SHOs r' q)"
        by (auto simp: SHORun_eq SHOnextConfig_eq)

      from mup muq p q
      have "{qq. \<mu>q qq \<noteq> None}  = HOs r' q"
        and 2:"{qq. \<mu>q qq = Some (sendMsg Ate_M r' qq q (rho r' qq))}
               \<supseteq> SHOs r' q \<inter> HOs r' q"
        and "{qq. \<mu>p qq \<noteq> None}  = HOs r' p"
        and 4:"{qq. \<mu>p qq = Some (sendMsg Ate_M r' qq p (rho r' qq))}
               \<supseteq> SHOs r' p \<inter> HOs r' p"
        by (auto simp: SHOmsgVectors_def)
      with p q hosho
      have aa:"\<pi>2 = {qq. \<mu>q qq \<noteq> None}"
        and cc:"\<pi>2 = {qq. \<mu>p qq \<noteq> None}" by auto
      from p q hosho 2
      have bb:"{qq. \<mu>q qq = Some (sendMsg Ate_M r' qq q (rho r' qq))} \<supseteq> \<pi>2"
        by auto
      from p q hosho 4
      have dd:"{qq. \<mu>p qq = Some (sendMsg Ate_M r' qq p (rho r' qq))} \<supseteq> \<pi>2"
        by auto
      have "Min (mostOftenRcvd \<mu>p) = Min (mostOftenRcvd \<mu>q)"
      proof -
        have "\<forall>qq. sendMsg Ate_M r' qq p (rho r' qq)
                   = sendMsg Ate_M r' qq q (rho r' qq)"
          by (auto simp: Ate_SHOMachine_def Ate_sendMsg_def)
        with aa bb cc dd have "\<forall>qq. \<mu>p qq \<noteq> None \<longrightarrow> \<mu>p qq = \<mu>q qq"
          by force
        moreover
        from aa bb cc dd
        have "{qq. \<mu>p qq \<noteq> None} = {qq. \<mu>q qq \<noteq> None}" by auto
        hence "\<forall>qq. \<mu>p qq = None \<longleftrightarrow> \<mu>q qq = None" by blast
        hence "\<forall>qq. \<mu>p qq = None \<longrightarrow> \<mu>p qq = \<mu>q qq" by auto
        ultimately
        have "\<forall>qq. \<mu>p qq = \<mu>q qq" by blast
        thus ?thesis by (auto simp: mostOftenRcvd_def)
      qed
      with \<pi>t aa nxtq \<pi>t cc nxtp
      show "x (rho (Suc r') p) = x (rho (Suc r') q)"
        by (auto simp: Ate_SHOMachine_def nextState_def Ate_nextState_def)
    qed
    then obtain v where Pv:"\<forall>p \<in> \<pi>1. x (rho (Suc r') p) = v" by blast
    {
      fix pp
      from Pv have "\<forall>p \<in> \<pi>1. sendMsg Ate_M (Suc r') p pp (rho (Suc r') p) = v"
        by (auto simp: Ate_SHOMachine_def Ate_sendMsg_def)
      hence "card \<pi>1 \<le> card {qq. sendMsg Ate_M (Suc r') qq pp (rho (Suc r') qq) = v}"
        by (auto intro: card_mono)
      with \<pi>ea
      have "E - \<alpha> < card {qq. sendMsg Ate_M (Suc r') qq pp (rho (Suc r') qq) = v}"
        by simp
    }
    with that show ?thesis by blast
  qed

  {
    fix k pp
    have "E - \<alpha> < card {qq. sendMsg Ate_M (Suc r' + k) qq pp (rho (Suc r' + k) qq) = v}"
      (is "?P k")
    proof (induct k)
      from P1 show "?P 0" by simp
    next
      fix k
      assume ih: "?P k"
      from commR
      have "(SHOcommPerRd::((Proc, 'val::linorder pstate, 'val) SHOMachine)
                               \<Rightarrow> (Proc HO) \<Rightarrow> (Proc HO) \<Rightarrow> bool)
                Ate_M (HOs (Suc r' + k)) (SHOs (Suc r' + k))" ..
      moreover
      from ih have "E - \<alpha> < card {qq. x (rho (Suc r' + k) qq) = v}"
        by (auto simp: Ate_SHOMachine_def Ate_sendMsg_def)
      ultimately
      have "E - \<alpha> < card {qq. x (rho (Suc r' + Suc k) qq) = v}"
        by (rule common_x_induct[OF run])
      thus "?P (Suc k)"
        by (auto simp: Ate_SHOMachine_def Ate_sendMsg_def)
    qed
  }
  note P2 = this

  {
    fix k pp
    assume ppupdatex: "x (rho (Suc r' + Suc k) pp) \<noteq> x (rho (Suc r' + k) pp)"

    from commR
    have "(SHOcommPerRd::((Proc, 'val::linorder pstate, 'val) SHOMachine)
                            \<Rightarrow> (Proc HO) \<Rightarrow> (Proc HO) \<Rightarrow> bool)
              Ate_M (HOs (Suc r' + k)) (SHOs (Suc r' + k))" ..
    moreover
    from run obtain \<mu>pp
      where nxt:"nextState Ate_M (Suc r' + k) pp (rho (Suc r' + k) pp) \<mu>pp
                           (rho (Suc r' + Suc k) pp)"
        and mu: "\<mu>pp \<in> SHOmsgVectors Ate_M (Suc r' + k) pp (rho (Suc r' + k))
                           (HOs (Suc r' + k) pp) (SHOs (Suc r' + k) pp)"
      by (auto simp: SHORun_eq SHOnextConfig_eq)
    moreover
    from nxt ppupdatex
    have threshold_T: "card {qq. \<mu>pp qq \<noteq> None} > T"
      and xsmall: "x (rho (Suc r' + Suc k) pp) = Min (mostOftenRcvd \<mu>pp)"
      by (auto simp: Ate_SHOMachine_def nextState_def Ate_nextState_def)
    moreover
    from P2
    have "E - \<alpha> < card {qq. sendMsg Ate_M (Suc r' + k) qq pp (rho (Suc r' + k) qq) = v}" .
    ultimately
    have "mostOftenRcvd \<mu>pp = {v}" by (auto dest!: mostOftenRcvd_v)
    with xsmall
    have "x (rho (Suc r' + Suc k) pp) = v" by simp
  }
  note P3 = this

  have P4:"\<forall>pp. \<exists>k. x (rho (Suc r' + Suc k) pp) = v"
  proof
    fix pp
    from commG have "\<exists>r'' > r'. card (HOs r'' pp) > T"
      by (auto simp: Ate_SHOMachine_def Ate_commGlobal_def)
    then obtain k where "Suc r' + k > r'" and t:"card (HOs (Suc r' + k) pp) > T"
      by (auto dest: less_imp_Suc_add)
    moreover
    from run obtain \<mu>pp
      where nxt: "nextState Ate_M (Suc r' + k) pp (rho (Suc r' + k) pp) \<mu>pp
                                  (rho (Suc r' + Suc k) pp)"
        and mu: "\<mu>pp \<in> SHOmsgVectors Ate_M (Suc r' + k) pp (rho (Suc r' + k))
                                  (HOs (Suc r' + k) pp) (SHOs (Suc r' + k) pp)"
      by (auto simp: SHORun_eq SHOnextConfig_eq)
    moreover
    have "x (rho (Suc r' + Suc k) pp) = v"
    proof -
      from commR
      have "(SHOcommPerRd::((Proc, 'val::linorder pstate, 'val::linorder) SHOMachine)
                                \<Rightarrow> (Proc HO) \<Rightarrow> (Proc HO) \<Rightarrow> bool)
                Ate_M (HOs (Suc r' + k)) (SHOs (Suc r' + k))" ..
      moreover
      from mu have "HOs (Suc r' + k) pp = {q. \<mu>pp q \<noteq> None}"
        by (auto simp: SHOmsgVectors_def)
      with nxt t
      have threshold_T: "card {q. \<mu>pp q \<noteq> None} > T"
        and xsmall: "x (rho (Suc r' + Suc k) pp) = Min (mostOftenRcvd \<mu>pp)"
        by (auto simp: Ate_SHOMachine_def nextState_def Ate_nextState_def)
      moreover
      from P2
      have "E - \<alpha> < card {qq. sendMsg Ate_M (Suc r' + k) qq pp (rho (Suc r' + k) qq) = v}" .
      ultimately
      have "mostOftenRcvd \<mu>pp = {v}"
        using nxt mu by (auto dest!: mostOftenRcvd_v)
      with xsmall show ?thesis by auto
    qed
    thus "\<exists>k. x (rho (Suc r' + Suc k) pp) = v" ..
  qed

  have P5a: "\<forall>pp. \<exists>rr. \<forall>k. x (rho (rr + k) pp) = v"
  proof
    fix pp
    from P4 obtain rk where
      xrrv: "x (rho (Suc r' + Suc rk) pp) = v" (is "x (rho ?rr pp) = v")
      by blast
    have "\<forall>k. x (rho (?rr + k) pp) = v"
    proof
      fix k
      show "x (rho (?rr + k) pp) = v"
      proof (induct k)
        from xrrv show "x (rho (?rr + 0) pp) = v" by simp
      next
        fix k
        assume ih: "x (rho (?rr + k) pp) = v"
        obtain k' where rrk: "Suc r' + k' = ?rr + k" by auto
        show "x (rho (?rr + Suc k) pp) = v"
        proof (rule ccontr)
          assume nv: "x (rho (?rr + Suc k) pp) \<noteq> v"
          with rrk ih
          have "x (rho (Suc r' + Suc k') pp) \<noteq> x (rho (Suc r' + k') pp)"
            by (simp add: ac_simps)
          hence "x (rho (Suc r' + Suc k') pp) = v" by (rule P3)
          with rrk nv show False by (simp add: ac_simps)
        qed
      qed
    qed
    thus "\<exists>rr. \<forall>k. x (rho (rr + k) pp) = v" by blast
  qed

  from P5a have "\<exists>F. \<forall>pp k. x (rho (F pp + k) pp) = v" by (rule choice)
  then obtain R::"(Proc \<Rightarrow> nat)"
    where imgR: "R ` (UNIV::Proc set) \<noteq> {}"
      and R: "\<forall>pp k. x (rho (R pp + k) pp) = v"
    by blast
  def rr \<equiv> "Max (R ` UNIV)"

  have P5: "\<forall>r' > rr. \<forall>pp. x (rho r' pp) = v"
  proof (clarify)
    fix r' pp
    assume r': "r' > rr"
    hence "r' > R pp" by (auto simp: rr_def)
    then obtain i where "r' = R pp + i"
      by (auto dest: less_imp_Suc_add)
    with R show "x (rho r' pp) = v" by auto
  qed

  from commG have "\<exists>r' > rr. card (SHOs r' p \<inter> HOs r' p) > E"
    by (auto simp: Ate_SHOMachine_def Ate_commGlobal_def)
  with P5 obtain r'
    where "r' > rr"
      and "card (SHOs r' p \<inter> HOs r' p) > E"
      and "\<forall>pp. sendMsg Ate_M r' pp p (rho r' pp) = v"
    by (auto simp: Ate_SHOMachine_def Ate_sendMsg_def)
  moreover
  from run obtain \<mu>p
    where nxt: "nextState Ate_M r' p (rho r' p) \<mu>p (rho (Suc r') p)"
      and mu: "\<mu>p \<in> SHOmsgVectors Ate_M r' p (rho r') (HOs r' p) (SHOs r' p)"
    by (auto simp: SHORun_eq SHOnextConfig_eq)
  from mu
  have "card (SHOs r' p \<inter> HOs r' p)
        \<le> card {q. \<mu>p q = Some (sendMsg Ate_M r' q p (rho r' q))}"
    by (auto simp: SHOmsgVectors_def intro: card_mono)
  ultimately
  have threshold_E: "card {q. \<mu>p q = Some v} > E" by auto
  with nxt show ?thesis
    by (auto simp: Ate_SHOMachine_def nextState_def Ate_nextState_def)
qed

subsection {* \ate{} Solves Weak Consensus *}

text {*
  Summing up, all (coarse-grained) runs of \ate{} for
  HO and SHO collections that satisfy the communication predicate
  satisfy the Weak Consensus property.
*}

theorem ate_weak_consensus:
  assumes run: "SHORun Ate_M rho HOs SHOs"
      and commR: "\<forall>r. SHOcommPerRd Ate_M (HOs r) (SHOs r)"
      and commG: "SHOcommGlobal Ate_M HOs SHOs"
  shows "weak_consensus (x \<circ> (rho 0)) decide rho"
  unfolding weak_consensus_def using assms
  by (auto elim: ate_validity ate_agreement ate_termination)

text {*
  By the reduction theorem, the correctness of the algorithm carries over
  to the fine-grained model of runs.
*}

theorem ate_weak_consensus_fg:
  assumes run: "fg_run Ate_M rho HOs SHOs (\<lambda>r q. undefined)"
      and commR: "\<forall>r. SHOcommPerRd Ate_M (HOs r) (SHOs r)"
      and commG: "SHOcommGlobal Ate_M HOs SHOs"
  shows "weak_consensus (\<lambda>p. x (state (rho 0) p)) decide (state \<circ> rho)"
    (is "weak_consensus ?inits _ _")
proof (rule local_property_reduction[OF run weak_consensus_is_local])
  fix crun
  assume crun: "CSHORun Ate_M crun HOs SHOs (\<lambda>r q. undefined)"
     and init: "crun 0 = state (rho 0)"
  from crun have "SHORun Ate_M crun HOs SHOs" by (unfold SHORun_def)
  from this commR commG
  have "weak_consensus (x \<circ> (crun 0)) decide crun"
    by (rule ate_weak_consensus)
  with init show "weak_consensus ?inits decide crun"
    by (simp add: o_def)
qed

end   -- {* context @{text "ate_parameters"} *}

end   (* theory AteProof *)


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

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

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

fun filter :: "('a => bool) => 'a list => 'a list" where
  "filter p (nil2) = nil2"
| "filter p (cons2 z xs) =
     (if p z then cons2 z (filter p xs) else filter p xs)"

(*fun did not finish the proof*)
function qsort :: "int list => int list" where
  "qsort (nil2) = nil2"
| "qsort (cons2 z xs) =
     x (qsort (filter (% (z2 :: int) => z2 <= z) xs))
       (x (cons2 z (nil2)) (qsort (filter (% (x2 :: int) => x2 > z) xs)))"
  by pat_completeness auto

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

theorem property0 :
  "((count y (qsort xs)) = (count y xs))"
  oops

end


theory Induction
  imports Main
begin

fun itrev :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"itrev [] ys = ys" |
"itrev (Cons x xs) ys = itrev xs (Cons x ys)"

value "itrev [Suc 0, Suc 2, Suc 3] []"

lemma itrev_rev : "itrev xs ys = (rev xs)@ys"
  apply(induction xs arbitrary: ys)
   apply(auto)
  done

end


theory sort_StoogeSort2Permutes
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)"

function stooge2sort2 :: "int list => int list"
         and stoogesort2 :: "int list => int list"
         and stooge2sort1 :: "int list => int list" where
"stooge2sort2 x =
   case zsplitAt (div ((2 * (zlength x)) + 1) 3) x of
     | Pair ys zs =>
         case zsplitAt (div ((2 * (zlength x)) + 1) 3) x of
           | Pair xs zs2 => append (stoogesort2 ys) zs2
         end
   end"
| "stoogesort2 (Nil2) = Nil2"
| "stoogesort2 (Cons2 y (Nil2)) = Cons2 y (Nil2)"
| "stoogesort2 (Cons2 y (Cons2 y2 (Nil2))) = sort2 y y2"
| "stoogesort2 (Cons2 y (Cons2 y2 (Cons2 x3 x4))) =
     stooge2sort2
       (stooge2sort1 (stooge2sort2 (Cons2 y (Cons2 y2 (Cons2 x3 x4)))))"
| "stooge2sort1 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 (stoogesort2 zs2)
           end
     end"
by pat_completeness auto

(*hipster ztake
          zlength
          zdrop
          zsplitAt
          sort2
          count
          append
          stooge2sort2
          stoogesort2
          stooge2sort1 *)

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

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   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.*)
  theory TIP_prop_01
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

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

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

theorem property0 :
  "((double x) = (t2 x x))"
  oops

end


theory prop_75
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
  | "plus (S z) y = S (plus z y)"
  fun equal2 :: "Nat => Nat => bool" where
  "equal2 (Z) (Z) = True"
  | "equal2 (Z) (S z) = False"
  | "equal2 (S x2) (Z) = False"
  | "equal2 (S x2) (S y2) = equal2 x2 y2"
  fun count :: "Nat => Nat list => Nat" where
  "count x (Nil2) = Z"
  | "count x (Cons2 z ys) =
       (if equal2 x z then S (count x ys) else count x ys)"
  (*hipster plus equal2 count *)
(*hipster count*)(*
lemma lemma_a []: "equal2 x4 y4 = equal2 y4 x4"
by (hipster_induct_schemes count.simps)

lemma lemma_aa []: "equal2 x2 x2 = True"
by (hipster_induct_schemes count.simps)

lemma lemma_ab []: "equal2 x2 (S x2) = False"
by (hipster_induct_schemes count.simps)*)

lemma lemma_ag [thy_expl]: "plus x2 Z = x2"
by (hipster_induct_schemes plus.simps)

lemma lemma_ah []: "plus (plus x2 y2) z2 = plus x2 (plus y2 z2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ai [thy_expl]: "plus x2 (S y2) = S (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_aj []: "plus x2 (plus y2 x2) = plus y2 (plus x2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ak []: "plus x2 (plus y2 y2) = plus y2 (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_al [thy_expl]: "plus x2 (S y2) = S (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_am []: "plus (plus x2 y2) x2 = plus x2 (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_an []: "plus (S x2) y2 = S (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ao []: "plus (plus x3 y3) (plus x3 z3) = plus (plus x3 z3) (plus x3 y3)"
by (hipster_induct_schemes Nat.exhaust)

  theorem x0 :
    "(plus (count n xs) (count n (Cons2 m (Nil2)))) = (count n (Cons2 m xs))"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


theory mult
imports Main
        "../data/Natu"
        "../funcs/plus"
        "$HIPSTER_HOME/IsaHipster"
begin

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

(*hipster mult plus*)
lemma lemma_aj [thy_expl]: "plus x2 y2 = plus y2 x2"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_ak [thy_expl]: "mult x2 Z = Z"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_al [thy_expl]: "mult x1 (S y1) = plus x1 (mult x1 y1)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_am [thy_expl]: "mult x2 (plus y2 y2) = mult y2 (plus x2 x2)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_an [thy_expl]: "mult x2 (S y2) = plus x2 (mult y2 x2)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_ao [thy_expl]: "mult (plus x2 y2) x2 = mult x2 (plus x2 y2)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_ap [thy_expl]: "mult (mult x1 y1) x1 = mult x1 (mult x1 y1)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_aq [thy_expl]: "mult (plus x2 x2) y2 = mult x2 (plus y2 y2)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_ar [thy_expl]: "mult (mult x2 x2) y2 = mult y2 (mult x2 x2)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_as [thy_expl]: "plus (mult x1 y1) (mult y1 z1) = mult y1 (plus x1 z1)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_at [thy_expl]: "plus (mult x2 y2) (mult z2 x2) = mult x2 (plus z2 y2)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_au [thy_expl]: "mult (plus x2 y2) (plus x2 z2) = mult (plus x2 z2) (plus x2 y2)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_av [thy_expl]: "mult (plus x2 y2) (plus z2 y2) = mult (plus z2 y2) (plus x2 y2)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_aw [thy_expl]: "mult (mult x2 y2) (plus x2 z2) = mult (plus x2 z2) (mult x2 y2)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_ax [thy_expl]: "mult (mult x2 y2) (plus y2 z2) = mult (plus y2 z2) (mult x2 y2)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_ay [thy_expl]: "mult (mult x2 y2) (mult z2 x2) = mult (mult z2 x2) (mult x2 y2)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_az [thy_expl]: "mult (plus x2 x2) (plus y2 z2) = mult (plus y2 z2) (plus x2 x2)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_ba [thy_expl]: "mult (plus x2 x2) (mult y2 z2) = mult (mult y2 z2) (plus x2 x2)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_bb [thy_expl]: "mult (S x2) (S y2) = mult (S y2) (S x2)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_bc [thy_expl]: "mult x2 y2 = mult y2 x2"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_bd [thy_expl]: "mult x2 (mult y2 z2) = mult y2 (mult x2 z2)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_be [thy_expl]: "plus (mult x1 y1) (mult x1 z1) = mult x1 (plus y1 z1)"
by (hipster_induct_schemes mult.simps plus.simps)

end


(*  Title:      HOL/Corec_Examples/Tests/Misc_Mono.thy
    Author:     Aymeric Bouzy, Ecole polytechnique
    Author:     Jasmin Blanchette, Inria, LORIA, MPII
    Copyright   2015, 2016

Miscellaneous monomorphic examples.
*)

section \<open>Miscellaneous Monomorphic Examples\<close>

theory Misc_Mono
imports "HOL-Library.BNF_Corec"
begin

codatatype T0 =
  C1 (lab: nat) (tl11: T0) (tl12: T0)
| C2 (lab: nat) (tl2: T0)
| C3 (tl3: "T0 list")

codatatype stream =
  S (hd: nat) (tl: stream)

corec (friend) ff where
  "ff x = S 0 (ff (ff x))"

corec test0 where
  "test0 x y = (case (x, y) of
  (S a1 s1, S a2 s2) \<Rightarrow> S (a1 + a2) (test0 s1 s2))"

friend_of_corec test0 where
  "test0 x y = (case (x, y) of
  (S a1 s1, S a2 s2) \<Rightarrow> S (a1 + a2) (test0 s1 s2))"
   apply (rule test0.code)
  apply transfer_prover
  done

corec test01 where
  "test01 x y = C2 (lab x + lab y) (test01 (tl2 x) (tl2 y))"

friend_of_corec test01 where
  "test01 x y = C2 (lab x + lab y) (test01 (tl2 x) (tl2 y))"
   apply (rule test01.code)
  sorry (* not parametric *)

corec test02 where
  "test02 x y = C2 (lab x * lab y) (test01 (test02 x (tl2 y)) (test02 (tl2 x) y))"

friend_of_corec test02 where
  "test02 x y = C2 (lab x * lab y) (test01 (test02 x (tl2 y)) (test02 (tl2 x) y))"
   apply (rule test02.code)
  sorry (* not parametric *)

corec test03 where
  "test03 x = C2 (lab x) (C2 (lab x) (test02 (test03 (tl2 x)) (test03 (tl2 x))))"

friend_of_corec test03 where
  "test03 x = C2 (lab x) (C2 (lab x) (test02 (test03 (tl2 x)) (test03 (tl2 x))))"
   apply (rule test03.code)
  sorry (* not parametric *)

corec (friend) test04a where
  "test04a x = (case x of C1 a t1 t2 \<Rightarrow> C1 (a * a) (test04a t1) (test04a t2) | C2 a t \<Rightarrow> C2 (a * a) (test04a t) | C3 l \<Rightarrow> C3 l)"

corec test04 where
  "test04 x = (case x of C1 a t1 t2 \<Rightarrow> C1 (a * a) (test04 t1) (test04 t2) | C2 a t \<Rightarrow> C2 (a * a) (test04 t) | C3 l \<Rightarrow> C3 l)"

friend_of_corec test04 where
  "test04 x = (case x of C1 a t1 t2 \<Rightarrow> C1 (a * a) (test04 t1) (test04 t2) | C2 a t \<Rightarrow> C2 (a * a) (test04 t) | C3 l \<Rightarrow> C3 l)"
   apply (rule test04.code)
  apply transfer_prover
  done

corec test05 where
  "test05 x y = (case (x, y) of
  (C1 a t11 t12, C1 b t21 t22) \<Rightarrow> C1 (a + b) (test05 t11 t21) (test05 t12 t22)
| (C1 a t11 _, C2 b t2) \<Rightarrow> C2 (a + b) (test05 t11 t2)
| (C2 a t1, C1 b _ t22) \<Rightarrow> C2 (a + b) (test05 t1 t22)
| (C2 a t1, C2 b t2) \<Rightarrow> C2 (a + b) (test05 t1 t2)
| (_, _) \<Rightarrow> C3 [])"

friend_of_corec test05 where
  "test05 x y = (case (x, y) of
  (C1 a t11 t12, C1 b t21 t22) \<Rightarrow> C1 (a + b) (test05 t11 t21) (test05 t12 t22)
| (C1 a t11 _, C2 b t2) \<Rightarrow> C2 (a + b) (test05 t11 t2)
| (C2 a t1, C1 b _ t22) \<Rightarrow> C2 (a + b) (test05 t1 t22)
| (C2 a t1, C2 b t2) \<Rightarrow> C2 (a + b) (test05 t1 t2)
| (_, _) \<Rightarrow> C3 [])"
   apply (rule test05.code)
  apply transfer_prover
  done

corec test06 :: "T0 \<Rightarrow> T0" where
  "test06 x =
  (if \<not> is_C1 x then
    let tail = tl2 x in
    C1 (lab x) (test06 tail) tail
  else
    C2 (lab x) (test06 (tl12 x)))"

friend_of_corec test06 :: "T0 \<Rightarrow> T0" where
  "test06 x =
  (if \<not> is_C1 x then
    let tail = tl2 x in
    C1 (lab x) (test06 tail) tail
  else
    C2 (lab x) (test06 (tl12 x)))"
   apply (rule test06.code)
  sorry (* not parametric *)

corec test07 where
  "test07 xs = C3 (map (\<lambda>x. test07 (tl3 x)) xs)"

friend_of_corec test07 where
  "test07 xs = C3 (map (\<lambda>x. test07 (tl3 x)) xs)"
   apply (rule test07.code)
  sorry (* not parametric *)

corec test08 where
  "test08 xs = (case xs of
    [] \<Rightarrow> C2 0 (test08 [])
  | T # r \<Rightarrow> C1 1 (test08 r) T)"

friend_of_corec test08 where
  "test08 xs = (case xs of
    [] \<Rightarrow> C2 0 (test08 [])
  | T # r \<Rightarrow> C1 1 (test08 r) T)"
   apply (rule test08.code)
  apply transfer_prover
  done

corec test09 where
  "test09 xs = test08 [case xs of
    [] \<Rightarrow> C2 0 (test09 [])
  | (C1 n T1 T2) # r \<Rightarrow> C1 n (test09 (T1 # r)) (test09 (T2 # r))
  | _ # r \<Rightarrow> C3 [test09 r]]"

friend_of_corec test09 where
  "test09 xs = (case xs of
    [] \<Rightarrow> C2 0 (test09 [])
  | (C1 n T1 T2) # r \<Rightarrow> C1 n (test09 (T1 # r)) (test09 (T2 # r))
  | _ # r \<Rightarrow> C3 [test09 r])"
   defer
   apply transfer_prover
  sorry (* not sure the specifications are equal *)

codatatype tree =
  Node (node: int) (branches: "tree list")

consts integerize_tree_list :: "'a list \<Rightarrow> int"

lemma integerize_tree_list_transfer[transfer_rule]:
  "rel_fun (list_all2 R) (=) integerize_tree_list integerize_tree_list"
  sorry

corec (friend) f10a where
  "f10a x y = Node
  (integerize_tree_list (branches x) + integerize_tree_list (branches y))
  (map (\<lambda>(x, y). f10a x y) (zip (branches x) (branches y)))"

corec f10 where
  "f10 x y = Node
  (integerize_tree_list (branches x) + integerize_tree_list (branches y))
  (map (\<lambda>(x, y). f10 x y) (zip (branches x) (branches y)))"

friend_of_corec f10 where
  "f10 x y = Node
  (integerize_tree_list (branches x) + integerize_tree_list (branches y))
  (map (\<lambda>(x, y). f10 x y) (zip (branches x) (branches y)))"
     apply (rule f10.code)
    by transfer_prover+

corec f12 where
  "f12 t = Node (node t) (map f12 (branches t))"

friend_of_corec f12 where
  "f12 t = Node (node t) (map f12 (branches t))"
  sorry

corec f13 where
  "f13 n ts = Node n (map (%t. f13 (node t) (branches t)) ts)"

friend_of_corec f13 where
  "f13 n ts = Node n (map (%t. f13 (node t) (branches t)) ts)"
  sorry

corec f14 :: "tree option \<Rightarrow> tree" where
  "f14 t_opt = Node 0
    (case map_option branches t_opt of
      None \<Rightarrow> []
    | Some ts \<Rightarrow> map (f14 o Some) ts)"

friend_of_corec f14 where
  "f14 t_opt = Node 0
    (case map_option branches t_opt of
      None \<Rightarrow> []
    | Some ts \<Rightarrow> map (f14 o Some) ts)"
  sorry

corec f15 :: "tree list option \<Rightarrow> tree" where
  "f15 ts_opt = Node 0
    (case map_option (map branches) ts_opt of
      None \<Rightarrow> []
    | Some tss \<Rightarrow> map (f15 o Some) tss)"

friend_of_corec f15 where
  "f15 ts_opt = Node 0
    (case map_option (map branches) ts_opt of
      None \<Rightarrow> []
    | Some tss \<Rightarrow> map (f15 o Some) tss)"
    sorry

corec f16 :: "tree list option \<Rightarrow> tree" where
  "f16 ts_opt = Node 0
    (case ts_opt of
      None \<Rightarrow> []
    | Some ts \<Rightarrow> map (f16 o Some o branches) ts)"

friend_of_corec f16 where
  "f16 ts_opt = Node 0
    (case ts_opt of
      None \<Rightarrow> []
    | Some ts \<Rightarrow> map (f16 o Some o branches) ts)"
    sorry

corec f17 :: "tree list option \<Rightarrow> tree" where
  "f17 ts_opt = Node 0 (case ts_opt of
    None \<Rightarrow> []
  | Some ts \<Rightarrow> [f17 (Some (map (List.hd o branches) ts))])"

(* not parametric
friend_of_corec f17 where
  "f17 ts_opt = Node 0 (case ts_opt of
    None \<Rightarrow> []
  | Some ts \<Rightarrow> [f17 (Some (map (List.hd o branches) ts))])"
  sorry
*)

corec f18 :: "tree \<Rightarrow> tree" where
  "f18 t = Node (node t) (map (f18 o f12) (branches t))"

friend_of_corec f18 :: "tree \<Rightarrow> tree" where
  "f18 t = Node (node t) (map (f18 o f12) (branches t))"
  sorry

corec f19 :: "tree \<Rightarrow> tree" where
  "f19 t = Node (node t) (map (%f. f [t]) (map f13 [1, 2, 3]))"

friend_of_corec f19 :: "tree \<Rightarrow> tree" where
  "f19 t = Node (node t) (map (%f. f [t]) (map f13 [1, 2, 3]))"
  sorry

datatype ('a, 'b, 'c) h = H1 (h_a: 'a) (h_tail: "('a, 'b, 'c) h") | H2 (h_b: 'b) (h_c: 'c) (h_tail: "('a, 'b, 'c) h") | H3

term "map_h (map_option f12) (%n. n) f12"

corec f20 :: "(tree option, int, tree) h \<Rightarrow> tree \<Rightarrow> tree" where
  "f20 x y = Node (node y) (case (map_h (map_option f12) (%n. n) f12 x) of
    H1 None r \<Rightarrow> (f20 r y) # (branches y)
  | H1 (Some t) r \<Rightarrow> (f20 r t) # (branches y)
  | H2 n t r \<Rightarrow> (f20 r (Node n [])) # (branches y)
  | H3 \<Rightarrow> branches y)"

friend_of_corec f20 where
  "f20 x y = Node (node y) (case (map_h (map_option f12) (%n. n) f12 x) of
    H1 None r \<Rightarrow> (f20 r y) # (branches y)
  | H1 (Some t) r \<Rightarrow> (f20 r t) # (branches y)
  | H2 n t r \<Rightarrow> (f20 r (Node n [])) # (branches y)
  | H3 \<Rightarrow> branches y)"
  sorry

corec f21 where
  "f21 x xh =
  Node (node x) (case xh of
    H1 (Some a) yh \<Rightarrow> (f21 x (map_h (map_option (f20 yh)) id id yh)) # (branches a)
  | H1 None yh \<Rightarrow> [f21 x yh]
  | H2 b c yh \<Rightarrow> (f21 c (map_h id (%n. n + b) id yh)) # (branches x)
  | H3 \<Rightarrow> branches x)"

friend_of_corec f21 where
  "f21 x xh =
  Node (node x) (case xh of
    H1 (Some a) yh \<Rightarrow> (f21 x (map_h (map_option (f20 yh)) (%t. t) (%t. t) yh)) # (branches a)
  | H1 None yh \<Rightarrow> [f21 x yh]
  | H2 b c yh \<Rightarrow> (f21 c (map_h (%t. t) (%n. n + b) (%t. t) yh)) # (branches x)
  | H3 \<Rightarrow> branches x)"
  sorry

corec f22 :: "('a \<Rightarrow> tree) \<Rightarrow> 'a list \<Rightarrow> tree" where
  "f22 f x = Node 0 (map f x)"

friend_of_corec f22:: "(nat \<Rightarrow> tree) \<Rightarrow> nat list \<Rightarrow> tree"  where
  "f22 f x = Node 0 (map f x)"
    sorry

corec f23 where
  "f23 xh = Node 0
    (if is_H1 xh then
      (f23 (h_tail xh)) # (branches (h_a xh))
    else if is_H1 xh then
      (f23 (h_tail xh)) # (h_c xh) # (branches (h_b xh))
    else
      [])"

friend_of_corec f23 where
  "f23 xh = Node 0
    (if is_H1 xh then
      (f23 (h_tail xh)) # (branches (h_a xh))
    else if is_H1 xh then
      (f23 (h_tail xh)) # (h_c xh) # (branches (h_b xh))
    else
      [])"
  sorry

corec f24 where
  "f24 xh =
    (if is_H1 xh then
      Node 0 ((f24 (h_tail xh)) # (h_a xh 0))
    else if is_H2 xh then
      Node (h_b xh) ((f24 (h_tail xh)) # (h_c xh 0))
    else
      Node 0 [])"

friend_of_corec f24 :: "(nat \<Rightarrow> tree list, int, int \<Rightarrow> tree list) h \<Rightarrow> tree" where
  "f24 xh =
    (if is_H1 xh then
      Node 0 ((f24 (h_tail xh)) # (h_a xh 0))
    else if is_H2 xh then
      Node (h_b xh) ((f24 (h_tail xh)) # (h_c xh 0))
    else
      Node 0 [])"
  sorry

corec f25 where
  "f25 x = Node (node x) (map f25 ((id branches) x))"

codatatype ('a, 'b) y_type =
  Y (lab: "'a \<Rightarrow> 'b") (y_tail: "('a, 'b) y_type")

corec f26 :: "(int, tree) y_type \<Rightarrow> tree \<Rightarrow> tree" where
  "f26 y x = (case map_y_type f12 y of
  Y f y' \<Rightarrow> Node (node x) ((f (node x)) # (map (f26 y') (branches x))))"

friend_of_corec f26 where
  "f26 y x = (case map_y_type f12 y of
  Y f y' \<Rightarrow> Node (node x) ((f (node x)) # (map (f26 y') (branches x))))"
  sorry

consts int_of_list :: "'a list \<Rightarrow> int"

corec f27 :: "(int, tree) y_type \<Rightarrow> tree \<Rightarrow> tree" where
  "f27 y x = Node (int_of_list (map (f26 (y_tail y)) (branches x))) [lab y (node x)]"

friend_of_corec f27 :: "(int, tree) y_type \<Rightarrow> tree \<Rightarrow> tree" where
  "f27 y x = Node (int_of_list (map (f26 (y_tail y)) (branches x))) [lab y (node x)]"
  sorry

corec f28 :: "(tree option list, (int \<Rightarrow> int) \<Rightarrow> int list \<Rightarrow> tree, tree) h \<Rightarrow> tree" where
  "f28 xh = (case xh of
    H3 \<Rightarrow> Node 0 []
  | H1 l r \<Rightarrow> Node 0 ((f28 r) # map the (filter (%opt. case opt of None \<Rightarrow> False | Some _ \<Rightarrow> True) l))
  | H2 f t r \<Rightarrow> Node (node t) (map (%t. f id [node t]) (branches t)))"

codatatype llist =
  LNil | LCons (head: nat) (tail: llist)

inductive llist_in where
  "llist_in (LCons x xs) x"
| "llist_in xs y \<Longrightarrow> llist_in (LCons x xs) y"

abbreviation "lset xs \<equiv> {x. llist_in xs x}"

corecursive lfilter where
  "lfilter P xs = (if \<forall> x \<in> lset xs. \<not> P x then
    LNil
    else if P (head xs) then
      LCons (head xs) (lfilter P (tail xs))
    else
      lfilter P (tail xs))"
proof (relation "measure (\<lambda>(P, xs). LEAST n. P (head ((tail ^^ n) xs)))", rule wf_measure, clarsimp)
  fix P xs x
  assume "llist_in xs x" "P x" "\<not> P (head xs)"
  from this(1,2) obtain a where "P (head ((tail ^^ a) xs))"
    by (atomize_elim, induct xs x rule: llist_in.induct) (auto simp: funpow_Suc_right
      simp del: funpow.simps(2) intro: exI[of _ 0] exI[of _ "Suc i" for i])
  with \<open>\<not> P (head xs)\<close>
    have "(LEAST n. P (head ((tail ^^ n) xs))) = Suc (LEAST n. P (head ((tail ^^ Suc n) xs)))"
    by (intro Least_Suc) auto
  then show "(LEAST n. P (head ((tail ^^ n) (tail xs)))) < (LEAST n. P (head ((tail ^^ n) xs)))"
    by (simp add: funpow_swap1[of tail])
qed

codatatype Stream =
  SCons (head: nat) (tail: Stream)

corec map_Stream where
  "map_Stream f s = SCons (f (head s)) (map_Stream f (tail s))"

friend_of_corec map_Stream where
  "map_Stream f s = SCons (f (head s)) (map_Stream f (tail s))"
  sorry

corec f29 where
  "f29 f ll = SCons (head ll) (f29 f (map_Stream f (tail ll)))"

friend_of_corec f29 where
  "f29 f ll = SCons (head ll) (f29 f (map_Stream f (tail ll)))"
  sorry

corec f30 where
  "f30 n m = (if n = 0 then SCons m (f30 m m) else f30 (n - 1) (n * m))"

corec f31 :: "llist \<Rightarrow> llist" where
  "f31 x = (if x = LNil then LCons undefined (f31 undefined) else LCons undefined undefined)"

friend_of_corec f31 where
  "f31 x = (if x = LNil then LCons undefined (f31 undefined) else LCons undefined undefined)"
  sorry

corec f32 :: "tree \<Rightarrow> tree" where
  "f32 t = Node (node t) (map ((\<lambda>t'. f18  t') o f32) (branches t))"

corec f33 :: "tree \<Rightarrow> tree" where
  "f33 t = f18 (f18 (Node (node t) (map (\<lambda>t'. (f18 o f18) (f18 (f18 (f33 t')))) (branches t))))"

corec f34 :: "tree \<Rightarrow> tree" where
  "f34 t = f18 (f18 (Node (node t) (map (f18 o f18 o f34) (branches t))))"

corec f35 :: "tree \<Rightarrow> tree" where
  "f35 t = f18 (f18 (Node (node t) (map (f18 o (f18 o (\<lambda>t'. f18 t')) o f35) (branches t))))"

corec f37 :: "int \<Rightarrow> tree list \<Rightarrow> tree option \<Rightarrow> nat \<Rightarrow> tree"  where
  "f37 a x1 = undefined a x1"

end


(*  Title:      ZF/AC/AC18_AC19.thy
    Author:     Krzysztof Grabczewski

The proof of AC1 ==> AC18 ==> AC19 ==> AC1
*)

theory AC18_AC19
imports AC_Equiv
begin

definition
  uu    :: "i => i" where
    "uu(a) == {c \<union> {0}. c \<in> a}"

(* ********************************************************************** *)
(* AC1 ==> AC18                                                           *)
(* ********************************************************************** *)

lemma PROD_subsets:
     "[| f \<in> (\<Prod>b \<in> {P(a). a \<in> A}. b);  \<forall>a \<in> A. P(a)<=Q(a) |]
      ==> (\<lambda>a \<in> A. f`P(a)) \<in> (\<Prod>a \<in> A. Q(a))"
by (rule lam_type, drule apply_type, auto)

lemma lemma_AC18:
     "[| \<forall>A. 0 \<notin> A \<longrightarrow> (\<exists>f. f \<in> (\<Prod>X \<in> A. X)); A \<noteq> 0 |]
      ==> (\<Inter>a \<in> A. \<Union>b \<in> B(a). X(a, b)) \<subseteq>
          (\<Union>f \<in> \<Prod>a \<in> A. B(a). \<Inter>a \<in> A. X(a, f`a))"
apply (rule subsetI)
apply (erule_tac x = "{{b \<in> B (a) . x \<in> X (a,b) }. a \<in> A}" in allE)
apply (erule impE, fast)
apply (erule exE)
apply (rule UN_I)
 apply (fast elim!: PROD_subsets)
apply (simp, fast elim!: not_emptyE dest: apply_type [OF _ RepFunI])
done

lemma AC1_AC18: "AC1 ==> PROP AC18"
apply (unfold AC1_def)
apply (rule AC18.intro)
apply (fast elim!: lemma_AC18 apply_type intro!: equalityI INT_I UN_I)
done

(* ********************************************************************** *)
(* AC18 ==> AC19                                                          *)
(* ********************************************************************** *)

theorem (in AC18) AC19
apply (unfold AC19_def)
apply (intro allI impI)
apply (rule AC18 [of _ "%x. x", THEN mp], blast)
done

(* ********************************************************************** *)
(* AC19 ==> AC1                                                           *)
(* ********************************************************************** *)

lemma RepRep_conj:
        "[| A \<noteq> 0; 0 \<notin> A |] ==> {uu(a). a \<in> A} \<noteq> 0 & 0 \<notin> {uu(a). a \<in> A}"
apply (unfold uu_def, auto)
apply (blast dest!: sym [THEN RepFun_eq_0_iff [THEN iffD1]])
done

lemma lemma1_1: "[|c \<in> a; x = c \<union> {0}; x \<notin> a |] ==> x - {0} \<in> a"
apply clarify
apply (rule subst_elem, assumption)
apply (fast elim: notE subst_elem)
done

lemma lemma1_2:
        "[| f`(uu(a)) \<notin> a; f \<in> (\<Prod>B \<in> {uu(a). a \<in> A}. B); a \<in> A |]
                ==> f`(uu(a))-{0} \<in> a"
apply (unfold uu_def, fast elim!: lemma1_1 dest!: apply_type)
done

lemma lemma1: "\<exists>f. f \<in> (\<Prod>B \<in> {uu(a). a \<in> A}. B) ==> \<exists>f. f \<in> (\<Prod>B \<in> A. B)"
apply (erule exE)
apply (rule_tac x = "\<lambda>a\<in>A. if (f` (uu(a)) \<in> a, f` (uu(a)), f` (uu(a))-{0})"
       in exI)
apply (rule lam_type)
apply (simp add: lemma1_2)
done

lemma lemma2_1: "a\<noteq>0 ==> 0 \<in> (\<Union>b \<in> uu(a). b)"
by (unfold uu_def, auto)

lemma lemma2: "[| A\<noteq>0; 0\<notin>A |] ==> (\<Inter>x \<in> {uu(a). a \<in> A}. \<Union>b \<in> x. b) \<noteq> 0"
apply (erule not_emptyE)
apply (rule_tac a = 0 in not_emptyI)
apply (fast intro!: lemma2_1)
done

lemma AC19_AC1: "AC19 ==> AC1"
apply (unfold AC19_def AC1_def, clarify)
apply (case_tac "A=0", force)
apply (erule_tac x = "{uu (a) . a \<in> A}" in allE)
apply (erule impE)
apply (erule RepRep_conj, assumption)
apply (rule lemma1)
apply (drule lemma2, assumption, auto)
done

end


theory prop_20
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun length :: "'a list => Nat" where
  "length (Nil2) = Z"
  | "length (Cons2 y xs) = S (length xs)"
  fun even :: "Nat => bool" where
  "even (Z) = True"
  | "even (S (Z)) = False"
  | "even (S (S z)) = even z"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  (*hipster length even append *)

fun yum ::  "'a list => 'a list => 'a list" where
  "yum Nil2 Nil2 = Nil2"
| "yum (Cons2 x xs) Nil2 = yum xs Nil2"
| "yum Nil2 (Cons2 y ys) = yum Nil2 ys"
| "yum (Cons2 x xs) (Cons2 y ys) = yum xs ys"

thm yum.induct
lemma xx: "even x = even y"
apply(induction x)
apply(induction y)
(*hipster length even append*)
lemma lemma_a [thy_expl]: "append x2 Nil2 = x2"
by (hipster_induct_schemes length.simps even.simps append.simps)

lemma lemma_aa [thy_expl]: "append (append x1 y1) z1 = append x1 (append y1 z1)"
by (hipster_induct_schemes length.simps even.simps append.simps)

lemma unknown [thy_expl]: "length (append x y) = length (append y x)"
oops

lemma ax2[thy_expl]: "length (append y (Cons2 ya xs)) = S (length (append y xs))"
by(hipster_induct_schemes)

  theorem x0 :
    "even (length (append x x))"
    by (hipster_induct_schemes length.simps even.simps append.simps list.exhaust Nat.exhaust)

    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
section \<open>Empty Set\<close>
theory Empty_Set
  imports Equality
begin

lemma emptyE [elim]: "x \<in> {} \<Longrightarrow> P" by auto

lemma eq_emptyI [intro]: "\<lbrakk>\<And>y. y \<in> A \<Longrightarrow> False\<rbrakk> \<Longrightarrow> A = {}"
  by auto

lemma not_mem_if_empty [dest]: "A = {} \<Longrightarrow> a \<notin> A"
  by auto

lemma ne_empty_if_mem: "a \<in> A \<Longrightarrow> A \<noteq> {}"
  by auto

lemma ex_mem_if_ne_empty: "A \<noteq> {} \<Longrightarrow> \<exists>x. x \<in> A"
  by auto

lemma ne_emptyE:
  assumes "A \<noteq> {}"
  obtains x where "x \<in> A"
  using ex_mem_if_ne_empty[OF assms]
  by blast

lemma mem_trans_empty [iff]: "mem_trans {}"
  unfolding mem_trans_def by blast

end