theory TransformTools
imports "Launchbury.Nominal-HOLCF" Launchbury.Terms Launchbury.Substitution Launchbury.Env
begin

default_sort type

fun lift_transform :: "('a::cont_pt \<Rightarrow> exp \<Rightarrow> exp) \<Rightarrow> ('a\<^sub>\<bottom> \<Rightarrow> exp \<Rightarrow> exp)"
  where "lift_transform t Ibottom  e = e"
  |     "lift_transform t (Iup a) e = t a e"

lemma lift_transform_simps[simp]:
  "lift_transform t \<bottom> e = e"
  "lift_transform t (up\<cdot>a) e = t a e"
  apply (metis inst_up_pcpo lift_transform.simps(1))
  apply (simp add: up_def cont_Iup)
  done

lemma lift_transform_eqvt[eqvt]: "\<pi> \<bullet>  lift_transform t a e = lift_transform (\<pi> \<bullet> t) (\<pi> \<bullet> a) (\<pi> \<bullet> e)"
  by (cases "a") simp_all

lemma lift_transform_fun_cong[fundef_cong]:
  "(\<And> a. t1 a e1 = t2 a e1) \<Longrightarrow> a1 = a2 \<Longrightarrow> e1 = e2 \<Longrightarrow> lift_transform t1 a1 e1 = lift_transform t2 a2 e2"
  by (cases "(t2,a2,e2)" rule: lift_transform.cases) auto

lemma subst_lift_transform:
  assumes "\<And> a. (t a e)[x ::= y] = t a (e[x ::= y])"
  shows "(lift_transform t a e)[x ::=y] = lift_transform t a (e[x ::= y])"
  using assms by (cases a) auto

definition
  map_transform :: "('a::cont_pt \<Rightarrow> exp \<Rightarrow> exp) \<Rightarrow> (var \<Rightarrow> 'a\<^sub>\<bottom>) \<Rightarrow> heap \<Rightarrow> heap"
  where "map_transform t ae = map_ran (\<lambda> x e . lift_transform t (ae x) e)"

lemma map_transform_eqvt[eqvt]: "\<pi> \<bullet> map_transform t ae = map_transform (\<pi> \<bullet> t) (\<pi> \<bullet> ae)"
  unfolding map_transform_def by simp

lemma domA_map_transform[simp]: "domA (map_transform t ae \<Gamma>) = domA \<Gamma>"
  unfolding map_transform_def by simp

lemma length_map_transform[simp]: "length (map_transform t ae xs) = length xs"
  unfolding map_transform_def map_ran_def by simp

lemma map_transform_delete:
  "map_transform t ae (delete x \<Gamma>) = delete x (map_transform t ae \<Gamma>)"
  unfolding map_transform_def by (simp add: map_ran_delete)

lemma map_transform_restrA:
  "map_transform t ae (restrictA S \<Gamma>) = restrictA S (map_transform t ae \<Gamma>)"
  unfolding map_transform_def by (auto simp add: map_ran_restrictA)

lemma delete_map_transform_env_delete:
  "delete x (map_transform t (env_delete x ae) \<Gamma>) = delete x (map_transform t ae \<Gamma>)"
  unfolding map_transform_def by (induction \<Gamma>) auto

lemma map_transform_Nil[simp]:
  "map_transform t ae [] = []"
  unfolding map_transform_def by simp

lemma map_transform_Cons:
  "map_transform t ae ((x,e)# \<Gamma>) = (x, lift_transform t (ae x) e) #  (map_transform t ae \<Gamma>)"
  unfolding map_transform_def by simp

lemma map_transform_append:
  "map_transform t ae (\<Delta>@\<Gamma>) = map_transform t ae \<Delta> @ map_transform t ae \<Gamma>"
  unfolding map_transform_def by (simp add: map_ran_append)

lemma map_transform_fundef_cong[fundef_cong]:
  "(\<And>x e a. (x,e) \<in> set m1 \<Longrightarrow> t1 a e = t2 a e) \<Longrightarrow> ae1 = ae2 \<Longrightarrow> m1 = m2 \<Longrightarrow> map_transform t1 ae1 m1 = map_transform t2 ae2 m2"
  by (induction m2 arbitrary: m1)
     (fastforce simp add: map_transform_Nil map_transform_Cons intro!: lift_transform_fun_cong)+

lemma map_transform_cong:
  "(\<And>x. x \<in> domA m1 \<Longrightarrow> ae x = ae' x) \<Longrightarrow> m1 = m2 \<Longrightarrow> map_transform t ae m1 = map_transform t ae' m2"
  unfolding map_transform_def by (auto intro!: map_ran_cong dest: domA_from_set)

lemma map_of_map_transform: "map_of (map_transform t ae \<Gamma>) x = map_option (lift_transform t (ae x)) (map_of \<Gamma> x)"
  unfolding map_transform_def by (simp add: map_ran_conv)

lemma supp_map_transform_step:
  assumes "\<And> x e a. (x, e) \<in> set \<Gamma> \<Longrightarrow> supp (t a e) \<subseteq> supp e"
  shows "supp (map_transform t ae \<Gamma>) \<subseteq> supp \<Gamma>"
  using assms
    apply (induction \<Gamma>)
    apply (auto simp add: supp_Nil supp_Cons map_transform_Nil map_transform_Cons supp_Pair pure_supp)
    apply (case_tac "ae a")
    apply (fastforce)+
    done

lemma subst_map_transform:
  assumes "\<And> x' e a. (x',e) : set \<Gamma> \<Longrightarrow> (t a e)[x ::= y] = t a (e[x ::= y])"
  shows "(map_transform t ae \<Gamma>)[x ::h=y] = map_transform t ae (\<Gamma>[x ::h= y])"
  using assms
  apply (induction \<Gamma>)
  apply (auto simp add: map_transform_Nil map_transform_Cons)
  apply (subst subst_lift_transform)
  apply auto
  done

locale supp_bounded_transform =
  fixes trans :: "'a::cont_pt \<Rightarrow> exp \<Rightarrow> exp"
  assumes supp_trans: "supp (trans a e) \<subseteq> supp e"
begin
  lemma supp_lift_transform: "supp (lift_transform trans a e) \<subseteq> supp e"
    by (cases "(trans, a, e)" rule:lift_transform.cases) (auto dest!: subsetD[OF supp_trans])

  lemma supp_map_transform: "supp (map_transform trans ae \<Gamma>) \<subseteq> supp \<Gamma>"
  unfolding map_transform_def
     by (induction \<Gamma>) (auto simp add: supp_Pair supp_Cons dest!: subsetD[OF supp_lift_transform])

  lemma fresh_transform[intro]: "a \<sharp> e \<Longrightarrow> a \<sharp> trans n e"
    by (auto simp add: fresh_def) (auto dest!: subsetD[OF supp_trans])

  lemma fresh_star_transform[intro]: "a \<sharp>* e \<Longrightarrow> a \<sharp>* trans n e"
    by (auto simp add: fresh_star_def)

  lemma fresh_map_transform[intro]: "a \<sharp> \<Gamma> \<Longrightarrow> a \<sharp> map_transform trans ae \<Gamma>"
    unfolding fresh_def using supp_map_transform by auto

  lemma fresh_star_map_transform[intro]: "a \<sharp>* \<Gamma> \<Longrightarrow> a \<sharp>* map_transform trans ae \<Gamma>"
    by (auto simp add: fresh_star_def)
end

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)
theory TraceMonadLemmas
imports TraceMonadVCG
begin

lemma mapM_Cons:
  "mapM f (x # xs) = do
    y \<leftarrow> f x;
    ys \<leftarrow> mapM f xs;
    return (y # ys)
  od"
  and mapM_Nil:
  "mapM f [] = return []"
  by (simp_all add: mapM_def sequence_def)

lemma mapM_x_Cons:
  "mapM_x f (x # xs) = do
    y \<leftarrow> f x;
    mapM_x f xs
  od"
  and mapM_x_Nil:
  "mapM_x f [] = return ()"
  by (simp_all add: mapM_x_def sequence_x_def)

lemma mapM_append:
  "mapM f (xs @ ys) = (do
    fxs \<leftarrow> mapM f xs;
    fys \<leftarrow> mapM f ys;
    return (fxs @ fys)
  od)"
  by (induct xs, simp_all add: mapM_Cons mapM_Nil bind_assoc)

lemma mapM_x_append:
  "mapM_x f (xs @ ys) = (do
    x \<leftarrow> mapM_x f xs;
    mapM_x f ys
  od)"
  by (induct xs, simp_all add: mapM_x_Cons mapM_x_Nil bind_assoc)

lemma mapM_map:
  "mapM f (map g xs) = mapM (f o g) xs"
  by (induct xs; simp add: mapM_Nil mapM_Cons)

lemma mapM_x_map:
  "mapM_x f (map g xs) = mapM_x (f o g) xs"
  by (induct xs; simp add: mapM_x_Nil mapM_x_Cons)

primrec
  repeat_n :: "nat \<Rightarrow> ('s, unit) tmonad \<Rightarrow> ('s, unit) tmonad"
where
    "repeat_n 0 f = return ()"
  | "repeat_n (Suc n) f = do f; repeat_n n f od"

lemma repeat_n_mapM_x:
  "repeat_n n f = mapM_x (\<lambda>_. f) (replicate n ())"
  by (induct n, simp_all add: mapM_x_Cons mapM_x_Nil)

definition
  repeat :: "('s, unit) tmonad \<Rightarrow> ('s, unit) tmonad"
where
  "repeat f = do n \<leftarrow> select UNIV; repeat_n n f od"

definition
  env_step :: "('s,unit) tmonad"
