section {* Augmented Type Syntax for Concrete Checker *}

theory Wasm_Checker_Types imports Wasm "HOL-Library.Sublist" begin

datatype ct =
    TAny
  | TSome t

datatype checker_type =
    TopType "ct list"
  | Type "t list"
  | Bot

definition to_ct_list :: "t list \<Rightarrow> ct list" where
  "to_ct_list ts = map TSome ts"

fun ct_eq :: "ct \<Rightarrow> ct \<Rightarrow> bool" where
  "ct_eq (TSome t) (TSome t') = (t = t')"
| "ct_eq TAny _ = True"
| "ct_eq _ TAny = True"

definition ct_list_eq :: "ct list \<Rightarrow> ct list \<Rightarrow> bool" where
  "ct_list_eq ct1s ct2s = list_all2 ct_eq ct1s ct2s"

definition ct_prefix :: "ct list \<Rightarrow> ct list \<Rightarrow> bool" where
  "ct_prefix xs ys = (\<exists>as bs. ys = as@bs \<and> ct_list_eq as xs)"

definition ct_suffix :: "ct list \<Rightarrow> ct list \<Rightarrow> bool" where
  "ct_suffix xs ys = (\<exists>as bs. ys = as@bs \<and> ct_list_eq bs xs)"

lemma ct_eq_commute:
  assumes "ct_eq x y"
  shows "ct_eq y x"
  using assms
  by (metis ct_eq.elims(3) ct_eq.simps(1))

lemma ct_eq_flip: "ct_eq\<inverse>\<inverse> = ct_eq"
  using ct_eq_commute
  by fastforce

lemma ct_eq_common_tsome: "ct_eq x y = (\<exists>t. ct_eq x (TSome t) \<and> ct_eq (TSome t) y)"
  by (metis ct_eq.elims(3) ct_eq.simps(1))

lemma ct_list_eq_commute:
  assumes "ct_list_eq xs ys"
  shows "ct_list_eq ys xs"
  using assms ct_eq_commute List.List.list.rel_flip ct_eq_flip
  unfolding ct_list_eq_def
  by fastforce

lemma ct_list_eq_refl: "ct_list_eq xs xs"
  unfolding ct_list_eq_def
  by (metis ct_eq.elims(3) ct_eq.simps(1) list_all2_refl)

lemma ct_list_eq_length:
  assumes "ct_list_eq xs ys"
  shows "length xs = length ys"
  using assms list_all2_lengthD
  unfolding ct_list_eq_def
  by blast

lemma ct_list_eq_concat:
  assumes "ct_list_eq xs ys"
          "ct_list_eq xs' ys'"
  shows "ct_list_eq (xs@xs') (ys@ys')"
  using assms
  unfolding ct_list_eq_def
  by (simp add: list_all2_appendI)

lemma ct_list_eq_ts_conv_eq:
  "ct_list_eq (to_ct_list ts) (to_ct_list ts') = (ts = ts')"
  unfolding ct_list_eq_def to_ct_list_def
            list_all2_map1 list_all2_map2
            ct_eq.simps(1)
  by (simp add: list_all2_eq)

lemma ct_list_eq_exists: "\<exists>ys. ct_list_eq xs (to_ct_list ys)"
proof (induction xs)
  case Nil
  thus ?case
    unfolding ct_list_eq_def to_ct_list_def
    by (simp)
next
  case (Cons a xs)
  thus ?case
    unfolding ct_list_eq_def to_ct_list_def
    apply (cases a)
     apply (metis ct_eq.simps(3) ct_eq_commute list.rel_intros(2) list.simps(9))
    apply (metis ct_eq.simps(1) list.rel_intros(2) list.simps(9))
    done
qed

lemma ct_list_eq_common_tsome_list:
  "ct_list_eq xs ys = (\<exists>zs. ct_list_eq xs (to_ct_list zs) \<and> ct_list_eq (to_ct_list zs) ys)"
proof (induction ys arbitrary: xs)
  case Nil
  thus ?case
    unfolding ct_list_eq_def to_ct_list_def
    by simp
