theory Short_Theory_13_2
  imports "HOL-IMP.BExp"
begin

datatype
  com = SKIP
      | Assign vname aexp       ("_ ::= _" [1000, 61] 61)
      | Seq    com  com         ("_;;/ _"  [60, 61] 60)
      | If     bexp com com     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61)
      | Or     com com          ("_/ OR _" [60, 61] 61)
      | While  bexp com         ("(WHILE _/ DO _)"  [0, 61] 61)

text \<open>acom is the type of annotated commands (wrt. a type of annotation)\<close>
datatype 'a acom =
  SKIP 'a                           ("SKIP {_}" 61) |
  Assign vname aexp 'a              ("(_ ::= _/ {_})" [1000, 61, 0] 61) |
  Seq "('a acom)" "('a acom)"       ("_;;//_"  [60, 61] 60) |
  If bexp 'a "'a acom" 'a "'a acom" 'a
    ("(IF _/ THEN ({_}/ _)/ ELSE ({_}/ _)//{_})"  [0, 0, 0, 61, 0, 0] 61) |
  Or "'a acom" "'a acom" 'a
    ("_ OR// _//{_}" [60, 61, 0] 60) |
  While 'a bexp 'a "'a acom" 'a
    ("({_}//WHILE _//DO ({_}//_)//{_})"  [0, 0, 0, 61, 0] 61)

notation com.SKIP ("SKIP")

text \<open>strip maps acoms back to the original commands\<close>
text_raw\<open>\snip{stripdef}{1}{1}{%\<close>
fun strip :: "'a acom \<Rightarrow> com" where
"strip (SKIP {P}) = SKIP" |
"strip (x ::= e {P}) = x ::= e" |
"strip (C\<^sub>1;;C\<^sub>2) = strip C\<^sub>1;; strip C\<^sub>2" |
"strip (IF b THEN {P\<^sub>1} C\<^sub>1 ELSE {P\<^sub>2} C\<^sub>2 {P}) =
  IF b THEN strip C\<^sub>1 ELSE strip C\<^sub>2" |
"strip (C\<^sub>1 OR C\<^sub>2 {P}) = strip C\<^sub>1 OR strip C\<^sub>2" |
"strip ({I} WHILE b DO {P} C {Q}) = WHILE b DO strip C"
text_raw\<open>}%endsnip\<close>

text \<open>asize counts the number of annotations that a com admits\<close>
text_raw\<open>\snip{asizedef}{1}{1}{%\<close>
fun asize :: "com \<Rightarrow> nat" where
"asize SKIP = 1" |
"asize (x ::= e) = 1" |
"asize (C\<^sub>1;;C\<^sub>2) = asize C\<^sub>1 + asize C\<^sub>2" |
"asize (IF b THEN C\<^sub>1 ELSE C\<^sub>2) = asize C\<^sub>1 + asize C\<^sub>2 + 3" |
"asize (C\<^sub>1 OR C\<^sub>2) = asize C\<^sub>1 + asize C\<^sub>2 + 1" |
"asize (WHILE b DO C) = asize C + 3"
text_raw\<open>}%endsnip\<close>

text \<open>shift eats the first n elements of a sequence\<close>
text_raw\<open>\snip{annotatedef}{1}{1}{%\<close>
definition shift :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a" where
"shift f n = (\<lambda>p. f(p+n))"

text \<open>Defined in terms of shift, annotate annotates a command c with a sequence of annotations\<close>
fun annotate :: "(nat \<Rightarrow> 'a) \<Rightarrow> com \<Rightarrow> 'a acom" where
"annotate f SKIP = SKIP {f 0}" |
"annotate f (x ::= e) = x ::= e {f 0}" |
"annotate f (c\<^sub>1;;c\<^sub>2) = annotate f c\<^sub>1;; annotate (shift f (asize c\<^sub>1)) c\<^sub>2" |
"annotate f (IF b THEN c\<^sub>1 ELSE c\<^sub>2) =
  IF b THEN {f 0} annotate (shift f 1) c\<^sub>1
  ELSE {f(asize c\<^sub>1 + 1)} annotate (shift f (asize c\<^sub>1 + 2)) c\<^sub>2
  {f(asize c\<^sub>1 + asize c\<^sub>2 + 2)}" |
"annotate f (c\<^sub>1 OR c\<^sub>2) =
  annotate f c\<^sub>1 OR annotate (shift f (asize c\<^sub>1)) c\<^sub>2 {f (asize c\<^sub>1 + asize c\<^sub>2)}" |
"annotate f (WHILE b DO c) =
  {f 0} WHILE b DO {f 1} annotate (shift f 2) c {f(asize c + 2)}"
text_raw\<open>}%endsnip\<close>

text \<open>annos collects a command's annotations into a list\<close>
text_raw\<open>\snip{annosdef}{1}{1}{%\<close>
fun annos :: "'a acom \<Rightarrow> 'a list" where
"annos (SKIP {P}) = [P]" |
"annos (x ::= e {P}) = [P]" |
"annos (C\<^sub>1;;C\<^sub>2) = annos C\<^sub>1 @ annos C\<^sub>2" |
"annos (IF b THEN {P\<^sub>1} C\<^sub>1 ELSE {P\<^sub>2} C\<^sub>2 {Q}) =
  P\<^sub>1 # annos C\<^sub>1 @  P\<^sub>2 # annos C\<^sub>2 @ [Q]" |
"annos (C\<^sub>1 OR C\<^sub>2 {P}) = annos C\<^sub>1 @ annos C\<^sub>2 @ [P]" |
"annos ({I} WHILE b DO {P} C {Q}) = I # P # annos C @ [Q]"
text_raw\<open>}%endsnip\<close>

text \<open>anno retrives the pth annotation of a command, by first collecting its annotations then
indexing into the pth list element\<close>
definition anno :: "'a acom \<Rightarrow> nat \<Rightarrow> 'a" where
"anno C p = annos C ! p"

text \<open>post retrieves the last annotation of a command, by first collecting its annotations\<close>
definition post :: "'a acom \<Rightarrow>'a" where
"post C = last(annos C)"

text \<open>map_acom maps the annotations of an acom\<close>
text_raw\<open>\snip{mapacomdef}{1}{2}{%\<close>
fun map_acom :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a acom \<Rightarrow> 'b acom" where
"map_acom f (SKIP {P}) = SKIP {f P}" |
"map_acom f (x ::= e {P}) = x ::= e {f P}" |
"map_acom f (C\<^sub>1;;C\<^sub>2) = map_acom f C\<^sub>1;; map_acom f C\<^sub>2" |
"map_acom f (IF b THEN {P\<^sub>1} C\<^sub>1 ELSE {P\<^sub>2} C\<^sub>2 {Q}) =
  IF b THEN {f P\<^sub>1} map_acom f C\<^sub>1 ELSE {f P\<^sub>2} map_acom f C\<^sub>2
  {f Q}" |
"map_acom f (C\<^sub>1 OR C\<^sub>2 {P}) = map_acom f C\<^sub>1 OR map_acom f C\<^sub>2 {f P}" |
"map_acom f ({I} WHILE b DO {P} C {Q}) =
  {f I} WHILE b DO {f P} map_acom f C {f Q}"
text_raw\<open>}%endsnip\<close>

text \<open>the list of annotations for any command is always nonempty\<close>
lemma annos_ne: "annos C \<noteq> []"
by(induction C) auto

text \<open>stripping a command that has been annotated recovers it\<close>
lemma strip_annotate[simp]: "strip(annotate f c) = c"
by(induction c arbitrary: f) auto

text \<open>the list of annotations of a com, once annotated, is as large as the number of annotations it admits\<close>
lemma length_annos_annotate[simp]: "length (annos (annotate f c)) = asize c"
by(induction c arbitrary: f) auto

text \<open>the size of the list of annotations of a command is as large as the number of annotations its underlying com admits\<close>
lemma size_annos: "size(annos C) = asize(strip C)"
by(induction C)(auto)

text \<open>if two acom share the same com, then they have the same number of annotations\<close>
lemma size_annos_same: "strip C1 = strip C2 \<Longrightarrow> size(annos C1) = size(annos C2)"
apply(induct C2 arbitrary: C1)
apply(case_tac C1, simp_all)+
done

lemmas size_annos_same2 = eqTrueI[OF size_annos_same]

text \<open>dually, the pth annotation is the pth element of the annotating sequence\<close>
lemma anno_annotate[simp]: "p < asize c \<Longrightarrow> anno (annotate f c) p = f p"
proof (induction c arbitrary: f p)
  case SKIP
  then show ?case by (auto simp: anno_def)
next
  case (Assign x1 x2)
  then show ?case by (auto simp: anno_def)
next
  case (Seq c1 c2)
  then show ?case by (auto simp: anno_def nth_append shift_def)
next
  case (If x1 c1 c2)
  then show ?case
    by (auto simp: anno_def nth_append nth_Cons shift_def split: nat.split,
        metis add_Suc_right add_diff_inverse add.commute,
        rule_tac f=f in arg_cong,
        arith)
next
  case (Or c1 c2)
  then show ?case
    by (auto simp: anno_def nth_append shift_def,
        rule_tac f=f in arg_cong,
        arith)
next
case (While x1 c)
  then show ?case
    by (auto simp: anno_def nth_append nth_Cons shift_def
        split: nat.split, rule_tac f=f in arg_cong,
        arith)
qed

text \<open>two acoms are equal iff they have the same underlying command and same list of annotations\<close>
text \<open>Proof is by inductive definiton of acom, and list lemmas / annos lemmas\<close>
lemma eq_acom_iff_strip_annos:
  "C1 = C2 \<longleftrightarrow> strip C1 = strip C2 \<and> annos C1 = annos C2"
apply(induction C1 arbitrary: C2)
apply(case_tac C2, auto simp: size_annos_same2)+
done

text \<open>two acoms are equal iff they have the same underlying command and same sublist of annotations\<close>
lemma eq_acom_iff_strip_anno:
  "C1=C2 \<longleftrightarrow> strip C1 = strip C2 \<and> (\<forall>p<size(annos C1). anno C1 p = anno C2 p)"
by(auto simp add: eq_acom_iff_strip_annos anno_def
     list_eq_iff_nth_eq size_annos_same2)

text \<open>the last annotation after mapping through f is exactly the last annotation, then mapping it by f\<close>
lemma post_map_acom[simp]: "post(map_acom f C) = f(post C)"
by (induction C) (auto simp: post_def last_append annos_ne)

text \<open>the underlying command is unchanged by map_acom\<close>
lemma strip_map_acom[simp]: "strip (map_acom f C) = strip C"
by (induction C) auto