where
  "env_step =
  (do
    s' \<leftarrow> select UNIV;
    put_trace_elem (Env, s');
    put s'
  od)"

abbreviation
  "env_n_steps n \<equiv> repeat_n n env_step"

lemma elem_select_bind:
  "(tr, res) \<in> (do x \<leftarrow> select S; f x od) s
    = (\<exists>x \<in> S. (tr, res) \<in> f x s)"
  by (simp add: bind_def select_def)

lemma select_bind_UN:
  "(do x \<leftarrow> select S; f x od) = (\<lambda>s. \<Union>x \<in> S. f x s)"
  by (rule ext, auto simp: elem_select_bind)

lemma select_early:
  "S \<noteq> {}
    \<Longrightarrow> do x \<leftarrow> f; y \<leftarrow> select S; g x y od
        = do y \<leftarrow> select S; x \<leftarrow> f; g x y od"
  apply (simp add: bind_def select_def Sigma_def)
  apply (rule ext)
  apply (fastforce elim: rev_bexI image_eqI[rotated] split: tmres.split_asm)
  done

lemma repeat_n_choice:
  "S \<noteq> {}
    \<Longrightarrow> repeat_n n (do x \<leftarrow> select S; f x od)
        = (do xs \<leftarrow> select {xs. set xs \<subseteq> S \<and> length xs = n}; mapM_x f xs od)"
  apply (induct n; simp?)
   apply (simp add: select_def bind_def mapM_x_Nil cong: conj_cong)
  apply (simp add: select_early bind_assoc)
  apply (subst select_early)
   apply simp
   apply (auto intro: exI[where x="replicate n xs" for n xs])[1]
  apply (simp(no_asm) add: fun_eq_iff set_eq_iff elem_select_bind)
  apply (simp only: conj_comms[where Q="length xs = n" for xs n])
  apply (simp only: ex_simps[symmetric] conj_assoc length_Suc_conv, simp)
  apply (auto simp: mapM_x_Cons)
  done

lemma repeat_choice:
  "S \<noteq> {}
    \<Longrightarrow> repeat (do x \<leftarrow> select S; f x od)
        = (do xs \<leftarrow> select {xs. set xs \<subseteq> S}; mapM_x f xs od)"
  apply (simp add: repeat_def repeat_n_choice)
  apply (simp(no_asm) add: fun_eq_iff set_eq_iff elem_select_bind)
  done

lemma put_trace_append:
  "put_trace (xs @ ys) = do put_trace ys; put_trace xs od"
  by (induct xs; simp add: bind_assoc)

lemma put_trace_elem_put_comm:
  "do y \<leftarrow> put_trace_elem x; put s od
    = do y \<leftarrow> put s; put_trace_elem x od"
  by (simp add: put_def put_trace_elem_def bind_def insert_commute)

lemma put_trace_put_comm:
  "do y \<leftarrow> put_trace xs; put s od
    = do y \<leftarrow> put s; put_trace xs od"
  apply (rule sym; induct xs; simp)
  apply (simp add: bind_assoc put_trace_elem_put_comm)
  apply (simp add: bind_assoc[symmetric])
  done

lemma mapM_x_comm:
  "(\<forall>x \<in> set xs. do y \<leftarrow> g; f x od = do y \<leftarrow> f x; g od)
    \<Longrightarrow> do y \<leftarrow> g; mapM_x f xs od = do y \<leftarrow> mapM_x f xs; g od"
  apply (induct xs; simp add: mapM_x_Nil mapM_x_Cons)
  apply (simp add: bind_assoc[symmetric], simp add: bind_assoc)
  done

lemma mapM_x_split:
  "(\<forall>x \<in> set xs. \<forall>y \<in> set xs. do z \<leftarrow> g y; f x od = do (z :: unit) \<leftarrow> f x; g y od)
    \<Longrightarrow> mapM_x (\<lambda>x. do z \<leftarrow> f x; g x od) xs = do y \<leftarrow> mapM_x f xs; mapM_x g xs od"
  apply (induct xs; simp add: mapM_x_Nil mapM_x_Cons bind_assoc)
  apply (subst bind_assoc[symmetric], subst mapM_x_comm[where f=f and g="g x" for x])
   apply simp
  apply (simp add: bind_assoc)
  done

lemma mapM_x_put:
  "mapM_x put xs = unless (xs = []) (put (last xs))"
  apply (induct xs rule: rev_induct)
   apply (simp add: mapM_x_Nil unless_def when_def)
  apply (simp add: mapM_x_append mapM_x_Cons mapM_x_Nil)
  apply (simp add: bind_def unless_def when_def put_def return_def)
  done

lemma put_trace_mapM_x:
  "put_trace xs = mapM_x put_trace_elem (rev xs)"
  by (induct xs; simp add: mapM_x_Nil mapM_x_append mapM_x_Cons)

lemma rev_surj:
  "surj rev"
  by (rule_tac f=rev in surjI, simp)

lemma select_image:
  "select (f ` S) = do x \<leftarrow> select S; return (f x) od"
  by (auto simp add: bind_def select_def return_def Sigma_def)

lemma env_steps_repeat:
  "env_steps = repeat env_step"
  apply (simp add: env_step_def repeat_choice env_steps_def
                   select_early)
  apply (simp add: put_trace_elem_put_comm)
  apply (simp add: mapM_x_split put_trace_elem_put_comm put_trace_put_comm
                   mapM_x_put)
  apply (simp add: put_trace_mapM_x rev_map mapM_x_map o_def)
  apply (subst rev_surj[symmetric], simp add: select_image bind_assoc)
  apply (rule arg_cong2[where f=bind, OF refl ext])
  apply (simp add: bind_def get_def put_def unless_def when_def return_def)
  apply (simp add: last_st_tr_def hd_map hd_rev)
  done

lemma repeat_n_plus:
  "repeat_n (n + m) f = do repeat_n n f; repeat_n m f od"
  by (induct n; simp add: bind_assoc)

lemma repeat_eq_twice[simp]:
  "(do x \<leftarrow> repeat f; repeat f od) = repeat f"
  apply (simp add: repeat_def select_early)
  apply (simp add: bind_assoc repeat_n_plus[symmetric, simplified])
  apply (simp add: bind_def select_def Sigma_def)
  apply (rule ext, fastforce intro: exI[where x=0])
  done

lemmas bind_then_eq = arg_cong2[where f=bind, OF _ refl]
lemmas repeat_eq_twice_then[simp]
    = repeat_eq_twice[THEN bind_then_eq, simplified bind_assoc]

lemmas env_steps_eq_twice[simp]
    = repeat_eq_twice[where f=env_step, folded env_steps_repeat]
lemmas env_steps_eq_twice_then[simp]
    = env_steps_eq_twice[THEN bind_then_eq, simplified bind_assoc]

lemmas mapM_collapse_append = mapM_append[symmetric, THEN bind_then_eq,
    simplified bind_assoc, simplified]

lemma prefix_closed_mapM[rule_format, wp_split]:
  "(\<forall>x \<in> set xs. prefix_closed (f x)) \<Longrightarrow> prefix_closed (mapM f xs)"
  apply (induct xs)
   apply (simp add: mapM_def sequence_def)
  apply (clarsimp simp: mapM_Cons)
  apply (intro prefix_closed_bind allI; clarsimp)
  done

lemma modify_id:
  "modify id = return ()"
  by (simp add: modify_def get_def bind_def put_def return_def)

lemma modify_modify:
  "(do x \<leftarrow> modify f; modify (g x) od) = modify (g () o f)"
  by (simp add: bind_def simpler_modify_def)

lemmas modify_modify_bind = arg_cong2[where f=bind,
  OF modify_modify refl, simplified bind_assoc]

lemma select_single:
  "select {x} = return x"
  by (simp add: select_def return_def)

lemma put_then_get[unfolded K_bind_def]:
  "do put s; get od = do put s; return s od"
  by (simp add: put_def bind_def get_def return_def)

lemmas put_then_get_then
    = put_then_get[THEN bind_then_eq, simplified bind_assoc return_bind]

lemmas bind_promote_If
    = if_distrib[where f="\<lambda>f. bind f g" for g]
      if_distrib[where f="\<lambda>g. bind f g" for f]

lemma bind_promote_If2:
  "do x \<leftarrow> f; if P then g x else h x od
    = (if P then bind f g else bind f h)"
  by simp

lemma exec_put_trace[unfolded K_bind_def]:
  "(do put_trace xs; f od) s
    = (\<Union>n \<in> {n. 0 < n \<and> n \<le> length xs}. {(drop n xs, Incomplete)})
        \<union> ((\<lambda>(a, b). (a @ xs, b)) ` f s)"
  apply (simp add: put_trace_eq_drop bind_def)
  apply (safe; (clarsimp split: if_split_asm)?;
      fastforce intro: bexI[where x=0] rev_bexI)
  done

lemma if_fun_lift:
  "(if P then f else g) x = (if P then f x else g x)"
  by simp

lemma UN_If_distrib:
  "(\<Union>x \<in> S. if P x then A x else B x)
    = ((\<Union>x \<in> S \<inter> {x. P x}. A x) \<union> (\<Union>x \<in> S \<inter> {x. \<not> P x}. B x))"
  by (fastforce split: if_split_asm)

lemma Await_redef:
  "Await P = do
    s1 \<leftarrow> select {s. P s};
    env_steps;
    s \<leftarrow> get;
    select (if P s then {()} else {})
  od"
  apply (simp add: Await_def env_steps_def bind_assoc)
  apply (cases "{s. P s} = {}")
   apply (simp add: select_def bind_def get_def)
  apply (rule ext)
  apply (simp add: exec_get select_bind_UN put_then_get_then)
  apply (simp add: bind_promote_If2 if_fun_lift if_distrib[where f=select])
  apply (simp add: exec_put_trace cong: if_cong)
  apply (simp add: put_def bind_def select_def cong: if_cong)
  apply (strengthen equalityI)
  apply clarsimp
  apply (strengthen exI[where x="s # xs" for s xs])
  apply (strengthen exI[where x="Suc n" for n])
  apply simp
  apply blast
  done

lemma bind_apply_cong':
  "f s = f' s
    \<Longrightarrow> (\<forall>rv s'. (rv, s') \<in> mres (f s) \<longrightarrow> g rv s' = g' rv s')
    \<Longrightarrow> bind f g s = bind f' g' s"
  apply (simp add: bind_def)
  apply (rule SUP_cong; simp?)
  apply (clarsimp split: tmres.split)
  apply (drule spec2, drule mp, erule in_mres)
  apply simp
  done

lemmas bind_apply_cong = bind_apply_cong'[rule_format]

lemma select_empty_bind[simp]:
  "select {} >>= f = select {}"
  by (simp add: select_def bind_def)

lemma fail_bind[simp]:
  "fail >>= f = fail"
  by (simp add: bind_def fail_def)

lemma eq_Me_neq_Env:
  "(x = Me) = (x \<noteq> Env)"
  by (cases x; simp)

lemma validI_invariant_imp:
  assumes v: "\<lbrace>P\<rbrace>,\<lbrace>R\<rbrace> f \<lbrace>G\<rbrace>,\<lbrace>Q\<rbrace>"
    and P: "\<forall>s0 s. P s0 s \<longrightarrow> I s0"
    and R: "\<forall>s0 s. I s0 \<longrightarrow> R s0 s \<longrightarrow> I s"
    and G: "\<forall>s0 s. I s0 \<longrightarrow> G s0 s \<longrightarrow> I s"
  shows "\<lbrace>P\<rbrace>,\<lbrace>R\<rbrace> f \<lbrace>\<lambda>s0 s. I s0 \<and> I s \<and> G s0 s\<rbrace>,\<lbrace>\<lambda>rv s0 s. I s0 \<and> Q rv s0 s\<rbrace>"
proof -
  { fix tr s0 i
  assume r: "rely_cond R s0 tr" and g: "guar_cond G s0 tr"
    and I: "I s0"
  hence imp: "\<forall>(_, s, s') \<in> trace_steps (rev tr) s0. I s \<longrightarrow> I s'"
    apply (clarsimp simp: guar_cond_def rely_cond_def)
    apply (drule(1) bspec)+
    apply (clarsimp simp: eq_Me_neq_Env)
    apply (metis R G)
    done
  hence "i < length tr \<longrightarrow> I (snd (rev tr ! i))"
    using I
    apply (induct i)
     apply (clarsimp simp: neq_Nil_conv[where xs="rev tr" for tr, simplified])
    apply clarsimp
    apply (drule bspec, fastforce simp add: trace_steps_nth)
    apply simp
    done
  }
  note I = this
  show ?thesis
    using v
    apply (clarsimp simp: validI_def rely_def imp_conjL)
    apply (drule spec2, drule(1) mp)+
    apply clarsimp
    apply (frule P[rule_format])
    apply (clarsimp simp: guar_cond_def trace_steps_nth I last_st_tr_def
                          hd_append last_rev[symmetric]
                          last_conv_nth rev_map)
    done
qed

lemma validI_guar_post_conj_lift:
  "\<lbrace>P\<rbrace>,\<lbrace>R\<rbrace> f \<lbrace>G1\<rbrace>,\<lbrace>Q1\<rbrace>
    \<Longrightarrow> \<lbrace>P\<rbrace>,\<lbrace>R\<rbrace> f \<lbrace>G2\<rbrace>,\<lbrace>Q2\<rbrace>
    \<Longrightarrow> \<lbrace>P\<rbrace>,\<lbrace>R\<rbrace> f \<lbrace>\<lambda>s0 s. G1 s0 s \<and> G2 s0 s\<rbrace>,\<lbrace>\<lambda>rv s0 s. Q1 rv s0 s \<and> Q2 rv s0 s\<rbrace>"
  apply (frule validI_prefix_closed)
  apply (subst validI_def, clarsimp simp: rely_def)
  apply (drule(3) validI_D)+
  apply (auto simp: guar_cond_def)
  done

lemmas modify_prefix_closed[simp] =
  modify_wp[THEN valid_validI_wp[OF no_trace_all(3)], THEN validI_prefix_closed]
lemmas await_prefix_closed[simp] = Await_sync_twp[THEN validI_prefix_closed]

lemma repeat_prefix_closed[intro!]:
  "prefix_closed f \<Longrightarrow> prefix_closed (repeat f)"
  apply (simp add: repeat_def)
  apply (rule prefix_closed_bind; clarsimp)
  apply (rename_tac n)
  apply (induct_tac n; simp)
  apply (auto intro: prefix_closed_bind)
  done

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory MultByAdd
imports
  "../../AutoCorres"
begin

(* Parse the input file. *)
install_C_file "mult_by_add.c"

(* Abstract the input file. *)
autocorres [ ts_force nondet = mult_by_add ] "mult_by_add.c"

context mult_by_add begin

(*
 * Prove the function returns the correct result, and (simultaneously)
 * does not fail and terminates.
 *)
lemma "\<lbrace> \<lambda>s. True \<rbrace> mult_by_add' a b \<lbrace> \<lambda>r s. r = a * b \<rbrace>!"
  (* Unfold function definition. *)
  apply (clarsimp simp: mult_by_add'_def)

  (* Annotate while loop with an invariant and measure. *)
  apply (subst whileLoop_add_inv
    [where I="\<lambda>(a', r) s. (a' * b) + r = (a * b)"
       and M="\<lambda>((a', _), s). unat a'"])

  (* Run "wp" weakest precondition tactic, and solve verification *
   * conditions generated by it. *)
  apply wp
     apply (simp add: field_simps)
    apply unat_arith
   apply (simp add: split_def word_neq_0_conv[symmetric])
  apply (simp add: split_def | wp)+
  done

(*
 * Equivalent partial-correctness proof using Simpl framework.
 *)
lemma "\<Gamma> \<turnstile> {s. s = t} \<acute>ret__unsigned :== CALL mult_by_add(\<acute>a, \<acute>b) \<lbrace> (\<acute>ret__unsigned = \<^bsup>t\<^esup>a * \<^bsup>t\<^esup>b) \<rbrace>"
  (* Unfold the body. *)
  apply vcg_step
   defer

   (* Annotate the while loop with an invariant and variant. *)
   apply (subst whileAnno_def)
   apply (subst whileAnno_def [symmetric,
     where I=" \<lbrace> (\<acute>a * \<acute>b + \<acute>result) = (\<^bsup>t\<^esup>a * \<^bsup>t\<^esup>b) \<rbrace>"
     and V="measure (\<lambda>s. unat (a_' s))"])

  (* Solve the remaining conditions. *)
   apply vcg
   apply (fastforce intro: unat_mono simp: gt0_iff_gem1 field_simps less_1_simp scast_id)+
  done

end

end


(*  Title:      JinjaThreads/Basic/Set_without_equal.thy
    Author:     Andreas Lochbihler
*)

theory Set_without_equal
imports Main
begin

text \<open>
  Adapt @{type "set"} code setup such that @{const "insert"},
  @{const "union"}, and @{term "set_of_pred"} do not generate
  sort constraint @{class equal}.
\<close>

definition insert' :: "'a \<Rightarrow> 'a set \<Rightarrow> 'a set"
where "insert' = Set.insert"

definition union' :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set"
where "union' A B = sup A B"

declare
  insert'_def [symmetric, code_unfold]
  union'_def [symmetric, code_unfold]

lemma insert'_code:
  "insert' x (set xs) = set (x # xs)"
  by (rule set_eqI) (simp add: insert'_def)

lemma union'_code:
  "union' (set xs) (set ys) = set (xs @ ys)"
  by (rule set_eqI) (simp add: union'_def fun_eq_iff)

declare
  insert'_code [code]
  union'_code [code]

text \<open>Merge name spaces to avoid cyclic module dependencies\<close>

code_identifier
  code_module Set_without_equal \<rightharpoonup>
    (SML) Set and (Haskell) Set and (OCaml) Set

end


section \<open>Correctness of Type Checker\<close>

theory Wasm_Checker_Properties imports Wasm_Checker Wasm_Properties begin

subsection \<open>Soundness\<close>

lemma b_e_check_single_type_sound:
  assumes "type_update (Type x1) (to_ct_list t_in) (Type t_out) = Type x2"
          "c_types_agree (Type x2) tm"
          "\<C> \<turnstile> [e] : (t_in _> t_out)"
  shows "\<exists>tn. c_types_agree (Type x1) tn \<and> \<C> \<turnstile> [e] : (tn _> tm)"
  using assms(2) b_e_typing.intros(35)[OF assms(3)] type_update_type[OF assms(1)]
  by auto

lemma b_e_check_single_top_sound:
  assumes "type_update (TopType x1) (to_ct_list t_in) (Type t_out) = TopType x2"
          "c_types_agree (TopType x2) tm"
          "\<C> \<turnstile> [e] : (t_in _> t_out)"
  shows "\<exists>tn. c_types_agree (TopType x1) tn \<and> \<C> \<turnstile> [e] : (tn _> tm)"
proof -
  obtain t_ag where t_ag_def:"ct_suffix (to_ct_list t_out) x2"
                             "tm = t_ag @ t_out"
                             "c_types_agree (TopType x1) (t_ag @ t_in)"
    using type_update_top_top[OF assms(1,2)]
    by fastforce
  hence "\<C> \<turnstile> [e] : (t_ag@t_in _> t_ag@t_out)"
    using b_e_typing.intros(35)[OF assms(3)]
    by fastforce
  thus ?thesis
    using t_ag_def
    by fastforce
qed

lemma b_e_check_single_top_not_bot_sound:
  assumes "type_update ts (to_ct_list t_in) (TopType []) = ts'"
          "ts \<noteq> Bot"
          "ts' \<noteq> Bot"
  shows "\<exists>tn. c_types_agree ts tn \<and> suffix t_in tn"
proof (cases ts)
  case (TopType x1)
  then obtain t_int where "consume (TopType x1) (to_ct_list t_in) = t_int" "t_int \<noteq> Bot"
    using assms(1,2,3)
    by fastforce
  thus ?thesis
    using TopType ct_suffix_ct_list_eq_exists ct_suffix_ts_conv_suffix
    unfolding consume.simps
    by (metis append_Nil c_types_agree.simps(2) ct_suffix_def)
next
  case (Type x2)
  then obtain t_int where "consume (Type x2) (to_ct_list t_in) = t_int" "t_int \<noteq> Bot"
    using assms(1,2,3)
    by fastforce
  thus ?thesis
    using c_types_agree_id Type consume_type suffixI ct_suffix_ts_conv_suffix
    by fastforce
next
  case Bot
  thus ?thesis
    using assms(2)
    by simp
qed

lemma b_e_check_single_type_not_bot_sound:
  assumes "type_update ts (to_ct_list t_in) (Type t_out) = ts'"
          "ts \<noteq> Bot"
          "ts' \<noteq> Bot"
          "c_types_agree ts' tm"
          "\<C> \<turnstile> [e] : (t_in _> t_out)"
  shows "\<exists>tn. c_types_agree ts tn \<and> \<C> \<turnstile> [e] : (tn _> tm)"
  using assms b_e_check_single_type_sound
proof (cases ts)
  case (TopType x1)
  then obtain x1' where x_def:"TopType x1' = ts'"
    using assms
    by (simp, metis (full_types) produce.simps(1) produce.simps(6))
  thus ?thesis
    using assms b_e_check_single_top_sound TopType
    by fastforce
next
  case (Type x2)
  then obtain x2' where x_def:"Type x2' = ts'"
    using assms
    by (simp, metis (full_types) produce.simps(2) produce.simps(6))
  thus ?thesis
    using assms b_e_check_single_type_sound Type
    by fastforce
next
  case Bot
  thus ?thesis
    using assms(2)
    by simp
qed

lemma b_e_check_single_sound_unop_testop_cvtop:
  assumes "check_single \<C> e tn' = tm'"
          "((e = (Unop_i t uu) \<or> e = (Testop t uv)) \<and> is_int_t t)
           \<or> (e = (Unop_f t uw) \<and> is_float_t t)
           \<or> (e = (Cvtop t1 Convert t sx) \<and> convert_cond t1 t sx)
           \<or> (e = (Cvtop t1 Reinterpret t sx) \<and> ((t1 \<noteq> t) \<and> t_length t1 = t_length t \<and> sx = None))"
          "c_types_agree tm' tm"
          "tn' \<noteq> Bot"
          "tm' \<noteq> Bot"
 shows "\<exists>tn. c_types_agree tn' tn \<and> \<C> \<turnstile> [e] : (tn _> tm)"
proof -
  have "(e = (Cvtop t1 Convert t sx) \<Longrightarrow> convert_cond t1 t sx)"
    using assms(2)
    by simp
  hence temp0:"(e = (Cvtop t1 Convert t sx)) \<Longrightarrow> (type_update tn' [TSome t] (Type [arity_1_result e]) = tm')"
    using assms(1,5) arity_1_result_def
    by (simp del: convert_cond.simps)
  have temp1:"(e = (Cvtop t1 Reinterpret t sx)) \<Longrightarrow> (type_update tn' [TSome t] (Type [arity_1_result e]) = tm')"
    using assms(1,2,5) arity_1_result_def
    by simp
  have 1:"type_update tn' (to_ct_list [t]) (Type [arity_1_result e]) = tm'"
    using assms arity_1_result_def
    unfolding to_ct_list_def
    apply (simp del: convert_cond.simps)
    apply (metis (no_types, lifting) temp0 temp1 b_e.simps(978,979,982) check_single.simps(2) check_single.simps(3) check_single.simps(6) type_update.simps)
    done
  have "\<C> \<turnstile> [e] : ([t] _> [arity_1_result e])"
    using assms(2) b_e_typing.intros(2,3,6,9,10)
    unfolding arity_1_result_def
    by fastforce
  thus ?thesis
    using b_e_check_single_type_not_bot_sound[OF 1 assms(4,5,3)]
    by fastforce
qed

lemma b_e_check_single_sound_binop_relop:
  assumes "check_single \<C> e tn' = tm'"
          "((e = Binop_i t iop \<and> is_int_t t)
            \<or> (e = Binop_f t fop \<and> is_float_t t)
            \<or> (e = Relop_i t irop \<and> is_int_t t)
            \<or> (e = Relop_f t frop \<and> is_float_t t))"
          "c_types_agree tm' tm"
          "tn' \<noteq> Bot"
          "tm' \<noteq> Bot"
 shows "\<exists>tn. c_types_agree tn' tn \<and> \<C> \<turnstile> [e] : (tn _> tm)"
proof -
  have "type_update tn' (to_ct_list [t,t]) (Type [arity_2_result e]) = tm'"
    using assms arity_2_result_def
    unfolding to_ct_list_def
    by auto
  moreover
  have "\<C> \<turnstile> [e] : ([t,t] _> [arity_2_result e])"
    using assms(2) b_e_typing.intros(4,5,7,8)
    unfolding arity_2_result_def
    by fastforce
  ultimately
  show ?thesis
    using b_e_check_single_type_not_bot_sound[OF _ assms(4,5,3)]
    by fastforce
qed

lemma b_e_type_checker_sound:
  assumes "b_e_type_checker \<C> es (tn _> tm)"
  shows "\<C> \<turnstile> es : (tn _> tm)"
proof -
  fix e tn'
  have "b_e_type_checker \<C> es (tn _> tm) \<Longrightarrow>
          \<C> \<turnstile> es : (tn _> tm)"
  and "\<And>tm' tm.
       check \<C> es tn' = tm' \<Longrightarrow>
       c_types_agree tm' tm \<Longrightarrow>
         \<exists>tn. c_types_agree tn' tn \<and> \<C> \<turnstile> es : (tn _> tm)"
  and "\<And>tm' tm.
       check_single \<C> e tn' = tm' \<Longrightarrow>
       c_types_agree tm' tm \<Longrightarrow>
       tn' \<noteq> Bot \<Longrightarrow>
       tm' \<noteq> Bot \<Longrightarrow>
         \<exists>tn. c_types_agree tn' tn \<and> \<C> \<turnstile> [e] : (tn _> tm)"
  proof (induction rule: b_e_type_checker_check_check_single.induct)
    case (1 \<C> es tn' tm)
    thus ?case
      by simp
  next
    case (2 \<C> es' ts)
    show ?case
    proof (cases es')
      case Nil
      thus ?thesis
        using 2(5,6)
        by (simp add: b_e_type_empty)
    next
      case (Cons e es)
        thus ?thesis
        proof (cases ts)
        case (TopType x1)
        have check_expand:"check \<C> es (check_single \<C> e ts) = tm'"
          using 2(5,6) TopType Cons
          by simp
        obtain ts' where ts'_def:"check_single \<C> e ts = ts'"
          by blast
        obtain t_int where t_int_def:"\<C> \<turnstile> es : (t_int _> tm)"
                                     "c_types_agree ts' t_int"
          using 2(2)[OF Cons TopType check_expand 2(6)] ts'_def
          by blast
        obtain t_int' where "c_types_agree ts t_int'" "\<C> \<turnstile> [e] : (t_int' _> t_int)"
          using 2(1)[OF Cons _ ts'_def] TopType c_types_agree.simps(3) t_int_def(2)
          by blast
        thus ?thesis
          using t_int_def(1) b_e_type_comp_conc Cons
          by fastforce
      next
        case (Type x2)
        have check_expand:"check \<C> es (check_single \<C> e ts) = tm'"
          using 2(5,6) Type Cons
          by simp
        obtain ts' where ts'_def:"check_single \<C> e ts = ts'"
          by blast
        obtain t_int where t_int_def:"\<C> \<turnstile> es : (t_int _> tm)"
                                     "c_types_agree ts' t_int"
          using 2(4)[OF Cons Type check_expand 2(6)] ts'_def
          by blast
        obtain t_int' where "c_types_agree ts t_int'" "\<C> \<turnstile> [e] : (t_int' _> t_int)"
          using 2(3)[OF Cons _ ts'_def] Type c_types_agree.simps(3) t_int_def(2)
          by blast
        thus ?thesis
          using t_int_def(1) b_e_type_comp_conc Cons
          by fastforce
      next
        case Bot
        then show ?thesis
          using 2(5,6) Cons
          by auto
      qed
    qed
  next
    case (3 \<C> v ts)
    hence "type_update ts [] (Type [typeof v]) = tm'"
      by simp
    moreover
    have "\<C> \<turnstile> [C v] : ([] _> [typeof v])"
      using b_e_typing.intros(1)
      by blast
    ultimately
    show ?case
      using b_e_check_single_type_not_bot_sound[OF _ 3(3,4,2)]
      by (metis list.simps(8) to_ct_list_def)
  next
    case (4 \<C> t uu ts)
    hence "is_int_t t"
      by (simp, meson)
    thus ?case
      using b_e_check_single_sound_unop_testop_cvtop 4
      by fastforce
  next
    case (5 \<C> t uv ts)
    hence "is_float_t t"
      by (simp, meson)
    thus ?case
      using b_e_check_single_sound_unop_testop_cvtop 5
      by fastforce
  next
    case (6 \<C> t uw ts)
    hence "is_int_t t"
      by (simp, meson)
    thus ?case
      using b_e_check_single_sound_binop_relop 6
      by fastforce
  next
    case (7 \<C> t ux ts)
    hence "is_float_t t"
      by (simp, meson)
    thus ?case
      using b_e_check_single_sound_binop_relop 7
      by fastforce
  next
    case (8 \<C> t uy ts)
    hence "is_int_t t"
      by (simp, meson)
    thus ?case
      using b_e_check_single_sound_unop_testop_cvtop 8
      by fastforce
  next
    case (9 \<C> t uz ts)
    hence "is_int_t t"
      by (simp, meson)
    thus ?case
      using b_e_check_single_sound_binop_relop 9
      by fastforce
  next
    case (10 \<C> t va ts)
    hence "is_float_t t"
      by (simp, meson)
    thus ?case
      using b_e_check_single_sound_binop_relop 10
      by fastforce
  next
    case (11 \<C> t1 t2 sx ts)
    hence "convert_cond t1 t2 sx"
      by (simp del: convert_cond.simps, meson)
    thus ?case
      using b_e_check_single_sound_unop_testop_cvtop 11
      by fastforce
  next
    case (12 \<C> t1 t2 sx ts)
    hence "t1 \<noteq> t2 \<and>  t_length t1 = t_length t2 \<and> sx = None"
      by (simp, presburger)
    thus ?case
      using b_e_check_single_sound_unop_testop_cvtop 12
      by fastforce
  next
    case (13 \<C> ts)
    thus ?case
      using b_e_typing.intros(11) c_types_agree_not_bot_exists
      by blast
  next
    case (14 \<C> ts)
    thus ?case
      using b_e_typing.intros(12,35)
      by fastforce
  next
    case (15 \<C> ts)
    thus ?case
    proof (cases ts)
      case (TopType x1)
      thus ?thesis
        proof (cases x1 rule: List.rev_cases)
          case Nil
          have "\<C> \<turnstile> [Drop] : (tm@[T_i32] _> tm)"
            using b_e_typing.intros(13,35)
            by fastforce
          thus ?thesis
            using c_types_agree_top1 Nil TopType
            by fastforce
        next
          case (snoc ys y)
            hence temp1:"(consume (TopType (ys@[y])) [TAny]) = tm'"
              using 15 TopType type_update_empty
              by (metis check_single.simps(13))
            hence temp2:"c_types_agree (TopType ys) tm"
              using consume_top_geq[OF temp1] 15(2,3,4)
              by (metis Suc_leI add_diff_cancel_right' append_eq_conv_conj consume.simps(2)
                        ct_suffix_def length_Cons length_append list.size(3) trans_le_add2
                        zero_less_Suc)
            obtain t where "ct_list_eq [y] (to_ct_list [t])"
              using ct_list_eq_exists
              unfolding ct_list_eq_def to_ct_list_def list_all2_map2
              by (metis list_all2_Cons1 list_all2_Nil)
            hence "c_types_agree ts (tm@[t])"
              using temp2 ct_suffix_extend_ct_list_eq snoc TopType
              by (simp add: to_ct_list_def)
            thus ?thesis
              using b_e_typing.intros(13,35)
              by fastforce
        qed
    next
      case (Type x2)
      thus ?thesis
      proof (cases x2 rule: List.rev_cases)
        case Nil
        hence "(consume (Type []) [TAny]) = tm'"
          using 15 Type type_update_empty
          by fastforce
        thus ?thesis
          using 15(4) ct_list_eq_def ct_suffix_def to_ct_list_def
          by simp
      next
        case (snoc ys y)
            hence temp1:"(consume (Type (ys@[y])) [TAny]) = tm'"
              using 15 Type type_update_empty
              by (metis check_single.simps(13))
            hence temp2:"c_types_agree (Type ys) tm"
              using 15(2,3,4) ct_suffix_def
              by (simp, metis One_nat_def butlast_conv_take butlast_snoc c_types_agree.simps(1)
                              length_Cons list.size(3))
            obtain t where "ct_list_eq [TSome y] (to_ct_list [t])"
              using ct_list_eq_exists
              unfolding ct_list_eq_def to_ct_list_def list_all2_map2
              by (metis list_all2_Cons1 list_all2_Nil)
            hence "c_types_agree ts (tm@[t])"
              using temp2 ct_suffix_extend_ct_list_eq snoc Type
              by (simp add: ct_list_eq_def to_ct_list_def)
            thus ?thesis
              using b_e_typing.intros(13,35)
              by fastforce
      qed
    qed simp
  next
    case (16 \<C> ts)
    thus ?case
    proof (cases ts)
      case (TopType x1)
      consider
          (1) "length x1 = 0"
        | (2) "length x1 = 1"
        | (3) "length x1 = 2"
        | (4) "length x1 \<ge> 3"
        by linarith
      thus ?thesis
      proof (cases)
        case 1
        hence "tm' = TopType [TAny]"
          using TopType 16
          by simp
        then obtain t'' tm'' where tm_def:"tm = tm''@[t'']"
          using 16(2) ct_suffix_def
          by (simp, metis Nil_is_append_conv append_butlast_last_id checker_type.inject(1)
                          ct_prefixI ct_prefix_nil(2) produce.simps(1) produce_nil)
        have "\<C> \<turnstile> [Select] : ([t'',t'',T_i32] _> [t''])"
          using b_e_typing.intros(14)
          by blast
        thus ?thesis
          using TopType 16 1 tm_def b_e_typing.intros(35) c_types_agree.simps(2) c_types_agree_top1
          by fastforce
      next
        case 2
        have "type_update_select (TopType x1) = tm'"
          using 16 TopType
          unfolding check_single.simps
          by simp
        hence x1_def:"ct_list_eq x1 [TSome T_i32]" "tm' = TopType [TAny]"
          using type_update_select_length1[OF _ 2 16(4)]
          by simp_all
        then obtain t'' tm'' where tm_def:"tm = tm''@[t'']"
          using 16(2) ct_suffix_def
          by (metis Nil_is_append_conv append_butlast_last_id c_types_agree.simps(2) ct_prefixI
                    ct_prefix_nil(2) list.simps(8) to_ct_list_def)
        have "c_types_agree (TopType x1) ((tm''@[t'',t''])@[T_i32])"
          using x1_def(1)
          by (metis c_types_agree_top2 list.simps(8,9) to_ct_list_def)
        thus ?thesis
          using TopType b_e_typing.intros(14,35) tm_def
          by auto
      next
        case 3
        have "type_update_select (TopType x1) = tm'"
          using 16 TopType
          unfolding check_single.simps
          by simp
        then obtain ct1 ct2 where x1_def:"x1 = [ct1, ct2]"
                                         "ct_eq ct2 (TSome T_i32)"
                                         "tm' = TopType [ct1]"
          using type_update_select_length2[OF _ 3 16(4)]
          by blast
        then obtain t'' tm'' where tm_def:"tm = tm''@[t'']"
                                          "ct_list_eq [ct1] [(TSome t'')]"
          using 16(2) c_types_agree_imp_ct_list_eq[of "[ct1]" tm]
          by (metis append_Nil2 append_butlast_last_id append_eq_append_conv_if append_eq_conv_conj
                    ct_list_eq_length diff_Suc_1 length_Cons length_butlast length_map
                    list.simps(8,9) list.size(3) nat.distinct(2) to_ct_list_def)
        hence "ct_list_eq x1 (to_ct_list [ t'', T_i32])"
          using x1_def(1,2)
          unfolding ct_list_eq_def to_ct_list_def
          by fastforce
        hence "c_types_agree (TopType x1) ((tm''@[t''])@[t'',T_i32])"
          using c_types_agree_top2
          by blast
        thus ?thesis
          using TopType b_e_typing.intros(14,35) tm_def
          by auto
      next
        case 4
        then obtain nat where nat_def:"length x1 = Suc (Suc (Suc nat))"
          by (metis add_eq_if diff_Suc_1 le_Suc_ex numeral_3_eq_3 nat.distinct(2))
        hence tm'_def:"type_update_select (TopType x1) = tm'"
          using 16 TopType
          by simp
        then obtain tm_int where "(select_return_top x1
                                    (x1 ! (length x1 - 2))
                                    (x1 ! (length x1 - 3))) = tm_int"
                                 "tm_int \<noteq> Bot"
          using nat_def 16(4)
          unfolding type_update_select.simps
          by fastforce
        then obtain x2 where x2_def:"(select_return_top x1
                                       (x1 ! (length x1 - 2))
                                       (x1 ! (length x1 - 3))) = TopType x2"
          using select_return_top_exists
          by fastforce
        have "ct_suffix x1 [TAny, TAny, TSome T_i32] \<or> ct_suffix [TAny, TAny, TSome T_i32] x1"
          using tm'_def nat_def 16(4)
          by (simp, metis (full_types) produce.simps(6))
        hence tm'_eq:"tm' = TopType x2"
          using tm'_def nat_def 16(4) x2_def
          by force
        then obtain cts' ct1 ct2 ct3 where cts'_def:"x1 = cts'@[ct1, ct2, ct3]"
                                                    "ct_eq ct3 (TSome T_i32)"
          using type_update_select_length3 tm'_def 4
          by blast
        then obtain c' cm' where tm_def:"tm = cm'@[c']"
                                        "ct_suffix cts' (to_ct_list cm')"
                                        "ct_eq (x1 ! (length x1 - 2)) (TSome c')"
                                        "ct_eq (x1 ! (length x1 - 3)) (TSome c')"
          using select_return_top_ct_eq[OF x2_def 4] tm'_eq 4 16(2)
          by fastforce
        then obtain as bs where cm'_def:"cm' = as@bs"
                                        "ct_list_eq (to_ct_list bs) cts'"
          using ct_list_eq_cons_ct_list1 ct_list_eq_ts_conv_eq
          by (metis ct_suffix_def to_ct_list_append(2))
        hence "ct_eq ct1 (TSome c')"
              "ct_eq ct2 (TSome c')"
          using cts'_def tm_def
          apply simp_all
          apply (metis append.assoc append_Cons append_Nil length_append_singleton nth_append_length)
          done
        hence "c_types_agree ts (cm'@[c',c',T_i32])"
          using c_types_agree_top2[of _ _ as] cm'_def(1) TopType
                ct_list_eq_concat[OF ct_list_eq_commute[OF cm'_def(2)]] cts'_def
          unfolding to_ct_list_def ct_list_eq_def
          by fastforce
        thus ?thesis
          using b_e_typing.intros(14,35) tm_def
          by auto
      qed
    next
      (* TODO: refactor *)
      case (Type x2)
      hence x2_cond:"(length x2 \<ge> 3 \<and> (x2!(length x2-2)) = (x2!(length x2-3)))"
        using 16
        by (simp, meson)
      hence tm'_def:"consume (Type x2) [TAny, TSome T_i32] = tm'"
        using 16 Type
        by simp
      obtain ts' ts'' where cts_def:"x2 = ts'@ ts''" "length ts'' = 3"
        using x2_cond
        by (metis append_take_drop_id diff_diff_cancel length_drop)
      then obtain t1 ts''2 where "ts'' = t1#ts''2" "length ts''2 = Suc (Suc 0)"
        using List.length_Suc_conv[of ts' "Suc (Suc 0)"]
        by (metis length_Suc_conv numeral_3_eq_3)
      then obtain t2 t3 where "ts'' = [t1,t2,t3]"
        using List.length_Suc_conv[of ts''2 "Suc 0"]
        by (metis length_0_conv length_Suc_conv)
      hence cts_def2:"x2 = ts'@ [t1,t2,t3]"
        using cts_def
        by simp
      have ts'_suffix:"ct_suffix [TAny, TSome T_i32] (to_ct_list (ts' @ [t1, t2, t3]))"
        using tm'_def 16(4)
        by (simp, metis cts_def2)
      hence tm'_def:"tm' = Type (ts'@[t1])"
        using tm'_def 16(4) cts_def2
        by simp
      obtain as bs where "(to_ct_list (ts' @ [t1])) @ (to_ct_list ([t2, t3])) = as@bs"
                         "ct_list_eq bs [TAny, TSome T_i32]"
        using ts'_suffix
        unfolding ct_suffix_def to_ct_list_def
        by fastforce
      hence "t3 = T_i32"
        unfolding to_ct_list_def ct_list_eq_def
        by (metis (no_types, lifting) Nil_is_map_conv append_eq_append_conv ct_eq.simps(1)
                  length_Cons list.sel(1,3) list.simps(9) list_all2_Cons2 list_all2_lengthD)
      moreover
      have "t1 = t2"
        using x2_cond cts_def2
        by (simp, metis append.left_neutral append_Cons append_assoc length_append_singleton
                        nth_append_length)
      ultimately
      have "c_types_agree (Type x2) ((ts'@[t1,t1])@[T_i32])"
        using cts_def2
        by simp
      thus ?thesis
        using b_e_typing.intros(14,35) Type tm'_def 16(2)
        by fastforce
    qed simp
  next
    case (17 \<C> tn'' tm'' es ts)
    hence "type_update ts (to_ct_list tn'') (Type tm'') = tm'"
      by auto
    moreover
    have "(b_e_type_checker (\<C>\<lparr>label := ([tm''] @ (label \<C>))\<rparr>) es (tn'' _> tm''))"
      using 17
      by (simp, meson)
    hence "\<C> \<turnstile> [Block (tn'' _> tm'') es] : (tn'' _> tm'')"
      using b_e_typing.intros(15)[OF _ 17(1)]
      by blast
    ultimately
    show ?case
      using b_e_check_single_type_not_bot_sound[OF _ 17(4,5,3)]
      by blast
  next
    case (18 \<C> tn'' tm'' es ts)
    hence "type_update ts (to_ct_list tn'') (Type tm'') = tm'"
      by auto
    moreover
    have "(b_e_type_checker (\<C>\<lparr>label := ([tn''] @ (label \<C>))\<rparr>) es (tn'' _> tm''))"
      using 18
      by (simp, meson)
    hence "\<C> \<turnstile> [Loop (tn'' _> tm'') es] : (tn'' _> tm'')"
      using b_e_typing.intros(16)[OF _ 18(1)]
      by blast
    ultimately
    show ?case
      using b_e_check_single_type_not_bot_sound[OF _ 18(4,5,3)]
      by blast
  next
    case (19 \<C> tn'' tm'' es1 es2 ts)
    hence "type_update ts (to_ct_list (tn''@[T_i32])) (Type tm'') = tm'"
      by auto
    moreover
    have "(b_e_type_checker (\<C>\<lparr>label := ([tm''] @ (label \<C>))\<rparr>) es1 (tn'' _> tm''))"
         "(b_e_type_checker (\<C>\<lparr>label := ([tm''] @ (label \<C>))\<rparr>) es2 (tn'' _> tm''))"
      using 19
      by (simp, meson)+
    hence "\<C> \<turnstile> [If (tn'' _> tm'') es1 es2] : (tn''@[T_i32] _> tm'')"
      using b_e_typing.intros(17)[OF _ 19(1,2)]
      by blast
    ultimately
    show ?case
      using b_e_check_single_type_not_bot_sound[OF _ 19(5,6,4)]
      by blast
  next
    case (20 \<C> i ts)
    hence "type_update ts (to_ct_list ((label \<C>)!i)) (TopType []) = tm'"
      by auto
    moreover
    have "i < length (label \<C>)"
      using 20
      by (simp, meson)
    ultimately
    show ?case
      using b_e_check_single_top_not_bot_sound[OF _ 20(3,4)]
            b_e_typing.intros(18)
            b_e_typing.intros(35)
      by (metis suffix_def)
  next
    case (21 \<C> i ts)
    hence "type_update ts (to_ct_list ((label \<C>)!i @ [T_i32])) (Type ((label \<C>)!i)) = tm'"
      by auto
    moreover
    have "i < length (label \<C>)"
      using 21
      by (simp, meson)
    hence "\<C> \<turnstile> [Br_if i] : ((label \<C>)!i @ [T_i32] _> (label \<C>)!i)"
      using b_e_typing.intros(19)
      by fastforce
    ultimately
    show ?case
      using b_e_check_single_type_not_bot_sound[OF _ 21(3,4,2)]
      by fastforce
  next
    case (22 \<C> "is" i ts)
    then obtain tls where tls_def:"(same_lab (is@[i]) (label \<C>)) = Some tls"
      by fastforce
    hence "type_update ts (to_ct_list (tls @ [T_i32])) (TopType []) = tm'"
      using 22
      by simp
    thus ?case
      using b_e_check_single_top_not_bot_sound[OF _ 22(3,4)]
            b_e_typing.intros(20)[OF same_lab_conv_list_all[OF tls_def]]
            b_e_typing.intros(35)
      by (metis suffix_def)
  next
    case (23 \<C> ts)
    then obtain ts_r where "(return \<C>) = Some ts_r"
      by fastforce
    moreover
    hence "type_update ts (to_ct_list ts_r) (TopType []) = tm'"
      using 23
      by simp
    ultimately
    show ?case
      using b_e_check_single_top_not_bot_sound[OF _ 23(3,4)]
            b_e_typing.intros(21,35)
      by (metis suffix_def)
  next
    case (24 \<C> i ts)
    obtain tn'' tm'' where func_def:"(func_t \<C>)!i = (tn'' _> tm'')"
      using tf.exhaust
      by blast
    hence "type_update ts (to_ct_list tn'') (Type tm'') = tm'"
      using 24
      by auto
    moreover
    have "i < length (func_t \<C>)"
      using 24
      by (simp, meson)
    hence "\<C> \<turnstile> [Call i] : (tn'' _> tm'')"
      using b_e_typing.intros(22) func_def
      by fastforce
    ultimately
    show ?case
      using b_e_check_single_type_not_bot_sound[OF _ 24(3,4,2)]
      by fastforce
  next
    case (25 \<C> i ts)
    obtain tn'' tm'' where type_def:"(types_t \<C>)!i = (tn'' _> tm'')"
      using tf.exhaust
      by blast
    hence "type_update ts (to_ct_list (tn''@[T_i32])) (Type tm'') = tm'"
      using 25
      by auto
    moreover
    have "(table \<C>) \<noteq> None \<and> i < length (types_t \<C>)"
      using 25
      by (simp, meson)
    hence "\<C> \<turnstile> [Call_indirect i] : (tn''@[T_i32] _> tm'')"
      using b_e_typing.intros(23) type_def
      by fastforce
    ultimately
    show ?case
      using b_e_check_single_type_not_bot_sound[OF _ 25(3,4,2)]
      by fastforce
  next
    case (26 \<C> i ts)
    hence "type_update ts [] (Type [(local \<C>)!i]) = tm'"
      by auto
    moreover
    have "i < length (local \<C>)"
      using 26
      by (simp, meson)
    hence "\<C> \<turnstile> [Get_local i] : ([] _> [(local \<C>)!i])"
      using b_e_typing.intros(24)
      by fastforce
    ultimately
    show ?case
      using b_e_check_single_type_not_bot_sound[OF _ 26(3,4,2)]
      unfolding to_ct_list_def
      by (metis list.map_disc_iff)
  next
    case (27 \<C> i ts)
    hence "type_update ts (to_ct_list [(local \<C>)!i]) (Type []) = tm'"
      unfolding to_ct_list_def
      by auto
    moreover
    have "i < length (local \<C>)"
      using 27
      by (simp, meson)
    hence "\<C> \<turnstile> [Set_local i] : ([(local \<C>)!i] _> [])"
      using b_e_typing.intros(25)
      by fastforce
    ultimately
    show ?case
      using b_e_check_single_type_not_bot_sound[OF _ 27(3,4,2)]
      by fastforce
  next
    case (28 \<C> i ts)
    hence "type_update ts (to_ct_list [(local \<C>)!i]) (Type [(local \<C>)!i]) = tm'"
      unfolding to_ct_list_def
      by auto
    moreover
    have "i < length (local \<C>)"
      using 28
      by (simp, meson)
    hence "\<C> \<turnstile> [Tee_local i] : ([(local \<C>)!i] _> [(local \<C>)!i])"
      using b_e_typing.intros(26)
      by fastforce
    ultimately
    show ?case
      using b_e_check_single_type_not_bot_sound[OF _ 28(3,4,2)]
      by fastforce
  next
    case (29 \<C> i ts)
    hence "type_update ts [] (Type [tg_t ((global \<C>)!i)]) = tm'"
      by auto
    moreover
    have "i < length (global \<C>)"
      using 29
      by (simp, meson)
    hence "\<C> \<turnstile> [Get_global i] : ([] _> [tg_t ((global \<C>)!i)])"
      using b_e_typing.intros(27)
      by fastforce
    ultimately
    show ?case
      using b_e_check_single_type_not_bot_sound[OF _ 29(3,4,2)]
      unfolding to_ct_list_def
      by (metis list.map_disc_iff)
  next
    case (30 \<C> i ts)
    hence "type_update ts (to_ct_list [tg_t ((global \<C>)!i)]) (Type []) = tm'"
      unfolding to_ct_list_def
      by auto
    moreover
    have "i < length (global \<C>) \<and> is_mut (global \<C> ! i)"
      using 30
      by (simp, meson)
    then obtain t where "(global \<C> ! i) = \<lparr>tg_mut = T_mut, tg_t = t\<rparr>" "i < length (global \<C>)"
      unfolding is_mut_def
      by (cases "global \<C> ! i", auto)
    hence "\<C> \<turnstile> [Set_global i] : ([tg_t (global \<C> ! i)] _> [])"
      using b_e_typing.intros(28)[of i \<C> "tg_t (global \<C> ! i)"]
      unfolding is_mut_def tg_t_def
      by fastforce
    ultimately
    show ?case
      using b_e_check_single_type_not_bot_sound[OF _ 30(3,4,2)]
      by fastforce
  next
    case (31 \<C> t tp_sx a off ts)
    hence "type_update ts (to_ct_list [T_i32]) (Type [t]) = tm'"
      unfolding to_ct_list_def
      by auto
    moreover
    have "(memory \<C>) \<noteq> None \<and> load_store_t_bounds a (option_projl tp_sx) t"
      using 31
      by (simp, meson)
    hence "\<C> \<turnstile> [Load t tp_sx a off] : ([T_i32] _> [t])"
      using b_e_typing.intros(29)
      by fastforce
    ultimately
    show ?case
      using b_e_check_single_type_not_bot_sound[OF _ 31(3,4,2)]
      by fastforce
  next
    case (32 \<C> t tp a off ts)
    hence "type_update ts (to_ct_list [T_i32,t]) (Type []) = tm'"
      unfolding to_ct_list_def
      by auto
    moreover
    have "(memory \<C>) \<noteq> None \<and> load_store_t_bounds a tp t"
      using 32
      by (simp, meson)
    hence "\<C> \<turnstile> [Store t tp a off] : ([T_i32,t] _> [])"
      using b_e_typing.intros(30)
      by fastforce
    ultimately
    show ?case
      using b_e_check_single_type_not_bot_sound[OF _ 32(3,4,2)]
      by fastforce
  next
    case (33 \<C> ts)
    hence "type_update ts [] (Type [T_i32]) = tm'"
      by auto
    moreover
    have "memory \<C> \<noteq> None"
      using 33
      by (simp, meson)
    hence "\<C> \<turnstile> [Current_memory] : ([] _> [T_i32])"
      using b_e_typing.intros(31)
      by fastforce
    ultimately
    show ?case
      using b_e_check_single_type_not_bot_sound[OF _ 33(3,4,2)]
      unfolding to_ct_list_def
      by (metis list.map_disc_iff)
  next
    case (34 \<C> ts)
    hence "type_update ts (to_ct_list [T_i32]) (Type [T_i32]) = tm'"
      unfolding to_ct_list_def
      by auto
    moreover
    have "memory \<C> \<noteq> None"
      using 34
      by (simp, meson)
    hence "\<C> \<turnstile> [Grow_memory] : ([T_i32] _> [T_i32])"
      using b_e_typing.intros(32)
      by fastforce
    ultimately
    show ?case
      using b_e_check_single_type_not_bot_sound[OF _ 34(3,4,2)]
      by fastforce
  qed
  thus ?thesis
    using assms
    by simp
qed

subsection \<open>Completeness\<close>

lemma check_single_imp:
  assumes "check_single \<C> e ctn = ctm"
          "ctm \<noteq> Bot"
  shows "check_single \<C> e = id
         \<or> check_single \<C> e = (\<lambda>ctn. type_update_select ctn)
         \<or> (\<exists>cons prods. (check_single \<C> e = (\<lambda>ctn. type_update ctn cons prods)))"
proof -
  have True
  and True
  and "check_single \<C> e ctn = ctm \<Longrightarrow>
       ctm \<noteq> Bot \<Longrightarrow>
         ?thesis"
  proof (induction rule: b_e_type_checker_check_check_single.induct)
    case (1 \<C> es tn tm)
    thus ?case
      by simp
  next
    case (2 \<C> es ts)
    thus ?case
      by simp
  next
    case (3 \<C> v ts)
    thus ?case
      by fastforce
  next
    case (4 \<C> t uu ts)
    thus ?case
      by (simp, meson assms(2) type_update.simps)
  next
    case (5 \<C> t uv ts)
    thus ?case
      by (simp, meson assms(2) type_update.simps)
  next
    case (6 \<C> t uw ts)
    thus ?case
      by (simp, meson assms(2) type_update.simps)
  next
    case (7 \<C> t ux ts)
    thus ?case
      by (simp, meson assms(2) type_update.simps)
  next
    case (8 \<C> t uy ts)
    thus ?case
      by (simp, meson assms(2) type_update.simps)
  next
    case (9 \<C> t uz ts)
    thus ?case
      by (simp, meson assms(2) type_update.simps)
  next
    case (10 \<C> t va ts)
    thus ?case
      by (simp, meson assms(2) type_update.simps)
  next
    case (11 \<C> t1 t2 sx ts)
    thus ?case
      by (simp del: convert_cond.simps, meson assms(2) type_update.simps)
  next
    case (12 \<C> t1 t2 sx ts)
    thus ?case
      by (simp, meson assms(2) type_update.simps)
  next
    case (13 \<C> ts)
    thus ?case
      by fastforce
  next
    case (14 \<C> ts)
    thus ?case
      by fastforce
  next
    case (15 \<C> ts)
    thus ?case
      by fastforce
  next
    case (16 \<C> ts)
    thus ?case
      by fastforce
  next
    case (17 \<C> tn tm es ts)
    thus ?case
      by (simp, meson assms(2) type_update.simps)
  next
    case (18 \<C> tn tm es ts)
    thus ?case
      by (simp, meson assms(2) type_update.simps)
  next
    case (19 \<C> tn tm es1 es2 ts)
    thus ?case
      by (simp, meson assms(2) type_update.simps)
  next
    case (20 \<C> i ts)
    thus ?case
      by (simp, meson assms(2) type_update.simps)
  next
    case (21 \<C> i ts)
    thus ?case
      by (simp, meson assms(2) type_update.simps)
  next
    case (22 \<C> "is" ts)
    thus ?case
      by (simp, metis assms(2) option.case_eq_if type_update.simps)
  next
    case (23 \<C> ts)
    thus ?case
      by (simp, metis assms(2) option.case_eq_if type_update.simps)
  next
    case (24 \<C> i ts)
    then show ?case
      by (simp, metis (no_types, lifting) assms(2) tf.case tf.exhaust type_update.simps)
  next
    case (25 \<C> i ts)
    thus ?case
      by (simp, metis (no_types, lifting) assms(2) tf.case tf.exhaust type_update.simps)
  next
    case (26 \<C> i ts)
    thus ?case
      by (simp, meson assms(2) type_update.simps)
  next
    case (27 \<C> i ts)
    thus ?case
      by (simp, meson assms(2) type_update.simps)
  next
    case (28 \<C> i ts)
    thus ?case
      by (simp, meson assms(2) type_update.simps)
  next
    case (29 \<C> i ts)
    thus ?case
      by (simp, meson assms(2) type_update.simps)
  next
    case (30 \<C> i ts)
    thus ?case
      by (simp, meson assms(2) type_update.simps)
  next
    case (31 \<C> t tp_sx a off ts)
    thus ?case
      by (simp, meson assms(2) type_update.simps)
  next
    case (32 \<C> t tp a off ts)
    thus ?case
      by (simp, meson assms(2) type_update.simps)
  next
    case (33 \<C> ts)
    thus ?case
      by (simp, meson assms(2) type_update.simps)
  next
    case (34 \<C> ts)
    thus ?case
      by (simp, meson assms(2) type_update.simps)
  qed
  thus ?thesis
    using assms
    by simp
qed

lemma check_equiv_fold:
  "check \<C> es ts = foldl (\<lambda> ts e. (case ts of Bot \<Rightarrow> Bot | _ \<Rightarrow> check_single \<C> e ts)) ts es"
proof (induction es arbitrary: ts)
  case Nil
  thus ?case
    by simp
next
  case (Cons e es)
  obtain ts' where ts'_def:"check \<C> (e # es) ts = ts'"
    by blast
  show ?case
  proof (cases "ts = Bot")
    case True
    thus ?thesis
      using ts'_def
      by (induction es, simp_all)
  next
    case False
    thus ?thesis
      using ts'_def Cons
      by (cases ts, simp_all)
  qed
qed

lemma check_neq_bot_snoc:
  assumes "check \<C> (es@[e]) ts \<noteq> Bot"
  shows "check \<C> es ts \<noteq> Bot"
  using assms
proof (induction es arbitrary: ts)
  case Nil
  thus ?case
    by (cases ts, simp_all)
next
  case (Cons a es)
  thus ?case
    by (cases ts, simp_all)
qed

lemma check_unfold_snoc:
  assumes "check \<C> es ts \<noteq> Bot"
  shows "check \<C> (es@[e]) ts = check_single \<C> e (check \<C> es ts)"
proof -
  obtain f where f_def:"f = (\<lambda> e ts. (case ts of Bot \<Rightarrow> Bot | _ \<Rightarrow> check_single \<C> e ts))"
    by blast
  have f_simp:"\<And>ts. ts \<noteq> Bot \<Longrightarrow> (f e ts = check_single \<C> e ts)"
  proof -
    fix ts
    show "ts \<noteq> Bot \<Longrightarrow> (f e ts = check_single \<C> e ts)"
      using f_def
      by (cases ts, simp_all)
  qed
  have "check \<C> (es@[e]) ts = foldl (\<lambda> ts e. (case ts of Bot \<Rightarrow> Bot | _ \<Rightarrow> check_single \<C> e ts)) ts (es@[e])"
    using check_equiv_fold
    by simp
  also
  have "... = foldr (\<lambda> e ts. (case ts of Bot \<Rightarrow> Bot | _ \<Rightarrow> check_single \<C> e ts)) (rev (es@[e])) ts"
    using foldl_conv_foldr
    by fastforce
  also
  have "... = f e (foldr (\<lambda> e ts. (case ts of Bot \<Rightarrow> Bot | _ \<Rightarrow> check_single \<C> e ts)) (rev es) ts)"
    using f_def
    by simp
  also
  have "... = f e (check \<C> es ts)"
    using foldr_conv_foldl[of _ "(rev es)" ts] rev_rev_ident[of es] check_equiv_fold
    by simp
  also
  have "... = check_single \<C> e (check \<C> es ts)"
    using assms f_simp
    by simp
  finally
  show ?thesis .
qed

lemma check_single_imp_weakening:
  assumes "check_single \<C> e (Type t1s) = ctm"
          "ctm \<noteq> Bot"
          "c_types_agree ctn t1s"
          "c_types_agree ctm t2s"
  shows "\<exists>ctm'. check_single \<C> e ctn = ctm' \<and> c_types_agree ctm' t2s"
proof -
  consider (1) "check_single \<C> e = id"
         | (2) "check_single \<C> e = (\<lambda>ctn. type_update_select ctn)"
         | (3) "(\<exists>cons prods. (check_single \<C> e = (\<lambda>ctn. type_update ctn cons prods)))"
    using check_single_imp assms
    by blast
  thus ?thesis
  proof (cases)
    case 1
    thus ?thesis
      using assms(1,3,4)
      by fastforce
  next
    (* TODO: better proof *)
    case 2
    note outer_2 = 2
    hence t1s_cond:"(length t1s \<ge> 3 \<and> (t1s!(length t1s-2)) = (t1s!(length t1s-3)))"
      using assms(1,2)
      by (simp, meson)
    hence ctm_def:"ctm = consume (Type t1s) [TAny, TSome T_i32]"
      using assms(1,2) 2
      by simp
    then obtain c_t where c_t_def:"ctm = Type c_t"
      using assms(2)
      by (meson consume.simps(1))
    hence t2s_eq:"t2s = c_t"
      using assms(4)
      by simp
    hence t2s_len:"length t2s > 0"
      using t1s_cond ctm_def c_t_def assms(2)
      by (metis Suc_leI Suc_n_not_le_n checker_type.inject(2) consume.simps(1)
                diff_is_0_eq dual_order.trans length_0_conv length_Cons length_greater_0_conv
                nat.simps(3) numeral_3_eq_3 take_eq_Nil)
    have t1s_suffix_full:"ct_suffix [TAny, TSome T_i32] (to_ct_list t1s)"
      using assms(2) ctm_def ct_suffix_less
      by (metis consume.simps(1))
    hence t1s_suffix:"ct_suffix [TSome T_i32] (to_ct_list t1s)"
      using assms(2) ctm_def ct_suffix_less
      by (metis append_butlast_last_id last.simps list.distinct(1))
    obtain t t1s' where t1s_suffix2:"t1s = t1s'@[t,t,T_i32]"
      using type_update_select_type_length3 assms(1) c_t_def outer_2
      by fastforce
    hence t2s_def:"t2s = t1s'@[t]"
      using ctm_def c_t_def t2s_eq t1s_suffix assms(2) t1s_suffix_full
      by simp
    show ?thesis
      using assms(1,3,4)
    proof (cases ctn)
      case (TopType x1)
      consider
          (1) "length x1 = 0"
        | (2) "length x1 = 1"
        | (3) "length x1 = 2"
        | (4) "length x1 \<ge> 3"
        by linarith
      thus ?thesis
      proof (cases)
        case 1
        hence "check_single \<C> e ctn = TopType [TAny]"
          using 2 TopType
          by simp
        thus ?thesis
          using ct_suffix_singleton to_ct_list_def t2s_len
          by auto
      next
        case 2
        hence "ct_suffix [TSome T_i32] x1"
          using assms(3) TopType ct_suffix_imp_ct_list_eq ct_suffix_shared t1s_suffix
          by (metis One_nat_def append_Nil c_types_agree.simps(2) ct_list_eq_commute ct_suffix_def
                    diff_self_eq_0 drop_0 length_Cons list.size(3))
        hence "check_single \<C> e ctn = TopType [TAny]"
          using outer_2 TopType 2
          by simp
        thus ?thesis
          using t2s_len ct_suffix_singleton
          by (simp add: to_ct_list_def)
      next
        case 3
        have "ct_list_eq (to_ct_list t1s) (to_ct_list (t1s' @ [t, t, T_i32]))"
          using t1s_suffix2
          by (simp add: ct_list_eq_ts_conv_eq)
        hence temp1:"to_ct_list t1s = (to_ct_list (t1s' @ [t])) @ (to_ct_list [t, T_i32])"
          using t1s_suffix2 to_ct_list_def
          by simp
        hence "ct_suffix (to_ct_list [t, T_i32]) (to_ct_list t1s)"
          using ct_suffix_def[of "(to_ct_list [t, T_i32])" "(to_ct_list t1s)"]
          by (simp add: ct_suffix_cons_it)
        hence "ct_suffix (to_ct_list [t, T_i32]) x1"
          using assms(3) TopType 3
          by (simp, metis temp1 append_Nil ct_suffix_cons2 ct_suffix_def length_Cons length_map
                          list.size(3) numeral_2_eq_2 to_ct_list_def)
        hence temp3:"ct_list_eq (to_ct_list [t, T_i32]) x1"
          using 3 ct_suffix_imp_ct_list_eq
          unfolding to_ct_list_def
          by (metis Suc_leI ct_list_eq_commute diff_is_0_eq drop_0 length_Cons length_map lessI
                    list.size(3) numeral_2_eq_2)
        hence temp4:"ct_suffix [TSome T_i32] x1"
          using ct_suffix_less[of "[TSome t]" "[TSome T_i32]" x1]
                ct_suffix_extend_ct_list_eq[of "[]" "[]"] ct_suffix_nil
          unfolding to_ct_list_def
          by fastforce
        hence "ct_suffix (take 1 x1) (to_ct_list [t])"
          using temp3 ct_suffix_nil ct_list_eq_commute ct_suffix_extend_ct_list_eq[of "[]" "[]" "(take 1 x1)" "(to_ct_list [t])"]
          unfolding to_ct_list_def
          by (simp, metis butlast.simps(2) butlast_conv_take ct_list_eq_take diff_Suc_1 length_Cons
                          list.distinct(1) list.size(3))
        thus ?thesis
          using TopType 2 3 ct_suffix_nil temp3 temp4 t2s_def to_ct_list_def
          apply (simp, safe)
          apply (metis append.assoc ct_suffix_def)
          done
      next
        case 4
        then obtain nat where nat_def:"length x1 = Suc (Suc (Suc nat))"
          by (metis add_eq_if diff_Suc_1 le_Suc_ex numeral_3_eq_3 nat.distinct(2))
        obtain x1' x x' x'' where x1_split:"x1 = x1'@[x,x',x'']"
        proof -
          assume local_assms:"(\<And>x1' x x' x''. x1 = x1' @ [x, x', x''] \<Longrightarrow> thesis)"
          obtain x1' x1'' where tn_split:"x1 = x1'@x1''"
                               "length x1'' = 3"
            using 4
            by (metis append_take_drop_id diff_diff_cancel length_drop)
          then obtain x x1''2 where "x1'' = x#x1''2" "length x1''2 = Suc (Suc 0)"
            by (metis length_Suc_conv numeral_3_eq_3)
          then obtain x' x'' where tn''_def:"x1''= [x,x',x'']"
            using List.length_Suc_conv[of x1''2 "Suc 0"]
            by (metis length_0_conv length_Suc_conv)
          thus ?thesis
            using tn_split local_assms
            by simp
        qed
        hence a:"ct_suffix (x1'@[x,x',x'']) (to_ct_list (t1s' @ [t, t, T_i32]))"
          using t1s_suffix2 assms(3) TopType
          by simp
        hence b:"ct_suffix (x1'@[x,x']) (to_ct_list (t1s' @ [t, t])) \<and> (ct_eq x'' (TSome T_i32))"
          using to_ct_list_def ct_suffix_unfold_one[of "(x1'@[x,x'])" "x''" "to_ct_list (t1s' @ [t, t])"]
          by fastforce
        hence c:"ct_suffix (x1'@[x]) (to_ct_list (t1s' @ [t])) \<and> (ct_eq x' (TSome t))"
          using to_ct_list_def ct_suffix_unfold_one[of "(x1'@[x])" "x'" "to_ct_list (t1s' @ [t])"]
          by fastforce
        hence d:"ct_suffix x1' (to_ct_list t1s') \<and> (ct_eq x (TSome t))"
          using to_ct_list_def ct_suffix_unfold_one[of "(x1')" "x" "to_ct_list (t1s')"]
          by fastforce
        have "(take (length x1 - 3) x1) = x1'"
          using x1_split
          by simp
        have x'_ind:"(x1!(length x1-2)) = x'"
          using x1_split List.nth_append_length[of "x1' @ [x]"]
          by simp
        have x_ind:"(x1!(length x1-3)) = x"
          using x1_split
          by simp
        have "ct_suffix [TSome T_i32] x1"
          using b x1_split ct_suffix_def ct_list_eq_def ct_suffixI[of x1 "x1' @ [x, x']"]
          by simp
        hence "check_single \<C> e (TopType x1) = (select_return_top x1 (x1!(length x1-2)) (x1!(length x1-3)))"
          using type_update_select_conv_select_return_top[OF _ 4]
          unfolding 2
          by blast
        moreover
        have "... = (TopType (x1'@[x])) \<or> ... = (TopType (x1'@[x']))"
          apply (cases x; cases x')
          using x1_split 4 nat_def 2 x_ind x'_ind c d
          by simp_all
        moreover
        have "ct_suffix (x1'@[x]) (to_ct_list t2s)"
          by (simp add: c t2s_def)
        moreover
        have "ct_suffix (x1'@[x']) (to_ct_list t2s)"
          using ct_suffix_unfold_one[symmetric, of x' "(TSome t)" x1' "(to_ct_list t1s')"] c d
                t2s_def
          unfolding to_ct_list_def
          by fastforce
        ultimately
        show ?thesis
          using TopType
          by auto
      qed
    qed simp_all
  next
    case 3
    then obtain cons prods where c_s_def:"check_single \<C> e = (\<lambda>ctn. type_update ctn cons prods)"
      by blast
    hence ctm_def:"ctm = type_update (Type t1s) cons prods"
      using assms(1)
      by fastforce
    hence cons_suffix:"ct_suffix cons (to_ct_list t1s)"
      using assms
      by (simp, metis (full_types) produce.simps(6))
    hence t_int_def:"consume (Type t1s) cons = (Type (take (length t1s - length cons) t1s))"
      using ctm_def
      by simp
    hence ctm_def2:"ctm = produce (Type (take (length t1s - length cons) t1s)) prods"
      using ctm_def
      by simp
    show ?thesis
    proof (cases ctn)
      case (TopType x1)
      hence "ct_suffix x1 (to_ct_list t1s)"
        using assms(3)
        by simp
      thus ?thesis
        using assms(2) ctm_def2
      proof (cases prods)
        case (TopType x1)
        thus ?thesis
          using consume_c_types_agree[OF t_int_def assms(3)] ctm_def2 assms(4) c_s_def
          by (metis c_types_agree.elims(2) produce.simps(3,4) type_update.simps)
      next
        case (Type x2)
        hence ctm_def3:"ctm = Type ((take (length t1s - length cons) t1s)@ x2)"
          using ctm_def2
          by simp
        have "ct_suffix x1 cons \<or> ct_suffix cons x1"
          using ct_suffix_shared assms(3) TopType cons_suffix
          by auto
        thus ?thesis
        proof (rule disjE)
          assume "ct_suffix x1 cons"
          hence "consume (TopType x1) cons = TopType []"
            by (simp add: ct_suffix_length)
          hence "check_single \<C> e ctn = TopType (to_ct_list x2)"
            using c_s_def TopType Type
            by simp
          thus ?thesis
            using TopType ctm_def3 assms(4) c_types_agree_top2 ct_list_eq_refl
            by auto
        next
          assume "ct_suffix cons x1"
          hence 4:"consume (TopType x1) cons = TopType (take (length x1 - length cons ) x1)"
            by (simp add: ct_suffix_length)
          hence 3:"check_single \<C> e ctn = TopType ((take (length x1 - length cons ) x1) @ to_ct_list x2)"
            using c_s_def TopType Type
            by simp
          have "((take (length t1s - length cons ) t1s) @  x2) = t2s"
            using assms(4) ctm_def3
            by simp
          have "c_types_agree (TopType (take (length x1 - length cons ) x1)) (take (length t1s - length cons) t1s)"
            using consume_c_types_agree[OF t_int_def assms(3)] 4 TopType
            by simp
          hence "c_types_agree (TopType (take (length x1 - length cons ) x1 @ to_ct_list x2)) (take (length t1s - length cons) t1s @ x2)"
            unfolding c_types_agree.simps to_ct_list_def
            by (simp add: ct_suffix_cons2 ct_suffix_cons_it ct_suffix_extend_ct_list_eq)
          thus ?thesis
            using ctm_def3 assms 3
            by simp
        qed
      qed simp
    next
      case (Type x2)
      thus ?thesis
        using assms
        by simp
    next
      case Bot
      thus ?thesis
        using assms
        by simp
    qed
  qed
qed

lemma b_e_type_checker_compose:
  assumes "b_e_type_checker \<C> es (t1s _> t2s)"
          "b_e_type_checker \<C> [e] (t2s _> t3s)"
  shows "b_e_type_checker \<C> (es @ [e]) (t1s _> t3s)"
proof -
  have "c_types_agree (check_single \<C> e (Type t2s)) t3s"
    using assms(2)
    by simp
  then obtain ctm where ctm_def:"check_single \<C> e (Type t2s) = ctm"
                                "c_types_agree ctm t3s"
                                "ctm \<noteq> Bot"
    by fastforce
  have "c_types_agree (check \<C> es (Type t1s)) t2s"
    using assms(1)
    by simp
  then obtain ctn where ctn_def:"check \<C> es (Type t1s) = ctn"
                                "c_types_agree ctn t2s"
                                "ctn \<noteq> Bot"
    by fastforce
  thus ?thesis
    using check_single_imp_weakening[OF ctm_def(1,3) ctn_def(2) ctm_def(2)]
          check_unfold_snoc[of \<C> es "(Type t1s)" e]
    by simp
qed

lemma b_e_check_single_type_type:
  assumes "check_single \<C> e xs = (Type tm)"
  shows "\<exists>tn. xs = (Type tn)"
proof -
  consider (1) "check_single \<C> e = id"
         | (2) "check_single \<C> e = (\<lambda>ctn. type_update_select ctn)"
         | (3) "(\<exists>cons prods. (check_single \<C> e = (\<lambda>ctn. type_update ctn cons prods)))"
    using check_single_imp assms
    by blast
  thus ?thesis
  proof (cases)
    case 1
    thus ?thesis
      using assms
      by simp
  next
    case 2
    note outer_2 = 2
    thus ?thesis
      using assms
    proof (cases xs)
      case (TopType x1)
      consider
          (1) "length x1 = 0"
        | (2) "length x1 = Suc 0"
        | (3) "length x1 = Suc (Suc 0)"
        | (4) "length x1 \<ge> 3"
        by linarith
      thus ?thesis
      proof cases
        case 1
        thus ?thesis
          using assms 2 TopType
          by simp
      next
        case 2
        thus ?thesis
          using assms outer_2 TopType produce_type_type
          by fastforce
      next
        case 3
        thus ?thesis
          using assms 2 TopType
          by (simp, metis checker_type.distinct(1) checker_type.distinct(5))
      next
        case 4
        then obtain nat where nat_def:"length x1 = Suc (Suc (Suc nat))"
          by (metis add_eq_if diff_Suc_1 le_Suc_ex numeral_3_eq_3 nat.distinct(2))
        thus ?thesis
          using assms 2 TopType
        proof -
          {
            assume a1: "produce (if ct_suffix [TAny, TAny, TSome T_i32] x1 then TopType (take (length x1 - length [TAny, TAny, TSome T_i32]) x1) else if ct_suffix x1 [TAny, TAny, TSome T_i32] then TopType [] else Bot) (select_return_top x1 (x1 ! Suc nat) (x1 ! nat)) = Type tm"
            obtain tts :: "checker_type \<Rightarrow> t list" where
              f2: "\<forall>c. (\<forall>ca ts. produce c ca \<noteq> Type ts) \<or> c = Type (tts c)"
              using produce_type_type by moura
            then have f3: "\<And>ts. \<not> ct_suffix [TAny, TAny, TSome T_i32] x1 \<or> Type tm \<noteq> Type ts"
              using a1 by fastforce
            then have "\<And>ts. \<not> ct_suffix x1 [TAny, TAny, TSome T_i32] \<or> Type tm \<noteq> Type ts"
              using f2 a1 by fastforce
            then have False
              using f3 a1 by fastforce
          }
          thus ?thesis
            using assms 2 TopType nat_def
            by simp
        qed
      qed
    qed simp_all
  next
    case 3
    then obtain cons prods where check_def:"check_single \<C> e = (\<lambda>ctn. type_update ctn cons prods)"
      by blast
    hence "produce (consume xs cons) prods = (Type tm)"
      using assms(1)
      by simp
    thus ?thesis
      using assms check_def consume_type_type produce_type_type
      by blast
  qed
qed

lemma b_e_check_single_weaken_type:
  assumes "check_single \<C> e (Type tn) = (Type tm)"
  shows "check_single \<C> e (Type (ts@tn)) = Type (ts@tm)"
proof -
  consider (1) "check_single \<C> e = id"
         | (2) "check_single \<C> e = (\<lambda>ctn. type_update_select ctn)"
         | (3) "(\<exists>cons prods. (check_single \<C> e = (\<lambda>ctn. type_update ctn cons prods)))"
    using check_single_imp assms
    by blast
  thus ?thesis
  proof (cases)
    case 1
    thus ?thesis
      using assms(1)
      by simp
  next
    case 2
    hence cond:"(length tn \<ge> 3 \<and> (tn!(length tn-2)) = (tn!(length tn-3)))"
      using assms
      by (simp, metis checker_type.distinct(5))
    hence "consume (Type tn) [TAny, TSome T_i32] = (Type tm)"
      using assms 2
      by simp
    hence "consume (Type (ts@tn)) [TAny, TSome T_i32] = (Type (ts@tm))"
      using consume_weaken_type
      by blast
    moreover
    have "(length (ts@tn) \<ge> 3 \<and> ((ts@tn)!(length (ts@tn)-2)) = ((ts@tn)!(length (ts@tn)-3)))"
      using cond
      by (simp, metis add.commute add_leE nth_append_length_plus numeral_Bit1 numeral_One
                      one_add_one ordered_cancel_comm_monoid_diff_class.diff_add_assoc2)
    ultimately
    show ?thesis
      using 2
      by simp
  next
    case 3
    then obtain cons prods where check_def:"check_single \<C> e = (\<lambda>ctn. type_update ctn cons prods)"
      by blast
    hence "produce (consume (Type tn) cons) prods = (Type tm)"
      using assms(1)
      by simp
    then obtain t_int where t_int_def:"consume (Type tn) cons = (Type t_int)"
      by (metis consume.simps(1) produce.simps(6))
    thus ?thesis
      using assms(1) check_def
            consume_weaken_type[OF t_int_def, of ts]
            produce_weaken_type[of t_int prods tm ts]
      by simp
  qed
qed

lemma b_e_check_single_weaken_top:
  assumes "check_single \<C> e (Type tn) = TopType tm"
  shows "check_single \<C> e (Type (ts@tn)) = TopType tm"
proof -
  consider (1) "check_single \<C> e = id"
         | (2) "check_single \<C> e = (\<lambda>ctn. type_update_select ctn)"
         | (3) "(\<exists>cons prods. (check_single \<C> e = (\<lambda>ctn. type_update ctn cons prods)))"
    using check_single_imp assms
    by blast
  thus ?thesis
  proof (cases)
    case 1
    thus ?thesis
      using assms
      by simp
  next
    case 2
    thus ?thesis
      using assms
      by (simp, metis checker_type.distinct(1) checker_type.distinct(3) consume.simps(1))
  next
    case 3
    then obtain cons prods where check_def:"check_single \<C> e = (\<lambda>ctn. type_update ctn cons prods)"
      by blast
    hence "produce (consume (Type tn) cons) prods = (TopType tm)"
      using assms(1)
      by simp
    moreover
    then obtain t_int where t_int_def:"consume (Type tn) cons = (Type t_int)"
      by (metis checker_type.distinct(3) consume.simps(1) produce.simps(6))
    ultimately
    show ?thesis
      using check_def consume_weaken_type
      by (cases prods, auto)
  qed
qed

lemma b_e_check_weaken_type:
  assumes "check \<C> es (Type tn) = (Type tm)"
  shows "check \<C> es (Type (ts@tn)) = (Type (ts@tm))"
  using assms
proof (induction es arbitrary: tn tm rule: List.rev_induct)
  case Nil
  thus ?case
    by simp
next
  case (snoc e es)
  hence "check_single \<C> e (check \<C> es (Type tn)) = Type tm"
    using check_unfold_snoc[OF check_neq_bot_snoc]
    by (metis checker_type.distinct(5))
  thus ?case
    using b_e_check_single_weaken_type b_e_check_single_type_type snoc
    by (metis check_unfold_snoc checker_type.distinct(5))
qed

lemma check_bot: "check \<C> es Bot = Bot"
  by (simp add: list.case_eq_if)

lemma b_e_check_weaken_top:
  assumes "check \<C> es (Type tn) = (TopType tm)"
  shows "check \<C> es (Type (ts@tn)) = (TopType tm)"
  using assms
proof (induction es arbitrary: tn tm)
  case Nil
  thus ?case
    by simp
next
  case (Cons e es)
  show ?case
  proof (cases "(check_single \<C> e (Type tn))")
    case (TopType x1)
    hence "check_single \<C> e (Type (ts@tn)) = TopType x1"
      using b_e_check_single_weaken_top
      by blast
    thus ?thesis
      using TopType Cons
      by simp
  next
    case (Type x2)
    hence "check_single \<C> e (Type (ts@tn)) = Type (ts@x2)"
      using b_e_check_single_weaken_type
      by blast
    thus ?thesis
      using Cons Type
      by fastforce
  next
    case Bot
    thus ?thesis
      using check_bot Cons
      by simp
  qed

qed

lemma b_e_type_checker_weaken:
  assumes "b_e_type_checker \<C> es (t1s _> t2s)"
  shows "b_e_type_checker \<C> es (ts@t1s _> ts@t2s)"
proof -
  have "c_types_agree (check \<C> es (Type t1s)) t2s"
    using assms(1)
    by simp
  then obtain ctn where ctn_def:"check \<C> es (Type t1s) = ctn"
                                "c_types_agree ctn t2s"
                                "ctn \<noteq> Bot"
    by fastforce
  show ?thesis
  proof (cases ctn)
    case (TopType x1)
    thus ?thesis
      using ctn_def(1,2) b_e_check_weaken_top[of \<C> es t1s x1 ts]
      by (metis append_assoc b_e_type_checker.simps c_types_agree_imp_ct_list_eq c_types_agree_top2)
  next
    case (Type x2)
    thus ?thesis
      using ctn_def(1,2) b_e_check_weaken_type[of \<C> es t1s x2 ts]
      by simp
  next
    case Bot
    thus ?thesis
      using ctn_def(3)
      by simp
  qed
qed

lemma b_e_type_checker_complete:
  assumes "\<C> \<turnstile> es : (tn _> tm)"
  shows "b_e_type_checker \<C> es (tn _> tm)"
  using assms
proof (induction es "(tn _> tm)" arbitrary: tn tm rule: b_e_typing.induct)
  case (select \<C> t)
  have "ct_list_eq [TAny, TSome T_i32] [TSome t, TSome T_i32]"
    by (simp add: to_ct_list_def ct_list_eq_def)
  thus ?case
    using ct_suffix_extend_ct_list_eq[OF ct_suffix_nil[of "[TSome t]"]] to_ct_list_def
    by auto
next
  case (br_table \<C> ts "is" i t1s t2s)
  show ?case
    using list_all_conv_same_lab[OF br_table]
    by (auto simp add: to_ct_list_def ct_suffix_nil ct_suffix_cons_it)
next
  case (set_global i \<C> t)
  thus ?case
    using to_ct_list_def ct_suffix_refl is_mut_def tg_t_def
    by auto
next
  case (composition \<C> es t1s t2s e t3s)
  thus ?case
    using b_e_type_checker_compose
    by simp
next
  case (weakening \<C> es t1s t2s ts)
  thus ?case
    using b_e_type_checker_weaken
    by simp
qed (auto simp add: to_ct_list_def ct_suffix_refl ct_suffix_nil ct_suffix_cons_it
                    ct_suffix_singleton_any)

theorem b_e_typing_equiv_b_e_type_checker:
  shows "(\<C> \<turnstile> es : (tn _> tm)) = (b_e_type_checker \<C> es (tn _> tm))"
  using b_e_type_checker_sound b_e_type_checker_complete
  by blast

end


theory CoCallFix
imports CoCallAnalysisSig CoCallAnalysisBinds ArityAnalysisSig "../Launchbury/Env-Nominal"  ArityAnalysisFix
begin

locale CoCallArityAnalysis =
  fixes cccExp :: "exp \<Rightarrow> (Arity \<rightarrow> AEnv \<times> CoCalls)"
begin

definition Aexp :: "exp \<Rightarrow> (Arity \<rightarrow> AEnv)"
  where "Aexp e = (\<Lambda> a. fst (cccExp e \<cdot> a))"

sublocale ArityAnalysis Aexp.

abbreviation Aexp_syn' ("\<A>\<^bsub>_\<^esub>") where "\<A>\<^bsub>a\<^esub> \<equiv> (\<lambda>e. Aexp e\<cdot>a)"
abbreviation Aexp_bot_syn' ("\<A>\<^sup>\<bottom>\<^bsub>_\<^esub>") where "\<A>\<^sup>\<bottom>\<^bsub>a\<^esub> \<equiv> (\<lambda>e. fup\<cdot>(Aexp e)\<cdot>a)"

lemma Aexp_eq:
  "\<A>\<^bsub>a\<^esub> e = fst (cccExp e \<cdot> a)"
  unfolding Aexp_def by (rule beta_cfun) (intro cont2cont)

lemma fup_Aexp_eq:
  "fup\<cdot>(Aexp e)\<cdot>a = fst (fup\<cdot>(cccExp e)\<cdot>a)"
  by (cases a)(simp_all add: Aexp_eq)

definition CCexp :: "exp \<Rightarrow> (Arity \<rightarrow> CoCalls)" where "CCexp \<Gamma> = (\<Lambda> a. snd (cccExp \<Gamma>\<cdot>a))"
lemma CCexp_eq:
  "CCexp e\<cdot>a = snd (cccExp e \<cdot> a)"
  unfolding CCexp_def by (rule beta_cfun) (intro cont2cont)

lemma fup_CCexp_eq:
  "fup\<cdot>(CCexp e)\<cdot>a = snd (fup\<cdot>(cccExp e)\<cdot>a)"
  by (cases a)(simp_all add: CCexp_eq)

sublocale CoCallAnalysis CCexp.

definition CCfix :: "heap \<Rightarrow> (AEnv \<times> CoCalls) \<rightarrow> CoCalls"
  where "CCfix \<Gamma> = (\<Lambda> aeG. (\<mu> G'. ccBindsExtra \<Gamma>\<cdot>(fst aeG , G') \<squnion> snd aeG))"

lemma CCfix_eq:
  "CCfix \<Gamma>\<cdot>(ae,G) = (\<mu> G'. ccBindsExtra \<Gamma>\<cdot>(ae, G') \<squnion> G)"
  unfolding CCfix_def
  by simp

lemma CCfix_unroll: "CCfix \<Gamma>\<cdot>(ae,G) = ccBindsExtra \<Gamma>\<cdot>(ae, CCfix \<Gamma>\<cdot>(ae,G)) \<squnion> G"
  unfolding  CCfix_eq
  apply (subst fix_eq)
  apply simp
  done

lemma fup_ccExp_restr_subst':
  assumes "\<And> a. cc_restr S (CCexp e[x::=y]\<cdot>a) = cc_restr S (CCexp e\<cdot>a)"
  shows "cc_restr S (fup\<cdot>(CCexp e[x::=y])\<cdot>a) = cc_restr S (fup\<cdot>(CCexp e)\<cdot>a)"
  using assms
  by (cases a) (auto simp del: cc_restr_cc_restr simp add: cc_restr_cc_restr[symmetric])

lemma ccBindsExtra_restr_subst':
  assumes "\<And> x' e a. (x',e) \<in> set \<Gamma> \<Longrightarrow> cc_restr S (CCexp e[x::=y]\<cdot>a) = cc_restr S (CCexp e\<cdot>a)"
  assumes "x \<notin> S"
  assumes "y \<notin> S"
  assumes "domA \<Gamma> \<subseteq> S"
  shows  "cc_restr S (ccBindsExtra  \<Gamma>[x::h=y]\<cdot>(ae, G))
       = cc_restr S (ccBindsExtra  \<Gamma>\<cdot>(ae f|` S , cc_restr S G))"
  apply (simp add: ccBindsExtra_simp ccBinds_eq ccBind_eq Int_absorb2[OF assms(4)] fv_subst_int[OF assms(3,2)])
  apply (intro arg_cong2[where f = "op \<squnion>"] refl  arg_cong[OF mapCollect_cong])
  apply (subgoal_tac "k \<in> S")
  apply (auto intro: fup_ccExp_restr_subst'[OF assms(1)[OF map_of_SomeD]] simp add: fv_subst_int[OF assms(3,2)]   fv_subst_int2[OF assms(3,2)] ccSquare_def)[1]
  apply (metis assms(4) contra_subsetD domI dom_map_of_conv_domA)
  apply (subgoal_tac "k \<in> S")
  apply (auto intro: fup_ccExp_restr_subst'[OF assms(1)[OF map_of_SomeD]]
              simp add: fv_subst_int[OF assms(3,2)]   fv_subst_int2[OF assms(3,2)] ccSquare_def cc_restr_twist[where S = S] simp del: cc_restr_cc_restr)[1]
  apply (subst fup_ccExp_restr_subst'[OF assms(1)[OF map_of_SomeD]], assumption)
  apply (simp add: fv_subst_int[OF assms(3,2)]   fv_subst_int2[OF assms(3,2)] )
  apply (subst fup_ccExp_restr_subst'[OF assms(1)[OF map_of_SomeD]], assumption)
  apply (simp add: fv_subst_int[OF assms(3,2)]   fv_subst_int2[OF assms(3,2)] )
  apply (metis assms(4) contra_subsetD domI dom_map_of_conv_domA)
  done

lemma ccBindsExtra_restr:
  assumes "domA \<Gamma> \<subseteq> S"
  shows "cc_restr S (ccBindsExtra \<Gamma>\<cdot>(ae, G)) = cc_restr S (ccBindsExtra \<Gamma>\<cdot>(ae f|` S, cc_restr S G))"
  using assms
  apply (simp add: ccBindsExtra_simp ccBinds_eq ccBind_eq Int_absorb2)
  apply (intro arg_cong2[where f = "op \<squnion>"] refl arg_cong[OF mapCollect_cong])
  apply (subgoal_tac "k \<in> S")
  apply simp
  apply (metis contra_subsetD domI dom_map_of_conv_domA)
  apply (subgoal_tac "k \<in> S")
  apply simp
  apply (metis contra_subsetD domI dom_map_of_conv_domA)
  done

lemma CCfix_restr:
  assumes "domA \<Gamma> \<subseteq> S"
  shows "cc_restr S (CCfix \<Gamma>\<cdot>(ae, G)) = cc_restr S (CCfix \<Gamma>\<cdot>(ae f|` S, cc_restr S G))"
  unfolding CCfix_def
  apply simp
  apply (rule parallel_fix_ind[where P = "\<lambda> x y . cc_restr S x = cc_restr S y"])
  apply simp
  apply rule
  apply simp
  apply (subst (1 2) ccBindsExtra_restr[OF assms])
  apply (auto)
  done

lemma ccField_CCfix:
  shows "ccField (CCfix \<Gamma>\<cdot>(ae, G)) \<subseteq> fv \<Gamma> \<union> ccField G"
  unfolding CCfix_def
  apply simp
  apply (rule fix_ind[where P = "\<lambda> x . ccField x \<subseteq> fv \<Gamma> \<union> ccField G"])
  apply (auto dest!: set_mp[OF ccField_ccBindsExtra])
  done

lemma CCfix_restr_subst':
  assumes "\<And> x' e a. (x',e) \<in> set \<Gamma> \<Longrightarrow> cc_restr S (CCexp e[x::=y]\<cdot>a) = cc_restr S (CCexp e\<cdot>a)"
  assumes "x \<notin> S"
  assumes "y \<notin> S"
  assumes "domA \<Gamma> \<subseteq> S"
  shows "cc_restr S (CCfix \<Gamma>[x::h=y]\<cdot>(ae, G)) = cc_restr S (CCfix \<Gamma>\<cdot>(ae f|` S, cc_restr S G))"
  unfolding CCfix_def
  apply simp
  apply (rule parallel_fix_ind[where P = "\<lambda> x y . cc_restr S x = cc_restr S y"])
  apply simp
  apply rule
  apply simp
  apply (subst  ccBindsExtra_restr_subst'[OF assms], assumption)
  apply (subst ccBindsExtra_restr[OF assms(4)]) back
  apply (auto)
  done

end

lemma Aexp_eqvt[eqvt]:  "\<pi> \<bullet> (CoCallArityAnalysis.Aexp cccExp e) = CoCallArityAnalysis.Aexp (\<pi> \<bullet> cccExp) (\<pi> \<bullet> e)"
  apply (rule cfun_eqvtI) unfolding CoCallArityAnalysis.Aexp_eq by perm_simp rule

lemma CCexp_eqvt[eqvt]:  "\<pi> \<bullet> (CoCallArityAnalysis.CCexp cccExp e) = CoCallArityAnalysis.CCexp (\<pi> \<bullet> cccExp) (\<pi> \<bullet> e)"
  apply (rule cfun_eqvtI) unfolding CoCallArityAnalysis.CCexp_eq by perm_simp rule

lemma CCfix_eqvt[eqvt]: "\<pi> \<bullet> (CoCallArityAnalysis.CCfix cccExp \<Gamma>) = CoCallArityAnalysis.CCfix (\<pi> \<bullet> cccExp) (\<pi> \<bullet> \<Gamma>)"
  unfolding CoCallArityAnalysis.CCfix_def by perm_simp (simp_all add: Abs_cfun_eqvt)

lemma ccFix_cong[fundef_cong]:
  "\<lbrakk> (\<And> e. e \<in> snd ` set heap2 \<Longrightarrow> cccexp1 e = cccexp2 e); heap1 = heap2 \<rbrakk>
      \<Longrightarrow> CoCallArityAnalysis.CCfix cccexp1 heap1 = CoCallArityAnalysis.CCfix cccexp2 heap2"
   unfolding CoCallArityAnalysis.CCfix_def
   apply (rule arg_cong) back
   apply (rule ccBindsExtra_cong)
   apply (auto simp add: CoCallArityAnalysis.CCexp_def)
   done

context CoCallArityAnalysis
begin
definition cccFix ::  "heap \<Rightarrow> ((AEnv \<times> CoCalls) \<rightarrow> (AEnv \<times> CoCalls))"
  where "cccFix \<Gamma> = (\<Lambda> i. (Afix \<Gamma>\<cdot>(fst i \<squnion> (\<lambda>_.up\<cdot>0) f|` thunks \<Gamma>), CCfix \<Gamma>\<cdot>(Afix \<Gamma>\<cdot>(fst i  \<squnion> (\<lambda>_.up\<cdot>0) f|` (thunks \<Gamma>)), snd i)))"

lemma cccFix_eq:
  "cccFix \<Gamma>\<cdot>i = (Afix \<Gamma>\<cdot>(fst i \<squnion> (\<lambda>_.up\<cdot>0) f|` thunks \<Gamma>), CCfix \<Gamma>\<cdot>(Afix \<Gamma>\<cdot>(fst i  \<squnion> (\<lambda>_.up\<cdot>0) f|` (thunks \<Gamma>)), snd i))"
  unfolding cccFix_def
  by (rule beta_cfun)(intro cont2cont)
end

lemma cccFix_eqvt[eqvt]: "\<pi> \<bullet> (CoCallArityAnalysis.cccFix cccExp \<Gamma>) = CoCallArityAnalysis.cccFix  (\<pi> \<bullet> cccExp) (\<pi> \<bullet> \<Gamma>)"
  apply (rule cfun_eqvtI) unfolding CoCallArityAnalysis.cccFix_eq by perm_simp rule

lemma cccFix_cong[fundef_cong]:
  "\<lbrakk> (\<And> e. e \<in> snd ` set heap2 \<Longrightarrow> cccexp1 e = cccexp2 e); heap1 = heap2 \<rbrakk>
      \<Longrightarrow> CoCallArityAnalysis.cccFix cccexp1 heap1 = CoCallArityAnalysis.cccFix cccexp2 heap2"
   unfolding CoCallArityAnalysis.cccFix_def
   apply (rule cfun_eqI)
   apply auto
   apply (rule arg_cong[OF Afix_cong], auto simp add: CoCallArityAnalysis.Aexp_def)[1]
   apply (rule arg_cong2[OF ccFix_cong Afix_cong ])
   apply (auto simp add: CoCallArityAnalysis.Aexp_def)
   done

subsubsection {* The non-recursive case *}

definition ABind_nonrec :: "var \<Rightarrow> exp \<Rightarrow> AEnv \<times> CoCalls \<rightarrow> Arity\<^sub>\<bottom>"
where
  "ABind_nonrec x e = (\<Lambda> i. (if isVal e \<or> x--x\<notin>(snd i) then fst i x else up\<cdot>0))"

lemma ABind_nonrec_eq:
  "ABind_nonrec x e\<cdot>(ae,G) = (if isVal e \<or> x--x\<notin>G then ae x else up\<cdot>0)"
  unfolding ABind_nonrec_def
  apply (subst beta_cfun)
  apply (rule cont_if_else_above)
  apply auto
  by (metis in_join join_self_below(4))

lemma ABind_nonrec_eqvt[eqvt]: "\<pi> \<bullet> (ABind_nonrec x e) = ABind_nonrec (\<pi> \<bullet> x) (\<pi> \<bullet> e)"
  apply (rule cfun_eqvtI)
  apply (case_tac xa, simp)
  unfolding ABind_nonrec_eq
  by perm_simp rule

lemma ABind_nonrec_above_arg:
  "ae x \<sqsubseteq> ABind_nonrec x e \<cdot> (ae, G)"
unfolding ABind_nonrec_eq by auto

definition Aheap_nonrec where
  "Aheap_nonrec x e = (\<Lambda> i. esing x\<cdot>(ABind_nonrec x e\<cdot>i))"

lemma Aheap_nonrec_simp:
  "Aheap_nonrec x e\<cdot>i = esing x\<cdot>(ABind_nonrec x e\<cdot>i)"
  unfolding Aheap_nonrec_def by simp

lemma Aheap_nonrec_lookup[simp]:
  "(Aheap_nonrec x e\<cdot>i) x = ABind_nonrec x e\<cdot>i"
  unfolding Aheap_nonrec_simp by simp

lemma Aheap_nonrec_eqvt'[eqvt]:
  "\<pi> \<bullet> (Aheap_nonrec x e) = Aheap_nonrec (\<pi> \<bullet> x) (\<pi> \<bullet> e)"
  apply (rule cfun_eqvtI)
  unfolding Aheap_nonrec_simp
  by (perm_simp, rule)

context CoCallArityAnalysis
begin

  definition Afix_nonrec
   where "Afix_nonrec x e = (\<Lambda> i. fup\<cdot>(Aexp e)\<cdot>(ABind_nonrec x e \<cdot> i) \<squnion> fst i)"

  lemma Afix_nonrec_eq[simp]:
    "Afix_nonrec x e \<cdot> i = fup\<cdot>(Aexp e)\<cdot>(ABind_nonrec x e \<cdot> i) \<squnion> fst i"
    unfolding Afix_nonrec_def
    by (rule beta_cfun) simp

  definition CCfix_nonrec
   where "CCfix_nonrec x e = (\<Lambda> i. ccBind x e \<cdot> (Aheap_nonrec x e\<cdot>i, snd i)  \<squnion> ccProd (fv e) (ccNeighbors x (snd i) - (if isVal e then {} else {x})) \<squnion> snd i)"

  lemma CCfix_nonrec_eq[simp]:
    "CCfix_nonrec x e \<cdot> i = ccBind x e\<cdot>(Aheap_nonrec x e\<cdot>i, snd i)  \<squnion> ccProd (fv e) (ccNeighbors x (snd i) - (if isVal e then {} else {x})) \<squnion> snd i"
    unfolding CCfix_nonrec_def
    by (rule beta_cfun) (intro cont2cont)

  definition cccFix_nonrec ::  "var \<Rightarrow> exp \<Rightarrow> ((AEnv \<times> CoCalls) \<rightarrow> (AEnv \<times> CoCalls))"
    where "cccFix_nonrec x e = (\<Lambda> i. (Afix_nonrec x e \<cdot>i , CCfix_nonrec x e \<cdot>i))"

  lemma cccFix_nonrec_eq[simp]:
    "cccFix_nonrec x e\<cdot>i = (Afix_nonrec x e \<cdot>i , CCfix_nonrec x e \<cdot>i)"
    unfolding cccFix_nonrec_def
    by (rule beta_cfun) (intro cont2cont)

end

lemma AFix_nonrec_eqvt[eqvt]: "\<pi> \<bullet> (CoCallArityAnalysis.Afix_nonrec cccExp x e) = CoCallArityAnalysis.Afix_nonrec (\<pi> \<bullet> cccExp) (\<pi> \<bullet> x) (\<pi> \<bullet> e)"
  apply (rule cfun_eqvtI)
  unfolding CoCallArityAnalysis.Afix_nonrec_eq
  by perm_simp rule

lemma CCFix_nonrec_eqvt[eqvt]: "\<pi> \<bullet> (CoCallArityAnalysis.CCfix_nonrec cccExp x e) = CoCallArityAnalysis.CCfix_nonrec (\<pi> \<bullet> cccExp) (\<pi> \<bullet> x) (\<pi> \<bullet> e)"
  apply (rule cfun_eqvtI)
  unfolding CoCallArityAnalysis.CCfix_nonrec_eq
  by perm_simp rule

lemma cccFix_nonrec_eqvt[eqvt]: "\<pi> \<bullet> (CoCallArityAnalysis.cccFix_nonrec cccExp x e) = CoCallArityAnalysis.cccFix_nonrec (\<pi> \<bullet> cccExp) (\<pi> \<bullet> x) (\<pi> \<bullet> e)"
  apply (rule cfun_eqvtI)
  unfolding CoCallArityAnalysis.cccFix_nonrec_eq
  by perm_simp rule

subsubsection {* Combining the cases *}

context CoCallArityAnalysis
begin
  definition cccFix_choose ::  "heap \<Rightarrow> ((AEnv \<times> CoCalls) \<rightarrow> (AEnv \<times> CoCalls))"
    where "cccFix_choose \<Gamma> = (if nonrec \<Gamma> then case_prod cccFix_nonrec (hd \<Gamma>) else cccFix \<Gamma>)"

  lemma cccFix_choose_simp1[simp]:
    "\<not> nonrec \<Gamma> \<Longrightarrow> cccFix_choose \<Gamma> = cccFix \<Gamma>"
  unfolding cccFix_choose_def by simp

  lemma cccFix_choose_simp2[simp]:
    "x \<notin> fv e \<Longrightarrow> cccFix_choose [(x,e)] = cccFix_nonrec x e"
  unfolding cccFix_choose_def nonrec_def by auto

end

lemma cccFix_choose_eqvt[eqvt]: "\<pi> \<bullet> (CoCallArityAnalysis.cccFix_choose cccExp \<Gamma>) = CoCallArityAnalysis.cccFix_choose (\<pi> \<bullet> cccExp) (\<pi> \<bullet> \<Gamma>)"
  unfolding CoCallArityAnalysis.cccFix_choose_def
  apply (cases nonrec \<pi>  rule: eqvt_cases[where x = \<Gamma>])
  apply (perm_simp, rule)
  apply simp
  apply (erule nonrecE)
  apply (simp )

  apply simp
  done

lemma cccFix_nonrec_cong[fundef_cong]:
  "cccexp1 e = cccexp2 e  \<Longrightarrow> CoCallArityAnalysis.cccFix_nonrec cccexp1 x e = CoCallArityAnalysis.cccFix_nonrec cccexp2 x e"
   apply (rule cfun_eqI)
   unfolding CoCallArityAnalysis.cccFix_nonrec_eq
   unfolding CoCallArityAnalysis.Afix_nonrec_eq
   unfolding CoCallArityAnalysis.CCfix_nonrec_eq
   unfolding CoCallArityAnalysis.fup_Aexp_eq
   apply (simp only: )
   apply (rule arg_cong[OF ccBind_cong])
   apply simp
   unfolding CoCallArityAnalysis.CCexp_def
   apply simp
   done

lemma cccFix_choose_cong[fundef_cong]:
  "\<lbrakk> (\<And> e. e \<in> snd ` set heap2 \<Longrightarrow> cccexp1 e = cccexp2 e); heap1 = heap2 \<rbrakk>
      \<Longrightarrow> CoCallArityAnalysis.cccFix_choose cccexp1 heap1 = CoCallArityAnalysis.cccFix_choose cccexp2 heap2"
   unfolding CoCallArityAnalysis.cccFix_choose_def
   apply (rule cfun_eqI)
   apply (auto elim!: nonrecE)
   apply (rule arg_cong[OF cccFix_nonrec_cong], auto)
   apply (rule arg_cong[OF cccFix_cong], auto)[1]
   done

end