next
  case (Cons a ys)
  show ?case
  proof (safe)
    assume assms:"ct_list_eq xs (a # ys)"
    then obtain x' xs' where xs_def:"xs = x'#xs'"
      by (meson ct_list_eq_def list_all2_Cons2)
    then obtain zs where zs_def:"ct_eq x' a"
                                "ct_list_eq xs' (to_ct_list zs) \<and> ct_list_eq (to_ct_list zs) ys"
      using Cons[of xs'] assms list_all2_Cons
      unfolding ct_list_eq_def
      by fastforce
    obtain z where "ct_eq x' (TSome z)" "ct_eq (TSome z) a"
      using ct_eq_common_tsome[of x' a] zs_def(1)
      by fastforce
    hence "ct_list_eq (x'#xs') (to_ct_list (z#zs)) \<and> ct_list_eq (to_ct_list (z#zs)) (a # ys)"
      using zs_def(2) list_all2_Cons
      unfolding ct_list_eq_def to_ct_list_def
      by simp
    thus "\<exists>zs. ct_list_eq xs (to_ct_list zs) \<and> ct_list_eq (to_ct_list zs) (a # ys)"
      using xs_def
      by fastforce
  next
    fix zs
    assume assms:"ct_list_eq xs (to_ct_list zs)" "ct_list_eq (to_ct_list zs) (a # ys)"
    then obtain x' xs' z' zs' where "xs = x'#xs'"
                                    "zs = z'#zs'"
                                    "ct_list_eq xs' (to_ct_list zs')"
                                    "ct_list_eq (to_ct_list zs') (ys)"
      using list_all2_Cons2
      unfolding ct_list_eq_def to_ct_list_def list_all2_map1 list_all2_map2
      by (metis (no_types, lifting))
    thus "ct_list_eq xs (a # ys)"
      using assms Cons ct_list_eq_def to_ct_list_def ct_eq_common_tsome
      by (metis list.simps(9) list_all2_Cons)
  qed
qed

lemma ct_list_eq_cons_ct_list:
  assumes "ct_list_eq (to_ct_list as) (xs @ ys)"
  shows "\<exists>bs bs'. as = bs @ bs' \<and> ct_list_eq (to_ct_list bs) xs \<and> ct_list_eq (to_ct_list bs') ys"
  using assms
proof (induction xs arbitrary: as)
  case Nil
  thus ?case
    by (metis append_Nil ct_list_eq_ts_conv_eq list.simps(8) to_ct_list_def)
next
  case (Cons a xs)
  thus ?case
    unfolding ct_list_eq_def to_ct_list_def list_all2_map1
    by (meson list_all2_append2)
qed

lemma ct_list_eq_cons_ct_list1:
  assumes "ct_list_eq (to_ct_list as) (xs @ (to_ct_list ys))"
  shows "\<exists>bs. as = bs @ ys \<and> ct_list_eq (to_ct_list bs) xs"
  using ct_list_eq_cons_ct_list[OF assms] ct_list_eq_ts_conv_eq
  by fastforce

lemma ct_list_eq_shared:
  assumes "ct_list_eq xs (to_ct_list as)"
          "ct_list_eq ys (to_ct_list as)"
  shows "ct_list_eq xs ys"
  using assms ct_list_eq_def
  by (meson ct_list_eq_common_tsome_list ct_list_eq_commute)

lemma ct_list_eq_take:
  assumes "ct_list_eq xs ys"
  shows "ct_list_eq (take n xs) (take n ys)"
  using assms list_all2_takeI
  unfolding ct_list_eq_def
  by blast

lemma ct_prefixI [intro?]:
  assumes "ys = as @ zs"
          "ct_list_eq as xs"
  shows "ct_prefix xs ys"
  using assms
  unfolding ct_prefix_def
  by blast

lemma ct_prefixE [elim?]:
  assumes "ct_prefix xs ys"
  obtains as zs where "ys = as @ zs" "ct_list_eq as xs"
  using assms
  unfolding ct_prefix_def
  by blast

lemma ct_prefix_snoc [simp]: "ct_prefix xs (ys @ [y]) = (ct_list_eq xs (ys@[y]) \<or> ct_prefix xs ys)"
proof (safe)
  assume "ct_prefix xs (ys @ [y])" "\<not> ct_prefix xs ys"
  thus "ct_list_eq xs (ys @ [y])"
    unfolding ct_prefix_def ct_list_eq_def
    by (metis butlast_append butlast_snoc ct_eq_flip list.rel_flip)
next
  assume "ct_list_eq xs (ys @ [y])"
  thus "ct_prefix xs (ys @ [y])"
    using ct_list_eq_commute ct_prefixI
    by fastforce
next
  assume "ct_prefix xs ys"
  thus "ct_prefix xs (ys @ [y])"
    using append_assoc
    unfolding ct_prefix_def
    by blast
qed

lemma ct_prefix_nil:"ct_prefix [] xs"
                    "\<not>ct_prefix (x # xs) []"
  by (simp_all add: ct_prefix_def ct_list_eq_def)

lemma Cons_ct_prefix_Cons[simp]: "ct_prefix (x # xs) (y # ys) = ((ct_eq x y) \<and> ct_prefix xs ys)"
proof (safe)
  assume "ct_prefix (x # xs) (y # ys)"
  thus "ct_eq x y"
    unfolding ct_prefix_def ct_list_eq_def
    by (metis ct_eq_commute hd_append2 list.sel(1) list.simps(3) list_all2_Cons2)
next
  assume "ct_prefix (x # xs) (y # ys)"
  thus "ct_prefix xs ys"
    unfolding ct_prefix_def ct_list_eq_def
    by (metis list.rel_distinct(1) list.sel(3) list_all2_Cons2 tl_append2)
next
  assume "ct_eq x y" "ct_prefix xs ys"
  thus "ct_prefix (x # xs) (y # ys)"
    unfolding ct_prefix_def ct_list_eq_def
    by (metis (full_types) append_Cons ct_list_eq_commute ct_list_eq_def list.rel_inject(2))
qed

lemma ct_prefix_code [code]:
  "ct_prefix [] xs = True"
  "ct_prefix (x # xs) [] = False"
  "ct_prefix (x # xs) (y # ys) = ((ct_eq x y) \<and> ct_prefix xs ys)"
  by (simp_all add: ct_prefix_nil)

lemma ct_suffix_to_ct_prefix [code]: "ct_suffix xs ys = ct_prefix (rev xs) (rev ys)"
  unfolding ct_suffix_def ct_prefix_def ct_list_eq_def
  by (metis list_all2_rev1 rev_append rev_rev_ident)

lemma inj_TSome: "inj TSome"
  by (meson ct.inject injI)

lemma to_ct_list_append:
  assumes "to_ct_list ts = as@bs"
  shows "\<exists>as'. to_ct_list as' = as"
        "\<exists>bs'. to_ct_list bs' = bs"
  using assms
proof (induct as arbitrary: ts)
  fix ts
  assume "to_ct_list ts = [] @ bs"
  thus "\<exists>as'. to_ct_list as' = []"
       "\<exists>bs'. to_ct_list bs' = bs"
    unfolding to_ct_list_def
    by auto
next
  case (Cons a as)
  fix ts
  assume local_assms:"to_ct_list ts = (a # as) @ bs"
  then obtain t' ts' where "ts = t'#ts'"
    unfolding to_ct_list_def
    by auto
  thus "\<exists>as'. to_ct_list as' = a # as"
       "\<exists>as'. to_ct_list as' = bs"
    using Cons local_assms
    unfolding to_ct_list_def
    apply simp_all
     apply (metis list.simps(9))
    apply blast
    done
qed

lemma ct_suffixI [intro?]:
  assumes "ys = as @ zs"
          "ct_list_eq zs xs"
  shows "ct_suffix xs ys"
  using assms
  unfolding ct_suffix_def
  by blast

lemma ct_suffixE [elim?]:
  assumes "ct_suffix xs ys"
  obtains as zs where "ys = as @ zs" "ct_list_eq zs xs"
  using assms
  unfolding ct_suffix_def
  by blast

lemma ct_suffix_nil: "ct_suffix [] ts"
  unfolding ct_suffix_def
  using ct_list_eq_refl
  by auto

lemma ct_suffix_refl: "ct_suffix ts ts"
  unfolding ct_suffix_def
  using ct_list_eq_refl
  by auto

lemma ct_suffix_length:
  assumes "ct_suffix ts ts'"
  shows "length ts \<le> length ts'"
  using assms list_all2_lengthD
  unfolding ct_suffix_def ct_list_eq_def
  by fastforce

lemma ct_suffix_take:
  assumes "ct_suffix ts ts'"
  shows "ct_suffix ((take (length ts - n) ts)) ((take (length ts' - n) ts'))"
  using assms ct_list_eq_take append_eq_conv_conj
  unfolding ct_suffix_def
proof -
  assume "\<exists>as bs. ts' = as @ bs \<and> ct_list_eq bs ts"
  then obtain ccs :: "ct list" and ccsa :: "ct list" where
    f1: "ts' = ccs @ ccsa \<and> ct_list_eq ccsa ts"
    by moura
  then have f2: "length ccsa = length ts"
    by (meson ct_list_eq_length)
  have "\<And>n. ct_list_eq (take n ccsa) (take n ts)"
    using f1 by (meson ct_list_eq_take)
  then show "\<exists>cs csa. take (length ts' - n) ts' = cs @ csa \<and> ct_list_eq csa (take (length ts - n) ts)"
    using f2 f1 by auto
qed

lemma ct_suffix_ts_conv_suffix:
  "ct_suffix (to_ct_list ts) (to_ct_list ts') = suffix ts ts'"
proof safe
  assume "ct_suffix (to_ct_list ts) (to_ct_list ts')"
  then obtain as bs where "to_ct_list ts' = (to_ct_list as) @ (to_ct_list bs)"
                          "ct_list_eq (to_ct_list bs) (to_ct_list ts)"
    using to_ct_list_append
    unfolding ct_suffix_def
    by metis
  thus "suffix ts ts'"
    using ct_list_eq_ts_conv_eq
    unfolding ct_suffix_def to_ct_list_def suffix_def
    by (metis map_append)
next
  assume "suffix ts ts'"
  thus "ct_suffix (to_ct_list ts) (to_ct_list ts')"
    using ct_list_eq_ts_conv_eq
    unfolding ct_suffix_def to_ct_list_def suffix_def
    by (metis map_append)
qed

lemma ct_suffix_exists: "\<exists>ts_c. ct_suffix x1 (to_ct_list ts_c)"
  using ct_list_eq_commute ct_list_eq_exists ct_suffix_def
  by fastforce

lemma ct_suffix_ct_list_eq_exists:
  assumes "ct_suffix x1 x2"
  shows "\<exists>ts_c. ct_suffix x1 (to_ct_list ts_c) \<and> ct_list_eq (to_ct_list ts_c) x2"
proof -
  obtain as bs where x2_def:"x2 = as @ bs" "ct_list_eq x1 bs"
    using assms ct_list_eq_commute
    unfolding ct_suffix_def
    by blast
  then obtain ts_as ts_bs where "ct_list_eq as (to_ct_list ts_as)"
                                "ct_list_eq x1 (to_ct_list ts_bs)"
                                "ct_list_eq (to_ct_list ts_bs) bs"
    using ct_list_eq_common_tsome_list[of x1 bs] ct_list_eq_exists
    by fastforce
  thus ?thesis
    using x2_def ct_list_eq_commute
    unfolding ct_suffix_def to_ct_list_def
    by (metis ct_list_eq_def list_all2_appendI map_append)
qed

lemma ct_suffix_cons_ct_list:
  assumes "ct_suffix (xs@ys) (to_ct_list zs)"
  shows "\<exists>as bs. zs = as@bs \<and> ct_list_eq ys (to_ct_list bs) \<and> ct_suffix xs (to_ct_list as)"
proof -
  obtain as bs where "to_ct_list zs = (to_ct_list as) @ (to_ct_list bs)"
                     "ct_list_eq (to_ct_list bs) (xs @ ys)"
    using assms to_ct_list_append[of zs]
    unfolding ct_suffix_def
    by blast
  thus ?thesis
    using assms ct_list_eq_cons_ct_list[of bs xs ys]
    unfolding ct_suffix_def
  by (metis append.assoc ct_list_eq_commute ct_list_eq_ts_conv_eq map_append to_ct_list_def)
qed

lemma ct_suffix_cons_ct_list1:
  assumes "ct_suffix (xs@(to_ct_list ys)) (to_ct_list zs)"
  shows "\<exists>as. zs = as@ys \<and> ct_suffix xs (to_ct_list as)"
  using ct_suffix_cons_ct_list[OF assms] ct_list_eq_ts_conv_eq
  by fastforce

lemma ct_suffix_cons2:
  assumes "ct_suffix (xs) (ys@zs)"
          "length xs = length zs"
  shows "ct_list_eq xs zs"
  using assms
  by (metis append_eq_append_conv ct_list_eq_commute ct_list_eq_def ct_suffix_def list_all2_lengthD)

lemma ct_suffix_imp_ct_list_eq:
  assumes "ct_suffix xs ys"
  shows "ct_list_eq (drop (length ys - length xs) ys) xs"
  using assms ct_list_eq_def list_all2_lengthD
  unfolding ct_suffix_def
  by fastforce

lemma ct_suffix_extend_ct_list_eq:
  assumes "ct_suffix xs ys"
          "ct_list_eq xs' ys'"
  shows "ct_suffix (xs@xs') (ys@ys')"
  using assms
  unfolding ct_suffix_def ct_list_eq_def
  by (meson append.assoc ct_list_eq_commute ct_list_eq_def list_all2_appendI)

lemma ct_suffix_extend_any1:
  assumes "ct_suffix xs ys"
          "length xs < length ys"
  shows "ct_suffix (TAny#xs) ys"
proof -
  obtain as bs where ys_def:"ys = as@bs"
                            "ct_list_eq bs xs"
    using assms(1) ct_suffix_def
    by fastforce
  hence "length as > 0"
    using list_all2_lengthD assms(2)
    unfolding ct_list_eq_def
    by fastforce
  then obtain as' a where as_def:"as = as'@[a]"
    by (metis append_butlast_last_id length_greater_0_conv)
  hence "ct_list_eq (a#bs) (TAny#xs)"
    using ys_def
    by (meson ct_eq.simps(2) ct_list_eq_commute ct_list_eq_def list.rel_intros(2))
  thus ?thesis
    using as_def ys_def ct_suffix_def
    by fastforce
qed

lemma ct_suffix_singleton_any: "ct_suffix [TAny] [t]"
  using ct_suffix_extend_ct_list_eq[of "[]" "[]" "[TAny]" "[t]"] ct_suffix_nil
  by (simp add: ct_list_eq_def)

lemma ct_suffix_cons_it: "ct_suffix xs (xs'@xs)"
  using ct_list_eq_refl ct_suffix_def
  by blast

lemma ct_suffix_singleton:
  assumes "length cts > 0"
  shows "ct_suffix [TAny] cts"
proof -
  have "\<And>c. ct_prefix [TAny] [c]"
    using ct_suffix_singleton_any ct_suffix_to_ct_prefix by force
  then show ?thesis
    by (metis (no_types) Suc_leI append_butlast_last_id assms butlast.simps(2) ct_list_eq_commute
                         ct_prefix_nil(2) ct_prefix_snoc ct_suffix_def impossible_Cons length_Cons
                         list.size(3))
qed

lemma ct_suffix_less:
  assumes "ct_suffix (xs@xs') ys"
  shows "ct_suffix xs' ys"
  using assms
  unfolding ct_suffix_def
  by (metis append_eq_appendI ct_list_eq_def list_all2_append2)

lemma ct_suffix_unfold_one: "ct_suffix (xs@[x]) (ys@[y]) = ((ct_eq x y) \<and> ct_suffix xs ys)"
  using ct_prefix_code(3)
  by (simp add: ct_suffix_to_ct_prefix)

lemma ct_suffix_shared:
  assumes "ct_suffix cts (to_ct_list ts)"
          "ct_suffix cts' (to_ct_list ts)"
  shows "ct_suffix cts cts' \<or> ct_suffix cts' cts"
proof (cases "length cts > length cts'")
  case True
  obtain as bs where cts_def:"ts = as@bs"
                             "ct_list_eq cts (to_ct_list bs)"
    using assms(1) ct_suffix_def to_ct_list_def
    by (metis append_Nil ct_suffix_cons_ct_list)
  obtain as' bs' where cts'_def:"ts = as'@bs'"
                                "ct_list_eq cts' (to_ct_list bs')"
    using assms(2) ct_suffix_def to_ct_list_def
    by (metis append_Nil ct_suffix_cons_ct_list)
  obtain ct1s ct2s where "cts = ct1s@ct2s"
                         "length ct2s = length cts'"
    using True (* List.append_eq_conv_conj[of _ _ cts] *)
    by (metis add_diff_cancel_right' append_take_drop_id length_drop less_imp_le_nat nat_le_iff_add)
  show ?thesis
  proof -
    obtain tts :: "t list \<Rightarrow> ct list \<Rightarrow> ct list \<Rightarrow> t list" and ttsa :: "t list \<Rightarrow> ct list \<Rightarrow> ct list \<Rightarrow> t list" where
      "\<forall>x0 x1 x2. (\<exists>v3 v4. x0 = v3 @ v4 \<and> ct_list_eq x1 (to_ct_list v4) \<and> ct_suffix x2 (to_ct_list v3)) = (x0 = tts x0 x1 x2 @ ttsa x0 x1 x2 \<and> ct_list_eq x1 (to_ct_list (ttsa x0 x1 x2)) \<and> ct_suffix x2 (to_ct_list (tts x0 x1 x2)))"
      by moura
    then have f1: "as' @ bs' = tts (as' @ bs') ct2s ct1s @ ttsa (as' @ bs') ct2s ct1s \<and> ct_list_eq ct2s (to_ct_list (ttsa (as' @ bs') ct2s ct1s)) \<and> ct_suffix ct1s (to_ct_list (tts (as' @ bs') ct2s ct1s))"
      using assms(1) \<open>cts = ct1s @ ct2s\<close> cts'_def(1) ct_suffix_cons_ct_list by force
    then have "ct_list_eq cts' (to_ct_list (ttsa (as' @ bs') ct2s ct1s))"
      by (metis \<open>ct_suffix cts' (to_ct_list ts)\<close> \<open>length ct2s = length cts'\<close> cts'_def(1) ct_list_eq_length ct_suffix_cons2 map_append to_ct_list_def)
    then show ?thesis
      using f1 by (metis \<open>cts = ct1s @ ct2s\<close> ct_list_eq_shared ct_suffix_def)
  qed
next
  case False
  hence len:"length cts' \<ge> length cts"
    by linarith
  obtain as bs where cts_def:"ts = as@bs"
                             "ct_list_eq cts (to_ct_list bs)"
    using assms(1) ct_suffix_def to_ct_list_def
    by (metis append_Nil ct_suffix_cons_ct_list)
  obtain as' bs' where cts'_def:"ts = as'@bs'"
                                "ct_list_eq cts' (to_ct_list bs')"
    using assms(2) ct_suffix_def to_ct_list_def
    by (metis append_Nil ct_suffix_cons_ct_list)
  obtain ct1s ct2s where "cts' = ct1s@ct2s"
                         "length ct2s = length cts"
    using len (* List.append_eq_conv_conj[of _ _ cts] *)
    by (metis add_diff_cancel_right' append_take_drop_id length_drop nat_le_iff_add)
  show ?thesis
  proof -
    obtain tts :: "t list \<Rightarrow> ct list \<Rightarrow> ct list \<Rightarrow> t list" and ttsa :: "t list \<Rightarrow> ct list \<Rightarrow> ct list \<Rightarrow> t list" where
      "\<forall>x0 x1 x2. (\<exists>v3 v4. x0 = v3 @ v4 \<and> ct_list_eq x1 (to_ct_list v4) \<and> ct_suffix x2 (to_ct_list v3)) = (x0 = tts x0 x1 x2 @ ttsa x0 x1 x2 \<and> ct_list_eq x1 (to_ct_list (ttsa x0 x1 x2)) \<and> ct_suffix x2 (to_ct_list (tts x0 x1 x2)))"
      by moura
    then have f1: "as @ bs = tts (as @ bs) ct2s ct1s @ ttsa (as @ bs) ct2s ct1s \<and> ct_list_eq ct2s (to_ct_list (ttsa (as @ bs) ct2s ct1s)) \<and> ct_suffix ct1s (to_ct_list (tts (as @ bs) ct2s ct1s))"
      using assms(2) \<open>cts' = ct1s @ ct2s\<close> cts_def(1) ct_suffix_cons_ct_list by force
    then have "ct_list_eq cts (to_ct_list (ttsa (as @ bs) ct2s ct1s))"
      by (metis \<open>ct_suffix cts (to_ct_list ts)\<close> \<open>length ct2s = length cts\<close> cts_def(1) ct_list_eq_length ct_suffix_cons2 map_append to_ct_list_def)
    then show ?thesis
      using f1 by (metis \<open>cts' = ct1s @ ct2s\<close> ct_list_eq_shared ct_suffix_def)
  qed
qed

fun checker_type_suffix::"checker_type \<Rightarrow> checker_type \<Rightarrow> bool" where
  "checker_type_suffix (Type ts) (Type ts') = suffix ts ts'"
| "checker_type_suffix (Type ts) (TopType cts) = ct_suffix (to_ct_list ts) cts"
| "checker_type_suffix (TopType cts) (Type ts) = ct_suffix cts (to_ct_list ts)"
| "checker_type_suffix _ _ = False"

fun consume :: "checker_type \<Rightarrow> ct list \<Rightarrow> checker_type" where
  "consume (Type ts) cons = (if ct_suffix cons (to_ct_list ts)
                               then Type (take (length ts - length cons) ts)
                               else Bot)"
| "consume (TopType cts) cons = (if ct_suffix cons cts
                                  then TopType (take (length cts - length cons) cts)
                                  else (if ct_suffix cts cons
                                          then TopType []
                                          else Bot))"
| "consume _ _ = Bot"

fun produce :: "checker_type \<Rightarrow> checker_type \<Rightarrow> checker_type" where
  "produce (TopType ts) (Type ts') = TopType (ts@(to_ct_list ts'))"
| "produce (Type ts) (Type ts') = Type (ts@ts')"
| "produce (Type ts') (TopType ts) = TopType ts"
| "produce (TopType ts') (TopType ts) = TopType ts"
| "produce _ _ = Bot"

fun type_update :: "checker_type \<Rightarrow> ct list \<Rightarrow> checker_type \<Rightarrow> checker_type" where
  "type_update curr_type cons prods = produce (consume curr_type cons) prods"

fun select_return_top :: "[ct list] \<Rightarrow> ct \<Rightarrow> ct \<Rightarrow> checker_type" where
  "select_return_top ts ct1 TAny = TopType ((take (length ts - 3) ts) @ [ct1])"
| "select_return_top ts TAny ct2 = TopType ((take (length ts - 3) ts) @ [ct2])"
| "select_return_top ts (TSome t1) (TSome t2) = (if (t1 = t2)
                                                   then (TopType ((take (length ts - 3) ts) @ [TSome t1]))
                                                   else Bot)"

fun type_update_select :: "checker_type \<Rightarrow> checker_type" where
  "type_update_select (Type ts) = (if (length ts \<ge> 3 \<and> (ts!(length ts-2)) = (ts!(length ts-3)))
                                    then consume (Type ts) [TAny, TSome T_i32]
                                    else Bot)"
| "type_update_select (TopType ts) = (case length ts of
                                        0 \<Rightarrow> TopType [TAny]
                                      | Suc 0 \<Rightarrow> type_update (TopType ts) [TSome T_i32] (TopType [TAny])
                                      | Suc (Suc 0) \<Rightarrow> consume (TopType ts) [TSome T_i32]
                                      | _  \<Rightarrow> type_update (TopType ts) [TAny, TAny, TSome T_i32]
                                                          (select_return_top ts (ts!(length ts-2)) (ts!(length ts-3))))"
| "type_update_select _ = Bot"

fun c_types_agree :: "checker_type \<Rightarrow> t list \<Rightarrow> bool" where
  "c_types_agree (Type ts) ts' = (ts = ts')"
| "c_types_agree (TopType ts) ts' = ct_suffix ts (to_ct_list ts')"
| "c_types_agree Bot _ = False"

lemma consume_type:
  assumes "consume (Type ts) ts' = c_t"
          "c_t \<noteq> Bot"
  shows "\<exists>ts''. ct_list_eq (to_ct_list ts) ((to_ct_list ts'')@ts') \<and> c_t = Type ts''"
proof -
  {
    assume a1: "(if ct_suffix ts' (map TSome ts) then Type (take (length ts - length ts') ts) else Bot) = c_t"
    assume a2: "c_t \<noteq> Bot"
    obtain ccs :: "ct list \<Rightarrow> ct list \<Rightarrow> ct list" and ccsa :: "ct list \<Rightarrow> ct list \<Rightarrow> ct list" where
      f3: "\<forall>cs csa. \<not> ct_suffix cs csa \<or> csa = ccs cs csa @ ccsa cs csa \<and> ct_list_eq (ccsa cs csa) cs"
      using ct_suffixE by moura
    have f4: "ct_suffix ts' (map TSome ts)"
      using a2 a1 by metis
    then have f5: "ct_list_eq (ccsa ts' (map TSome ts)) ts'"
      using f3 by blast
    have f6: "take (length (map TSome ts) - length (ccsa ts' (map TSome ts))) (map TSome ts) @ ccsa ts' (map TSome ts) = map TSome ts"
      using f4 f3 by (metis (full_types) suffixI suffix_take)
    have "\<And>cs. ct_list_eq (cs @ ccsa ts' (map TSome ts)) (cs @ ts')"
      using f5 ct_list_eq_concat ct_list_eq_refl by blast
    then have "\<exists>tsa. ct_list_eq (map TSome ts) (map TSome tsa @ ts') \<and> c_t = Type tsa"
      using f6 f5 f4 a1 by (metis (no_types) ct_list_eq_length length_map take_map)
  }
  thus ?thesis
    using assms to_ct_list_def
    by simp
qed

lemma consume_top_geq:
  assumes "consume (TopType ts) ts' = c_t"
          "length ts \<ge> length ts'"
          "c_t \<noteq> Bot"
  shows "(\<exists>as bs. ts = as@bs \<and> ct_list_eq bs ts' \<and> c_t = TopType as)"
proof -
  consider (1) "ct_suffix ts' ts"
         | (2) "\<not>ct_suffix ts' ts" "ct_suffix ts ts'"
         | (3) "\<not>ct_suffix ts' ts" "\<not>ct_suffix ts ts'"
    by blast
  thus ?thesis
  proof (cases)
    case 1
    hence "TopType (take (length ts - length ts') ts) = c_t"
      using assms
      by simp
    thus ?thesis
      using assms(2) 1 ct_list_eq_def
      unfolding ct_suffix_def
      by (metis (no_types, lifting) append_eq_append_conv append_take_drop_id diff_diff_cancel length_drop list_all2_lengthD)
  next
    case 2
    thus ?thesis
      using assms append_eq_append_conv ct_list_eq_commute
      unfolding ct_suffix_def
      by (metis append.left_neutral ct_suffix_def ct_suffix_length le_antisym)
  next
    case 3
    thus ?thesis
      using assms
      by auto
  qed
qed

lemma consume_top_leq:
  assumes "consume (TopType ts) ts' = c_t"
          "length ts \<le> length ts'"
          "c_t \<noteq> Bot"
  shows "c_t = TopType []"
  using assms append_eq_conv_conj
  by fastforce

lemma consume_type_type:
  assumes "consume xs cons = (Type t_int)"
  shows "\<exists>tn. xs = Type tn"
  using assms
  apply (cases xs)
    apply simp_all
  apply (metis checker_type.distinct(1) checker_type.distinct(5))
  done

lemma produce_type_type:
  assumes "produce xs cons = (Type tm)"
  shows "\<exists>tn. xs = Type tn"
  apply (cases xs; cases cons)
  using assms
          apply simp_all
  done

lemma consume_weaken_type:
  assumes "consume (Type tn) cons = (Type t_int)"
  shows "consume (Type (ts@tn)) cons = (Type (ts@t_int))"
proof -
  obtain ts' where "ct_list_eq (to_ct_list tn) (to_ct_list ts' @ cons) \<and> Type t_int = Type ts'"
    using consume_type[OF assms]
    by blast
  have cond:"ct_suffix cons (to_ct_list tn)"
    using assms
    by (simp, metis checker_type.distinct(5))
  hence res:"t_int = take (length tn - length cons) tn"
    using assms
    by simp
  have "ct_suffix cons (to_ct_list (ts@tn))"
    using cond
    unfolding to_ct_list_def
    by (metis append_assoc ct_suffix_def map_append)
  moreover
  have "ts@t_int = take (length (ts@tn) - length cons) (ts@tn)"
    using res take_append cond ct_suffix_length to_ct_list_def
    by fastforce
  ultimately
  show ?thesis
    by simp