text \<open>the pth annotation after mapping through f is exactly the pth annotation, then mapping it by f\<close>
lemma anno_map_acom: "p < size(annos C) \<Longrightarrow> anno (map_acom f C) p = f(anno C p)"
apply(induction C arbitrary: p)
apply(auto simp: anno_def nth_append nth_Cons' size_annos)
done

text \<open>inversion lemma for strip C\<close>

lemma strip_eq_SKIP:
  "strip C = SKIP \<longleftrightarrow> (\<exists>P. C = SKIP {P})"
by (cases C) simp_all

lemma strip_eq_Assign:
  "strip C = x::=e \<longleftrightarrow> (\<exists>P. C = x::=e {P})"
by (cases C) simp_all

lemma strip_eq_Seq:
  "strip C = c1;;c2 \<longleftrightarrow> (\<exists>C1 C2. C = C1;;C2 & strip C1 = c1 & strip C2 = c2)"
by (cases C) simp_all

lemma strip_eq_If:
  "strip C = IF b THEN c1 ELSE c2 \<longleftrightarrow>
  (\<exists>P1 P2 C1 C2 Q. C = IF b THEN {P1} C1 ELSE {P2} C2 {Q} & strip C1 = c1 & strip C2 = c2)"
by (cases C) simp_all

lemma strip_eq_Or:
  "strip C = c1 OR c2 \<longleftrightarrow>
  (\<exists>C1 C2 P. C = C1 OR C2 {P} & strip C1 = c1 & strip C2 = c2)"
by (cases C) simp_all

lemma strip_eq_While:
  "strip C = WHILE b DO c1 \<longleftrightarrow>
  (\<exists>I P C1 Q. C = {I} WHILE b DO {P} C1 {Q} & strip C1 = c1)"
by (cases C) simp_all

text \<open>shifting a constant sequence does nothing\<close>

text \<open>the set of all members of an acom created by annotate with a constant sequence on that annotation is a singleton\<close>
lemma set_annos_anno[simp]: "set (annos (annotate (\<lambda>p. a) c)) = {a}"
  by(induction c) simp_all

text \<open>the last annotation of an acom is in the set of list of annotations of that acom\<close>
lemma post_in_annos: "post C \<in> set(annos C)"
by(auto simp: post_def annos_ne)

text \<open>the last annotation of C is the last element of the list of annotations generated from C.\<close>
lemma post_anno_asize: "post C = anno C (size(annos C) - 1)"
  by(simp add: post_def last_conv_nth[OF annos_ne] anno_def)

notation
  sup (infixl "\<squnion>" 65) and
  inf (infixl "\<sqinter>" 70) and
  bot ("\<bottom>") and
  top ("\<top>")

context
  fixes f :: "vname \<Rightarrow> aexp \<Rightarrow> 'a \<Rightarrow> 'a::sup"
  fixes g :: "bexp \<Rightarrow> 'a \<Rightarrow> 'a"
begin
fun Step :: "'a \<Rightarrow> 'a acom \<Rightarrow> 'a acom" where
"Step S (SKIP {Q}) = (SKIP {S})" |
"Step S (x ::= e {Q}) =
  x ::= e {f x e S}" |
"Step S (C1;; C2) = Step S C1;; Step (post C1) C2" |
"Step S (IF b THEN {P1} C1 ELSE {P2} C2 {Q}) =
  IF b THEN {g b S} Step P1 C1 ELSE {g (Not b) S} Step P2 C2
  {post C1 \<squnion> post C2}" |
"Step S (C1 OR C2 {P}) =
  Step S C1 OR Step S C2
  {post C1 \<squnion> post C2}" |
"Step S ({I} WHILE b DO {P} C {Q}) =
  {S \<squnion> post C} WHILE b DO {g b I} Step P C {g (Not b) I}"
end

end


section \<open>Insertion Sorts for PDQ-Sort\<close>
theory Sorting_Pdq_Insertion_Sort
imports Sorting_Setup Sorting_Partially_Sorted
begin

  (* Partially overlapping with Sorting_Unguarded_Insertion_Sort, but the details of the
    required specs are different enough, such that we decided for the redundancy, rarther than
    trying to find a good generalization.
  *)

  subsection \<open>Insertion Sort\<close>

  subsubsection \<open>Abstract Algorithm\<close>

  context weak_ordering begin
    definition "pdq_sort_one_more_spec GUARDED xs l i \<equiv> doN {
      ASSERT (sorted_wrt_lt (\<^bold><) (slice l i xs) \<and> l\<le>i \<and> i<length xs \<and> (\<not>GUARDED \<longrightarrow> 0<l \<and> \<not> xs!(l-1) \<^bold>> xs!i ) );
      SPEC (\<lambda>xs'. slice_eq_mset l (Suc i) xs xs' \<and> sorted_wrt_lt (\<^bold><) (slice l (Suc i) xs'))
    }"

    definition "pdq_guarded_sort_spec G xs l h \<equiv> doN {
      ASSERT (\<not>G \<longrightarrow> 0<l \<and> (\<forall>x\<in>set (slice l h xs). \<not> x \<^bold>< xs!(l-1)));
      slice_sort_spec (\<^bold><) xs l h
    }"

    definition pdq_insort where "pdq_insort GUARDED xs\<^sub>0 l h \<equiv> doN {
      ASSERT( l\<le>h \<and> h\<le>length xs\<^sub>0 \<and> (\<not>GUARDED \<longrightarrow> 0<l \<and> (\<forall>x\<in>set (slice l h xs\<^sub>0). \<not> x \<^bold>< xs\<^sub>0!(l-1))));

      if l\<noteq>h then doN {
        ASSERT (l<h);
        (_,xs)\<leftarrow>WHILEIT
          (\<lambda>(i,xs). l<i \<and> i\<le>h \<and> slice_eq_mset l h xs\<^sub>0 xs \<and> sorted_wrt_lt (\<^bold><) (slice l i xs))
          (\<lambda>(i,xs). i<h)
          (\<lambda>(i,xs). doN {
            xs \<leftarrow> pdq_sort_one_more_spec GUARDED xs l i;
            ASSERT (i<h);
            RETURN (i+1,xs)
          })
          (l+1,xs\<^sub>0);
        RETURN xs
      } else RETURN xs\<^sub>0
    }"

    lemma insort_correct_aux1: "h\<le>length xs \<Longrightarrow> (\<forall>x\<in>set (slice l h xs). \<not> x \<^bold>< k) \<longleftrightarrow> (\<forall>j\<in>{l..<h}. \<not> xs!j \<^bold>< k)"
      by (auto simp: Ball_def set_slice_conv)

    lemma insort_correct: "pdq_insort G xs l h \<le> pdq_guarded_sort_spec G xs l h"
      unfolding pdq_insort_def slice_sort_spec_sem_alt pdq_guarded_sort_spec_def pdq_sort_one_more_spec_def
      apply (refine_vcg WHILEIT_rule[where R="measure (\<lambda>(i,_). h-i)"])
      apply (clarsimp_all simp: slice_eq_mset_eq_length)
      subgoal
        apply (subst (asm) slice_eq_mset_nth_outside, assumption)
        apply (auto simp: slice_eq_mset_eq_length) [2]
        apply (simp add: slice_eq_mset_set_inside)
        apply (simp add: insort_correct_aux1 slice_eq_mset_eq_length)
        done
      subgoal by (meson Suc_leI dual_order.refl le_SucI less_imp_le slice_eq_mset_subslice slice_eq_mset_trans)
      subgoal by simp
      done

    definition "pdq_is_insert GUARDED xs\<^sub>0 l i\<^sub>0 \<equiv> doN {
      ASSERT ( l\<le>i\<^sub>0 \<and> i\<^sub>0<length xs\<^sub>0 \<and> (\<not>GUARDED \<longrightarrow> 0<l \<and> \<not>(xs\<^sub>0!(l-1) \<^bold>> xs\<^sub>0!i\<^sub>0)));

      tmp \<leftarrow> mop_list_get xs\<^sub>0 i\<^sub>0;

      (xs,i)\<leftarrow>WHILEIT
        (\<lambda>(xs,i).
            l\<le>i \<and> i\<le>i\<^sub>0
          \<and> eq_outside_range xs\<^sub>0 xs l (i\<^sub>0+1)
          \<and> (\<forall>j\<in>{l..<i}. xs\<^sub>0!j = xs!j)
          \<and> (\<forall>j\<in>{i<..i\<^sub>0}. xs\<^sub>0!(j-1) = xs!j \<and> tmp \<^bold>< xs!j)
          \<and> (\<not>GUARDED \<longrightarrow> i\<ge>1)
        )
        (\<lambda>(xs,i). (\<not>GUARDED \<or> l<i) \<and> tmp \<^bold>< xs!(i-1) )
        (\<lambda>(xs,i). doN {
          ASSERT (i\<ge>1);
          x \<leftarrow> mop_list_get xs (i-1);
          xs \<leftarrow> mop_list_set xs i x;
          RETURN (xs,i-1)
        })
        (xs\<^sub>0,i\<^sub>0);

      xs \<leftarrow> mop_list_set xs i tmp;

      RETURN xs
    }"

    lemma is_insert_aux1:
      assumes BOUNDS: "l \<le> i" "i \<le> i\<^sub>0" "i\<^sub>0<length xs" "length xs\<^sub>0 = length xs"
      assumes PRFX_EQ: "\<forall>j\<in>{l..<i}. xs\<^sub>0 ! j = xs ! j"
      assumes SFX_SHIFT: "\<forall>j\<in>{i<..i\<^sub>0}. xs\<^sub>0 ! (j - Suc 0) = xs ! j \<and> xs\<^sub>0!i\<^sub>0 \<^bold>< xs!j"
      assumes SORTED: "sorted_wrt_lt (\<^bold><) (slice l i\<^sub>0 xs\<^sub>0)"
      assumes GUARD: "l < i \<longrightarrow> \<not> xs\<^sub>0 ! i\<^sub>0 \<^bold>< xs ! (i - Suc 0)"
      shows "mset (slice l (Suc i\<^sub>0) xs\<^sub>0) = mset (slice l (Suc i\<^sub>0) (xs[i := xs\<^sub>0 ! i\<^sub>0]))"
        and "sorted_wrt_lt (\<^bold><) (slice l (Suc i\<^sub>0) (xs[i := xs\<^sub>0 ! i\<^sub>0]))"
    proof -
      define sxs\<^sub>0 where "sxs\<^sub>0 = slice l (Suc i\<^sub>0) xs\<^sub>0"
      define sxs' where "sxs' = slice l (Suc i\<^sub>0) (xs[i := xs\<^sub>0 ! i\<^sub>0])"

      have "slice l i\<^sub>0 xs\<^sub>0 = butlast sxs\<^sub>0"
        unfolding sxs\<^sub>0_def using BOUNDS
        by (simp add: slice_Suc_conv)

      with SORTED have SORTED': "sorted_wrt_lt (\<^bold><) (butlast sxs\<^sub>0)" by simp

      have [simp]: "length sxs\<^sub>0 = length sxs'"
        unfolding sxs'_def sxs\<^sub>0_def using BOUNDS
        by (auto)

      have [simp]: "length sxs' = i\<^sub>0+1-l"
        unfolding sxs'_def using BOUNDS
        by (auto)

      from PRFX_EQ have 1: "\<forall>j\<in>{0..<i-l}. sxs\<^sub>0 ! j = sxs' ! j"
        unfolding sxs'_def sxs\<^sub>0_def using BOUNDS
        by (auto simp: slice_nth)

      from SFX_SHIFT have 2: "\<forall>j\<in>{i-l..<i\<^sub>0-l}. sxs\<^sub>0 ! j = sxs' ! (j + 1)"
        unfolding sxs'_def sxs\<^sub>0_def using BOUNDS
        apply (auto simp: slice_nth)
        by (smt One_nat_def Suc_leI add.commute add_Suc_right diff_add_inverse greaterThanAtMost_iff le_add_diff_inverse le_imp_less_Suc less_diff_conv plus_1_eq_Suc)

      have 3: "sxs\<^sub>0!(i\<^sub>0-l) = sxs'!(i-l)"
        unfolding sxs'_def sxs\<^sub>0_def using BOUNDS
        by (auto simp: slice_nth)

      have A: "sxs\<^sub>0 = take (i-l) sxs' @ drop (i-l+1) sxs' @ [sxs'!(i-l)]"
        apply (subst list_eq_iff_nth_eq) using BOUNDS
        apply (auto simp: nth_append 1 2 3)
        by (metis "3" add_diff_cancel_right' leI le_add_diff_inverse2 less_antisym less_diff_conv)

      have B: "sxs' = take (i-l) sxs' @ sxs'!(i-l) # drop (i-l+1) sxs'"
        using BOUNDS by (auto simp: id_take_nth_drop)

      show "mset sxs\<^sub>0 = mset sxs'"
        apply (rewrite in "mset \<hole> = _" A)
        apply (rewrite in "_ = mset \<hole>" B)
        by simp

      from SFX_SHIFT have S: "\<forall>j\<in>{i-l..<i\<^sub>0-l}. sxs' ! (i-l) \<^bold>< sxs' ! (j+1)"
        unfolding sxs'_def sxs\<^sub>0_def using BOUNDS
        by (auto simp: slice_nth nth_list_update less_diff_conv)

      from GUARD have GUARD': "i=l \<or> \<not> sxs'!(i-l) \<^bold>< sxs'!(i-Suc 0-l)"
        unfolding sxs'_def sxs\<^sub>0_def using BOUNDS
        by (auto simp: slice_nth)

      show "sorted_wrt_lt (\<^bold><) sxs'"
        apply (rewrite B)
        apply (rule sorted_lelI)

        using SORTED'[unfolded A]
        apply (auto simp add: sorted_wrt_append butlast_append le_by_lt)
        subgoal
          using GUARD'
          by (simp add: add.commute BOUNDS last_take_nth_conv le_imp_less_Suc less_diff_conv less_imp_le_nat wo_leI)
        subgoal premises prems
          using S prems(1) by (auto simp: in_set_conv_nth unfold_lt_to_le)
        done

    qed

    lemma pdq_is_insert_correct: "pdq_is_insert G xs\<^sub>0 l i\<^sub>0 \<le> pdq_sort_one_more_spec G xs\<^sub>0 l i\<^sub>0"
      unfolding pdq_is_insert_def pdq_sort_one_more_spec_def
      apply (refine_vcg WHILEIT_rule[where R="measure (\<lambda>(_,i). i)"])
      apply simp_all
      apply (all \<open>(elim conjE)?\<close>)
      apply (simp_all add: slice_eq_mset_eq_length eq_outside_rane_lenD eq_outside_range_triv)
      apply clarsimp_all
      subgoal
        by (metis One_nat_def eq_outside_range_def last_take_nth_conv le_less_trans less_le nat_le_Suc_less_imp)
      subgoal by (simp add: eq_outside_erange_upd_inside)
      subgoal
        apply (clarsimp simp: nth_list_update)
        by (metis One_nat_def atLeastLessThan_iff eq_outside_range_def last_take_nth_conv le_neq_implies_less less_not_refl2 nat_le_Suc_less_imp nat_minus1_less_if_neZ order_trans)
      subgoal
        by (metis One_nat_def Suc_leI diff_0_eq_0 diff_is_0_eq eq_outside_range_def last_take_nth_conv le_antisym not_less_eq_eq)
      subgoal for xs i
        apply (thin_tac "\<not>G \<longrightarrow> _")+
        apply (clarsimp simp: slice_eq_mset_alt)
        apply (intro conjI)
        apply (auto simp: eq_outside_erange_upd_inside eq_outside_rane_lenD intro!: is_insert_aux1)
        done
      subgoal for xs i
        apply (thin_tac "\<not>G \<longrightarrow> _")+
        apply (auto simp: eq_outside_rane_lenD intro!: is_insert_aux1)
        done
      done

    subsubsection \<open>Loop unrolling Optimization\<close>
    text \<open>Avoid move from/to temporary variable when the element is already at correct position.\<close>

    definition "pdq_is_insert' GUARDED xs l i \<equiv> doN {
      ASSERT ( l\<le>i \<and> i<length xs \<and> (\<not>GUARDED \<longrightarrow> i\<ge>1));
      if ((\<not>GUARDED \<or> l<i) \<and> xs!i \<^bold>< xs!(i-1)) then doN {
        tmp \<leftarrow> mop_list_get xs i;
        ASSERT (i\<ge>1);
        x \<leftarrow> mop_list_get xs (i-1);
        xs \<leftarrow> mop_list_set xs i x;
        (xs,i)\<leftarrow>WHILEIT (\<lambda>(xs,i). \<not>GUARDED \<longrightarrow> i\<ge>1)
          (\<lambda>(xs,i). (\<not>GUARDED \<or> l<i) \<and> tmp \<^bold>< xs!(i-1) )
          (\<lambda>(xs,i). doN {
            ASSERT (i\<ge>1);
            x \<leftarrow> mop_list_get xs (i-1);
            xs \<leftarrow> mop_list_set xs i x;
            RETURN (xs,i-1)
          })
          (xs,i-1);

        xs \<leftarrow> mop_list_set xs i tmp;
        RETURN xs
      } else RETURN xs
    }"

    lemma pdq_is_insert'_refine: "pdq_is_insert' G xs l i \<le> pdq_is_insert G xs l i"
      unfolding pdq_is_insert_def

      apply (rewrite WHILEIT_unfold')
      unfolding pdq_is_insert'_def
      supply if_split[split del]
      apply (cases "(\<not> G \<or> l < i) \<and> xs ! i \<^bold>< xs ! (i - 1)"; simp only:; simp)
      subgoal
        apply (rule refine_IdD)
        apply refine_vcg
        apply refine_dref_type
        apply (clarsimp_all simp only: list_rel_id_simp prod_rel_id_simp IdI)
        apply simp_all
        done
      subgoal
        by (simp add: pw_le_iff refine_pw_simps split!: if_splits)
      done

    subsection \<open>Maybe Insertion Sort\<close>
    text \<open>Will stop sorting after a few swaps\<close>
    abbreviation "partial_insertion_sort_limit \<equiv> 8::nat"

    subsubsection \<open>Abstract Algorithm\<close>
    definition "maybe_sort_spec xs l h \<equiv> doN {
      ASSERT (l\<le>h \<and> h\<le>length xs);
      SPEC (\<lambda>(r,xs'). slice_eq_mset l h xs xs' \<and> (r \<longrightarrow> sorted_wrt_lt (\<^bold><) (slice l h xs')))
    }"

    definition "maybe_sort_one_more_spec xs l i \<equiv> doN {
      ASSERT (sorted_wrt_lt (\<^bold><) (slice l i xs) \<and> l\<le>i \<and> i<length xs );
      SPEC (\<lambda>(d,xs'). slice_eq_mset l (Suc i) xs xs' \<and> d\<le>i-l \<and> sorted_wrt_lt (\<^bold><) (slice l (Suc i) xs'))
    }"

    definition maybe_insort where "maybe_insort xs\<^sub>0 l h \<equiv> doN {
      ASSERT( l\<le>h \<and> h\<le>length xs\<^sub>0 );

      if l\<noteq>h then doN {
        ASSERT (l<h);
        (i,_,xs)\<leftarrow>WHILEIT
          (\<lambda>(i,nc,xs).
            l<i \<and> i\<le>h
            \<and> slice_eq_mset l h xs\<^sub>0 xs
            \<and> sorted_wrt_lt (\<^bold><) (slice l i xs))
          (\<lambda>(i,nc,xs). i<h \<and> nc>0)
          (\<lambda>(i,nc,xs). doN {
            (d,xs) \<leftarrow> maybe_sort_one_more_spec xs l i;

            let nc = (if d<nc then nc-d else 0);
            ASSERT (i<h);
            RETURN (i+1,nc,xs)
          })
          (l+1,partial_insertion_sort_limit+1,xs\<^sub>0);
        RETURN (i=h,xs)
      } else RETURN (True,xs\<^sub>0)
    }"

    lemma maybe_insort_correct: "maybe_insort xs l h \<le> maybe_sort_spec xs l h"
      unfolding maybe_insort_def maybe_sort_spec_def maybe_sort_one_more_spec_def
      apply (refine_vcg WHILEIT_rule[where R="measure (\<lambda>(i,_). h-i)"])
      apply (clarsimp_all simp: slice_eq_mset_eq_length)
      subgoal by (meson Suc_leI dual_order.refl le_SucI less_imp_le slice_eq_mset_subslice slice_eq_mset_trans)
      subgoal by simp
      done

    definition "maybe_is_insert xs\<^sub>0 l i\<^sub>0 \<equiv> doN {
      ASSERT ( l\<le>i\<^sub>0 \<and> i\<^sub>0<length xs\<^sub>0);

      tmp \<leftarrow> mop_list_get xs\<^sub>0 i\<^sub>0;

      (xs,i)\<leftarrow>WHILEIT
        (\<lambda>(xs,i).
            l\<le>i \<and> i\<le>i\<^sub>0
          \<and> eq_outside_range xs\<^sub>0 xs l (i\<^sub>0+1)
          \<and> (\<forall>j\<in>{l..<i}. xs\<^sub>0!j = xs!j)
          \<and> (\<forall>j\<in>{i<..i\<^sub>0}. xs\<^sub>0!(j-1) = xs!j \<and> tmp \<^bold>< xs!j)
        )
        (\<lambda>(xs,i). l<i \<and> tmp \<^bold>< xs!(i-1) )
        (\<lambda>(xs,i). doN {
          ASSERT (i\<ge>1);
          x \<leftarrow> mop_list_get xs (i-1);
          xs \<leftarrow> mop_list_set xs i x;
          RETURN (xs,i-1)
        })
        (xs\<^sub>0,i\<^sub>0);

      xs \<leftarrow> mop_list_set xs i tmp;

      ASSERT (i\<le>i\<^sub>0);
      RETURN (i\<^sub>0-i,xs)
    }"

    lemma maybe_is_insert_correct: "maybe_is_insert xs\<^sub>0 l i\<^sub>0 \<le> maybe_sort_one_more_spec xs\<^sub>0 l i\<^sub>0"
      unfolding maybe_is_insert_def maybe_sort_one_more_spec_def
      apply (refine_vcg WHILEIT_rule[where R="measure (\<lambda>(_,i). i)"])
      apply simp_all
      apply (all \<open>(elim conjE)?\<close>)
      apply (simp_all add: slice_eq_mset_eq_length eq_outside_rane_lenD eq_outside_range_triv)
      apply clarsimp_all
      subgoal by (simp add: eq_outside_erange_upd_inside)
      subgoal
        by (auto simp: nth_list_update)
      subgoal for xs i
        apply (clarsimp simp: slice_eq_mset_alt)
        apply (intro conjI)
        apply (auto simp: eq_outside_erange_upd_inside eq_outside_rane_lenD intro: is_insert_aux1)
        done
      subgoal for xs i
        apply (auto simp: eq_outside_rane_lenD intro: is_insert_aux1)
        done
      done

    subsubsection \<open>Loop Unrolling Optimization\<close>

    definition "maybe_is_insert' xs l i\<^sub>0 \<equiv> doN {
      let i = i\<^sub>0;
      ASSERT ( l\<le>i \<and> i<length xs);

      if (l<i \<and> xs!i \<^bold>< xs!(i-1)) then doN {
        tmp \<leftarrow> mop_list_get xs i;

        ASSERT (i\<ge>1);
        x \<leftarrow> mop_list_get xs (i-1);
        xs \<leftarrow> mop_list_set xs i x;

        (xs,i)\<leftarrow>WHILET
          (\<lambda>(xs,i). l<i \<and> tmp \<^bold>< xs!(i-1) )
          (\<lambda>(xs,i). doN {
            ASSERT (i\<ge>1);
            x \<leftarrow> mop_list_get xs (i-1);
            xs \<leftarrow> mop_list_set xs i x;
            RETURN (xs,i-1)
          })
          (xs,i-1);

        xs \<leftarrow> mop_list_set xs i tmp;
        ASSERT (i\<le>i\<^sub>0);
        RETURN (i\<^sub>0-i,xs)
      } else RETURN (0,xs)
    }"

    lemma maybe_is_insert'_refine: "maybe_is_insert' xs l i \<le> maybe_is_insert xs l i"
      unfolding maybe_is_insert_def

      apply (rewrite WHILEIT_unfold')
      unfolding maybe_is_insert'_def Let_def
      supply if_split[split del]
      apply (cases "l < i \<and> xs ! i \<^bold>< xs ! (i - 1)"; simp only:; simp)
      subgoal
        apply (rule refine_IdD)
        apply refine_vcg
        apply refine_dref_type
        apply (clarsimp_all simp only: list_rel_id_simp prod_rel_id_simp IdI)
        apply simp_all
        done
      subgoal
        by (simp add: pw_le_iff refine_pw_simps split!: if_splits)
      done

  subsection \<open>Refinements to Explicit Ownership\<close>

    definition "pdq_is_insert2' GUARDED xs l i \<equiv> doN {
      xs \<leftarrow> mop_to_eo_conv xs;

      if\<^sub>N (if (\<not>GUARDED \<or> l<i) then doN { ASSERT (i\<ge>1); mop_cmpo_idxs xs i (i-1) } else RETURN False) then doN {

        (tmp,xs) \<leftarrow> mop_eo_extract xs i;

        ASSERT (i\<ge>1);
        (x,xs) \<leftarrow> mop_eo_extract xs (i-1);
        xs \<leftarrow> mop_eo_set xs i x;

        (xs,i)\<leftarrow>monadic_WHILEIT
          (\<lambda>_. True)
          (\<lambda>(xs,i). if (\<not>GUARDED \<or> l<i) then doN { ASSERT (i\<ge>1); mop_cmpo_v_idx xs tmp (i-1) } else RETURN False )
          (\<lambda>(xs,i). doN {
            ASSERT (i>0);
            (x,xs) \<leftarrow> mop_eo_extract xs (i-1);
            xs \<leftarrow> mop_eo_set xs i x;
            RETURN (xs,i-1)
          })
          (xs,i-1);
        xs \<leftarrow> mop_eo_set xs i tmp;
        xs \<leftarrow> mop_to_wo_conv xs;
        RETURN xs
      } else mop_to_wo_conv xs
    }"

    definition "pdq_ii2_loop_rel \<equiv> {((xs',i'), (xs,i)). i'=i \<and> length xs' = length xs \<and> i<length xs \<and> (\<forall>j\<in>{0..<length xs}-{i}. xs'!j = Some (xs!j)) \<and> xs'!i=None}"

    lemma pdq_is_insert2'_refine: "pdq_is_insert2' G xs l i \<le>\<Down>(\<langle>Id\<rangle>list_rel) (pdq_is_insert' G xs l i)"
    proof -

      have 1: "mop_cmpo_idxs (map Some xs) i (i - 1) = doN { ASSERT (i<length xs); RETURN (xs!i \<^bold>< xs!(i-1)) }"
        by (auto simp: pw_eq_iff refine_pw_simps)

      show ?thesis
        unfolding pdq_is_insert2'_def pdq_is_insert'_def
        supply [simp del] = conc_Id
        supply [split del] = if_split
        apply (
          cases "\<not> G \<or> l < i";
          simp named_ss HOL_ss: split del: if_split;
          cases "xs ! i \<^bold>< xs ! (i - 1)";
          simp named_ss HOL_ss: mop_to_eo_conv_def nres_monad_laws 1 split del: if_split)
        subgoal
          apply (intro refine0; simp)
          apply linarith
          apply (rule refine)
          apply (rule refine)
          apply blast
          apply (rule refine)
          apply (rule monadic_WHILEIT_refine_WHILEIT[where R=pdq_ii2_loop_rel])
          subgoal by (auto simp: pdq_ii2_loop_rel_def nth_list_update split: if_splits)
          subgoal by simp
          subgoal
            apply (thin_tac "G \<longrightarrow> _")+
            apply (clarsimp split: prod.splits if_splits simp: pdq_ii2_loop_rel_def)
            apply refine_vcg
            apply (auto)
            done
          subgoal
            apply (thin_tac "G \<longrightarrow> _")+
            apply clarsimp
            apply refine_vcg
            unfolding pdq_ii2_loop_rel_def
            apply (auto simp: nth_list_update split: if_splits)
            done
          subgoal
            apply (thin_tac "G \<longrightarrow> _")+
            apply refine_vcg
            apply (auto simp: pdq_ii2_loop_rel_def nth_list_update in_set_conv_nth split: if_split intro: list_eq_iff_nth_eq[THEN iffD2])
            done
          done
        subgoal by refine_rcg auto
        subgoal by refine_rcg auto
        subgoal by refine_rcg auto
        done
    qed

    definition "pdq_is_insert2 GUARDED xs\<^sub>0 l i\<^sub>0 \<equiv> doN {
      xs \<leftarrow> mop_to_eo_conv xs\<^sub>0;

      (tmp,xs) \<leftarrow> mop_eo_extract xs i\<^sub>0;

      (xs,i)\<leftarrow>monadic_WHILEIT
        (\<lambda>(xs,i). True
        )
        (\<lambda>(xs,i). if (\<not>GUARDED \<or> l<i) then doN { ASSERT (i>0); mop_cmpo_v_idx xs tmp (i-1) } else RETURN False )
        (\<lambda>(xs,i). doN {
          ASSERT (i>0);
          (x,xs) \<leftarrow> mop_eo_extract xs (i-1);
          xs \<leftarrow> mop_eo_set xs i x;
          RETURN (xs,i-1)
        })
        (xs,i\<^sub>0);

      xs \<leftarrow> mop_eo_set xs i tmp;

      xs \<leftarrow> mop_to_wo_conv xs;

      RETURN xs
    }"

    lemma pdq_is_insert2_refine: "pdq_is_insert2 G xs l i \<le>\<Down>(\<langle>Id\<rangle>list_rel) (pdq_is_insert G xs l i)"
      unfolding pdq_is_insert2_def pdq_is_insert_def
      supply [simp del] = conc_Id

      apply simp
      apply (intro refine0; simp)
      apply (rule refine)
      apply (rule monadic_WHILEIT_refine_WHILEIT[where R=pdq_ii2_loop_rel])
      subgoal by (auto simp: pdq_ii2_loop_rel_def)
      subgoal by simp
      subgoal
        apply (clarsimp split: prod.splits simp: pdq_ii2_loop_rel_def)
        apply refine_vcg
        apply (auto)
        done
      subgoal
        apply clarsimp
        apply refine_vcg
        unfolding pdq_ii2_loop_rel_def
        apply (auto simp: nth_list_update split: if_splits)
        done
      subgoal
        apply refine_vcg
        apply (auto simp: pdq_ii2_loop_rel_def nth_list_update in_set_conv_nth intro: list_eq_iff_nth_eq[THEN iffD2])
        done
      done

    definition "maybe_is_insert2 xs\<^sub>0 l i\<^sub>0 \<equiv> doN {
      ASSERT ( l\<le>i\<^sub>0 \<and> i\<^sub>0<length xs\<^sub>0);

      xs \<leftarrow> mop_to_eo_conv xs\<^sub>0;

      (tmp,xs) \<leftarrow> mop_eo_extract xs i\<^sub>0;

      (xs,i)\<leftarrow>monadic_WHILEIT
        (\<lambda>(xs,i). True)
        (\<lambda>(xs,i). if l<i then doN { ASSERT (i>0); mop_cmpo_v_idx xs tmp (i-1) } else RETURN False )
        (\<lambda>(xs,i). doN {
          ASSERT (i>0);
          (x,xs) \<leftarrow> mop_eo_extract xs (i-1);
          xs \<leftarrow> mop_eo_set xs i x;
          RETURN (xs,i-1)
        })
        (xs,i\<^sub>0);

      xs \<leftarrow> mop_eo_set xs i tmp;

      xs \<leftarrow> mop_to_wo_conv xs;

      ASSERT (i\<le>i\<^sub>0);
      RETURN (i\<^sub>0-i,xs)
    }"

    lemma maybe_is_insert2_refine: "maybe_is_insert2 xs l i \<le>\<Down>(Id \<times>\<^sub>r \<langle>Id\<rangle>list_rel) (maybe_is_insert xs l i)"
      unfolding maybe_is_insert2_def maybe_is_insert_def
      supply [simp del] = conc_Id

      apply simp
      apply (intro refine0; simp)
      apply (rule refine)
      apply (rule monadic_WHILEIT_refine_WHILEIT[where R=pdq_ii2_loop_rel])
      subgoal by (auto simp: pdq_ii2_loop_rel_def)
      subgoal by simp
      subgoal
        apply (clarsimp split: prod.splits simp: pdq_ii2_loop_rel_def)
        apply refine_vcg
        apply (auto)
        done
      subgoal
        apply clarsimp
        apply refine_vcg
        unfolding pdq_ii2_loop_rel_def
        apply (auto simp: nth_list_update split: if_splits)
        done
      subgoal
        apply refine_vcg
        apply (auto simp: pdq_ii2_loop_rel_def nth_list_update in_set_conv_nth intro: list_eq_iff_nth_eq[THEN iffD2])
        done
      done

    definition "maybe_is_insert2' xs l i\<^sub>0 \<equiv> doN {
      let i=i\<^sub>0;
      ASSERT ( l\<le>i \<and> i<length xs);
      xs \<leftarrow> mop_to_eo_conv xs;

      if\<^sub>N (if l<i then doN { ASSERT (i>0); mop_cmpo_idxs xs i (i-1) } else RETURN False) then doN {
        (tmp,xs) \<leftarrow> mop_eo_extract xs i\<^sub>0;

        ASSERT (i\<ge>1);
        (x,xs) \<leftarrow> mop_eo_extract xs (i-1);
        xs \<leftarrow> mop_eo_set xs i x;

        (xs,i)\<leftarrow>monadic_WHILEIT
          (\<lambda>_. True)
          (\<lambda>(xs,i). if l<i then doN { ASSERT (i\<ge>1); mop_cmpo_v_idx xs tmp (i-1) } else RETURN False )
          (\<lambda>(xs,i). doN {
            ASSERT (i\<ge>1);
            (x,xs) \<leftarrow> mop_eo_extract xs (i-1);
            xs \<leftarrow> mop_eo_set xs i x;
            RETURN (xs,i-1)
          })
          (xs,i-1);

        xs \<leftarrow> mop_eo_set xs i tmp;
        xs \<leftarrow> mop_to_wo_conv xs;

        ASSERT (i\<le>i\<^sub>0);
        RETURN (i\<^sub>0-i,xs)
      } else doN {
        xs \<leftarrow> mop_to_wo_conv xs;
        RETURN (0,xs)
      }
    }"

    lemma maybe_is_insert2'_refine: "maybe_is_insert2' xs l i \<le>\<Down>(Id \<times>\<^sub>r \<langle>Id\<rangle>list_rel) (maybe_is_insert' xs l i)"
    proof -
      have 1: "mop_cmpo_idxs (map Some xs) i (i - 1) = doN { ASSERT (i<length xs); RETURN (xs!i \<^bold>< xs!(i-1)) }"
        by (auto simp: pw_eq_iff refine_pw_simps)

      show ?thesis
        unfolding maybe_is_insert2'_def maybe_is_insert'_def Let_def
        supply [simp del] = conc_Id
        supply [split del] = if_split
        apply (
          cases "l < i";
          simp named_ss HOL_ss: split del: if_split;
          cases "xs ! i \<^bold>< xs ! (i - 1)";
          simp named_ss HOL_ss: mop_to_eo_conv_def nres_monad_laws 1 split del: if_split)

        subgoal
          apply (intro refine0; simp)
          apply (intro refine0; simp)
          apply (rule refine)
          apply (rule monadic_WHILEIT_refine_WHILET[where R=pdq_ii2_loop_rel])
          subgoal by (auto simp: pdq_ii2_loop_rel_def nth_list_update split: if_splits)
          subgoal
            apply (clarsimp split: prod.splits simp: pdq_ii2_loop_rel_def split: if_split)
            apply refine_vcg
            apply (auto)
            done
          subgoal
            apply clarsimp
            apply refine_vcg
            unfolding pdq_ii2_loop_rel_def
            apply (auto simp: nth_list_update split: if_splits)
            done
          subgoal
            apply refine_vcg
            apply (auto simp: pdq_ii2_loop_rel_def nth_list_update in_set_conv_nth split: if_splits intro: list_eq_iff_nth_eq[THEN iffD2])
            done
          done
        subgoal by refine_rcg auto
        subgoal by refine_rcg auto
        subgoal by refine_rcg auto
        done

    qed

  end

subsection \<open>Refinement to Isabelle-LLVM\<close>

context sort_impl_context begin
  sepref_register
    pdq_is_guarded_insert3: "pdq_is_insert2 True"
    pdq_is_unguarded_insert3: "pdq_is_insert2 False"
    maybe_is_insert3: "maybe_is_insert2"

  sepref_def pdq_is_guarded_insert_impl [llvm_inline] is "uncurry2 (PR_CONST (pdq_is_insert2' True))"
    :: "(woarray_assn elem_assn)\<^sup>d *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k \<rightarrow>\<^sub>a woarray_assn elem_assn"
    unfolding pdq_is_insert2'_def PR_CONST_def
    apply (simp named_ss HOL_ss:)
    supply [[goals_limit = 1]]
    apply (annot_snat_const "TYPE(size_t)")
    by sepref

  sepref_def pdq_is_unguarded_insert_impl [llvm_inline] is "uncurry2 (PR_CONST (pdq_is_insert2' False))"
    :: "(woarray_assn elem_assn)\<^sup>d *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k \<rightarrow>\<^sub>a woarray_assn elem_assn"
    unfolding pdq_is_insert2'_def PR_CONST_def
    apply (simp named_ss HOL_ss:)
    supply [[goals_limit = 1]]
    apply (annot_snat_const "TYPE(size_t)")
    by sepref

  sepref_def maybe_is_insert_impl [llvm_inline] is "uncurry2 (PR_CONST maybe_is_insert2')"
    :: "(woarray_assn elem_assn)\<^sup>d *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k \<rightarrow>\<^sub>a size_assn \<times>\<^sub>a woarray_assn elem_assn"
    unfolding maybe_is_insert2'_def PR_CONST_def
    supply [[goals_limit = 1]]
    apply (annot_snat_const "TYPE(size_t)")
    by sepref

  sepref_register
    pdq_is_guarded_som: "pdq_sort_one_more_spec True"
    pdq_is_unguarded_som: "pdq_sort_one_more_spec False"
    maybe_sort_one_more_spec

   lemma pdq_is_insert2_refine': "(PR_CONST (pdq_is_insert2 G), PR_CONST (pdq_sort_one_more_spec G))\<in>Id \<rightarrow> Id \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
   proof -
     note pdq_is_insert2_refine also note pdq_is_insert_correct
     finally show ?thesis by (auto intro!: nres_relI)
   qed

   lemma pdq_is_insert2'_refine': "(PR_CONST (pdq_is_insert2' G), PR_CONST (pdq_sort_one_more_spec G))\<in>Id \<rightarrow> Id \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
   proof -
     note pdq_is_insert2'_refine also note pdq_is_insert'_refine also note pdq_is_insert_correct
     finally show ?thesis by (auto intro!: nres_relI)
   qed

   lemma maybe_is_insert2_refine': "(PR_CONST (maybe_is_insert2), PR_CONST (maybe_sort_one_more_spec))\<in>Id \<rightarrow> Id \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
   proof -
     note maybe_is_insert2_refine also note maybe_is_insert_correct
     finally show ?thesis by (auto intro!: nres_relI)
   qed

   lemma maybe_is_insert2'_refine': "(PR_CONST (maybe_is_insert2'), PR_CONST (maybe_sort_one_more_spec))\<in>Id \<rightarrow> Id \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
   proof -
     note maybe_is_insert2'_refine also note maybe_is_insert'_refine also note maybe_is_insert_correct
     finally show ?thesis by (auto intro!: nres_relI)
   qed

   lemmas [sepref_fr_rules] =
     pdq_is_unguarded_insert_impl.refine[FCOMP pdq_is_insert2'_refine']
     pdq_is_guarded_insert_impl.refine[FCOMP pdq_is_insert2'_refine']
     maybe_is_insert_impl.refine[FCOMP maybe_is_insert2'_refine']

  sepref_register
    pdq_unguarded_insort: "pdq_insort False"
    pdq_guarded_insort: "pdq_insort True"
    maybe_insort

  sepref_def pdq_unguarded_insort_impl is "uncurry2 (PR_CONST (pdq_insort False))"
    :: "(woarray_assn elem_assn)\<^sup>d *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k \<rightarrow>\<^sub>a woarray_assn elem_assn"
    unfolding pdq_insort_def PR_CONST_def
    apply (simp named_ss HOL_ss:)
    apply (annot_snat_const "TYPE(size_t)")
    by sepref

  sepref_def pdq_guarded_insort_impl is "uncurry2 (PR_CONST (pdq_insort True))"
    :: "(woarray_assn elem_assn)\<^sup>d *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k \<rightarrow>\<^sub>a woarray_assn elem_assn"
    unfolding pdq_insort_def PR_CONST_def
    apply (simp named_ss HOL_ss:)
    apply (annot_snat_const "TYPE(size_t)")
    by sepref

  sepref_def maybe_insort_impl is "uncurry2 (PR_CONST maybe_insort)"
    :: "(woarray_assn elem_assn)\<^sup>d *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k \<rightarrow>\<^sub>a bool1_assn \<times>\<^sub>a woarray_assn elem_assn"
    unfolding maybe_insort_def PR_CONST_def
    apply (simp named_ss HOL_ss:)
    apply (annot_snat_const "TYPE(size_t)")
    by sepref

  definition "pdq_insort_decG G xs l h \<equiv> if G then pdq_insort True xs l h else pdq_insort False xs l h"
  lemma insort_is_decG: "pdq_insort = pdq_insort_decG" unfolding pdq_insort_decG_def by (auto intro!: ext)

  sepref_definition pdq_insort_impl [llvm_inline] is "uncurry3 (PR_CONST pdq_insort_decG)"
    :: "bool1_assn\<^sup>k *\<^sub>a (woarray_assn elem_assn)\<^sup>d *\<^sub>a size_assn\<^sup>k *\<^sub>a size_assn\<^sup>k \<rightarrow>\<^sub>a woarray_assn elem_assn"
    unfolding pdq_insort_decG_def PR_CONST_def by sepref

  sepref_register
    pdq_guarded_sort_spec
    maybe_sort_spec

  lemma pdq_insort_refine': "(PR_CONST pdq_insort_decG, PR_CONST pdq_guarded_sort_spec) \<in> Id \<rightarrow> Id \<rightarrow> Id \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
    using insort_correct by (auto intro!: nres_relI simp: insort_is_decG)

  lemma maybe_insort_refine': "(PR_CONST maybe_insort, PR_CONST maybe_sort_spec) \<in> Id \<rightarrow> Id \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
    using maybe_insort_correct by (auto intro!: nres_relI)

  lemmas [sepref_fr_rules] =
    pdq_insort_impl.refine[FCOMP pdq_insort_refine']
    maybe_insort_impl.refine[FCOMP maybe_insort_refine']

end

(* TODO: Parameterized comparisons *)

end


(* Copyright 2021 (C) Mihails Milehins *)

section\<open>Smallness for categories\<close>
theory CZH_ECAT_Small_Category
  imports
    CZH_Foundations.CZH_SMC_Small_Semicategory
    CZH_ECAT_Category
begin

subsection\<open>Background\<close>

text\<open>
An explanation of the methodology chosen for the exposition of all
matters related to the size of the categories and associated entities
is given in \<^cite>\<open>"milehins_category_2021"\<close>.
\<close>

named_theorems cat_small_cs_simps
named_theorems cat_small_cs_intros

subsection\<open>Tiny category\<close>

subsubsection\<open>Definition and elementary properties\<close>

locale tiny_category = \<Z> \<alpha> + vfsequence \<CC> + CId: vsv \<open>\<CC>\<lparr>CId\<rparr>\<close> for \<alpha> \<CC> +
  assumes tiny_cat_length[cat_cs_simps]: "vcard \<CC> = 6\<^sub>\<nat>"
    and tiny_cat_tiny_semicategory[slicing_intros]:
      "tiny_semicategory \<alpha> (cat_smc \<CC>)"
    and tiny_cat_CId_vdomain[cat_cs_simps]: "\<D>\<^sub>\<circ> (\<CC>\<lparr>CId\<rparr>) = \<CC>\<lparr>Obj\<rparr>"
    and tiny_cat_CId_is_arr[cat_cs_intros]:
      "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr> \<Longrightarrow> \<CC>\<lparr>CId\<rparr>\<lparr>a\<rparr> : a \<mapsto>\<^bsub>\<CC>\<^esub> a"
    and tiny_cat_CId_left_left[cat_cs_simps]:
      "f : a \<mapsto>\<^bsub>\<CC>\<^esub> b \<Longrightarrow> \<CC>\<lparr>CId\<rparr>\<lparr>b\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f = f"
    and tiny_cat_CId_right_left[cat_cs_simps]:
      "f : b \<mapsto>\<^bsub>\<CC>\<^esub> c \<Longrightarrow> f \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<CC>\<lparr>CId\<rparr>\<lparr>b\<rparr> = f"

lemmas [slicing_intros] = tiny_category.tiny_cat_tiny_semicategory

text\<open>Rules.\<close>

lemma (in tiny_category) tiny_category_axioms'[cat_small_cs_intros]:
  assumes "\<alpha>' = \<alpha>"
  shows "tiny_category \<alpha>' \<CC>"
  unfolding assms by (rule tiny_category_axioms)

mk_ide rf tiny_category_def[unfolded tiny_category_axioms_def]
  |intro tiny_categoryI|
  |dest tiny_categoryD[dest]|
  |elim tiny_categoryE[elim]|

lemma tiny_categoryI':
  assumes "category \<alpha> \<CC>" and "\<CC>\<lparr>Obj\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>" and "\<CC>\<lparr>Arr\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
  shows "tiny_category \<alpha> \<CC>"
proof-
  interpret category \<alpha> \<CC> by (rule assms(1))
  show ?thesis
  proof(intro tiny_categoryI)
    from assms show "tiny_semicategory \<alpha> (cat_smc \<CC>)"
      by (intro tiny_semicategoryI') (auto simp: slicing_simps)
  qed (auto simp: vfsequence_axioms cat_cs_simps cat_cs_intros)
qed

lemma tiny_categoryI'':
  assumes "\<Z> \<alpha>"
    and "vfsequence \<CC>"
    and "vcard \<CC> = 6\<^sub>\<nat>"
    and "vsv (\<CC>\<lparr>Dom\<rparr>)"
    and "vsv (\<CC>\<lparr>Cod\<rparr>)"
    and "vsv (\<CC>\<lparr>Comp\<rparr>)"
    and "vsv (\<CC>\<lparr>CId\<rparr>)"
    and "\<D>\<^sub>\<circ> (\<CC>\<lparr>Dom\<rparr>) = \<CC>\<lparr>Arr\<rparr>"
    and "\<R>\<^sub>\<circ> (\<CC>\<lparr>Dom\<rparr>) \<subseteq>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    and "\<D>\<^sub>\<circ> (\<CC>\<lparr>Cod\<rparr>) = \<CC>\<lparr>Arr\<rparr>"
    and "\<R>\<^sub>\<circ> (\<CC>\<lparr>Cod\<rparr>) \<subseteq>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr>"
    and "\<And>gf. gf \<in>\<^sub>\<circ> \<D>\<^sub>\<circ> (\<CC>\<lparr>Comp\<rparr>) \<longleftrightarrow>
      (\<exists>g f b c a. gf = [g, f]\<^sub>\<circ> \<and> g : b \<mapsto>\<^bsub>\<CC>\<^esub> c \<and> f : a \<mapsto>\<^bsub>\<CC>\<^esub> b)"
    and "\<D>\<^sub>\<circ> (\<CC>\<lparr>CId\<rparr>) = \<CC>\<lparr>Obj\<rparr>"
    and "\<And>b c g a f. \<lbrakk> g : b \<mapsto>\<^bsub>\<CC>\<^esub> c; f : a \<mapsto>\<^bsub>\<CC>\<^esub> b \<rbrakk> \<Longrightarrow> g \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f : a \<mapsto>\<^bsub>\<CC>\<^esub> c"
    and "\<And>c d h b g a f. \<lbrakk> h : c \<mapsto>\<^bsub>\<CC>\<^esub> d; g : b \<mapsto>\<^bsub>\<CC>\<^esub> c; f : a \<mapsto>\<^bsub>\<CC>\<^esub> b \<rbrakk> \<Longrightarrow>
      (h \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> g) \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f = h \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> (g \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f)"
    and "\<And>a. a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr> \<Longrightarrow> \<CC>\<lparr>CId\<rparr>\<lparr>a\<rparr> : a \<mapsto>\<^bsub>\<CC>\<^esub> a"
    and "\<And>a b f. f : a \<mapsto>\<^bsub>\<CC>\<^esub> b \<Longrightarrow> \<CC>\<lparr>CId\<rparr>\<lparr>b\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f = f"
    and "\<And>b c f. f : b \<mapsto>\<^bsub>\<CC>\<^esub> c \<Longrightarrow> f \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<CC>\<lparr>CId\<rparr>\<lparr>b\<rparr> = f"
    and "\<CC>\<lparr>Obj\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
    and "\<CC>\<lparr>Arr\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
  shows "tiny_category \<alpha> \<CC>"
  by (intro tiny_categoryI tiny_semicategoryI'', unfold slicing_simps)
    (simp_all add: cat_smc_def nat_omega_simps assms)

text\<open>Slicing.\<close>

context tiny_category
begin

interpretation smc: tiny_semicategory \<alpha> \<open>cat_smc \<CC>\<close>
  by (rule tiny_cat_tiny_semicategory)

lemmas_with [unfolded slicing_simps]:
  tiny_cat_semicategory = smc.semicategory_axioms
  and tiny_cat_Obj_in_Vset[cat_small_cs_intros] = smc.tiny_smc_Obj_in_Vset
  and tiny_cat_Arr_in_Vset[cat_small_cs_intros] = smc.tiny_smc_Arr_in_Vset
  and tiny_cat_Dom_in_Vset[cat_small_cs_intros] = smc.tiny_smc_Dom_in_Vset
  and tiny_cat_Cod_in_Vset[cat_small_cs_intros] = smc.tiny_smc_Cod_in_Vset
  and tiny_cat_Comp_in_Vset[cat_small_cs_intros] = smc.tiny_smc_Comp_in_Vset

end

text\<open>Elementary properties.\<close>

sublocale tiny_category \<subseteq> category
  by (rule categoryI)
    (
      auto simp:
        vfsequence_axioms tiny_cat_semicategory cat_cs_intros cat_cs_simps
    )

lemmas (in tiny_category) tiny_cat_category = category_axioms

lemmas [cat_small_cs_intros] = tiny_category.tiny_cat_category

text\<open>Size.\<close>

lemma (in tiny_category) tiny_cat_CId_in_Vset: "\<CC>\<lparr>CId\<rparr> \<in>\<^sub>\<circ> Vset \<alpha>"
proof-
  from tiny_cat_Obj_in_Vset have "\<D>\<^sub>\<circ> (\<CC>\<lparr>CId\<rparr>) \<in>\<^sub>\<circ> Vset \<alpha>"
    by (simp add: tiny_cat_Obj_in_Vset cat_cs_simps)
  moreover from tiny_cat_Arr_in_Vset cat_CId_vrange tiny_cat_Arr_in_Vset have
    "\<R>\<^sub>\<circ> (\<CC>\<lparr>CId\<rparr>) \<in>\<^sub>\<circ> Vset \<alpha>"
    by auto
  ultimately show ?thesis by (blast intro: \<Z>_Limit_\<alpha>\<omega>)
qed

lemma (in tiny_category) tiny_cat_in_Vset: "\<CC> \<in>\<^sub>\<circ> Vset \<alpha>"
proof-
  note [cat_cs_intros] =
    tiny_cat_Obj_in_Vset
    tiny_cat_Arr_in_Vset
    tiny_cat_Dom_in_Vset
    tiny_cat_Cod_in_Vset
    tiny_cat_Comp_in_Vset
    tiny_cat_CId_in_Vset
  show ?thesis
    by (subst cat_def) (cs_concl cs_shallow cs_intro: cat_cs_intros V_cs_intros)
qed

lemma tiny_category[simp]: "small {\<CC>. tiny_category \<alpha> \<CC>}"
proof(rule down)
  show "{\<CC>. tiny_category \<alpha> \<CC>} \<subseteq> elts (set {\<CC>. category \<alpha> \<CC>})"
    by (auto intro: cat_small_cs_intros)
qed

lemma small_categories_vsubset_Vset: "set {\<CC>. tiny_category \<alpha> \<CC>} \<subseteq>\<^sub>\<circ> Vset \<alpha>"
  by (rule vsubsetI) (simp_all add: tiny_category.tiny_cat_in_Vset)

lemma (in category) cat_tiny_category_if_ge_Limit:
  assumes "\<Z> \<beta>" and "\<alpha> \<in>\<^sub>\<circ> \<beta>"
  shows "tiny_category \<beta> \<CC>"
proof(intro tiny_categoryI)
  show "tiny_semicategory \<beta> (cat_smc \<CC>)"
    by
      (
        rule semicategory.smc_tiny_semicategory_if_ge_Limit,
        rule cat_semicategory;
        intro assms
      )
qed (auto simp:  assms(1) cat_cs_simps cat_cs_intros vfsequence_axioms)

subsubsection\<open>Opposite tiny category\<close>

lemma (in tiny_category) tiny_category_op: "tiny_category \<alpha> (op_cat \<CC>)"
  by (intro tiny_categoryI')
    (auto simp: cat_op_simps cat_cs_intros cat_small_cs_intros)

lemmas tiny_category_op[cat_op_intros] = tiny_category.tiny_category_op

subsection\<open>Finite category\<close>

subsubsection\<open>Definition and elementary properties\<close>

text\<open>
A definition of a finite category can be found in nLab
\<^cite>\<open>"noauthor_nlab_nodate"\<close>\footnote{
\url{https://ncatlab.org/nlab/show/finite+category}
}.
\<close>

(*TODO: implicit redundant assumption*)
locale finite_category = \<Z> \<alpha> + vfsequence \<CC> + CId: vsv \<open>\<CC>\<lparr>CId\<rparr>\<close> for \<alpha> \<CC> +
  assumes fin_cat_length[cat_cs_simps]: "vcard \<CC> = 6\<^sub>\<nat>"
    and fin_cat_finite_semicategory[slicing_intros]:
      "finite_semicategory \<alpha> (cat_smc \<CC>)"
    and fin_cat_CId_vdomain[cat_cs_simps]: "\<D>\<^sub>\<circ> (\<CC>\<lparr>CId\<rparr>) = \<CC>\<lparr>Obj\<rparr>"
    and fin_cat_CId_is_arr[cat_cs_intros]:
      "a \<in>\<^sub>\<circ> \<CC>\<lparr>Obj\<rparr> \<Longrightarrow> \<CC>\<lparr>CId\<rparr>\<lparr>a\<rparr> : a \<mapsto>\<^bsub>\<CC>\<^esub> a"
    and fin_cat_CId_left_left[cat_cs_simps]:
      "f : a \<mapsto>\<^bsub>\<CC>\<^esub> b \<Longrightarrow> \<CC>\<lparr>CId\<rparr>\<lparr>b\<rparr> \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> f = f"
    and fin_cat_CId_right_left[cat_cs_simps]:
      "f : b \<mapsto>\<^bsub>\<CC>\<^esub> c \<Longrightarrow> f \<circ>\<^sub>A\<^bsub>\<CC>\<^esub> \<CC>\<lparr>CId\<rparr>\<lparr>b\<rparr> = f"

lemmas [slicing_intros] = finite_category.fin_cat_finite_semicategory

text\<open>Rules.\<close>

lemma (in finite_category) fin_category_axioms'[cat_small_cs_intros]:
  assumes "\<alpha>' = \<alpha>"
  shows "finite_category \<alpha>' \<CC>"
  unfolding assms by (rule finite_category_axioms)

mk_ide rf finite_category_def[unfolded finite_category_axioms_def]
  |intro finite_categoryI|
  |dest finite_categoryD[dest]|
  |elim finite_categoryE[elim]|

lemma finite_categoryI':
  assumes "category \<alpha> \<CC>"  and "vfinite (\<CC>\<lparr>Obj\<rparr>)" and "vfinite (\<CC>\<lparr>Arr\<rparr>)"
  shows "finite_category \<alpha> \<CC>"
proof-
  interpret category \<alpha> \<CC> by (rule assms(1))
  show ?thesis
  proof(intro finite_categoryI)
    from assms show "finite_semicategory \<alpha> (cat_smc \<CC>)"
      by (intro finite_semicategoryI') (auto simp: slicing_simps)
  qed (auto simp: vfsequence_axioms cat_cs_simps cat_cs_intros)
qed

lemma finite_categoryI'':
  assumes "tiny_category \<alpha> \<CC>" and "vfinite (\<CC>\<lparr>Obj\<rparr>)" and "vfinite (\<CC>\<lparr>Arr\<rparr>)"
  shows "finite_category \<alpha> \<CC>"
  using assms by (intro finite_categoryI') (auto intro: cat_small_cs_intros)

text\<open>Slicing.\<close>

context finite_category
begin

interpretation smc: finite_semicategory \<alpha> \<open>cat_smc \<CC>\<close>
  by (rule fin_cat_finite_semicategory)

lemmas_with [unfolded slicing_simps]:
  fin_cat_tiny_semicategory = smc.tiny_semicategory_axioms
  and fin_smc_Obj_vfinite[cat_small_cs_intros] = smc.fin_smc_Obj_vfinite
  and fin_smc_Arr_vfinite[cat_small_cs_intros] = smc.fin_smc_Arr_vfinite

end

text\<open>Elementary properties.\<close>

sublocale finite_category \<subseteq> tiny_category
  by (rule tiny_categoryI)
    (
      auto
        simp: vfsequence_axioms
        intro:
          cat_cs_intros cat_cs_simps cat_small_cs_intros
          finite_category.fin_cat_tiny_semicategory
    )

lemmas (in finite_category) fin_cat_tiny_category = tiny_category_axioms

lemmas [cat_small_cs_intros] = finite_category.fin_cat_tiny_category

lemma (in finite_category) fin_cat_in_Vset: "\<CC> \<in>\<^sub>\<circ> Vset \<alpha>"
  by (rule tiny_cat_in_Vset)

text\<open>Size.\<close>

lemma small_finite_categories[simp]: "small {\<CC>. finite_category \<alpha> \<CC>}"
proof(rule down)
  show "{\<CC>. finite_category \<alpha> \<CC>} \<subseteq> elts (set {\<CC>. tiny_category  \<alpha> \<CC>})"
    by (auto intro: cat_small_cs_intros)
qed

lemma small_finite_categories_vsubset_Vset:
  "set {\<CC>. finite_category \<alpha> \<CC>} \<subseteq>\<^sub>\<circ> Vset \<alpha>"
  by (rule vsubsetI) (simp_all add: finite_category.fin_cat_in_Vset)

subsubsection\<open>Opposite finite category\<close>

lemma (in finite_category) finite_category_op: "finite_category \<alpha> (op_cat \<CC>)"
  by (intro finite_categoryI', unfold cat_op_simps)
    (auto simp: cat_cs_intros cat_small_cs_intros)

lemmas finite_category_op[cat_op_intros] = finite_category.finite_category_op

text\<open>\newpage\<close>

end


(*
   Title: Psi-calculi
   Author/Maintainer: Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Tau_Laws_No_Weak
  imports Tau_Sim Tau_Stat_Imp
begin

context tauSum
begin

lemma tauLaw2:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"

  shows "\<Psi> \<rhd> P \<oplus> \<tau>.(P) \<approx> \<tau>.(P)"
proof -
  let ?X = "{(\<Psi>, P \<oplus> \<tau>.(P), \<tau>.(P)) | \<Psi> P. True}"
  let ?Y = "{(\<Psi>, \<tau>.(P), P \<oplus> \<tau>.(P)) | \<Psi> P. True}"

  have "(\<Psi>, P \<oplus> \<tau>.(P), \<tau>.(P)) \<in> ?X \<union> ?Y" by auto
  moreover have "eqvt(?X \<union> ?Y)" by(auto simp add: eqvt_def eqvts)
  ultimately show ?thesis
  proof(coinduct rule: weakTransitiveCoinduct)
    case(cStatImp \<Psi> P Q)
    show ?case
    proof(cases "(\<Psi>, P, Q) \<in> ?X")
      case True
      note \<open>(\<Psi>, P, Q) \<in> ?X\<close>
      moreover {
        fix \<Psi> P
        have "\<And>\<Psi>'. (\<Psi> \<otimes> \<Psi>', P \<oplus> \<tau>.(P), \<tau>.(P)) \<in> ?X \<union> ?Y \<union> weakBisim" by auto
        hence "\<Psi> \<rhd> P \<oplus> \<tau>.(P) \<lessapprox><(?X \<union> ?Y \<union> weakBisim)> \<tau>.(P)" by(rule tauLaw2StatImpLeft)
      }
      ultimately show ?thesis by blast
    next
      case False
      from \<open>(\<Psi>, P, Q) \<notin> ?X\<close> \<open>(\<Psi>, P, Q) \<in> ?X \<union> ?Y\<close> have "(\<Psi>, P, Q) \<in> ?Y" by auto
      moreover {
        fix \<Psi> P
        have "\<And>\<Psi>'. (\<Psi> \<otimes> \<Psi>', \<tau>.(P), P \<oplus> \<tau>.(P)) \<in> ?X \<union> ?Y \<union> weakBisim" by auto
        hence "\<Psi> \<rhd> \<tau>.(P) \<lessapprox><(?X \<union> ?Y \<union> weakBisim)> P \<oplus> \<tau>.(P)" by(rule tauLaw2StatImpRight)
      }
      ultimately show ?thesis by blast
    qed
  next
    case(cSim \<Psi> P Q)
    let ?Z = "{(\<Psi>, P, S) | \<Psi> P S. \<exists>Q R. \<Psi> \<rhd> P \<sim> Q \<and> (\<Psi>, Q, R) \<in> ?X \<union> ?Y \<union> weakBisim \<and> \<Psi> \<rhd> R \<sim> S}"
    show ?case

    proof(cases "(\<Psi>, P, Q) \<in> ?X")
      case True
      note \<open>(\<Psi>, P, Q) \<in> ?X\<close>
      moreover {
        fix \<Psi> P
        have "\<And>\<Psi> P. (\<Psi>, P, P) \<in> ?Z" by(blast intro: weakBisimReflexive bisimReflexive)
        moreover have "\<And>\<Psi> P Q R S. \<lbrakk>\<Psi> \<rhd> P \<sim> Q; (\<Psi>, Q, R) \<in> ?Z; \<Psi> \<rhd> R \<sim> S\<rbrakk> \<Longrightarrow> (\<Psi>, P, S) \<in> ?Z"
          by(blast intro: bisimTransitive dest: bisimE(4))
        ultimately have "\<Psi> \<rhd> P \<oplus> \<tau>.(P) \<leadsto><?Z> \<tau>.(P)" by(rule tauLaw2SimLeft)
      }
      ultimately show ?thesis by blast
    next
      case False
      from \<open>(\<Psi>, P, Q) \<notin> ?X\<close> \<open>(\<Psi>, P, Q) \<in> ?X \<union> ?Y\<close> have "(\<Psi>, P, Q) \<in> ?Y" by auto
      moreover {
        fix \<Psi> P
        have "\<And>\<Psi> P Q. \<Psi> \<rhd> P \<sim> Q \<Longrightarrow> (\<Psi>, P, Q) \<in> ?Z" by(blast intro: weakBisimReflexive bisimReflexive)
        hence "\<Psi> \<rhd> \<tau>.(P) \<leadsto><?Z> P \<oplus> \<tau>.(P)" by(rule tauLaw2SimRight)
      }
      ultimately show ?thesis by blast
    qed
  next
    case(cExt \<Psi> P Q \<Psi>')
    thus ?case by auto
  next
    case(cSym \<Psi> P Q)
    thus ?case by auto
  qed
qed

lemma tauLawPsiCong2:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"

  shows "\<Psi> \<rhd> P \<oplus> \<tau>.(P) \<doteq> \<tau>.(P)"
proof(induct rule: weakPsiCongI)
  case cWeakBisim
  thus ?case by(rule tauLaw2)
next
  case cSimLeft
  note weakBisimReflexive
  moreover have "\<And>\<Psi> P Q R S. \<lbrakk>\<Psi> \<rhd> P \<sim> Q; \<Psi> \<rhd> Q \<approx> R; \<Psi> \<rhd> R \<sim> S\<rbrakk> \<Longrightarrow> \<Psi> \<rhd> P \<approx> S"
    by(metis weakBisimTransitive strongBisimWeakBisim)
  ultimately show ?case by(rule tauLaw2CongSimLeft)
next
  case cSimRight
  from strongBisimWeakBisim show ?case by(rule tauLaw2CongSimRight)
qed

lemma tauLawCong2:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"

  shows "P \<oplus> \<tau>.(P) \<doteq>\<^sub>c \<tau>.(P)"
using tauLawPsiCong2
by(rule_tac weakCongI) auto

lemma tauLaw4:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   \<alpha> :: "'a prefix"

  shows "\<Psi> \<rhd> \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q) \<approx> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)"
proof -
  let ?X = "{(\<Psi>, \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q), \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)) | \<Psi> P \<alpha> Q. True}"
  let ?Y = "{(\<Psi>, \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q), \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)) | \<Psi> P \<alpha> Q. True}"
  have "(\<Psi>, \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q), \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)) \<in> ?X \<union> ?Y" by auto
  moreover have "eqvt(?X \<union> ?Y)" by(fastforce simp add: eqvt_def eqvts)
  ultimately show ?thesis
  proof(coinduct rule: weakTransitiveCoinduct)
    case(cStatImp \<Psi> P Q)
    show ?case
    proof(cases "(\<Psi>, P, Q) \<in> ?X")
      case True
      note \<open>(\<Psi>, P, Q) \<in> ?X\<close>
      moreover {
        fix \<Psi> \<alpha> P Q
        have "\<And>\<Psi>'. (\<Psi> \<otimes> \<Psi>', \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q), \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)) \<in> ?X \<union> ?Y \<union> weakBisim" by blast
        hence "\<Psi> \<rhd>  \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q) \<lessapprox><(?X \<union> ?Y \<union> weakBisim)>  \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)" by(rule tauLaw4StatImpLeft)
      }
      ultimately show ?thesis by blast
    next
      case False
      from \<open>(\<Psi>, P, Q) \<notin> ?X\<close> \<open>(\<Psi>, P, Q) \<in> ?X \<union> ?Y\<close> have "(\<Psi>, P, Q) \<in> ?Y" by blast
      moreover {
        fix \<Psi> \<alpha> P Q
        have "\<And>\<Psi>'. (\<Psi> \<otimes> \<Psi>', \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q), \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)) \<in> ?X \<union> ?Y \<union> weakBisim" by auto
        hence "\<Psi> \<rhd>  \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q) \<lessapprox><(?X \<union> ?Y \<union> weakBisim)> \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)" by(rule tauLaw4StatImpRight)
      }
      ultimately show ?thesis by blast
    qed
  next
    case(cSim \<Psi> P Q)
    let ?Z = "{(\<Psi>, P, S) | \<Psi> P S. \<exists>Q R. \<Psi> \<rhd> P \<sim> Q \<and> (\<Psi>, Q, R) \<in> ?X \<union> ?Y \<union> weakBisim \<and> \<Psi> \<rhd> R \<sim> S}"
    show ?case
    proof(cases "(\<Psi>, P, Q) \<in> ?X")
      case True
      note \<open>(\<Psi>, P, Q) \<in> ?X\<close>
      moreover {
        fix \<Psi> P \<alpha> Q
        have "\<And>\<Psi> P. (\<Psi>, P, P) \<in> ?Z" by(blast intro: weakBisimReflexive bisimReflexive)
        moreover have "\<And>\<Psi> P Q. \<Psi> \<rhd> P \<sim> Q \<Longrightarrow> (\<Psi>, P, Q) \<in> ?Z" by(blast intro: weakBisimReflexive bisimReflexive)
        ultimately have "\<Psi> \<rhd>  \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q) \<leadsto><?Z>  \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)" by(rule tauLaw4SimLeft)
      }
      ultimately show ?thesis by blast
    next
      case False
      from \<open>(\<Psi>, P, Q) \<notin> ?X\<close> \<open>(\<Psi>, P, Q) \<in> ?X \<union> ?Y\<close> have "(\<Psi>, P, Q) \<in> ?Y" by blast
      moreover {
        fix \<Psi> P \<alpha> Q
        have "\<And>\<Psi> P Q. \<Psi> \<rhd> P \<sim> Q \<Longrightarrow> (\<Psi>, P, Q) \<in> ?Z" by(blast intro: weakBisimReflexive bisimReflexive)
        moreover have "\<And>\<Psi> P. (\<Psi>, P, P) \<in> ?Z" by(blast intro: weakBisimReflexive bisimReflexive)
        ultimately have "\<Psi> \<rhd> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q) \<leadsto><?Z> \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)" by(rule tauLaw4SimRight)
      }
      ultimately show ?thesis by blast
    qed
  next
    case(cExt \<Psi> P Q \<Psi>')
    thus ?case by auto
  next
    case(cSym \<Psi> P Q)
    thus ?case by blast
  qed
qed

lemma tauLaw4PsiCong:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   \<alpha> :: "'a prefix"
  and   Q :: "('a, 'b, 'c) psi"

  shows "\<Psi> \<rhd> \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q) \<doteq> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)"
proof(induct rule: weakPsiCongI)
  case cWeakBisim
  show ?case by(rule tauLaw4)
next
  case cSimLeft
  from weakBisimReflexive strongBisimWeakBisim show ?case by(rule tauLaw4CongSimLeft)
next
  case cSimRight
  from strongBisimWeakBisim show ?case by(rule tauLaw4CongSimRight)
qed

lemma tauLaw4Cong:
  fixes P :: "('a, 'b, 'c) psi"
  and   \<alpha> :: "'a prefix"
  and   Q :: "('a, 'b, 'c) psi"

  shows "\<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q) \<doteq>\<^sub>c \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)"
proof(induct rule: weakCongI)
  case(cWeakPsiCong \<Psi> \<sigma>)
  show ?case
  proof(nominal_induct \<alpha> rule: prefix.strong_inducts)
  next
    case(pInput M yvec N)
    obtain p where "set p \<subseteq> set yvec \<times> set(p \<bullet> yvec)" and "(p \<bullet> yvec) \<sharp>* N" and "(p \<bullet> yvec) \<sharp>* P" and "(p \<bullet> yvec) \<sharp>* Q" and "(p \<bullet> yvec) \<sharp>* \<sigma>"
      by(rule_tac xvec=yvec and c="(N, P, Q, \<sigma>)" in name_list_avoiding) auto
    thus ?case using \<open>wellFormedSubst \<sigma>\<close> tauLaw4PsiCong[where \<alpha>="pInput (substTerm.seqSubst M \<sigma>) (p \<bullet> yvec) (substTerm.seqSubst (p \<bullet> N) \<sigma>)"]
      by(simp add: inputChainAlpha' eqvts)
  next
    case(pOutput M N)
    thus ?case using  \<open>wellFormedSubst \<sigma>\<close> tauLaw4PsiCong[where \<alpha>="pOutput (substTerm.seqSubst M \<sigma>) (substTerm.seqSubst N \<sigma>)"]
      by simp
  next
    case pTau
    thus ?case using  \<open>wellFormedSubst \<sigma>\<close> tauLaw4PsiCong[where \<alpha>="pTau"]
      by simp
  qed
qed

end

end


theory Benchmark_Set_Default
imports
  Benchmark_Set
  "~~/src/HOL/Library/Code_Target_Nat"
begin

text {* Implement set equality for all combinations of @{term "List.set"} and @{term "List.coset"} *}

ML_val {*
  val seed = (Code_Numeral.natural_of_integer 12345, Code_Numeral.natural_of_integer 67889);
  val n = @{code nat_of_integer} 30;
  val m = @{code nat_of_integer} 40;
  val c = @{code complete} n m seed;
*}

notepad begin
  have "complete 30 40 (12345, 67889) = (30, 4294967296)" by eval
end

end


theory TailCallOptimization
  imports TailCall "../06TreeCode/TreeCode" "../00Utils/Iteration"
begin

fun tco_r :: "tree_code list \<Rightarrow> tco_return" where
  "tco_r [] = TCOReturn"
| "tco_r (TApply # cd) = (case cd of
      [] \<Rightarrow> TCOJump
    | _ \<Rightarrow> tco_r cd)"
| "tco_r (op # cd) = tco_r cd"

fun tco_cd :: "tree_code list \<Rightarrow> tco_code list" where
  "tco_cd [] = []"
| "tco_cd (TLookup x # cd) = TCOLookup x # tco_cd cd"
| "tco_cd (TPushCon k # cd) = TCOPushCon k # tco_cd cd"
| "tco_cd (TPushLam cd' # cd) = TCOPushLam (tco_cd cd') (tco_r cd') # tco_cd cd"
| "tco_cd (TApply # cd) = (case cd of
      [] \<Rightarrow> []
    | _ \<Rightarrow> TCOApply # tco_cd cd)"

fun tco_cd_one :: "tree_code \<Rightarrow> tco_code" where
  "tco_cd_one (TLookup x) = TCOLookup x"
| "tco_cd_one (TPushCon k) = TCOPushCon k"
| "tco_cd_one (TPushLam cd') = TCOPushLam (tco_cd cd') (tco_r cd')"
| "tco_cd_one TApply = TCOApply"

definition tco :: "tree_code list \<Rightarrow> tco_code list \<times> tco_return" where
  "tco cd = (tco_cd cd, tco_r cd)"

primrec tco_val :: "tclosure \<Rightarrow> tco_closure" where
  "tco_val (TConst k) = TCOConst k"
| "tco_val (TLam vs cd) = TCOLam (map tco_val vs) (tco_cd cd) (tco_r cd)"

fun tco_stack_frame :: "tree_stack_frame \<Rightarrow> tco_stack_frame" where
  "tco_stack_frame (vs, cd) = (map tco_val vs, tco_cd cd, tco_r cd)"

fun live_frame :: "tco_stack_frame \<Rightarrow> bool" where
  "live_frame (vs, [], TCOReturn) = False"
| "live_frame (vs, [], TCOJump) = True"
| "live_frame (vs, op # cd, r) = True"

primrec dead_frame :: "tree_stack_frame \<Rightarrow> bool" where
  "dead_frame (vs, cd) = (cd = [])"

abbreviation tco_stack :: "tree_stack_frame list \<Rightarrow> tco_stack_frame list" where
  "tco_stack sfs \<equiv> filter live_frame (map tco_stack_frame sfs)"

primrec tco_state :: "tree_code_state \<Rightarrow> tco_code_state" where
  "tco_state (TS vs sfs) = TCOS (map tco_val vs) (tco_stack sfs)"

lemma tco_r_append [simp]: "cd' \<noteq> [] \<Longrightarrow> tco_r (cd @ cd') = tco_r cd'"
  by (induction cd) simp_all

lemma [simp]: "cd \<noteq> [] \<Longrightarrow> tco_cd (op # cd) = tco_cd_one op # tco_cd cd"
  by (induction op) (simp_all split: list.splits)

lemma tco_cd_append [simp]: "cd' \<noteq> [] \<Longrightarrow> tco_cd (cd @ cd') = map tco_cd_one cd @ tco_cd cd'"
  by (induction cd) simp_all

lemma [simp]: "cd \<noteq> [] \<Longrightarrow> cd' \<noteq> [] \<Longrightarrow> tco_cd (cd @ cd') \<noteq> []"
  by (induction cd rule: tco_cd.induct) (simp_all split: list.splits)

lemma [dest]: "(env, cd, r) # sfs = tco_stack sfs' \<Longrightarrow> \<exists>dsfs env' cd' sfs''.
  sfs' = dsfs @ (env', cd') # sfs'' \<and> env = map tco_val env' \<and> cd = tco_cd cd' \<and>
    r = tco_r cd' \<and> list_all dead_frame dsfs \<and> sfs = tco_stack sfs''"
proof (induction sfs')
  case (Cons sf sfs')
  thus ?case
  proof (induction sf)
    case (Pair env' cd')
    thus ?case
    proof (induction cd' rule: tco_cd.induct)
      case 1
      then obtain dsfs env'' cd' sfs'' where X: "sfs' = dsfs @ (env'', cd') # sfs'' \<and>
        env = map tco_val env'' \<and> cd = tco_cd cd' \<and> r = tco_r cd' \<and> list_all dead_frame dsfs \<and>
          sfs = tco_stack sfs''" by auto
      hence "\<exists>dsfsx. (env', []) # dsfs @ (env'', cd') # sfs'' = dsfsx @ (env'', cd') # sfs'' \<and>
          list_all dead_frame dsfsx \<and> sfs = tco_stack sfs''" by simp
      hence "\<exists>dsfsx sfs'''.
        (env', []) # dsfs @ (env'', cd') # sfs'' = dsfsx @ (env'', cd') # sfs''' \<and>
          list_all dead_frame dsfsx \<and> sfs = tco_stack sfs'''" by fastforce
      with X show ?case by fastforce
    next
      case (2 x cd')
      hence "env = map tco_val env' \<and> cd = TCOLookup x # tco_cd cd' \<and> r = tco_r cd' \<and>
        sfs = tco_stack sfs'" by simp
      thus ?case by fastforce
    next
      case (3 k cd')
      hence "env = map tco_val env' \<and> cd = TCOPushCon k # tco_cd cd' \<and> r = tco_r cd' \<and>
        sfs = tco_stack sfs'" by simp
      thus ?case by fastforce
    next
      case (4 cd\<^sub>l cd')
      hence "env = map tco_val env' \<and> cd = TCOPushLam (tco_cd cd\<^sub>l) (tco_r cd\<^sub>l) # tco_cd cd' \<and>
        r = tco_r cd' \<and> sfs = tco_stack sfs'" by simp
      thus ?case by fastforce
    next
      case (5 cd')
      thus ?case
      proof (cases cd')
        case Nil
        moreover with 5 have "env = map tco_val env' \<and> cd = [] \<and> r = TCOJump \<and> sfs = tco_stack sfs'"
          by simp
        ultimately show ?thesis by fastforce
      next
        case (Cons op cd'')
        moreover with 5 have "env = map tco_val env' \<and> cd = TCOApply # tco_cd (op # cd'') \<and>
          r = tco_r (op # cd'') \<and> sfs = tco_stack sfs'" by simp
        ultimately show ?thesis by fastforce
      qed
    qed
  qed
qed simp_all

lemma [dest]: "TCOS vs ((env, cd, r) # sfs) = tco_state \<Sigma> \<Longrightarrow> \<exists>dsfs vs' env' cd' sfs'.
  \<Sigma> = TS vs' (dsfs @ (env', cd') # sfs') \<and> vs = map tco_val vs' \<and> env = map tco_val env' \<and>
    cd = tco_cd cd' \<and> r = tco_r cd' \<and> list_all dead_frame dsfs \<and> sfs = tco_stack sfs'"
  by (induction \<Sigma>) auto

lemma [dest]: "TCOLookup x # cd = tco_cd cd' \<Longrightarrow> \<exists>cd''. cd' = TLookup x # cd'' \<and> cd = tco_cd cd''"
  by (induction cd' rule: tco_cd.induct) (simp_all split: list.splits)

lemma [dest]: "TCOPushCon k # cd = tco_cd cd' \<Longrightarrow> \<exists>cd''. cd' = TPushCon k # cd'' \<and> cd = tco_cd cd''"
  by (induction cd' rule: tco_cd.induct) (simp_all split: list.splits)

lemma [dest]: "TCOPushLam cd' r # cd = tco_cd cd\<^sub>t \<Longrightarrow> \<exists>cd\<^sub>t' cd\<^sub>t''. cd\<^sub>t = TPushLam cd\<^sub>t'' # cd\<^sub>t' \<and>
    cd = tco_cd cd\<^sub>t' \<and> r = tco_r cd\<^sub>t'' \<and> cd' = tco_cd cd\<^sub>t''"
  by (induction cd\<^sub>t rule: tco_cd.induct) (simp_all split: list.splits)

lemma [dest]: "TCOApply # cd = tco_cd cd' \<Longrightarrow>
    \<exists>op cd''. cd' = TApply # op # cd'' \<and> cd = tco_cd (op # cd'')"
  by (induction cd' rule: tco_cd.induct) (simp_all split: list.splits)

lemma [dest]: "TCOConst k = tco_val v \<Longrightarrow> v = TConst k"
  by (induction v) simp_all

lemma [dest]: "TCOLam env cd r = tco_val v \<Longrightarrow>
    \<exists>env\<^sub>t cd\<^sub>t. v = TLam env\<^sub>t cd\<^sub>t \<and> env = map tco_val env\<^sub>t \<and> cd = tco_cd cd\<^sub>t \<and> r = tco_r cd\<^sub>t"
  by (induction v) simp_all

lemma [dest]: "TCOReturn = tco_r cd \<Longrightarrow> [] = tco_cd cd \<Longrightarrow> cd = []"
  by (induction cd rule: tco_cd.induct) (simp_all split: list.splits)

lemma [dest]: "TCOJump = tco_r cd \<Longrightarrow> [] = tco_cd cd \<Longrightarrow> cd = [TApply]"
  by (induction cd rule: tco_cd.induct) (simp_all split: list.splits)

lemma [simp]: "list_all dead_frame dsfs \<Longrightarrow> iter (\<leadsto>\<^sub>t) (TS vs (dsfs @ sfs)) (TS vs sfs)"
proof (induction dsfs)
  case (Cons sf dsfs)
  then obtain vs' where "sf = (vs', [])" by (cases sf) simp_all
  hence "TS vs ((sf # dsfs) @ sfs) \<leadsto>\<^sub>t TS vs (dsfs @ sfs)" by simp
  with Cons show ?case by simp
qed simp_all

lemma [simp]: "\<not> live_frame fr \<Longrightarrow> iter (\<leadsto>\<^sub>t\<^sub>c\<^sub>o) (TCOS vs (fr # sfs)) (TCOS vs sfs)"
proof (induction fr rule: live_frame.induct)
  case (1 env)
  hence "TCOS vs ((env, [], TCOReturn) # sfs) \<leadsto>\<^sub>t\<^sub>c\<^sub>o TCOS vs sfs" by simp
  thus ?case by (metis iter_one)
qed simp_all

lemma [simp]: "tco_cd (op # cd) = [] \<Longrightarrow> tco_r (op # cd) = TCOJump"
  by (induction op) (simp_all split: list.splits)

lemma [simp]: "live_frame (env, cd, TCOJump)"
  by (induction cd) simp_all

lemma tco_never_dead [simp]: "live_frame (env, tco_cd (op # cd), tco_r (op # cd))"
  by (induction op) (simp_all split: list.splits)

theorem completetco [simp]: "tco_state \<Sigma>\<^sub>t \<leadsto>\<^sub>t\<^sub>c\<^sub>o \<Sigma>' \<Longrightarrow> full_state \<Sigma>\<^sub>t \<Longrightarrow> \<exists>\<Sigma>\<^sub>t'. iter (\<leadsto>\<^sub>t) \<Sigma>\<^sub>t \<Sigma>\<^sub>t' \<and>
  iter (\<leadsto>\<^sub>t\<^sub>c\<^sub>o) \<Sigma>' (tco_state \<Sigma>\<^sub>t')"
proof (induction "tco_state \<Sigma>\<^sub>t" \<Sigma>' rule: evaltco.induct)
  case (evtco_lookup env x v vs cd r sfs)
  then obtain dsfs vs' env' cd' sfs' where S:
    "\<Sigma>\<^sub>t = TS vs' (dsfs @ (env', TLookup x # cd') # sfs') \<and> vs = map tco_val vs' \<and>
      env = map tco_val env' \<and> cd = tco_cd cd' \<and> r = tco_r cd' \<and> list_all dead_frame dsfs \<and>
        sfs = tco_stack sfs'" by fastforce
  with evtco_lookup obtain v' where V: "lookup env' x = Some v' \<and> v = tco_val v'" by fastforce
  from S have "iter (\<leadsto>\<^sub>t) (TS vs' (dsfs @ (env', TLookup x # cd') # sfs'))
    (TS vs' ((env', TLookup x # cd') # sfs'))" by simp
  moreover from V have "iter (\<leadsto>\<^sub>t) (TS vs' ((env', TLookup x # cd') # sfs'))
    (TS (v' # vs') ((env', cd') # sfs'))" by (metis evt_lookup iter_one)
  ultimately have X: "iter (\<leadsto>\<^sub>t) (TS vs' (dsfs @ (env', TLookup x # cd') # sfs'))
    (TS (v' # vs') ((env', cd') # sfs'))" by (metis iter_append)
  from S V have "iter (\<leadsto>\<^sub>t\<^sub>c\<^sub>o) (TCOS (v # map tco_val vs')
    ((map tco_val env', tco_cd cd', tco_r cd') # tco_stack sfs'))
      (tco_state (TS (v' # vs') ((env', cd') # sfs')))" by simp
  with S X show ?case by blast
next
  case (evtco_pushcon vs env k cd r sfs)
  then obtain dsfs vs' env' cd' sfs' where S:
    "\<Sigma>\<^sub>t = TS vs' (dsfs @ (env', TPushCon k # cd') # sfs') \<and> vs = map tco_val vs' \<and>
      env = map tco_val env' \<and> cd = tco_cd cd' \<and> r = tco_r cd' \<and> list_all dead_frame dsfs \<and>
        sfs = tco_stack sfs'" by fastforce
  hence "iter (\<leadsto>\<^sub>t) (TS vs' (dsfs @ (env', TPushCon k # cd') # sfs'))
    (TS vs' ((env', TPushCon k # cd') # sfs'))" by simp
  moreover have "iter (\<leadsto>\<^sub>t) (TS vs' ((env', TPushCon k # cd') # sfs'))
    (TS (TConst k # vs') ((env', cd') # sfs'))" by (metis evt_pushcon iter_one)
  ultimately have X: "iter (\<leadsto>\<^sub>t) (TS vs' (dsfs @ (env', TPushCon k # cd') # sfs'))
    (TS (TConst k # vs') ((env', cd') # sfs'))" by simp
  from S have "iter (\<leadsto>\<^sub>t\<^sub>c\<^sub>o) (TCOS (TCOConst k # map tco_val vs')
    ((map tco_val env', tco_cd cd', tco_r cd') # tco_stack sfs'))
      (tco_state (TS (TConst k # vs') ((env', cd') # sfs')))" by simp
  with S X show ?case by blast
next
  case (evtco_pushlam vs env cd' r' cd r sfs)
  then obtain dsfs vs\<^sub>t env\<^sub>t cd\<^sub>t cd\<^sub>t' sfs\<^sub>t where S:
    "\<Sigma>\<^sub>t = TS vs\<^sub>t (dsfs @ (env\<^sub>t, TPushLam cd\<^sub>t' # cd\<^sub>t) # sfs\<^sub>t) \<and> vs = map tco_val vs\<^sub>t \<and>
      env = map tco_val env\<^sub>t \<and> cd = tco_cd cd\<^sub>t \<and> cd' = tco_cd cd\<^sub>t' \<and> r' = tco_r cd\<^sub>t' \<and>
        r = tco_r cd\<^sub>t \<and> list_all dead_frame dsfs \<and> sfs = tco_stack sfs\<^sub>t" by fastforce
  hence "iter (\<leadsto>\<^sub>t) (TS vs\<^sub>t (dsfs @ (env\<^sub>t, TPushLam cd\<^sub>t' # cd\<^sub>t) # sfs\<^sub>t))
    (TS vs\<^sub>t ((env\<^sub>t, TPushLam cd\<^sub>t' # cd\<^sub>t) # sfs\<^sub>t))" by simp
  moreover have "iter (\<leadsto>\<^sub>t) (TS vs\<^sub>t ((env\<^sub>t, TPushLam cd\<^sub>t' # cd\<^sub>t) # sfs\<^sub>t))
    (TS (TLam env\<^sub>t cd\<^sub>t' # vs\<^sub>t) ((env\<^sub>t, cd\<^sub>t) # sfs\<^sub>t))" by (metis evt_pushlam iter_one)
  ultimately have X: "iter (\<leadsto>\<^sub>t) (TS vs\<^sub>t (dsfs @ (env\<^sub>t, TPushLam cd\<^sub>t' # cd\<^sub>t) # sfs\<^sub>t))
    (TS (TLam env\<^sub>t cd\<^sub>t' # vs\<^sub>t) ((env\<^sub>t, cd\<^sub>t) # sfs\<^sub>t))" by simp
  from S have "iter (\<leadsto>\<^sub>t\<^sub>c\<^sub>o) (TCOS (TCOLam env cd' r' # map tco_val vs\<^sub>t)
    ((map tco_val env\<^sub>t, tco_cd cd\<^sub>t, tco_r cd\<^sub>t) # tco_stack sfs\<^sub>t))
      (tco_state (TS (TLam env\<^sub>t cd\<^sub>t' # vs\<^sub>t) ((env\<^sub>t, cd\<^sub>t) # sfs\<^sub>t)))" by simp
  with S X show ?case by blast
next
  case (evtco_apply v env' cd' r' vs env cd r sfs)
  then obtain dsfs v\<^sub>t vl vs\<^sub>t env\<^sub>t cd\<^sub>t'' sfs\<^sub>t where S:
    "\<Sigma>\<^sub>t = TS (v\<^sub>t # vl # vs\<^sub>t) (dsfs @ (env\<^sub>t, cd\<^sub>t'') # sfs\<^sub>t) \<and> v = tco_val v\<^sub>t \<and>
      TCOLam env' cd' r' = tco_val vl \<and> vs = map tco_val vs\<^sub>t \<and> env = map tco_val env\<^sub>t \<and>
        TCOApply # cd = tco_cd cd\<^sub>t'' \<and> r = tco_r cd\<^sub>t'' \<and> list_all dead_frame dsfs \<and>
          sfs = tco_stack sfs\<^sub>t" by blast
  then obtain op cd\<^sub>t where C: "cd\<^sub>t'' = TApply # op # cd\<^sub>t \<and> cd = tco_cd (op # cd\<^sub>t)" by blast
  from S obtain env\<^sub>t' cd\<^sub>t' where V: "vl = TLam env\<^sub>t' cd\<^sub>t' \<and> env' = map tco_val env\<^sub>t' \<and>
    cd' = tco_cd cd\<^sub>t' \<and> r' = tco_r cd\<^sub>t'" by blast
  from S have "iter (\<leadsto>\<^sub>t) (TS (v\<^sub>t # TLam env\<^sub>t' cd\<^sub>t' # vs\<^sub>t) (dsfs @ (env\<^sub>t, TApply # op # cd\<^sub>t) # sfs\<^sub>t))
    (TS (v\<^sub>t # TLam env\<^sub>t' cd\<^sub>t' # vs\<^sub>t) ((env\<^sub>t, TApply # op # cd\<^sub>t) # sfs\<^sub>t))" by simp
  moreover have "TS (v\<^sub>t # TLam env\<^sub>t' cd\<^sub>t' # vs\<^sub>t) ((env\<^sub>t, TApply # op # cd\<^sub>t) # sfs\<^sub>t) \<leadsto>\<^sub>t
    TS vs\<^sub>t ((v\<^sub>t # env\<^sub>t', cd\<^sub>t') # (env\<^sub>t, op # cd\<^sub>t) # sfs\<^sub>t)" by simp
  ultimately have X: "iter (\<leadsto>\<^sub>t) (TS (v\<^sub>t # TLam env\<^sub>t' cd\<^sub>t' # vs\<^sub>t)
    (dsfs @ (env\<^sub>t, TApply # op # cd\<^sub>t) # sfs\<^sub>t)) (TS vs\<^sub>t ((v\<^sub>t # env\<^sub>t', cd\<^sub>t') # (env\<^sub>t, op # cd\<^sub>t) # sfs\<^sub>t))"
      by simp
  from evtco_apply S V have "full_block cd\<^sub>t' 0 = Some (Suc 0)" by simp
  hence "live_frame (tco_val v\<^sub>t # map tco_val env\<^sub>t', tco_cd cd\<^sub>t', tco_r cd\<^sub>t')"
    by (induction cd\<^sub>t' rule: tco_cd.induct) (simp_all split: list.splits)
  with S have "iter (\<leadsto>\<^sub>t\<^sub>c\<^sub>o) (TCOS (map tco_val vs\<^sub>t) ((tco_val v\<^sub>t # map tco_val env\<^sub>t', tco_cd cd\<^sub>t',
    tco_r cd\<^sub>t') # (map tco_val env\<^sub>t, tco_cd (op # cd\<^sub>t), tco_r (TApply # op # cd\<^sub>t)) # tco_stack sfs\<^sub>t))
      (tco_state (TS vs\<^sub>t ((v\<^sub>t # env\<^sub>t', cd\<^sub>t') # (env\<^sub>t, op # cd\<^sub>t) # sfs\<^sub>t)))" by simp
  with S C V X show ?case by blast
next
  case (evtco_return vs env sfs)
  then obtain dsfs vs' env' sfs' where S: "\<Sigma>\<^sub>t = TS vs' (dsfs @ (env', []) # sfs') \<and>
    vs = map tco_val vs' \<and> env = map tco_val env' \<and> list_all dead_frame dsfs \<and> sfs = tco_stack sfs'"
      by blast
  hence "iter (\<leadsto>\<^sub>t) (TS vs' (dsfs @ (env', []) # sfs')) (TS vs' ((env', []) # sfs'))" by simp
  moreover have "iter (\<leadsto>\<^sub>t) (TS vs' ((env', []) # sfs')) (TS vs' sfs')" by (simp add: iter_one)
  ultimately have X: "iter (\<leadsto>\<^sub>t) (TS vs' (dsfs @ (env', []) # sfs')) (TS vs' sfs')" by simp
  from S have "iter (\<leadsto>\<^sub>t\<^sub>c\<^sub>o) (TCOS vs sfs) (tco_state (TS vs' sfs'))" by simp
  with S X show ?case by blast
next
  case (evtco_jump v env' cd' r' vs env sfs)
  then obtain dsfs v\<^sub>t vl vs\<^sub>t env\<^sub>t cd\<^sub>t sfs\<^sub>t where S:
    "\<Sigma>\<^sub>t = TS (v\<^sub>t # vl # vs\<^sub>t) (dsfs @ (env\<^sub>t, cd\<^sub>t) # sfs\<^sub>t) \<and> v = tco_val v\<^sub>t \<and>
      TCOLam env' cd' r' = tco_val vl \<and> vs = map tco_val vs\<^sub>t \<and> env = map tco_val env\<^sub>t \<and>
        [] = tco_cd cd\<^sub>t \<and> TCOJump = tco_r cd\<^sub>t \<and> list_all dead_frame dsfs \<and>
          sfs = tco_stack sfs\<^sub>t" by blast
  then obtain env\<^sub>t' cd\<^sub>t' where V: "vl = TLam env\<^sub>t' cd\<^sub>t' \<and> env' = map tco_val env\<^sub>t' \<and>
    cd' = tco_cd cd\<^sub>t' \<and> r' = tco_r cd\<^sub>t'" by blast
  from S have C: "cd\<^sub>t = [TApply]" by blast
  with S have "iter (\<leadsto>\<^sub>t) (TS (v\<^sub>t # TLam env\<^sub>t' cd\<^sub>t' # vs\<^sub>t) (dsfs @ (env\<^sub>t, [TApply]) # sfs\<^sub>t))
    (TS (v\<^sub>t # TLam env\<^sub>t' cd\<^sub>t' # vs\<^sub>t) ((env\<^sub>t, [TApply]) # sfs\<^sub>t))" by simp
  moreover have "iter (\<leadsto>\<^sub>t) (TS (v\<^sub>t # TLam env\<^sub>t' cd\<^sub>t' # vs\<^sub>t) ((env\<^sub>t, [TApply]) # sfs\<^sub>t))
    (TS vs\<^sub>t ((v\<^sub>t # env\<^sub>t', cd\<^sub>t') # (env\<^sub>t, []) # sfs\<^sub>t))" by (simp add: iter_one)
  ultimately have X: "iter (\<leadsto>\<^sub>t) (TS (v\<^sub>t # TLam env\<^sub>t' cd\<^sub>t' # vs\<^sub>t) (dsfs @ (env\<^sub>t, [TApply]) # sfs\<^sub>t))
    (TS vs\<^sub>t ((v\<^sub>t # env\<^sub>t', cd\<^sub>t') # (env\<^sub>t, []) # sfs\<^sub>t))" using iter_append by fastforce
  have "iter (\<leadsto>\<^sub>t\<^sub>c\<^sub>o) (TCOS (map tco_val vs\<^sub>t) ((tco_val v\<^sub>t # map tco_val env\<^sub>t', tco_cd cd\<^sub>t', tco_r cd\<^sub>t')
    # tco_stack sfs\<^sub>t)) (tco_state (TS vs\<^sub>t ((v\<^sub>t # env\<^sub>t', cd\<^sub>t') # (env\<^sub>t, []) # sfs\<^sub>t)))" by simp
  with S V C X show ?case by blast
qed

theorem correcttco [simp]: "\<Sigma> \<leadsto>\<^sub>t \<Sigma>' \<Longrightarrow> iter (\<leadsto>\<^sub>t\<^sub>c\<^sub>o) (tco_state \<Sigma>) (tco_state \<Sigma>')"
proof (induction \<Sigma> \<Sigma>' rule: evalt.induct)
  case (evt_lookup env x v vs cd sfs)
  thus ?case
  proof (cases cd)
    case Nil
    have "TCOS (tco_val v # map tco_val vs) ((map tco_val env, [], TCOReturn) # tco_stack sfs) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
      TCOS (tco_val v # map tco_val vs) (tco_stack sfs)" by (metis evtco_return)
    hence "TCOS (tco_val v # map tco_val vs) ((map tco_val env, [], TCOReturn) # tco_stack sfs) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
      tco_state (TS (v # vs) ((env, []) # sfs))" by simp
    moreover from evt_lookup have "tco_state (TS vs ((env, [TLookup x]) # sfs)) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
      TCOS (tco_val v # map tco_val vs) ((map tco_val env, [], TCOReturn) # tco_stack sfs)" by simp
    ultimately have "iter (\<leadsto>\<^sub>t\<^sub>c\<^sub>o) (tco_state (TS vs ((env, [TLookup x]) # sfs)))
      (tco_state (TS (v # vs) ((env, []) # sfs)))" by (metis iter_refl iter_step)
    with Nil show ?thesis by simp
  next
    case (Cons op cd)
    moreover from evt_lookup have "tco_state (TS vs ((env, TLookup x # op # cd) # sfs)) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
      tco_state (TS (v # vs) ((env, op # cd) # sfs))" by simp
    ultimately show ?thesis by (metis iter_one)
  qed
next
  case (evt_pushcon vs env k cd sfs)
  thus ?case
  proof (cases cd)
    case Nil
    have "TCOS (TCOConst k # map tco_val vs) ((map tco_val env, [], TCOReturn) # tco_stack sfs) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
        TCOS (TCOConst k # map tco_val vs) (tco_stack sfs)" by (metis evtco_return)
    hence "TCOS (TCOConst k # map tco_val vs)
      ((map tco_val env, [], TCOReturn) # tco_stack sfs) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
        tco_state (TS (TConst k # vs) ((env, []) # sfs))" by simp
    moreover have "tco_state (TS vs ((env, [TPushCon k]) # sfs)) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
      TCOS (TCOConst k # map tco_val vs)
        ((map tco_val env, [], TCOReturn) # tco_stack sfs)" by simp
    ultimately have "iter (\<leadsto>\<^sub>t\<^sub>c\<^sub>o) (tco_state (TS vs ((env, [TPushCon k]) # sfs)))
      (tco_state (TS (TConst k # vs) ((env, []) # sfs)))" by (metis iter_refl iter_step)
    with Nil show ?thesis by simp
  next
    case (Cons op cd)
    moreover have "tco_state (TS vs ((env, TPushCon k # op # cd) # sfs)) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
      tco_state (TS (TConst k # vs) ((env, op # cd) # sfs))" by simp
    ultimately show ?thesis by (metis iter_one)
  qed
next
  case (evt_pushlam vs env cd' cd sfs)
  thus ?case
  proof (cases cd)
    case Nil
    have "TCOS (map tco_val vs) ((map tco_val env,
      [TCOPushLam (tco_cd cd') (tco_r cd')], TCOReturn) # tco_stack sfs) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
        TCOS (TCOLam (map tco_val env) (tco_cd cd') (tco_r cd') # map tco_val vs)
          ((map tco_val env, [], TCOReturn) # tco_stack sfs)" by (metis evtco_pushlam)
    hence X: "tco_state (TS vs ((env, [TPushLam cd']) # sfs)) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
      TCOS (TCOLam (map tco_val env) (tco_cd cd') (tco_r cd') # map tco_val vs)
        ((map tco_val env, [], TCOReturn) # tco_stack sfs)" by simp
    have "TCOS (TCOLam (map tco_val env) (tco_cd cd') (tco_r cd') #
      map tco_val vs) ((map tco_val env, [], TCOReturn) # tco_stack sfs) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
        TCOS (TCOLam (map tco_val env) (tco_cd cd') (tco_r cd') # map tco_val vs) (tco_stack sfs)"
          by (metis evtco_return)
    hence "TCOS (TCOLam (map tco_val env) (tco_cd cd') (tco_r cd') #
      map tco_val vs) ((map tco_val env, [], TCOReturn) # tco_stack sfs) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
        tco_state (TS (TLam env cd' # vs) ((env, []) # sfs))" by simp
    with X have "iter (\<leadsto>\<^sub>t\<^sub>c\<^sub>o) (tco_state (TS vs ((env, [TPushLam cd']) # sfs)))
      (tco_state (TS (TLam env cd' # vs) ((env, []) # sfs)))" by (metis iter_refl iter_step)
    with Nil show ?thesis by simp
  next
    case (Cons op cd)
    have "TCOS (map tco_val vs) ((map tco_val env, TCOPushLam (tco_cd cd') (tco_r cd') #
      tco_cd (op # cd), tco_r (op # cd)) # tco_stack sfs) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
        TCOS (TCOLam (map tco_val env) (tco_cd cd') (tco_r cd') # map tco_val vs)
          ((map tco_val env, tco_cd (op # cd), tco_r (op # cd)) # tco_stack sfs)"
      by (metis evtco_pushlam)
    hence "tco_state (TS vs ((env, TPushLam cd' # op # cd) # sfs)) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
      tco_state (TS (TLam env cd' # vs) ((env, op # cd) # sfs))" by simp
    with Cons show ?thesis by (metis iter_one)
  qed
next
  case (evt_apply v env' cd' vs env cd sfs)
  thus ?case
  proof (cases cd)
    case Nil note CD = Nil
    thus ?thesis
    proof (cases cd')
      case Nil
      have "TCOS (map tco_val vs) ((tco_val v # map tco_val env', [], TCOReturn) # tco_stack sfs)
        \<leadsto>\<^sub>t\<^sub>c\<^sub>o TCOS (map tco_val vs) (tco_stack sfs)" by (metis evtco_return)
      hence "TCOS (map tco_val vs) ((tco_val v # map tco_val env', [], TCOReturn) # tco_stack sfs)
        \<leadsto>\<^sub>t\<^sub>c\<^sub>o tco_state (TS vs ((v # env', []) # (env, []) # sfs))" by simp
      hence X: "iter (\<leadsto>\<^sub>t\<^sub>c\<^sub>o) (TCOS (map tco_val vs) ((tco_val v # map tco_val env', [], TCOReturn) #
        tco_stack sfs)) (tco_state (TS vs ((v # env', []) # (env, []) # sfs)))" by (metis iter_one)
      have "TCOS (tco_val v # TCOLam (map tco_val env') [] TCOReturn #
        map tco_val vs) ((map tco_val env, [], TCOJump) # tco_stack sfs) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
          TCOS (map tco_val vs) ((tco_val v # map tco_val env', [], TCOReturn) #
            tco_stack sfs)" by (metis evtco_jump)
      hence "tco_state (TS (v # TLam env' [] # vs) ((env, [TApply]) # sfs)) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
        TCOS (map tco_val vs) ((tco_val v # map tco_val env', [], TCOReturn) # tco_stack sfs)"
          by simp
      with X have "iter (\<leadsto>\<^sub>t\<^sub>c\<^sub>o) (tco_state (TS (v # TLam env' [] # vs) ((env, [TApply]) # sfs)))
        (tco_state (TS vs ((v # env', []) # (env, []) # sfs)))" using iter_step by fast
      with CD Nil show ?thesis by simp
    next
      case (Cons op' cd'')
      have "TCOS (tco_val v # TCOLam (map tco_val env') (tco_cd (op' # cd'')) (tco_r (op' # cd'')) #
        map tco_val vs) ((map tco_val env, [], TCOJump) # tco_stack sfs) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
          TCOS (map tco_val vs) ((tco_val v # map tco_val env', tco_cd (op' # cd''),
            tco_r (op' # cd'')) # tco_stack sfs)"  by (metis evtco_jump)
      hence "tco_state (TS (v # TLam env' (op' # cd'') # vs) ((env, [TApply]) # sfs)) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
        tco_state (TS vs ((v # env', op' # cd'') # (env, []) # sfs))" by simp
      with Nil Cons show ?thesis by (metis iter_one)
    qed
  next
    case (Cons op cd) note CD = Cons
    thus ?thesis
    proof (cases cd')
      case Nil
      have "TCOS (map tco_val vs) ((tco_val v # map tco_val env', [], TCOReturn) #
        (map tco_val env, tco_cd (op # cd), tco_r (op # cd)) # tco_stack sfs) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
          TCOS (map tco_val vs) ((map tco_val env, tco_cd (op # cd),
            tco_r (op # cd)) # tco_stack sfs)" by (metis evtco_return)
      hence "TCOS (map tco_val vs) ((tco_val v # map tco_val env', [], TCOReturn) #
        (map tco_val env, tco_cd (op # cd), tco_r (op # cd)) # tco_stack sfs) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
            tco_state (TS vs ((v # env', []) # (env, op # cd) # sfs))" by simp
      hence X: "iter (\<leadsto>\<^sub>t\<^sub>c\<^sub>o) (TCOS (map tco_val vs) ((tco_val v # map tco_val env', [], TCOReturn) #
        (map tco_val env, tco_cd (op # cd), tco_r (op # cd)) # tco_stack sfs))
          (tco_state (TS vs ((v # env', []) # (env, op # cd) # sfs)))" by (metis iter_one)
      have "tco_state (TS (v # TLam env' [] # vs) ((env, TApply # op # cd) # sfs)) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
        TCOS (map tco_val vs) ((tco_val v # map tco_val env', [], TCOReturn) #
          (map tco_val env, tco_cd (op # cd), tco_r (op # cd)) # tco_stack sfs)" by simp
      with X have "iter (\<leadsto>\<^sub>t\<^sub>c\<^sub>o) (tco_state (TS (v # TLam env' [] # vs)
        ((env, TApply # op # cd) # sfs)))
          (tco_state (TS vs ((v # env', []) # (env, op # cd) # sfs)))"
        using iter_step by fast
      with Cons Nil show ?thesis by simp
    next
      case (Cons op' cd')
      have "tco_state (TS (v # TLam env' (op' # cd') # vs)
        ((env, TApply # op # cd) # sfs)) \<leadsto>\<^sub>t\<^sub>c\<^sub>o
          tco_state (TS vs ((v # env', (op' # cd')) # (env, op # cd) # sfs))" by simp
      with CD Cons show ?thesis by (metis iter_one)
    qed
  qed
qed simp_all

lemma iter_tco_eval [simp]: "iter (\<leadsto>\<^sub>t) \<Sigma> \<Sigma>' \<Longrightarrow> iter (\<leadsto>\<^sub>t\<^sub>c\<^sub>o) (tco_state \<Sigma>) (tco_state \<Sigma>')"
  by (induction \<Sigma> \<Sigma>' rule: iter.induct) (simp, metis iter_append correcttco)

end