qed

lemma produce_weaken_type:
  assumes "produce (Type tn) cons = (Type tm)"
  shows "produce (Type (ts@tn)) cons = (Type (ts@tm))"
  using assms
  by (cases cons, simp_all)

lemma produce_nil: "produce ts (Type []) = ts"
  using to_ct_list_def
  by (cases ts, simp_all)

lemma c_types_agree_id: "c_types_agree (Type ts) ts"
  by simp

lemma c_types_agree_top1: "c_types_agree (TopType []) ts"
  using ct_suffix_ts_conv_suffix to_ct_list_def
  by (simp add: ct_suffix_nil)

lemma c_types_agree_top2:
  assumes "ct_list_eq ts (to_ct_list ts'')"
  shows "c_types_agree (TopType ts) (ts'@ts'')"
  using assms ct_list_eq_commute ct_suffix_def to_ct_list_def
  by auto

lemma c_types_agree_imp_ct_list_eq:
  assumes "c_types_agree (TopType cts) ts"
  shows "\<exists>ts' ts''. (ts = ts'@ts'') \<and> ct_list_eq cts (to_ct_list ts'')"
  using assms ct_suffix_def to_ct_list_def
  by (simp, metis ct_list_eq_commute ct_list_eq_ts_conv_eq ct_suffix_ts_conv_suffix suffixE
                  to_ct_list_append(2))

lemma c_types_agree_not_bot_exists:
  assumes "ts \<noteq> Bot"
  shows "\<exists>ts_c. c_types_agree ts ts_c"
  using assms ct_suffix_exists
  by (cases ts, simp_all)

lemma consume_c_types_agree:
  assumes "consume (Type ts) cts = (Type ts')"
          "c_types_agree ctn ts"
  shows "\<exists>c_t'. consume ctn cts = c_t' \<and> c_types_agree c_t' ts'"
  using assms
proof (cases ctn)
  case (TopType x1)
  have 1:"ct_suffix cts (to_ct_list ts)"
    using assms
    by (simp, metis checker_type.distinct(5))
  hence "ct_suffix cts x1 \<or> ct_suffix x1 cts"
    using TopType 1 assms(2) ct_suffix_shared
    by simp
  thus ?thesis
  proof (rule disjE)
    assume local_assms:"ct_suffix cts x1"
    hence 2:"consume (TopType x1) cts = TopType (take (length x1 - length cts) x1)"
      by simp
    have "(take (length ts - length cts) ts) = ts'"
      using assms 1
      by simp
    hence "c_types_agree (TopType (take (length x1 - length cts) x1)) ts'"
      using 2 assms local_assms TopType ct_suffix_take
      by (simp, metis length_map take_map to_ct_list_def)
    thus ?thesis
      using 2 TopType
      by simp
  next
    assume local_assms:"ct_suffix x1 cts"
    hence 3:"consume (TopType x1) cts = TopType []"
      by (simp add: ct_suffix_length)
    thus ?thesis
      using TopType c_types_agree_top1
      by blast
  qed
qed simp_all

lemma type_update_type:
  assumes "type_update (Type ts) (to_ct_list cons) prods = ts'"
          "ts' \<noteq> Bot"
        shows "(ts' = prods \<and> (\<exists>ts_c. prods = (TopType ts_c)))
               \<or> (\<exists>ts_a ts_b. prods = Type ts_a \<and> ts = ts_b@cons \<and> ts' = Type (ts_b@ts_a))"
  using assms
  apply (cases prods)
    apply simp_all
   apply (metis (full_types) produce.simps(3) produce.simps(7))
  using ct_suffix_ts_conv_suffix suffix_take to_ct_list_def
  apply fastforce
  done

lemma type_update_empty: "type_update ts cons (Type []) = consume ts cons"
  using produce_nil
  by simp

lemma type_update_top_top:
  assumes "type_update (TopType ts) (to_ct_list cons) (Type prods) = (TopType ts')"
          "c_types_agree (TopType ts') t_ag"
  shows "ct_suffix (to_ct_list prods) ts'"
        "\<exists>t_ag'. t_ag = t_ag'@prods \<and> c_types_agree (TopType ts) (t_ag'@cons)"
proof -
  consider (1) "ct_suffix (to_ct_list cons) ts"
         | (2) "\<not>ct_suffix (to_ct_list cons) ts" "ct_suffix ts (to_ct_list cons)"
         | (3) "\<not>ct_suffix (to_ct_list cons) ts" "\<not>ct_suffix ts (to_ct_list cons)"
    by blast
  hence "ct_suffix (to_ct_list prods) ts' \<and> (\<exists>t_ag'. t_ag = t_ag'@prods \<and> c_types_agree (TopType ts) (t_ag'@cons))"
  proof (cases)
    case 1
    hence "ts' = (take (length ts - length cons) ts) @ to_ct_list prods"
      using assms(1) to_ct_list_def
      by simp
    moreover
    then obtain t_ag' where "t_ag = t_ag' @ prods"
                            "ct_suffix (take (length ts - length cons) ts) (to_ct_list t_ag')"
      using assms(2) ct_suffix_cons_ct_list1
      unfolding c_types_agree.simps
      by blast
    moreover
    hence "ct_suffix ts (to_ct_list (t_ag'@cons))"
      using 1 ct_suffix_imp_ct_list_eq ct_suffix_extend_ct_list_eq to_ct_list_def
      by fastforce
    ultimately
    show ?thesis
      using c_types_agree.simps(2) ct_list_eq_ts_conv_eq ct_suffix_def
      by auto
  next
    case 2
    thus ?thesis
      using assms
      by (metis append.assoc c_types_agree.simps(2) checker_type.inject(1) consume.simps(2)
                ct_list_eq_ts_conv_eq ct_suffix_cons_ct_list ct_suffix_def map_append
                produce.simps(1) to_ct_list_def type_update.simps)
  next
    case 3
    thus ?thesis
      using assms
      by simp
  qed
  thus "ct_suffix (to_ct_list prods) ts'"
        "\<exists>t_ag'. t_ag = t_ag'@prods \<and> c_types_agree (TopType ts) (t_ag'@cons)"
  by simp_all
qed

lemma type_update_select_length0:
  assumes "type_update_select (TopType cts) = tm"
          "length cts = 0"
          "tm \<noteq> Bot"
  shows "tm = TopType [TAny]"
  using assms
  by simp

lemma type_update_select_length1:
  assumes "type_update_select (TopType cts) = tm"
          "length cts = 1"
          "tm \<noteq> Bot"
  shows "ct_list_eq cts [TSome T_i32]"
        "tm = TopType [TAny]"
proof -
  have 1:"type_update (TopType cts) [TSome T_i32] (TopType [TAny]) = tm"
    using assms(1,2)
    by simp
  hence "ct_suffix cts [TSome T_i32] \<or> ct_suffix [TSome T_i32] cts"
    using assms(3)
    by (metis consume.simps(2) produce.simps(7) type_update.simps)
  thus "ct_list_eq cts [TSome T_i32]"
    using assms(2,3) ct_suffix_imp_ct_list_eq
    by (metis One_nat_def Suc_length_conv ct_list_eq_commute diff_Suc_1 drop_0 list.size(3))
  show "tm = TopType [TAny]"
    using 1 assms(3) consume_top_leq
    by (metis One_nat_def assms(2) diff_Suc_1 diff_is_0_eq length_Cons list.size(3)
              produce.simps(4,7) type_update.simps)
qed

lemma type_update_select_length2:
  assumes "type_update_select (TopType cts) = tm"
          "length cts = 2"
          "tm \<noteq> Bot"
  shows "\<exists>t1 t2. cts = [t1, t2] \<and> ct_eq t2 (TSome T_i32) \<and> tm = TopType [t1]"
proof -
  obtain x y where cts_def:"cts = [x,y]"
    using assms(2) List.length_Suc_conv[of cts "Suc 0"]
    by (metis length_0_conv length_Suc_conv numeral_2_eq_2)
  moreover
  hence "consume (TopType [x,y]) [TSome T_i32] = tm"
    using assms(1,2)
    by simp
  moreover
  hence "ct_suffix [x,y] [TSome T_i32] \<or> ct_suffix [TSome T_i32] [x,y]"
    using assms(3)
    by (metis consume.simps(2))
  hence "ct_suffix [TSome T_i32] ([x]@[y])"
    using assms(2) ct_suffix_length
    by fastforce
  moreover
  hence "ct_eq y (TSome T_i32)"
    by (metis ct_eq_commute ct_list_eq_def ct_suffix_cons2 list.rel_sel list.sel(1) list.simps(3)
              list.size(4))
  ultimately
  show ?thesis
    by auto
qed

lemma type_update_select_length3:
  assumes "type_update_select (TopType cts) = (TopType ctm)"
          "length cts \<ge> 3"
  shows "\<exists>cts' ct1 ct2 ct3. cts = cts'@[ct1, ct2, ct3] \<and> ct_eq ct3 (TSome T_i32)"
proof -
  obtain cts' cts'' where cts_def:"cts = cts'@ cts''" "length cts'' = 3"
    using assms(2)
    by (metis append_take_drop_id diff_diff_cancel length_drop)
  then obtain ct1 cts''2 where "cts'' = ct1#cts''2" "length cts''2 = Suc (Suc 0)"
    using List.length_Suc_conv[of cts' "Suc (Suc 0)"]
    by (metis length_Suc_conv numeral_3_eq_3)
  then obtain ct2 ct3 where "cts'' = [ct1,ct2,ct3]"
    using List.length_Suc_conv[of cts''2 "Suc 0"]
    by (metis length_0_conv length_Suc_conv)
  hence cts_def2:"cts = cts'@ [ct1,ct2,ct3]"
    using cts_def
    by simp
  obtain nat where "length cts = Suc (Suc (Suc nat))"
    using assms(2)
    by (simp add: cts_def)
  hence "(type_update (TopType cts) [TAny, TAny, TSome T_i32] (select_return_top cts (cts ! (length cts - 2)) (cts ! (length cts - 3)))) = TopType ctm"
    using assms
    by simp
  then obtain c_mid where "consume (TopType cts) [TAny, TAny, TSome T_i32] = TopType c_mid"
    by (metis consume.simps(2) produce.simps(6) type_update.simps)
  hence "ct_suffix [TAny, TAny, TSome T_i32] (cts'@ [ct1,ct2,ct3])"
    using assms(2) consume_top_geq cts_def2
    by (metis checker_type.distinct(3) ct_suffix_def length_Cons list.size(3) numeral_3_eq_3)
  hence "ct_eq ct3 (TSome T_i32)"
    using ct_suffix_def ct_list_eq_def
    by (simp, metis append_eq_append_conv length_Cons list_all2_Cons list_all2_lengthD)
  thus ?thesis
    using cts_def2
    by simp
qed

lemma type_update_select_type_length3:
  assumes "type_update_select (Type tn) = (Type tm)"
  shows "\<exists>t ts'. tn = ts'@[t, t, T_i32]"
proof -
  have tn_cond:"(length tn \<ge> 3 \<and> (tn!(length tn-2)) = (tn!(length tn-3)))"
    using assms
    by (simp, metis checker_type.distinct(5))
  hence tm_def:"consume (Type tn) [TAny, TSome T_i32] = Type tm"
    using assms
    by simp
  obtain tn' tn'' where tn_split:"tn = tn'@tn''"
                                 "length tn'' = 3"
    using assms tn_cond
    by (metis append_take_drop_id diff_diff_cancel length_drop)
  then obtain t1 tn''2 where "tn'' = t1#tn''2" "length tn''2 = Suc (Suc 0)"
    by (metis length_Suc_conv numeral_3_eq_3)
  then obtain t2 t3 where tn''_def:"tn'' = [t1,t2,t3]"
    using List.length_Suc_conv[of tn''2 "Suc 0"]
    by (metis length_0_conv length_Suc_conv)
  hence tn_def:"tn = tn'@ [t1,t2,t3]"
    using tn_split
    by simp
  hence t1_t2_eq:"t1 = t2"
    using tn_cond
    by (metis (no_types, lifting) Suc_diff_Suc Suc_eq_plus1_left Suc_lessD tn''_def
                                  add_diff_cancel_right' diff_is_0_eq length_append neq0_conv
                                  not_less_eq_eq nth_Cons_0 nth_Cons_numeral
                                  nth_append numeral_2_eq_2 numeral_3_eq_3 numeral_One tn_split(2)
                                  zero_less_diff)
  have "ct_suffix [TAny, TSome T_i32] (to_ct_list (tn' @ [t1, t2, t3]))"
    using tn_def tm_def
    by (simp, metis checker_type.distinct(5))
  hence "t3 = T_i32"
    using ct_suffix_unfold_one[of "[TAny]" "TSome T_i32" "to_ct_list (tn' @ [t1, t2])" "TSome t3"]
          ct_eq.simps(1)
    unfolding to_ct_list_def
    by simp
  thus ?thesis
    using t1_t2_eq tn_def
    by simp
qed

lemma select_return_top_exists:
  assumes "select_return_top cts c1 c2 = ctm"
          "ctm \<noteq> Bot"
  shows "\<exists>xs. ctm = TopType xs"
  using assms
  by (meson select_return_top.elims)

lemma type_update_select_top_exists:
  assumes "type_update_select xs = (TopType tm)"
  shows "\<exists>tn. xs = TopType tn"
  using assms
proof (cases xs)
  case (Type x2)
  thus ?thesis
    using assms
    by (simp, metis checker_type.distinct(1) checker_type.distinct(3) consume.simps(1))
qed simp_all

lemma type_update_select_conv_select_return_top:
  assumes "ct_suffix [TSome T_i32] cts"
          "length cts \<ge> 3"
  shows "type_update_select (TopType cts) = (select_return_top cts (cts!(length cts-2)) (cts!(length cts-3)))"
proof -
  obtain nat where nat_def:"length cts = Suc (Suc (Suc nat))"
    using assms(2)
    by (metis add_eq_if diff_Suc_1 le_Suc_ex numeral_3_eq_3 nat.distinct(2))
  have "ct_suffix [TAny, TAny, TSome T_i32] cts"
    using assms ct_suffix_extend_any1
    by simp
  then obtain cts' where "consume (TopType cts) [TAny, TAny, TSome T_i32] = TopType cts'"
    by simp
  thus ?thesis
    using nat_def select_return_top_exists
    apply (cases "select_return_top cts (cts ! Suc nat) (cts ! nat)")
      apply simp_all
    apply blast
    done
qed

lemma select_return_top_ct_eq:
  assumes "select_return_top cts c1 c2 = TopType ctm"
          "length cts \<ge> 3"
          "c_types_agree (TopType ctm) cm"
  shows "\<exists>c' cm'. cm = cm'@[c']
                  \<and> ct_suffix (take (length cts - 3) cts) (to_ct_list cm')
                  \<and> ct_eq c1 (TSome c')
                  \<and> ct_eq c2 (TSome c')"
proof (cases c1)
  case TAny
  note outer_TAny = TAny
  show ?thesis
  proof (cases c2)
    case TAny
    hence "take (length cts - 3) cts @ [TAny] = ctm"
      using outer_TAny  assms ct_suffix_cons_ct_list
      by simp
    then obtain cm' c where "cm = cm' @ [c]"
                            "ct_suffix (take (length cts - 3) cts) (to_ct_list cm')"
      using ct_suffix_cons_ct_list[of "take (length cts - 3) cts" "[TAny]"]
            assms(3) c_types_agree.simps(2)[of ctm cm]
      unfolding ct_list_eq_def to_ct_list_def
      by (metis Suc_leI impossible_Cons length_Cons length_map list.exhaust list.size(3)
                list_all2_conv_all_nth zero_less_Suc)
    thus ?thesis
      using TAny outer_TAny ct_eq.simps(2)
      by blast
  next
    case (TSome x2)
    hence "take (length cts - 3) cts @ [TSome x2] = ctm"
      using outer_TAny assms ct_suffix_cons_ct_list
      by simp
    then obtain cm' where "cm = cm' @ [x2]"
                          "ct_suffix (take (length cts - 3) cts) (to_ct_list cm')"
      using ct_suffix_cons_ct_list[of "take (length cts - 3) cts" "[TSome x2]"]
            assms(3) c_types_agree.simps(2)[of ctm cm] ct_list_eq_ts_conv_eq
      unfolding ct_list_eq_def to_ct_list_def
      by (metis (no_types, hide_lams) list.simps(8,9))
    thus ?thesis
      using TSome outer_TAny
      by simp
  qed
next
  case (TSome x2)
  note outer_TSome = TSome
  show ?thesis
  proof (cases c2)
    case TAny
    hence "take (length cts - 3) cts @ [TSome x2] = ctm"
      using TSome assms ct_suffix_cons_ct_list
      by simp
    then obtain cm' where "cm = cm' @ [x2]"
                          "ct_suffix (take (length cts - 3) cts) (to_ct_list cm')"
      using ct_suffix_cons_ct_list[of "take (length cts - 3) cts" "[TSome x2]"]
            assms(3) c_types_agree.simps(2)[of ctm cm] ct_list_eq_ts_conv_eq
      unfolding ct_list_eq_def to_ct_list_def
      by (metis (no_types, hide_lams) list.simps(8,9))
    thus ?thesis
      using TSome TAny
      by simp
  next
    case (TSome x3)
    hence x_eq:"x2 = x3"
      using outer_TSome assms ct_suffix_cons_ct_list
      by (metis checker_type.distinct(3) select_return_top.simps(3))
    hence "take (length cts - 3) cts @ [TSome x2] = ctm"
      using TSome outer_TSome assms ct_suffix_cons_ct_list
      by (metis checker_type.inject(1) select_return_top.simps(3))
    then obtain cm' where "cm = cm' @ [x2]"
                          "ct_suffix (take (length cts - 3) cts) (to_ct_list cm')"
      using ct_suffix_cons_ct_list[of "take (length cts - 3) cts" "[TSome x2]"]
            assms(3) c_types_agree.simps(2)[of ctm cm] ct_list_eq_ts_conv_eq
      unfolding ct_list_eq_def to_ct_list_def
      by (metis (no_types, hide_lams) list.simps(8,9))
    thus ?thesis
      using TSome outer_TSome x_eq
      by simp
  qed
qed

end


(*<*)
theory Plus imports Main begin
(*>*)

text{*\noindent Define the following addition function *}

primrec add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"add m 0 = m" |
"add m (Suc n) = add (Suc m) n"

text{*\noindent and prove*}
(*<*)

end
(*>*)


(* Author: Dmitriy Traytel *)

header "Partial Derivatives-like Normalization"

(*<*)
theory PNormalization
imports Pi_Derivatives
begin
(*>*)

fun pnPlus :: "'a::linorder rexp \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp" where
  "pnPlus Zero r = r"
| "pnPlus r Zero = r"
(*<*)
(*
| "pnPlus Full r = Full"
| "pnPlus r Full = Full"
*)
(*>*)
| "pnPlus (Plus r s) t = pnPlus r (pnPlus s t)"
| "pnPlus r (Plus s t) =
     (if r = s then (Plus s t)
     else if r \<le> s then Plus r (Plus s t)
     else Plus s (pnPlus r t))"
| "pnPlus r s =
     (if r = s then r
      else if r \<le> s then Plus r s
      else Plus s r)"

lemma (in alphabet) wf_pnPlus[simp]: "\<lbrakk>wf n r; wf n s\<rbrakk> \<Longrightarrow> wf n (pnPlus r s)"
  by (induct r s rule: pnPlus.induct) auto

lemma (in project) lang_pnPlus[simp]: "\<lbrakk>wf n r; wf n s\<rbrakk> \<Longrightarrow> lang n (pnPlus r s) = lang n (Plus r s)"
  by (induct r s rule: pnPlus.induct) (auto dest!: lang_subset_lists dest: project
      subsetD[OF star_subset_lists, unfolded in_lists_conv_set, rotated -1]
      subsetD[OF conc_subset_lists, unfolded in_lists_conv_set, rotated -1])

fun pnTimes :: "'a::linorder rexp \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp" where
  "pnTimes Zero r = Zero"
| "pnTimes One r = r"
| "pnTimes (Plus r s) t = pnPlus (pnTimes r t) (pnTimes s t)"
| "pnTimes r s = Times r s"

lemma (in alphabet) wf_pnTimes[simp]: "\<lbrakk>wf n r; wf n s\<rbrakk> \<Longrightarrow> wf n (pnTimes r s)"
  by (induct r s rule: pnTimes.induct) auto

lemma (in project) lang_pnTimes[simp]: "\<lbrakk>wf n r; wf n s\<rbrakk> \<Longrightarrow> lang n (pnTimes r s) = lang n (Times r s)"
  by (induct r s rule: pnTimes.induct) auto

fun pnInter :: "'a::linorder rexp \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp" where
  "pnInter Zero r = Zero"
| "pnInter r Zero = Zero"
| "pnInter Full r = r"
| "pnInter r Full = r"
| "pnInter (Plus r s) t = pnPlus (pnInter r t) (pnInter s t)"
| "pnInter r (Plus s t) = pnPlus (pnInter r s) (pnInter r t)"
| "pnInter (Inter r s) t = pnInter r (pnInter s t)"
| "pnInter r (Inter s t) =
     (if r = s then Inter s t
     else if r \<le> s then Inter r (Inter s t)
     else Inter s (pnInter r t))"
| "pnInter r s =
     (if r = s then s
      else if r \<le> s then Inter r s
      else Inter s r)"

lemma (in alphabet) wf_pnInter[simp]: "\<lbrakk>wf n r; wf n s\<rbrakk> \<Longrightarrow> wf n (pnInter r s)"
  by (induct r s rule: pnInter.induct) auto

lemma (in project) lang_pnInter[simp]: "\<lbrakk>wf n r; wf n s\<rbrakk> \<Longrightarrow> lang n (pnInter r s) = lang n (Inter r s)"
  by (induct r s rule: pnInter.induct) (auto, auto dest!: lang_subset_lists dest: project
      subsetD[OF star_subset_lists, unfolded in_lists_conv_set, rotated -1]
      subsetD[OF conc_subset_lists, unfolded in_lists_conv_set, rotated -1])

fun pnNot :: "'a::linorder rexp \<Rightarrow> 'a rexp" where
  "pnNot (Plus r s) = pnInter (pnNot r) (pnNot s)"
| "pnNot (Inter r s) = pnPlus (pnNot r) (pnNot s)"
| "pnNot Full = Zero"
| "pnNot Zero = Full"
| "pnNot (Not r) = r"
| "pnNot r = Not r"

lemma (in alphabet) wf_pnNot[simp]: "wf n r \<Longrightarrow> wf n (pnNot r)"
  by (induct r rule: pnNot.induct) auto

lemma (in project) lang_pnNot[simp]: "wf n r \<Longrightarrow> lang n (pnNot r) = lang n (Not r)"
  by (induct r rule: pnNot.induct) (auto dest: lang_subset_lists)

fun pnPr :: "'a::linorder rexp \<Rightarrow> 'a rexp" where
  "pnPr Zero = Zero"
| "pnPr One = One"
| "pnPr (Plus r s) = pnPlus (pnPr r) (pnPr s)"
| "pnPr r = Pr r"

lemma (in alphabet) wf_pnPr[simp]: "wf (Suc n) r \<Longrightarrow> wf n (pnPr r)"
  by (induct r rule: pnPr.induct) auto

lemma (in project) lang_pnPr[simp]: "wf (Suc n) r \<Longrightarrow> lang n (pnPr r) = lang n (Pr r)"
  by (induct r rule: pnPr.induct) auto

primrec pnorm :: "'a::linorder rexp \<Rightarrow> 'a rexp" where
  "pnorm Zero = Zero"
| "pnorm Full = Full"
| "pnorm One = One"
| "pnorm (Atom a) = Atom a"
| "pnorm (Plus r s) = pnPlus (pnorm r) (pnorm s)"
| "pnorm (Times r s) = pnTimes (pnorm r) s"
| "pnorm (Star r) = Star r"
| "pnorm (Inter r s) = pnInter (pnorm r) (pnorm s)"
| "pnorm (Not r) = pnNot (pnorm r)"
| "pnorm (Pr r) = pnPr (pnorm r)"

lemma (in alphabet) wf_pnorm[simp]: "wf n r \<Longrightarrow> wf n (pnorm r)"
  by (induct r arbitrary: n) auto

lemma (in project) lang_pnorm[simp]: "wf n r \<Longrightarrow> lang n (pnorm r) = lang n r"
  by (induct r arbitrary: n) auto

(*<*)
end
(*>*)


(*  Title:      HOL/HOLCF/Algebraic.thy
    Author:     Brian Huffman
*)

section {* Algebraic deflations *}

theory Algebraic
imports Universal Map_Functions
begin

default_sort bifinite

subsection {* Type constructor for finite deflations *}

typedef 'a fin_defl = "{d::'a \<rightarrow> 'a. finite_deflation d}"
by (fast intro: finite_deflation_bottom)

instantiation fin_defl :: (bifinite) below
begin

definition below_fin_defl_def:
  "below \<equiv> \<lambda>x y. Rep_fin_defl x \<sqsubseteq> Rep_fin_defl y"

instance ..
end

instance fin_defl :: (bifinite) po
using type_definition_fin_defl below_fin_defl_def
by (rule typedef_po)

lemma finite_deflation_Rep_fin_defl: "finite_deflation (Rep_fin_defl d)"
using Rep_fin_defl by simp

lemma deflation_Rep_fin_defl: "deflation (Rep_fin_defl d)"
using finite_deflation_Rep_fin_defl
by (rule finite_deflation_imp_deflation)

interpretation Rep_fin_defl: finite_deflation "Rep_fin_defl d"
by (rule finite_deflation_Rep_fin_defl)

lemma fin_defl_belowI:
  "(\<And>x. Rep_fin_defl a\<cdot>x = x \<Longrightarrow> Rep_fin_defl b\<cdot>x = x) \<Longrightarrow> a \<sqsubseteq> b"
unfolding below_fin_defl_def
by (rule Rep_fin_defl.belowI)

lemma fin_defl_belowD:
  "\<lbrakk>a \<sqsubseteq> b; Rep_fin_defl a\<cdot>x = x\<rbrakk> \<Longrightarrow> Rep_fin_defl b\<cdot>x = x"
unfolding below_fin_defl_def
by (rule Rep_fin_defl.belowD)

lemma fin_defl_eqI:
  "(\<And>x. Rep_fin_defl a\<cdot>x = x \<longleftrightarrow> Rep_fin_defl b\<cdot>x = x) \<Longrightarrow> a = b"
apply (rule below_antisym)
apply (rule fin_defl_belowI, simp)
apply (rule fin_defl_belowI, simp)
done

lemma Rep_fin_defl_mono: "a \<sqsubseteq> b \<Longrightarrow> Rep_fin_defl a \<sqsubseteq> Rep_fin_defl b"
unfolding below_fin_defl_def .

lemma Abs_fin_defl_mono:
  "\<lbrakk>finite_deflation a; finite_deflation b; a \<sqsubseteq> b\<rbrakk>
    \<Longrightarrow> Abs_fin_defl a \<sqsubseteq> Abs_fin_defl b"
unfolding below_fin_defl_def
by (simp add: Abs_fin_defl_inverse)

lemma (in finite_deflation) compact_belowI:
  assumes "\<And>x. compact x \<Longrightarrow> d\<cdot>x = x \<Longrightarrow> f\<cdot>x = x" shows "d \<sqsubseteq> f"
by (rule belowI, rule assms, erule subst, rule compact)

lemma compact_Rep_fin_defl [simp]: "compact (Rep_fin_defl a)"
using finite_deflation_Rep_fin_defl
by (rule finite_deflation_imp_compact)

subsection {* Defining algebraic deflations by ideal completion *}

typedef 'a defl = "{S::'a fin_defl set. below.ideal S}"
by (rule below.ex_ideal)

instantiation defl :: (bifinite) below
begin

definition
  "x \<sqsubseteq> y \<longleftrightarrow> Rep_defl x \<subseteq> Rep_defl y"

instance ..
end

instance defl :: (bifinite) po
using type_definition_defl below_defl_def
by (rule below.typedef_ideal_po)

instance defl :: (bifinite) cpo
using type_definition_defl below_defl_def
by (rule below.typedef_ideal_cpo)

definition
  defl_principal :: "'a fin_defl \<Rightarrow> 'a defl" where
  "defl_principal t = Abs_defl {u. u \<sqsubseteq> t}"

lemma fin_defl_countable: "\<exists>f::'a fin_defl \<Rightarrow> nat. inj f"
proof -
  obtain f :: "'a compact_basis \<Rightarrow> nat" where inj_f: "inj f"
    using compact_basis.countable ..
  have *: "\<And>d. finite (f ` Rep_compact_basis -` {x. Rep_fin_defl d\<cdot>x = x})"
    apply (rule finite_imageI)
    apply (rule finite_vimageI)
    apply (rule Rep_fin_defl.finite_fixes)
    apply (simp add: inj_on_def Rep_compact_basis_inject)
    done
  have range_eq: "range Rep_compact_basis = {x. compact x}"
    using type_definition_compact_basis by (rule type_definition.Rep_range)
  have "inj (\<lambda>d. set_encode
    (f ` Rep_compact_basis -` {x. Rep_fin_defl d\<cdot>x = x}))"
    apply (rule inj_onI)
    apply (simp only: set_encode_eq *)
    apply (simp only: inj_image_eq_iff inj_f)
    apply (drule_tac f="image Rep_compact_basis" in arg_cong)
    apply (simp del: vimage_Collect_eq add: range_eq set_eq_iff)
    apply (rule Rep_fin_defl_inject [THEN iffD1])
    apply (rule below_antisym)
    apply (rule Rep_fin_defl.compact_belowI, rename_tac z)
    apply (drule_tac x=z in spec, simp)
    apply (rule Rep_fin_defl.compact_belowI, rename_tac z)
    apply (drule_tac x=z in spec, simp)
    done
  thus ?thesis by - (rule exI)
qed

interpretation defl: ideal_completion below defl_principal Rep_defl
using type_definition_defl below_defl_def
using defl_principal_def fin_defl_countable
by (rule below.typedef_ideal_completion)

text {* Algebraic deflations are pointed *}

lemma defl_minimal: "defl_principal (Abs_fin_defl \<bottom>) \<sqsubseteq> x"
apply (induct x rule: defl.principal_induct, simp)
apply (rule defl.principal_mono)
apply (simp add: below_fin_defl_def)
apply (simp add: Abs_fin_defl_inverse finite_deflation_bottom)
done

instance defl :: (bifinite) pcpo
by intro_classes (fast intro: defl_minimal)

lemma inst_defl_pcpo: "\<bottom> = defl_principal (Abs_fin_defl \<bottom>)"
by (rule defl_minimal [THEN bottomI, symmetric])

subsection {* Applying algebraic deflations *}

definition
  cast :: "'a defl \<rightarrow> 'a \<rightarrow> 'a"
where
  "cast = defl.extension Rep_fin_defl"

lemma cast_defl_principal:
  "cast\<cdot>(defl_principal a) = Rep_fin_defl a"
unfolding cast_def
apply (rule defl.extension_principal)
apply (simp only: below_fin_defl_def)
done

lemma deflation_cast: "deflation (cast\<cdot>d)"
apply (induct d rule: defl.principal_induct)
apply (rule adm_subst [OF _ adm_deflation], simp)
apply (simp add: cast_defl_principal)
apply (rule finite_deflation_imp_deflation)
apply (rule finite_deflation_Rep_fin_defl)
done

lemma finite_deflation_cast:
  "compact d \<Longrightarrow> finite_deflation (cast\<cdot>d)"
apply (drule defl.compact_imp_principal, clarify)
apply (simp add: cast_defl_principal)
apply (rule finite_deflation_Rep_fin_defl)
done

interpretation cast: deflation "cast\<cdot>d"
by (rule deflation_cast)

declare cast.idem [simp]

lemma compact_cast [simp]: "compact d \<Longrightarrow> compact (cast\<cdot>d)"
apply (rule finite_deflation_imp_compact)
apply (erule finite_deflation_cast)
done

lemma cast_below_cast: "cast\<cdot>A \<sqsubseteq> cast\<cdot>B \<longleftrightarrow> A \<sqsubseteq> B"
apply (induct A rule: defl.principal_induct, simp)
apply (induct B rule: defl.principal_induct, simp)
apply (simp add: cast_defl_principal below_fin_defl_def)
done

lemma compact_cast_iff: "compact (cast\<cdot>d) \<longleftrightarrow> compact d"
apply (rule iffI)
apply (simp only: compact_def cast_below_cast [symmetric])
apply (erule adm_subst [OF cont_Rep_cfun2])
apply (erule compact_cast)
done

lemma cast_below_imp_below: "cast\<cdot>A \<sqsubseteq> cast\<cdot>B \<Longrightarrow> A \<sqsubseteq> B"
by (simp only: cast_below_cast)

lemma cast_eq_imp_eq: "cast\<cdot>A = cast\<cdot>B \<Longrightarrow> A = B"
by (simp add: below_antisym cast_below_imp_below)

lemma cast_strict1 [simp]: "cast\<cdot>\<bottom> = \<bottom>"
apply (subst inst_defl_pcpo)
apply (subst cast_defl_principal)
apply (rule Abs_fin_defl_inverse)
apply (simp add: finite_deflation_bottom)
done

lemma cast_strict2 [simp]: "cast\<cdot>A\<cdot>\<bottom> = \<bottom>"
by (rule cast.below [THEN bottomI])

subsection {* Deflation combinators *}

definition
  "defl_fun1 e p f =
    defl.extension (\<lambda>a.
      defl_principal (Abs_fin_defl
        (e oo f\<cdot>(Rep_fin_defl a) oo p)))"

definition
  "defl_fun2 e p f =
    defl.extension (\<lambda>a.
      defl.extension (\<lambda>b.
        defl_principal (Abs_fin_defl
          (e oo f\<cdot>(Rep_fin_defl a)\<cdot>(Rep_fin_defl b) oo p))))"

lemma cast_defl_fun1:
  assumes ep: "ep_pair e p"
  assumes f: "\<And>a. finite_deflation a \<Longrightarrow> finite_deflation (f\<cdot>a)"
  shows "cast\<cdot>(defl_fun1 e p f\<cdot>A) = e oo f\<cdot>(cast\<cdot>A) oo p"
proof -
  have 1: "\<And>a. finite_deflation (e oo f\<cdot>(Rep_fin_defl a) oo p)"
    apply (rule ep_pair.finite_deflation_e_d_p [OF ep])
    apply (rule f, rule finite_deflation_Rep_fin_defl)
    done
  show ?thesis
    by (induct A rule: defl.principal_induct, simp)
       (simp only: defl_fun1_def
                   defl.extension_principal
                   defl.extension_mono
                   defl.principal_mono
                   Abs_fin_defl_mono [OF 1 1]
                   monofun_cfun below_refl
                   Rep_fin_defl_mono
                   cast_defl_principal
                   Abs_fin_defl_inverse [unfolded mem_Collect_eq, OF 1])
qed

lemma cast_defl_fun2:
  assumes ep: "ep_pair e p"
  assumes f: "\<And>a b. finite_deflation a \<Longrightarrow> finite_deflation b \<Longrightarrow>
                finite_deflation (f\<cdot>a\<cdot>b)"
  shows "cast\<cdot>(defl_fun2 e p f\<cdot>A\<cdot>B) = e oo f\<cdot>(cast\<cdot>A)\<cdot>(cast\<cdot>B) oo p"
proof -
  have 1: "\<And>a b. finite_deflation
      (e oo f\<cdot>(Rep_fin_defl a)\<cdot>(Rep_fin_defl b) oo p)"
    apply (rule ep_pair.finite_deflation_e_d_p [OF ep])
    apply (rule f, (rule finite_deflation_Rep_fin_defl)+)
    done
  show ?thesis
    apply (induct A rule: defl.principal_induct, simp)
    apply (induct B rule: defl.principal_induct, simp)
    by (simp only: defl_fun2_def
                   defl.extension_principal
                   defl.extension_mono
                   defl.principal_mono
                   Abs_fin_defl_mono [OF 1 1]
                   monofun_cfun below_refl
                   Rep_fin_defl_mono
                   cast_defl_principal
                   Abs_fin_defl_inverse [unfolded mem_Collect_eq, OF 1])
qed

end


section "Kruskal Implementation"

theory Kruskal_Impl
imports Kruskal_Refine Refine_Imperative_HOL.IICF
begin

subsection \<open>Refinement III: concrete edges\<close>

text \<open>Given a concrete representation of edges and their endpoints as a pair, we refine
  Kruskal's algorithm to work on these concrete edges.\<close>

locale Kruskal_concrete = Kruskal_interface E V vertices  joins  forest connected  weight
  for E V vertices joins forest connected  and weight :: "'edge \<Rightarrow> int"  +
  fixes
    \<alpha> :: "'cedge \<Rightarrow> 'edge"
    and endpoints :: "'cedge \<Rightarrow> ('a*'a) nres"
  assumes
    endpoints_refine: "\<alpha> xi = x \<Longrightarrow> endpoints xi \<le> \<Down> Id (a_endpoints x)"
begin

definition wsorted' where "wsorted' == sorted_wrt (\<lambda>x y. weight (\<alpha> x) \<le> weight (\<alpha> y))"

lemma wsorted_map\<alpha>[simp]: "wsorted' s \<Longrightarrow> wsorted (map \<alpha> s)"
  by(auto simp: wsorted'_def sorted_wrt_map)

definition "obtain_sorted_carrier' == SPEC (\<lambda>L. wsorted' L \<and> \<alpha> ` set L = E)"

abbreviation concrete_edge_rel :: "('cedge  \<times> 'edge) set" where
  "concrete_edge_rel \<equiv> br \<alpha> (\<lambda>_. True)"

lemma obtain_sorted_carrier'_refine:
  "(obtain_sorted_carrier', obtain_sorted_carrier) \<in> \<langle>\<langle>concrete_edge_rel\<rangle>list_rel\<rangle>nres_rel"
  unfolding obtain_sorted_carrier'_def obtain_sorted_carrier_def
  apply refine_vcg
  apply (auto intro!: RES_refine simp:     )
  subgoal for s apply(rule exI[where x="map \<alpha> s"])
    by(auto simp: map_in_list_rel_conv in_br_conv)
  done

definition kruskal2
  where "kruskal2 \<equiv> do {
    l \<leftarrow> obtain_sorted_carrier';
    let initial_union_find = per_init V;
    (per, spanning_forest) \<leftarrow> nfoldli l (\<lambda>_. True)
        (\<lambda>ce (uf, T). do {
            ASSERT (\<alpha> ce \<in> E);
            (a,b) \<leftarrow> endpoints ce;
            ASSERT (a\<in>V \<and> b\<in>V \<and> a \<in> Domain uf \<and> b \<in> Domain uf );
            if \<not> per_compare uf a b then
              do {
                let uf = per_union uf a b;
                ASSERT (ce \<notin> set T);
                RETURN (uf, T@[ce])
              }
            else
              RETURN (uf,T)
        }) (initial_union_find, []);
        RETURN spanning_forest
      }"

lemma lst_graph_rel_empty[simp]: "([], {}) \<in> \<langle>concrete_edge_rel\<rangle>list_set_rel"
  unfolding list_set_rel_def apply(rule relcompI[where b="[]"])
  by (auto simp add: in_br_conv)

lemma loop_initial_rel:
  "((per_init V, []), per_init V, {}) \<in> Id \<times>\<^sub>r \<langle>concrete_edge_rel\<rangle>list_set_rel"
  by simp

lemma concrete_edge_rel_list_set_rel:
  "(a, b) \<in> \<langle>concrete_edge_rel\<rangle>list_set_rel \<Longrightarrow> \<alpha> ` (set a) = b"
  by (auto simp: in_br_conv list_set_rel_def dest: list_relD2)

theorem kruskal2_refine: "(kruskal2, kruskal1)\<in>\<langle>\<langle>concrete_edge_rel\<rangle>list_set_rel\<rangle>nres_rel"
  unfolding kruskal1_def kruskal2_def Let_def
  apply (refine_rcg obtain_sorted_carrier'_refine[THEN nres_relD]
                    endpoints_refine loop_initial_rel)
  by (auto intro!: list_set_rel_append
            dest: concrete_edge_rel_list_set_rel
            simp: in_br_conv)

end

subsection \<open>Refinement to Imperative/HOL with Sepref-Tool\<close>

text \<open>Given implementations for the operations of getting a list of concrete edges
  and getting the endpoints of a concrete edge we synthesize Kruskal in Imperative/HOL.\<close>

locale Kruskal_Impl = Kruskal_concrete E V vertices joins forest connected weight \<alpha> endpoints
  for E V vertices joins forest connected and weight :: "'edge \<Rightarrow> int"
    and \<alpha> and endpoints :: "nat \<times> int \<times> nat \<Rightarrow> (nat \<times> nat) nres"
    +
  fixes getEdges  :: "(nat \<times> int \<times> nat) list nres"
    and getEdges_impl :: "(nat \<times> int \<times> nat) list Heap"
    and superE :: "(nat \<times> int \<times> nat) set"
    and endpoints_impl :: "(nat \<times> int \<times> nat) \<Rightarrow> (nat \<times> nat) Heap"
  assumes
    getEdges_refine: "getEdges \<le> SPEC (\<lambda>L. \<alpha> ` set L = E
                            \<and> (\<forall>(a,wv,b)\<in>set L.  weight (\<alpha> (a,wv,b)) = wv) \<and> set L \<subseteq> superE)"
    and
    getEdges_impl: "(uncurry0 getEdges_impl, uncurry0 getEdges)
                     \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a list_assn (nat_assn \<times>\<^sub>a int_assn \<times>\<^sub>a nat_assn)"
    and
    max_node_is_Max_V: "E = \<alpha> ` set la \<Longrightarrow> max_node la = Max (insert 0 V)"
    and
    endpoints_impl: "( endpoints_impl,  endpoints)
                      \<in> (nat_assn \<times>\<^sub>a int_assn \<times>\<^sub>a nat_assn)\<^sup>k \<rightarrow>\<^sub>a (nat_assn \<times>\<^sub>a nat_assn)"
begin

  lemma this_loc: "Kruskal_Impl E V vertices  joins  forest connected  weight
            \<alpha> endpoints getEdges getEdges_impl superE    endpoints_impl" by unfold_locales

  subsubsection \<open>Refinement IV: given an edge set\<close>

  text \<open>We now assume to have an implementation of the operation to obtain a list of the edges of
    a graph. By sorting this list we refine @{term obtain_sorted_carrier'}.\<close>

  definition "obtain_sorted_carrier'' = do {
      l \<leftarrow> SPEC (\<lambda>L.  \<alpha> ` set L = E
                              \<and> (\<forall>(a,wv,b)\<in>set L.  weight (\<alpha> (a,wv,b)) = wv) \<and> set L \<subseteq> superE);
      SPEC (\<lambda>L. sorted_wrt edges_less_eq L \<and> set L = set l)
  }"

  lemma wsorted'_sorted_wrt_edges_less_eq:
    assumes "\<forall>(a,wv,b)\<in>set s.  weight (\<alpha> (a,wv,b)) = wv"
        "sorted_wrt edges_less_eq s"
    shows "wsorted' s"
    using assms apply -
    unfolding wsorted'_def   unfolding edges_less_eq_def
    apply(rule sorted_wrt_mono_rel )
    by (auto simp: case_prod_beta)

  lemma obtain_sorted_carrier''_refine:
    "(obtain_sorted_carrier'', obtain_sorted_carrier') \<in> \<langle>Id\<rangle>nres_rel"
    unfolding obtain_sorted_carrier''_def obtain_sorted_carrier'_def
    apply refine_vcg
     apply(auto simp: in_br_conv   wsorted'_sorted_wrt_edges_less_eq
        distinct_map map_in_list_rel_conv)
    done

  definition "obtain_sorted_carrier''' =
        do {
      l \<leftarrow> getEdges;
      RETURN (quicksort_by_rel edges_less_eq [] l, max_node l)
  }"

  definition "add_size_rel   = br fst (\<lambda>(l,n). n= Max (insert 0 V))"

  lemma obtain_sorted_carrier'''_refine:
    "(obtain_sorted_carrier''', obtain_sorted_carrier'') \<in> \<langle>add_size_rel\<rangle>nres_rel"
    unfolding obtain_sorted_carrier'''_def obtain_sorted_carrier''_def
    apply (refine_rcg getEdges_refine)
    by (auto intro!: RETURN_SPEC_refine simp: quicksort_by_rel_distinct sort_edges_correct
        add_size_rel_def in_br_conv  max_node_is_Max_V
        dest!: distinct_mapI)

  lemmas osc_refine =  obtain_sorted_carrier'''_refine[FCOMP obtain_sorted_carrier''_refine,
                                                        to_foparam, simplified]

  definition kruskal3 :: "(nat \<times> int \<times> nat) list nres"
    where "kruskal3  \<equiv> do {
      (sl,mn) \<leftarrow> obtain_sorted_carrier''';
      let initial_union_find = per_init' (mn + 1);
      (per, spanning_forest) \<leftarrow> nfoldli sl (\<lambda>_. True)
          (\<lambda>ce (uf, T). do {
              ASSERT (\<alpha> ce \<in> E);
              (a,b) \<leftarrow> endpoints ce;
              ASSERT (a \<in> Domain uf \<and> b \<in> Domain uf);
              if \<not> per_compare uf a b then
                do {
                  let uf = per_union uf a b;
                  ASSERT (ce\<notin>set T);
                  RETURN (uf, T@[ce])
                }
              else
                RETURN (uf,T)
          }) (initial_union_find, []);
          RETURN spanning_forest
        }"

  lemma endpoints_spec: "endpoints ce \<le> SPEC (\<lambda>_. True)"
    by(rule order.trans[OF endpoints_refine], auto)

  lemma  kruskal3_subset:
    shows "kruskal3 \<le>\<^sub>n SPEC (\<lambda>T. distinct T \<and> set T \<subseteq> superE )"
    unfolding kruskal3_def obtain_sorted_carrier'''_def
    apply (refine_vcg getEdges_refine[THEN leof_lift] endpoints_spec[THEN leof_lift]
        nfoldli_leof_rule[where I="\<lambda>_ _ (_, T). distinct T \<and>  set T \<subseteq> superE "])
             apply auto
    subgoal
      by (metis append_self_conv in_set_conv_decomp set_quicksort_by_rel subset_iff)
    subgoal
      by blast
    done

  definition per_supset_rel :: "('a per \<times> 'a per) set" where
    "per_supset_rel
      \<equiv> {(p1,p2). p1 \<inter> Domain p2 \<times> Domain p2 = p2 \<and> p1 - (Domain p2 \<times> Domain p2) \<subseteq> Id}"

  lemma per_supset_rel_dom: "(p1, p2) \<in> per_supset_rel \<Longrightarrow> Domain p1 \<supseteq> Domain p2"
    by (auto simp: per_supset_rel_def)

  lemma per_supset_compare:
    "(p1, p2) \<in> per_supset_rel \<Longrightarrow> x1\<in>Domain p2 \<Longrightarrow> x2\<in>Domain p2
       \<Longrightarrow> per_compare p1 x1 x2 \<longleftrightarrow> per_compare p2 x1 x2"
    by (auto simp: per_supset_rel_def)

  lemma per_supset_union: "(p1, p2) \<in> per_supset_rel \<Longrightarrow> x1\<in>Domain p2 \<Longrightarrow> x2\<in>Domain p2 \<Longrightarrow>
    (per_union p1 x1 x2, per_union p2 x1 x2) \<in> per_supset_rel"
    apply (clarsimp simp: per_supset_rel_def per_union_def Domain_unfold )
    apply (intro subsetI conjI)
     apply blast
    apply force
    done

  lemma per_initN_refine: "(per_init' (Max (insert 0 V) + 1), per_init V) \<in> per_supset_rel"
    unfolding per_supset_rel_def per_init'_def per_init_def max_node_def
    by (auto simp: less_Suc_eq_le  )

  theorem kruskal3_refine: "(kruskal3, kruskal2)\<in>\<langle>Id\<rangle>nres_rel"
    unfolding kruskal2_def kruskal3_def Let_def
    apply (refine_rcg osc_refine[THEN nres_relD]   )
               supply RELATESI[where R="per_supset_rel::(nat per \<times> _) set", refine_dref_RELATES]
               apply refine_dref_type
    subgoal by (simp add: add_size_rel_def in_br_conv)
    subgoal using per_initN_refine by (simp add: add_size_rel_def in_br_conv)
    by (auto simp add: add_size_rel_def in_br_conv per_supset_compare per_supset_union
        dest: per_supset_rel_dom
        simp del: per_compare_def )

  subsubsection \<open>Synthesis of Kruskal by SepRef\<close>

  lemma [sepref_import_param]: "(sort_edges,sort_edges)\<in>\<langle>Id\<times>\<^sub>rId\<times>\<^sub>rId\<rangle>list_rel \<rightarrow>\<langle>Id\<times>\<^sub>rId\<times>\<^sub>rId\<rangle>list_rel"
    by simp
  lemma [sepref_import_param]: "(max_node, max_node) \<in> \<langle>Id\<times>\<^sub>rId\<times>\<^sub>rId\<rangle>list_rel \<rightarrow> nat_rel" by simp

  sepref_register "getEdges" :: "(nat \<times> int \<times> nat) list nres"
  sepref_register "endpoints" :: "(nat \<times> int \<times> nat) \<Rightarrow> (nat*nat) nres"

  declare getEdges_impl [sepref_fr_rules]
  declare endpoints_impl [sepref_fr_rules]

  schematic_goal kruskal_impl:
    "(uncurry0 ?c, uncurry0 kruskal3 ) \<in> (unit_assn)\<^sup>k \<rightarrow>\<^sub>a list_assn (nat_assn \<times>\<^sub>a int_assn \<times>\<^sub>a nat_assn)"
    unfolding kruskal3_def obtain_sorted_carrier'''_def
    unfolding sort_edges_def[symmetric]
    apply (rewrite at "nfoldli _ _ _ (_,rewrite_HOLE)" HOL_list.fold_custom_empty)
    by sepref

  concrete_definition (in -) kruskal uses Kruskal_Impl.kruskal_impl
  prepare_code_thms (in -) kruskal_def
  lemmas kruskal_refine = kruskal.refine[OF this_loc]

  abbreviation "MSF == minBasis"
  abbreviation "SpanningForest == basis"
  lemmas SpanningForest_def = basis_def
  lemmas MSF_def = minBasis_def

  lemmas kruskal3_ref_spec_ = kruskal3_refine[FCOMP kruskal2_refine, FCOMP kruskal1_refine,
      FCOMP kruskal0_refine,
      FCOMP minWeightBasis_refine]

  lemma kruskal3_ref_spec':
    "(uncurry0 kruskal3, uncurry0 (SPEC (\<lambda>r. MSF (\<alpha> ` set r)))) \<in> unit_rel \<rightarrow>\<^sub>f \<langle>Id\<rangle>nres_rel"
    unfolding fref_def
    apply auto
    apply(rule nres_relI)
    apply(rule order.trans[OF  kruskal3_ref_spec_[unfolded fref_def, simplified,  THEN nres_relD]])
    by (auto simp: conc_fun_def list_set_rel_def in_br_conv dest!: list_relD2)

  lemma kruskal3_ref_spec:
   "(uncurry0 kruskal3,
      uncurry0 (SPEC (\<lambda>r. distinct r \<and> set r \<subseteq> superE \<and>  MSF (\<alpha> ` set r))))
      \<in> unit_rel \<rightarrow>\<^sub>f \<langle>Id\<rangle>nres_rel"
    unfolding fref_def
    apply auto
    apply(rule nres_relI)
    apply simp
    using SPEC_rule_conj_leofI2[OF kruskal3_subset kruskal3_ref_spec'
              [unfolded fref_def, simplified,  THEN nres_relD, simplified]]
    by simp

  lemma [fcomp_norm_simps]: "list_assn (nat_assn \<times>\<^sub>a int_assn \<times>\<^sub>a nat_assn) = id_assn"
    by (auto simp: list_assn_pure_conv)

  lemmas kruskal_ref_spec = kruskal_refine[FCOMP kruskal3_ref_spec]

  text \<open>The final correctness lemma for Kruskal's algorithm. \<close>

  lemma kruskal_correct_forest:
    shows "<emp> kruskal getEdges_impl endpoints_impl ()
             <\<lambda>r. \<up>( distinct r \<and> set r \<subseteq> superE \<and> MSF (set (map \<alpha> r)))>\<^sub>t"
  proof -
    show ?thesis
      using kruskal_ref_spec[to_hnr]
      unfolding hn_refine_def
      apply clarsimp
      apply (erule cons_post_rule)
      by (sep_auto simp: hn_ctxt_def pure_def list_set_rel_def in_br_conv dest: list_relD)
  qed

end \<comment> \<open>locale @{text Kruskal_Impl}\<close>

end


(*<*)
theory Examples
  imports Monitor_Code
begin
(*>*)

section \<open>Examples\<close>

abbreviation "TT \<equiv> MFOTL.Eq (MFOTL.Const ''_'') (MFOTL.Const ''_'')"
abbreviation "Eventually I \<psi> \<equiv> MFOTL.Until TT I \<psi>"

definition "\<phi>\<^sub>e\<^sub>x = MFOTL.And_Not (MFOTL.Pred ''A'' [MFOTL.Var 0])
  (Eventually (interval 1 2) (MFOTL.Exists (MFOTL.Pred ''B'' [MFOTL.Var 1, MFOTL.Var 0])))"

lemma "mmonitorable \<phi>\<^sub>e\<^sub>x" by eval

text \<open>Offline monitoring:\<close>

lift_definition \<pi>\<^sub>e\<^sub>x :: "string MFOTL.prefix" is
  "[ ({(''A'', [''d'']), (''A'', [''e''])}, 1)
   , ({(''B'', [''d'', ''f''])}, 2)
   , ({(''B'', [''e'', ''f''])}, 5)
  ]"
  by simp

lemma "monitor \<phi>\<^sub>e\<^sub>x \<pi>\<^sub>e\<^sub>x = {(0, [Some ''e''])}" by eval

text \<open>Online monitoring:\<close>

definition "m1 = mstep ({(''A'', [''d'']), (''A'', [''e''])}, 1) (minit \<phi>\<^sub>e\<^sub>x)"
definition "m2 = mstep ({(''B'', [''d'', ''f''])}, 2) (snd m1)"
definition "m3 = mstep ({(''B'', [''e'', ''f''])}, 5) (snd m2)"

lemma "fst m1 = {}" by eval
lemma "fst m2 = {}" by eval
lemma "fst m3 = {(0, [Some ''e''])}" by eval

text \<open>Operation of the monitor:\<close>

value "minit \<phi>\<^sub>e\<^sub>x"
value "\<lparr>mstate_i = 0,
  mstate_m =
    MAnd (MPred ''A'' [MFOTL.Var 0]) False
     (MUntil True (MRel {[None]}) (interval 1 2) (MExists (MPred ''B'' [MFOTL.Var 1, MFOTL.Var 0]))
       ([], []) [] [])
     ([], []),
  mstate_n = 1\<rparr> :: string mstate"

value "mstate_m (snd m1)"
value "MAnd (MPred ''A'' [MFOTL.Var 0]) False
  (MUntil True (MRel {[None]}) (interval 1 2) (MExists (MPred ''B'' [MFOTL.Var 1, MFOTL.Var 0]))
    ([], []) [] [(1, {[None]}, {})])
  ([{[Some ''d''], [Some ''e'']}], [])"

value "mstate_m (snd m2)"
value "MAnd (MPred ''A'' [MFOTL.Var 0]) False
  (MUntil True (MRel {[None]}) (interval 1 2) (MExists (MPred ''B'' [MFOTL.Var 1, MFOTL.Var 0]))
   ([], []) [] [(1, {[None]}, {[Some ''d'']}), (2, {[None]}, {})])
  ([{[Some ''d''], [Some ''e'']}, {}], [])"

value "mstate_m (snd m3)"
value "MAnd (MPred ''A'' [MFOTL.Var 0]) False
  (MUntil True (MRel {[None]}) (interval 1 2) (MExists (MPred ''B'' [MFOTL.Var 1, MFOTL.Var 0]))
    ([], []) [] [(5, {[None]}, {})])
  ([{}], []) :: string mformula"

(*<*)
end
(*>*)