theory PhiSem_Aggregate_Tuple
  imports PhiSem_Aggregate_Base
begin

section \<open>Semantics\<close>

subsection \<open>Models\<close>

subsubsection \<open>Type\<close>

virtual_datatype tuple_ty =
  tup     :: \<open>'self list\<close>

debt_axiomatization T_tup :: \<open>TY list type_entry\<close>
  where tuple_ty_ax: \<open>tuple_ty TY_CONS_OF T_tup\<close>

interpretation tuple_ty TY_CONS_OF \<open>TYPE(TY_N)\<close> \<open>TYPE(TY)\<close> T_tup using tuple_ty_ax .

(*TODO: intergrate the hidding into the automation command*)
hide_fact tuple_ty_ax

subsubsection \<open>Value\<close>

virtual_datatype tuple_val =
  V_tup     :: \<open>'self list\<close>

debt_axiomatization V_tup :: \<open>VAL list value_entry\<close>
  where tuple_val_ax: \<open>tuple_val VAL_CONS_OF V_tup\<close>

interpretation tuple_val VAL_CONS_OF \<open>TYPE(VAL_N)\<close> \<open>TYPE(VAL)\<close> V_tup
  using tuple_val_ax .

hide_fact tuple_val_ax

abbreviation \<open>tup \<equiv> tup.mk\<close>

subsection \<open>Semantics\<close>

debt_axiomatization
        WT_tup[simp]: \<open>Well_Type (tup ts)  = { V_tup.mk vs       |vs. list_all2 (\<lambda> t v. v \<in> Well_Type t) ts vs }\<close>
  and   zero_tup[simp]: \<open>Zero (tup Ts)     = map_option V_tup.mk (those (map Zero Ts))\<close>
  and   V_tup_sep_disj_R[simp]: \<open>V_tup.mk l1 ## vl2 \<longleftrightarrow> (\<exists>l2. vl2 = V_tup.mk l2)\<close>
  and   V_tup_sep_disj_L[simp]: \<open>vl1 ## V_tup.mk l2 \<longleftrightarrow> (\<exists>l1. vl1 = V_tup.mk l1)\<close>
  and   V_tup_mult    : \<open>V_tup.mk l1 * V_tup.mk l2 = V_tup.mk (l2 @ l1)\<close>
  and   idx_step_type_tup [eval_semantic_index] : \<open>i < length tys \<Longrightarrow> idx_step_type i (tup tys) = tys!i \<close>
  and   valid_idx_step_tup[eval_semantic_index] : \<open>valid_idx_step (tup tys) i \<longleftrightarrow> i < length tys\<close>
  and   idx_step_value_tup[eval_semantic_index] : \<open>idx_step_value i (V_tup.mk vs) = vs!i\<close>
  and   idx_step_mod_value_tup : \<open>idx_step_mod_value i f (V_tup.mk vs) = V_tup.mk (vs[i := f (vs!i)])\<close>

lemma V_tup_mult_cons:
  \<open>NO_MATCH vs ([]::VAL list) \<Longrightarrow> V_tup.mk (v#vs) = V_tup.mk vs * V_tup.mk [v]\<close>
  using V_tup_mult by simp

lemma list_all_replicate:
  \<open>list_all P (replicate n x) \<longleftrightarrow> n = 0 \<or> P x\<close>
  by (induct n; simp; blast)

(* lemma Valid_Type_\<tau>Tuple[simp]:
  \<open>Valid_Type (tup Ts) \<longleftrightarrow> list_all Valid_Type Ts\<close>
  unfolding Inhabited_def
  by (simp; induct Ts; simp add: list_all2_Cons1) *)

section \<open>\<phi>Type\<close>

subsection \<open>Empty Tuple\<close>

definition EmptyTuple :: \<open>(VAL, unit) \<phi>\<close>
  where \<open>EmptyTuple x = { V_tup.mk [] }\<close>

lemma EmptyTuple_expn[\<phi>expns]:
  \<open>p \<in> (x \<Ztypecolon> EmptyTuple) \<longleftrightarrow> p = V_tup.mk []\<close>
  unfolding EmptyTuple_def \<phi>Type_def by simp

subsection \<open>Field\<close>

definition Tuple_Field :: "(VAL, 'a) \<phi> \<Rightarrow> (VAL, 'a) \<phi>"
  where "Tuple_Field T x = { V_tup.mk [v] |v. v \<in> T x }"

syntax "_\<phi>Tuple" :: \<open>tuple_args \<Rightarrow> logic\<close> ("\<lbrace> _ \<rbrace>")

translations
  "_\<phi>Tuple (_tuple_arg X)" \<rightleftharpoons> "CONST Tuple_Field X"
  "_\<phi>Tuple (_tuple_args y z)" \<rightleftharpoons> "CONST \<phi>Prod (_\<phi>Tuple (_tuple_arg y)) (_\<phi>Tuple z)"

lemma Tuple_Field_expn[\<phi>expns]:
  \<open>p \<in> (x \<Ztypecolon> \<lbrace> T \<rbrace>) \<longleftrightarrow> (\<exists>v. p = V_tup.mk [v] \<and> v \<in> (x \<Ztypecolon> T))\<close>
  unfolding Tuple_Field_def \<phi>Type_def by simp

lemma Tuple_Field_inhabited[elim!,\<phi>inhabitance_rule]:
  \<open>Inhabited (x \<Ztypecolon> \<lbrace> T \<rbrace>) \<Longrightarrow> (Inhabited (x \<Ztypecolon> T) \<Longrightarrow> C) \<Longrightarrow> C\<close>
  unfolding Inhabited_def by (simp add: \<phi>expns)

lemma EmptyTuple_reduce[simp]:
  \<open>(((),a) \<Ztypecolon> EmptyTuple \<^emph> \<lbrace> T \<rbrace>) = (a \<Ztypecolon> \<lbrace> T \<rbrace>)\<close>
  \<open>((a,()) \<Ztypecolon> \<lbrace> T \<rbrace> \<^emph> EmptyTuple) = (a \<Ztypecolon> \<lbrace> T \<rbrace>)\<close>
  unfolding set_eq_iff
  apply (clarsimp; rule; clarsimp simp add: \<phi>expns V_tup_mult)
  apply (metis V_tup_mult append_Nil)
  apply (clarsimp; rule; clarsimp simp add: \<phi>expns V_tup_mult)
  by (metis V_tup_mult append.right_neutral)

lemma Tuple_Field_zero  [\<phi>reason 1000]:
  \<open>\<phi>Zero ty T x \<Longrightarrow> \<phi>Zero (tup [ty]) \<lbrace> T \<rbrace> x \<close>
  unfolding \<phi>Zero_def by (clarsimp simp add: \<phi>expns)

lemma Tuple_Field_zeros [\<phi>reason 1000]:
  \<open>\<phi>Zero ty T x
    \<Longrightarrow> \<phi>Zero (tup tys) Ts xs
    \<Longrightarrow> \<phi>Zero (tup (ty#tys)) (\<lbrace> T \<rbrace> \<^emph> Ts) (x,xs) \<close>
  unfolding \<phi>Zero_def
  apply (clarsimp simp add: \<phi>expns V_tup_mult_cons image_iff)
  using V_tup_sep_disj_L by blast

lemma Tuple_Field_semty[\<phi>reason 1000]:
  \<open> \<phi>SemType (x \<Ztypecolon> T) TY
\<Longrightarrow> \<phi>SemType (x \<Ztypecolon> \<lbrace> T \<rbrace>) (tup [TY])\<close>
  unfolding \<phi>SemType_def subset_iff
  by (clarsimp simp add: \<phi>expns)

lemma Tuple_Field_semtys[\<phi>reason 1000]:
  \<open> \<phi>SemType (x \<Ztypecolon> T) TY
\<Longrightarrow> \<phi>SemType (xs \<Ztypecolon> Ts) (tup TYs)
\<Longrightarrow> \<phi>SemType ((x,xs) \<Ztypecolon> (\<lbrace> T \<rbrace> \<^emph> Ts)) (tup (TY#TYs))\<close>
  unfolding \<phi>SemType_def subset_iff
  apply (clarsimp simp add: \<phi>expns)
  by (metis V_tup_mult append.left_neutral append_Cons list.rel_inject(2))

section \<open>Reasoning\<close>

subsection \<open>Show validity of an index for a type\<close>

declare [[\<phi>trace_reasoning = 1]]

lemma [\<phi>reason 1200]:
  \<open> \<s>\<i>\<m>\<p>\<r>\<e>\<m> i < length Tys
\<Longrightarrow> Simplify eval_semantic_index Ty (Tys!i)
\<Longrightarrow> valid_index Ty L
\<Longrightarrow> valid_index (tup Tys) (i#L)\<close>
  unfolding Premise_def Simplify_def
  by (simp add: valid_idx_step_tup idx_step_type_tup)

subsection \<open>Index\<close>

lemma idx_step_value_V_tup_suc:
  \<open>idx_step_value (Suc i) (V_tup.mk (va # vs)) = idx_step_value i (V_tup.mk vs)\<close>
  by (simp add: idx_step_value_tup)

lemma idx_step_mod_value_V_tup_suc:
  \<open>idx_step_mod_value (Suc i) g (V_tup.mk (va # vs)) = idx_step_mod_value i g (V_tup.mk vs) * V_tup.mk [va]\<close>
  by (metis NO_MATCH_I V_tup_mult_cons idx_step_mod_value_tup list_update_code(3) nth_Cons_Suc)

declare [[\<phi>trace_reasoning = 1]]

lemma [\<phi>reason 1200]:
  \<open> \<phi>Index_getter (i # idx) X Y f
\<Longrightarrow> \<phi>Index_getter (Suc i # idx) (\<lbrace> T \<rbrace> \<^emph> X) Y (f o snd)\<close>
  unfolding \<phi>Index_getter_def
  by (clarsimp simp add: \<phi>expns V_tup_mult idx_step_value_V_tup_suc)

lemma [\<phi>reason 1200]:
  \<open> \<phi>Index_getter idx X Y f
\<Longrightarrow> \<phi>Index_getter (0 # idx) \<lbrace> X \<rbrace> Y f\<close>
  unfolding \<phi>Index_getter_def
  by (clarsimp simp add: \<phi>expns V_tup_mult idx_step_value_tup)

lemma [\<phi>reason 1200]:
  \<open> \<phi>Index_getter idx X Y f
\<Longrightarrow> \<phi>Index_getter (0 # idx) (\<lbrace> X \<rbrace> \<^emph> R) Y (f o fst)\<close>
  unfolding \<phi>Index_getter_def
  by (clarsimp simp add: \<phi>expns V_tup_mult idx_step_value_tup)

lemma [\<phi>reason 1200]:
  \<open> \<phi>Index_mapper (i # idx) X X' Y Y' f
\<Longrightarrow> \<phi>Index_mapper (Suc i # idx) (\<lbrace> T \<rbrace> \<^emph> X) (\<lbrace> T \<rbrace> \<^emph> X') Y Y' (apsnd o f)\<close>
  unfolding \<phi>Index_mapper_def
  apply (clarsimp simp add: \<phi>expns V_tup_mult idx_step_mod_value_V_tup_suc)
  by (metis V_tup_sep_disj_R idx_step_mod_value_tup)

lemma [\<phi>reason 1200]:
  \<open> \<phi>Index_mapper idx X X' Y Y' f
\<Longrightarrow> \<phi>Index_mapper (0 # idx) \<lbrace> X \<rbrace> \<lbrace> X' \<rbrace> Y Y' f\<close>
  unfolding \<phi>Index_mapper_def
  by (clarsimp simp add: \<phi>expns V_tup_mult idx_step_mod_value_tup)

lemma [\<phi>reason 1200]:
  \<open> \<phi>Index_mapper idx X X' Y Y' f
\<Longrightarrow> \<phi>Index_mapper (0 # idx) (\<lbrace> X \<rbrace> \<^emph> R) (\<lbrace> X' \<rbrace> \<^emph> R) Y Y' (apfst o f)\<close>
  unfolding \<phi>Index_mapper_def
  apply (clarsimp simp add: \<phi>expns V_tup_mult idx_step_mod_value_tup)
  by (metis NO_MATCH_def V_tup_mult_cons V_tup_sep_disj_L)

end


theory Chapter4Sols
imports Main
begin

(*  Exercise 4.1  *)
lemma assumes T: "\<forall>x y. T x y \<or> T y x"
  and A: "\<forall>x y. A x y \<and> A y x \<longrightarrow> x = y"
  and TA: "\<forall>x y. T x y \<longrightarrow> A x y" and "A x y"
shows "T x y"
  using A T TA assms(4) by blast

(*  Exercise 4.2  *)
lemma "\<exists>ys zs. xs = ys @ zs \<and> (length ys = length zs \<or> length ys = length zs + 1)"

(* not complete *)

end

github-repos/isabelle/mrtkp9993-Isabelle-HOL-Examples/Isabelle-HOL-Examples-37a31d2aefce20eb5c49d358c1ea236f5e693458/Programming and Proving in Isabelle-Hol Exercise Solutions/Chapter4Sols.thy


theory Executable
  imports Interval_Newton_Method

begin

section "Lemmas to Enable Evaluation"

subsection "Code Lemmas"

lemmas newton_floatarith_simp_rules [code] = newton_floatarith.simps

lemma element_in_interval_bounds [code_unfold]: "x \<in> set_of ivl \<longleftrightarrow> (case bounds_of_interval ivl of (l, u) \<Rightarrow> l \<le> x \<and> x \<le> u)"
  unfolding set_of.rep_eq by auto

lemma interval''_order [code]: "bounds_of_interval (Interval'' lu) = (if fst lu \<le> snd lu then lu else (snd lu, fst lu))"
  unfolding Interval''_def by (auto simp: case_prod_unfold Interval_inverse split_beta')

lemma interval''_split [code]:
  "Interval_Help.split_float_interval ivl m =
     (if m \<in>\<^sub>i ivl then [Interval'' (lower ivl, m), Interval'' (m, upper ivl)] else [ivl])"
  unfolding Interval_Help.split_float_interval_def Interval''_def by (simp add: set_of_eq)

lemma float_interval''_intersection [code]:
  "float_interval_intersection ivl1 ivl2 =
     (if upper ivl2 < lower ivl1 \<or> upper ivl1 < lower ivl2 then []
      else [Interval'' (max (lower ivl1) (lower ivl2), min (upper ivl1) (upper ivl2))])"
  unfolding float_interval_intersection_def Interval''_def
  by (auto simp: min_def max_def simp: real_of_float_le_iff real_of_float_less_iff
           simp del: less_eq_float.rep_eq less_float.rep_eq)

lemma inverse_float_interval'' [code]:
  "Interval_Help.inverse_float_interval' prec ivl =
     Interval'' (float_divl prec 1 (upper ivl), float_divr prec 1 (lower ivl))"
  unfolding inverse_float_interval'_def by simp

lemma float_interval''_intersection_unbounded_lower [code]:
  "float_interval_intersection_unbounded_lower ivl u =
     (if u < lower ivl then [] else [Interval'' (lower ivl, min (upper ivl) u)])"
  unfolding float_interval_intersection_unbounded_lower_def Interval''_def
  by (auto simp: real_of_float_le_iff real_of_float_less_iff
           simp del: less_eq_float.rep_eq less_float.rep_eq)

lemma float_interval''_intersection_unbounded_upper [code]:
  "float_interval_intersection_unbounded_upper ivl u =
     (if upper ivl < u then [] else [Interval'' (max (lower ivl) u, upper ivl)])"
  unfolding float_interval_intersection_unbounded_upper_def Interval''_def
  by (auto simp: real_of_float_le_iff real_of_float_less_iff
           simp del: less_eq_float.rep_eq less_float.rep_eq)

subsection "Helper for floatariths"

instantiation floatarith :: plus
begin
definition "plus_floatarith = floatarith.Add"
instance ..
end

instantiation floatarith :: times
begin
definition "times_floatarith = floatarith.Mult"
instance ..
end

instantiation floatarith :: uminus
begin
definition "uminus_floatarith = floatarith.Minus"
instance ..
end

definition floatarith_Sin where "floatarith_Sin x = floatarith.Cos (floatarith.Num (Float 1 (-1)) * floatarith.Pi + (-x))"

subsection "Variations of the Newton Method for Testing"

text "Additional argument for maximum amount of iterations."

partial_function (option) newton_floatarith_max_its ::
  "nat \<Rightarrow> nat \<Rightarrow> floatarith \<Rightarrow> nat \<Rightarrow> float interval \<Rightarrow> float interval list option" where
"newton_floatarith_max_its its eps f prec ivl = (if its = 0 \<or> width ivl < Float 1 (-eps) then Some [ivl] else do {
  ivls \<leftarrow> newton_step_floatarith f prec ivl;
  if ivls = [ivl] then Some [ivl]
  else do {
    ivls' \<leftarrow> mapM (newton_floatarith_max_its (its - 1) eps f prec) ivls;
    Some (concat ivls')
  }
})"

lemmas newton_floatarith_max_rec_simp_rules [code] = newton_floatarith_max_its.simps

fun max_element :: "nat list \<Rightarrow> nat" where
"max_element [] = 0" |
"max_element (x#xs) = max x (max_element xs)"

text "Instead of intervals the result of this function is the amount of iterations."

partial_function (option) newton_floatarith_c_its ::
  "nat \<Rightarrow> floatarith \<Rightarrow> nat \<Rightarrow> float interval \<Rightarrow> nat option" where
"newton_floatarith_c_its eps f prec ivl = (if width ivl < Float 1 (-eps) then Some 1 else do {
  ivls \<leftarrow> newton_step_floatarith f prec ivl;
  if ivls = [ivl] then Some 1
  else do {
    ivls' \<leftarrow> mapM (newton_floatarith_c_its eps f prec) ivls;
    Some (Suc (max_element ivls'))
  }
})"

lemmas newton_floatarith_rec_simp_rules [code] = newton_floatarith_c_its.simps

subsection "Helping Lemmas for Evaluation"

fun some_intervals_to_real::  "float interval list option \<Rightarrow> real interval list" where
"some_intervals_to_real None = []" |
"some_intervals_to_real (Some []) = []" |
"some_intervals_to_real (Some (ivl#ivls)) = real_interval ivl # some_intervals_to_real (Some ivls)"

fun some_intervals_to_width:: "float interval list option \<Rightarrow> real list" where
"some_intervals_to_width None = []" |
"some_intervals_to_width (Some []) = []" |
"some_intervals_to_width (Some (ivl#ivls)) = width (real_interval ivl) # some_intervals_to_width (Some ivls)"

definition newton_fa where "newton_fa   f ivl = some_intervals_to_real (newton_floatarith 30 f 30 ivl)"
definition newton_mi where "newton_mi i f ivl = some_intervals_to_real (newton_floatarith_max_its i 30 f 30 ivl)"
definition newton_ci where "newton_ci   f ivl = newton_floatarith_c_its 30 f 30 ivl"
definition newton_wd where "newton_wd   f ivl = some_intervals_to_width (newton_floatarith 30 f 30 ivl)"

section "Examples"

locale examples

begin

definition x     where "x = floatarith.Var 0"
definition pos   where "pos n = floatarith.Num n"
definition neg   where "neg n = pos (-n)"

definition ivl_d where "ivl_d = Interval'' (-10, 10)"

subsection "Basic Cases"

subsubsection "Factorised Polynomials"

definition  f_1  where  "f_1  = pos 0"
definition  f_2  where  "f_2  = pos 1"
definition  f_3  where  "f_3  = x"
definition  f_4  where  "f_4  = x + neg 1"
definition  f_5  where  "f_5  = (x + neg 1) * (x + pos 2)"
definition  f_6  where  "f_6  = (x + neg 1) * (x + pos 2) * (x + neg 3)"
definition  f_6' where  "f_6' = floatarith.Power x 3 + (neg 2) * floatarith.Power x 2 + (neg 5) * x + (pos 6)"
definition  f_6o where  "f_6o = x * x * x + (neg 2) * x * x + (neg 5) * x + (pos 6)"

definition f'_6  where "f'_6  = DERIV_floatarith 0 f_6"
definition f'_6' where "f'_6' = DERIV_floatarith 0 f_6'"
definition f'_6o where "f'_6o = DERIV_floatarith 0 f_6o"

subsubsection "Square Roots"

definition  f_7 where   "f_7 = x * x"
definition  f_8 where   "f_8 = x * x + neg 1"
definition  f_9 where   "f_9 = x * x + neg 2"
definition f_10 where  "f_10 = x * x + neg 3"
definition f_11 where  "f_11 = x * x + neg 4"
definition f_12 where  "f_12 = x * x + neg 5"

subsection "Advanced Cases"

definition f_13 where  "f_13 = floatarith.Power x 50"
definition f_14 where  "f_14 = floatarith_Sin x"
definition I_14 where  "I_14 = Interval'' (2, 4)"
definition f_15 where  "f_15 = floatarith.Ln x + neg 1"
definition I_15 where  "I_15 = Interval'' (1, 3)"
definition f_16 where  "f_16 = x * floatarith.Exp x + neg 23"
definition I_16 where  "I_16 = Interval'' (1, 3)"

subsection "Corner Cases"

subsubsection "Root not in Interval"

definition f_17  where  "f_17  = floatarith.Power x 2"
definition I_17  where  "I_17  = Interval'' (Float 1 (-30), 10)"
definition I_17' where  "I_17' = Interval'' (Float 1 (-50), 10)"
definition f_18  where  "f_18  = floatarith.Power x 2 + neg 2"
definition I_18  where  "I_18  = Interval'' (2 + Float 1 (-50), 10)"
definition I_18' where  "I_18' = Interval'' (2 + Float 1 (-100000), 10)"
definition f_19  where  "f_19  = floatarith_Sin (x + pos 1)"
definition I_19  where  "I_19  = Interval'' (-1 + Float 1 (-30) ,2)"
definition I_19' where  "I_19' = Interval'' (-1 + Float 1 (-50) ,2)"

subsubsection "Root at Bound of Interval"

definition f_20   where  "f_20   = x + pos 3"
definition I_20_1 where  "I_20_1 = Interval'' (-10, 3)"
definition I_20_2 where  "I_20_2 = Interval'' (-3, 10)"
definition f_21   where  "f_21   = floatarith.Power x 2 + neg 9"
definition I_21_1 where  "I_21_1 = Interval'' (-10, -3)"
definition I_21_2 where  "I_21_2 = Interval'' (-3, 0)"
definition I_21_3 where  "I_21_3 = Interval'' (0, 3)"
definition I_21_4 where  "I_21_4 = Interval'' (3, 10)"
definition f_22   where  "f_22   = floatarith_Sin x"
definition I_22_1 where  "I_22_1 = Interval'' (-2, 0)"
definition I_22_2 where  "I_22_2 = Interval'' (0, 2)"

subsubsection "Function Without Root, Converging to Zero"

definition f_23  where  "f_23  = floatarith.Inverse x"
definition I_23  where  "I_23  = Interval'' (-1000000, -500000)"
definition I_23' where  "I_23' = Interval'' (500000, 1000000)"
definition f_24  where  "f_24  = floatarith.Exp x"
definition I_24  where  "I_24  = Interval'' (-1000000, -500000)"

end

end


theory Ltake_lmap
  imports Main "$HIPSTER_HOME/IsaHipster"
    Ltake
    Lmap
begin
setup Tactic_Data.set_coinduct_sledgehammer
setup Misc_Data.set_noisy

(* cohipster ltake lmap *)
(* Discovers and proves the following in ca. 40 seconds *)
lemma lemma_aj [thy_expl]: "ltake z (lmap y x2) = lmap y (ltake z x2)"
  by (coinduction arbitrary: x2 y z rule: Llist.Llist.coinduct_strong)
    (smt ENat.collapse(2) Llist.case_eq_if Llist.sel(1) Lmap.lemma_ab Ltake.lemma_aa lmap.disc_iff(2) lmap.sel(1) ltake.ctr(2) ltake.disc(1) ltake.disc(2))

end


(*  Title:      HOL/HOLCF/Cfun.thy
    Author:     Franz Regensburger
    Author:     Brian Huffman
*)

section \<open>The type of continuous functions\<close>

theory Cfun
  imports Cpodef Fun_Cpo Product_Cpo
begin

default_sort cpo

subsection \<open>Definition of continuous function type\<close>

definition "cfun = {f::'a \<Rightarrow> 'b. cont f}"

cpodef ('a, 'b) cfun ("(_ \<rightarrow>/ _)" [1, 0] 0) = "cfun :: ('a \<Rightarrow> 'b) set"
  by (auto simp: cfun_def intro: cont_const adm_cont)

type_notation (ASCII)
  cfun  (infixr "->" 0)

notation (ASCII)
  Rep_cfun  ("(_$/_)" [999,1000] 999)

notation
  Rep_cfun  ("(_\<cdot>/_)" [999,1000] 999)

subsection \<open>Syntax for continuous lambda abstraction\<close>

syntax "_cabs" :: "[logic, logic] \<Rightarrow> logic"

parse_translation \<open>
(* rewrite (_cabs x t) => (Abs_cfun (%x. t)) *)
  [Syntax_Trans.mk_binder_tr (\<^syntax_const>\<open>_cabs\<close>, \<^const_syntax>\<open>Abs_cfun\<close>)]
\<close>

print_translation \<open>
  [(\<^const_syntax>\<open>Abs_cfun\<close>, fn _ => fn [Abs abs] =>
      let val (x, t) = Syntax_Trans.atomic_abs_tr' abs
      in Syntax.const \<^syntax_const>\<open>_cabs\<close> $ x $ t end)]
\<close>  \<comment> \<open>To avoid eta-contraction of body\<close>

text \<open>Syntax for nested abstractions\<close>

syntax (ASCII)
  "_Lambda" :: "[cargs, logic] \<Rightarrow> logic"  ("(3LAM _./ _)" [1000, 10] 10)

syntax
  "_Lambda" :: "[cargs, logic] \<Rightarrow> logic" ("(3\<Lambda> _./ _)" [1000, 10] 10)

parse_ast_translation \<open>
(* rewrite (LAM x y z. t) => (_cabs x (_cabs y (_cabs z t))) *)
(* cf. Syntax.lambda_ast_tr from src/Pure/Syntax/syn_trans.ML *)
  let
    fun Lambda_ast_tr [pats, body] =
          Ast.fold_ast_p \<^syntax_const>\<open>_cabs\<close>
            (Ast.unfold_ast \<^syntax_const>\<open>_cargs\<close> (Ast.strip_positions pats), body)
      | Lambda_ast_tr asts = raise Ast.AST ("Lambda_ast_tr", asts);
  in [(\<^syntax_const>\<open>_Lambda\<close>, K Lambda_ast_tr)] end
\<close>

print_ast_translation \<open>
(* rewrite (_cabs x (_cabs y (_cabs z t))) => (LAM x y z. t) *)
(* cf. Syntax.abs_ast_tr' from src/Pure/Syntax/syn_trans.ML *)
  let
    fun cabs_ast_tr' asts =
      (case Ast.unfold_ast_p \<^syntax_const>\<open>_cabs\<close>
          (Ast.Appl (Ast.Constant \<^syntax_const>\<open>_cabs\<close> :: asts)) of
        ([], _) => raise Ast.AST ("cabs_ast_tr'", asts)
      | (xs, body) => Ast.Appl
          [Ast.Constant \<^syntax_const>\<open>_Lambda\<close>,
           Ast.fold_ast \<^syntax_const>\<open>_cargs\<close> xs, body]);
  in [(\<^syntax_const>\<open>_cabs\<close>, K cabs_ast_tr')] end
\<close>

text \<open>Dummy patterns for continuous abstraction\<close>
translations
  "\<Lambda> _. t" \<rightharpoonup> "CONST Abs_cfun (\<lambda>_. t)"

subsection \<open>Continuous function space is pointed\<close>

lemma bottom_cfun: "\<bottom> \<in> cfun"
  by (simp add: cfun_def inst_fun_pcpo)

instance cfun :: (cpo, discrete_cpo) discrete_cpo
  by intro_classes (simp add: below_cfun_def Rep_cfun_inject)

instance cfun :: (cpo, pcpo) pcpo
  by (rule typedef_pcpo [OF type_definition_cfun below_cfun_def bottom_cfun])

lemmas Rep_cfun_strict =
  typedef_Rep_strict [OF type_definition_cfun below_cfun_def bottom_cfun]

lemmas Abs_cfun_strict =
  typedef_Abs_strict [OF type_definition_cfun below_cfun_def bottom_cfun]

text \<open>function application is strict in its first argument\<close>

lemma Rep_cfun_strict1 [simp]: "\<bottom>\<cdot>x = \<bottom>"
  by (simp add: Rep_cfun_strict)

lemma LAM_strict [simp]: "(\<Lambda> x. \<bottom>) = \<bottom>"
  by (simp add: inst_fun_pcpo [symmetric] Abs_cfun_strict)

text \<open>for compatibility with old HOLCF-Version\<close>
lemma inst_cfun_pcpo: "\<bottom> = (\<Lambda> x. \<bottom>)"
  by simp

subsection \<open>Basic properties of continuous functions\<close>

text \<open>Beta-equality for continuous functions\<close>

lemma Abs_cfun_inverse2: "cont f \<Longrightarrow> Rep_cfun (Abs_cfun f) = f"
  by (simp add: Abs_cfun_inverse cfun_def)

lemma beta_cfun: "cont f \<Longrightarrow> (\<Lambda> x. f x)\<cdot>u = f u"
  by (simp add: Abs_cfun_inverse2)

subsubsection \<open>Beta-reduction simproc\<close>

text \<open>
  Given the term \<^term>\<open>(\<Lambda> x. f x)\<cdot>y\<close>, the procedure tries to
  construct the theorem \<^term>\<open>(\<Lambda> x. f x)\<cdot>y \<equiv> f y\<close>.  If this
  theorem cannot be completely solved by the cont2cont rules, then
  the procedure returns the ordinary conditional \<open>beta_cfun\<close>
  rule.

  The simproc does not solve any more goals that would be solved by
  using \<open>beta_cfun\<close> as a simp rule.  The advantage of the
  simproc is that it can avoid deeply-nested calls to the simplifier
  that would otherwise be caused by large continuity side conditions.

  Update: The simproc now uses rule \<open>Abs_cfun_inverse2\<close> instead
  of \<open>beta_cfun\<close>, to avoid problems with eta-contraction.
\<close>

simproc_setup beta_cfun_proc ("Rep_cfun (Abs_cfun f)") = \<open>
  fn phi => fn ctxt => fn ct =>
    let
      val f = #2 (Thm.dest_comb (#2 (Thm.dest_comb ct)));
      val [T, U] = Thm.dest_ctyp (Thm.ctyp_of_cterm f);
      val tr = Thm.instantiate' [SOME T, SOME U] [SOME f] (mk_meta_eq @{thm Abs_cfun_inverse2});
      val rules = Named_Theorems.get ctxt \<^named_theorems>\<open>cont2cont\<close>;
      val tac = SOLVED' (REPEAT_ALL_NEW (match_tac ctxt (rev rules)));
    in SOME (perhaps (SINGLE (tac 1)) tr) end
\<close>

text \<open>Eta-equality for continuous functions\<close>

lemma eta_cfun: "(\<Lambda> x. f\<cdot>x) = f"
  by (rule Rep_cfun_inverse)

text \<open>Extensionality for continuous functions\<close>

lemma cfun_eq_iff: "f = g \<longleftrightarrow> (\<forall>x. f\<cdot>x = g\<cdot>x)"
  by (simp add: Rep_cfun_inject [symmetric] fun_eq_iff)

lemma cfun_eqI: "(\<And>x. f\<cdot>x = g\<cdot>x) \<Longrightarrow> f = g"
  by (simp add: cfun_eq_iff)

text \<open>Extensionality wrt. ordering for continuous functions\<close>

lemma cfun_below_iff: "f \<sqsubseteq> g \<longleftrightarrow> (\<forall>x. f\<cdot>x \<sqsubseteq> g\<cdot>x)"
  by (simp add: below_cfun_def fun_below_iff)

lemma cfun_belowI: "(\<And>x. f\<cdot>x \<sqsubseteq> g\<cdot>x) \<Longrightarrow> f \<sqsubseteq> g"
  by (simp add: cfun_below_iff)

text \<open>Congruence for continuous function application\<close>

lemma cfun_cong: "f = g \<Longrightarrow> x = y \<Longrightarrow> f\<cdot>x = g\<cdot>y"
  by simp

lemma cfun_fun_cong: "f = g \<Longrightarrow> f\<cdot>x = g\<cdot>x"
  by simp

lemma cfun_arg_cong: "x = y \<Longrightarrow> f\<cdot>x = f\<cdot>y"
  by simp

subsection \<open>Continuity of application\<close>

lemma cont_Rep_cfun1: "cont (\<lambda>f. f\<cdot>x)"
  by (rule cont_Rep_cfun [OF cont_id, THEN cont2cont_fun])

lemma cont_Rep_cfun2: "cont (\<lambda>x. f\<cdot>x)"
  using Rep_cfun [where x = f] by (simp add: cfun_def)

lemmas monofun_Rep_cfun = cont_Rep_cfun [THEN cont2mono]

lemmas monofun_Rep_cfun1 = cont_Rep_cfun1 [THEN cont2mono]
lemmas monofun_Rep_cfun2 = cont_Rep_cfun2 [THEN cont2mono]

text \<open>contlub, cont properties of \<^term>\<open>Rep_cfun\<close> in each argument\<close>

lemma contlub_cfun_arg: "chain Y \<Longrightarrow> f\<cdot>(\<Squnion>i. Y i) = (\<Squnion>i. f\<cdot>(Y i))"
  by (rule cont_Rep_cfun2 [THEN cont2contlubE])

lemma contlub_cfun_fun: "chain F \<Longrightarrow> (\<Squnion>i. F i)\<cdot>x = (\<Squnion>i. F i\<cdot>x)"
  by (rule cont_Rep_cfun1 [THEN cont2contlubE])

text \<open>monotonicity of application\<close>

lemma monofun_cfun_fun: "f \<sqsubseteq> g \<Longrightarrow> f\<cdot>x \<sqsubseteq> g\<cdot>x"
  by (simp add: cfun_below_iff)

lemma monofun_cfun_arg: "x \<sqsubseteq> y \<Longrightarrow> f\<cdot>x \<sqsubseteq> f\<cdot>y"
  by (rule monofun_Rep_cfun2 [THEN monofunE])

lemma monofun_cfun: "f \<sqsubseteq> g \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> f\<cdot>x \<sqsubseteq> g\<cdot>y"
  by (rule below_trans [OF monofun_cfun_fun monofun_cfun_arg])

text \<open>ch2ch - rules for the type \<^typ>\<open>'a \<rightarrow> 'b\<close>\<close>

lemma chain_monofun: "chain Y \<Longrightarrow> chain (\<lambda>i. f\<cdot>(Y i))"
  by (erule monofun_Rep_cfun2 [THEN ch2ch_monofun])

lemma ch2ch_Rep_cfunR: "chain Y \<Longrightarrow> chain (\<lambda>i. f\<cdot>(Y i))"
  by (rule monofun_Rep_cfun2 [THEN ch2ch_monofun])

lemma ch2ch_Rep_cfunL: "chain F \<Longrightarrow> chain (\<lambda>i. (F i)\<cdot>x)"
  by (rule monofun_Rep_cfun1 [THEN ch2ch_monofun])

lemma ch2ch_Rep_cfun [simp]: "chain F \<Longrightarrow> chain Y \<Longrightarrow> chain (\<lambda>i. (F i)\<cdot>(Y i))"
  by (simp add: chain_def monofun_cfun)

lemma ch2ch_LAM [simp]:
  "(\<And>x. chain (\<lambda>i. S i x)) \<Longrightarrow> (\<And>i. cont (\<lambda>x. S i x)) \<Longrightarrow> chain (\<lambda>i. \<Lambda> x. S i x)"
  by (simp add: chain_def cfun_below_iff)

text \<open>contlub, cont properties of \<^term>\<open>Rep_cfun\<close> in both arguments\<close>

lemma lub_APP: "chain F \<Longrightarrow> chain Y \<Longrightarrow> (\<Squnion>i. F i\<cdot>(Y i)) = (\<Squnion>i. F i)\<cdot>(\<Squnion>i. Y i)"
  by (simp add: contlub_cfun_fun contlub_cfun_arg diag_lub)

lemma lub_LAM:
  assumes "\<And>x. chain (\<lambda>i. F i x)"
    and "\<And>i. cont (\<lambda>x. F i x)"
  shows "(\<Squnion>i. \<Lambda> x. F i x) = (\<Lambda> x. \<Squnion>i. F i x)"
  using assms by (simp add: lub_cfun lub_fun ch2ch_lambda)

lemmas lub_distribs = lub_APP lub_LAM

text \<open>strictness\<close>

lemma strictI: "f\<cdot>x = \<bottom> \<Longrightarrow> f\<cdot>\<bottom> = \<bottom>"
  apply (rule bottomI)
  apply (erule subst)
  apply (rule minimal [THEN monofun_cfun_arg])
  done

text \<open>type \<^typ>\<open>'a \<rightarrow> 'b\<close> is chain complete\<close>

lemma lub_cfun: "chain F \<Longrightarrow> (\<Squnion>i. F i) = (\<Lambda> x. \<Squnion>i. F i\<cdot>x)"
  by (simp add: lub_cfun lub_fun ch2ch_lambda)

subsection \<open>Continuity simplification procedure\<close>

text \<open>cont2cont lemma for \<^term>\<open>Rep_cfun\<close>\<close>

lemma cont2cont_APP [simp, cont2cont]:
  assumes f: "cont (\<lambda>x. f x)"
  assumes t: "cont (\<lambda>x. t x)"
  shows "cont (\<lambda>x. (f x)\<cdot>(t x))"
proof -
  from cont_Rep_cfun1 f have "cont (\<lambda>x. (f x)\<cdot>y)" for y
    by (rule cont_compose)
  with t cont_Rep_cfun2 show "cont (\<lambda>x. (f x)\<cdot>(t x))"
    by (rule cont_apply)
qed

text \<open>
  Two specific lemmas for the combination of LCF and HOL terms.
  These lemmas are needed in theories that use types like \<^typ>\<open>'a \<rightarrow> 'b \<Rightarrow> 'c\<close>.
\<close>

lemma cont_APP_app [simp]: "cont f \<Longrightarrow> cont g \<Longrightarrow> cont (\<lambda>x. ((f x)\<cdot>(g x)) s)"
  by (rule cont2cont_APP [THEN cont2cont_fun])

lemma cont_APP_app_app [simp]: "cont f \<Longrightarrow> cont g \<Longrightarrow> cont (\<lambda>x. ((f x)\<cdot>(g x)) s t)"
  by (rule cont_APP_app [THEN cont2cont_fun])

text \<open>cont2mono Lemma for \<^term>\<open>\<lambda>x. LAM y. c1(x)(y)\<close>\<close>

lemma cont2mono_LAM:
  "\<lbrakk>\<And>x. cont (\<lambda>y. f x y); \<And>y. monofun (\<lambda>x. f x y)\<rbrakk>
    \<Longrightarrow> monofun (\<lambda>x. \<Lambda> y. f x y)"
  by (simp add: monofun_def cfun_below_iff)

text \<open>cont2cont Lemma for \<^term>\<open>\<lambda>x. LAM y. f x y\<close>\<close>

text \<open>
  Not suitable as a cont2cont rule, because on nested lambdas
  it causes exponential blow-up in the number of subgoals.
\<close>

lemma cont2cont_LAM:
  assumes f1: "\<And>x. cont (\<lambda>y. f x y)"
  assumes f2: "\<And>y. cont (\<lambda>x. f x y)"
  shows "cont (\<lambda>x. \<Lambda> y. f x y)"
proof (rule cont_Abs_cfun)
  from f1 show "f x \<in> cfun" for x
    by (simp add: cfun_def)
  from f2 show "cont f"
    by (rule cont2cont_lambda)
qed

text \<open>
  This version does work as a cont2cont rule, since it
  has only a single subgoal.
\<close>

lemma cont2cont_LAM' [simp, cont2cont]:
  fixes f :: "'a::cpo \<Rightarrow> 'b::cpo \<Rightarrow> 'c::cpo"
  assumes f: "cont (\<lambda>p. f (fst p) (snd p))"
  shows "cont (\<lambda>x. \<Lambda> y. f x y)"
  using assms by (simp add: cont2cont_LAM prod_cont_iff)

lemma cont2cont_LAM_discrete [simp, cont2cont]:
  "(\<And>y::'a::discrete_cpo. cont (\<lambda>x. f x y)) \<Longrightarrow> cont (\<lambda>x. \<Lambda> y. f x y)"
  by (simp add: cont2cont_LAM)

subsection \<open>Miscellaneous\<close>

text \<open>Monotonicity of \<^term>\<open>Abs_cfun\<close>\<close>

lemma monofun_LAM: "cont f \<Longrightarrow> cont g \<Longrightarrow> (\<And>x. f x \<sqsubseteq> g x) \<Longrightarrow> (\<Lambda> x. f x) \<sqsubseteq> (\<Lambda> x. g x)"
  by (simp add: cfun_below_iff)

text \<open>some lemmata for functions with flat/chfin domain/range types\<close>

lemma chfin_Rep_cfunR: "chain Y \<Longrightarrow> \<forall>s. \<exists>n. (LUB i. Y i)\<cdot>s = Y n\<cdot>s"
  for Y :: "nat \<Rightarrow> 'a::cpo \<rightarrow> 'b::chfin"
  apply (rule allI)
  apply (subst contlub_cfun_fun)
   apply assumption
  apply (fast intro!: lub_eqI chfin lub_finch2 chfin2finch ch2ch_Rep_cfunL)
  done

lemma adm_chfindom: "adm (\<lambda>(u::'a::cpo \<rightarrow> 'b::chfin). P(u\<cdot>s))"
  by (rule adm_subst, simp, rule adm_chfin)

subsection \<open>Continuous injection-retraction pairs\<close>

text \<open>Continuous retractions are strict.\<close>

lemma retraction_strict: "\<forall>x. f\<cdot>(g\<cdot>x) = x \<Longrightarrow> f\<cdot>\<bottom> = \<bottom>"
  apply (rule bottomI)
  apply (drule_tac x="\<bottom>" in spec)
  apply (erule subst)
  apply (rule monofun_cfun_arg)
  apply (rule minimal)
  done

lemma injection_eq: "\<forall>x. f\<cdot>(g\<cdot>x) = x \<Longrightarrow> (g\<cdot>x = g\<cdot>y) = (x = y)"
  apply (rule iffI)
   apply (drule_tac f=f in cfun_arg_cong)
   apply simp
  apply simp
  done

lemma injection_below: "\<forall>x. f\<cdot>(g\<cdot>x) = x \<Longrightarrow> (g\<cdot>x \<sqsubseteq> g\<cdot>y) = (x \<sqsubseteq> y)"
  apply (rule iffI)
   apply (drule_tac f=f in monofun_cfun_arg)
   apply simp
  apply (erule monofun_cfun_arg)
  done

lemma injection_defined_rev: "\<forall>x. f\<cdot>(g\<cdot>x) = x \<Longrightarrow> g\<cdot>z = \<bottom> \<Longrightarrow> z = \<bottom>"
  apply (drule_tac f=f in cfun_arg_cong)
  apply (simp add: retraction_strict)
  done

lemma injection_defined: "\<forall>x. f\<cdot>(g\<cdot>x) = x \<Longrightarrow> z \<noteq> \<bottom> \<Longrightarrow> g\<cdot>z \<noteq> \<bottom>"
  by (erule contrapos_nn, rule injection_defined_rev)

text \<open>a result about functions with flat codomain\<close>

lemma flat_eqI: "x \<sqsubseteq> y \<Longrightarrow> x \<noteq> \<bottom> \<Longrightarrow> x = y"
  for x y :: "'a::flat"
  by (drule ax_flat) simp

lemma flat_codom: "f\<cdot>x = c \<Longrightarrow> f\<cdot>\<bottom> = \<bottom> \<or> (\<forall>z. f\<cdot>z = c)"
  for c :: "'b::flat"
  apply (cases "f\<cdot>x = \<bottom>")
   apply (rule disjI1)
   apply (rule bottomI)
   apply (erule_tac t="\<bottom>" in subst)
   apply (rule minimal [THEN monofun_cfun_arg])
  apply clarify
  apply (rule_tac a = "f\<cdot>\<bottom>" in refl [THEN box_equals])
   apply (erule minimal [THEN monofun_cfun_arg, THEN flat_eqI])
  apply (erule minimal [THEN monofun_cfun_arg, THEN flat_eqI])
  done

subsection \<open>Identity and composition\<close>

definition ID :: "'a \<rightarrow> 'a"
  where "ID = (\<Lambda> x. x)"

definition cfcomp  :: "('b \<rightarrow> 'c) \<rightarrow> ('a \<rightarrow> 'b) \<rightarrow> 'a \<rightarrow> 'c"
  where oo_def: "cfcomp = (\<Lambda> f g x. f\<cdot>(g\<cdot>x))"

abbreviation cfcomp_syn :: "['b \<rightarrow> 'c, 'a \<rightarrow> 'b] \<Rightarrow> 'a \<rightarrow> 'c"  (infixr "oo" 100)
  where "f oo g == cfcomp\<cdot>f\<cdot>g"

lemma ID1 [simp]: "ID\<cdot>x = x"
  by (simp add: ID_def)

lemma cfcomp1: "(f oo g) = (\<Lambda> x. f\<cdot>(g\<cdot>x))"
  by (simp add: oo_def)

lemma cfcomp2 [simp]: "(f oo g)\<cdot>x = f\<cdot>(g\<cdot>x)"
  by (simp add: cfcomp1)

lemma cfcomp_LAM: "cont g \<Longrightarrow> f oo (\<Lambda> x. g x) = (\<Lambda> x. f\<cdot>(g x))"
  by (simp add: cfcomp1)

lemma cfcomp_strict [simp]: "\<bottom> oo f = \<bottom>"
  by (simp add: cfun_eq_iff)

text \<open>
  Show that interpretation of (pcpo, \<open>_\<rightarrow>_\<close>) is a category.
  \<^item> The class of objects is interpretation of syntactical class pcpo.
  \<^item> The class of arrows  between objects \<^typ>\<open>'a\<close> and \<^typ>\<open>'b\<close> is interpret. of \<^typ>\<open>'a \<rightarrow> 'b\<close>.
  \<^item> The identity arrow is interpretation of \<^term>\<open>ID\<close>.
  \<^item> The composition of f and g is interpretation of \<open>oo\<close>.
\<close>

lemma ID2 [simp]: "f oo ID = f"
  by (rule cfun_eqI, simp)

lemma ID3 [simp]: "ID oo f = f"
  by (rule cfun_eqI) simp

lemma assoc_oo: "f oo (g oo h) = (f oo g) oo h"
  by (rule cfun_eqI) simp

subsection \<open>Strictified functions\<close>

default_sort pcpo

definition seq :: "'a \<rightarrow> 'b \<rightarrow> 'b"
  where "seq = (\<Lambda> x. if x = \<bottom> then \<bottom> else ID)"

lemma cont2cont_if_bottom [cont2cont, simp]:
  assumes f: "cont (\<lambda>x. f x)"
    and g: "cont (\<lambda>x. g x)"
  shows "cont (\<lambda>x. if f x = \<bottom> then \<bottom> else g x)"
proof (rule cont_apply [OF f])
  show "cont (\<lambda>y. if y = \<bottom> then \<bottom> else g x)" for x
    unfolding cont_def is_lub_def is_ub_def ball_simps
    by (simp add: lub_eq_bottom_iff)
  show "cont (\<lambda>x. if y = \<bottom> then \<bottom> else g x)" for y
    by (simp add: g)
qed

lemma seq_conv_if: "seq\<cdot>x = (if x = \<bottom> then \<bottom> else ID)"
  by (simp add: seq_def)

lemma seq_simps [simp]:
  "seq\<cdot>\<bottom> = \<bottom>"
  "seq\<cdot>x\<cdot>\<bottom> = \<bottom>"
  "x \<noteq> \<bottom> \<Longrightarrow> seq\<cdot>x = ID"
  by (simp_all add: seq_conv_if)

definition strictify  :: "('a \<rightarrow> 'b) \<rightarrow> 'a \<rightarrow> 'b"
  where "strictify = (\<Lambda> f x. seq\<cdot>x\<cdot>(f\<cdot>x))"

lemma strictify_conv_if: "strictify\<cdot>f\<cdot>x = (if x = \<bottom> then \<bottom> else f\<cdot>x)"
  by (simp add: strictify_def)

lemma strictify1 [simp]: "strictify\<cdot>f\<cdot>\<bottom> = \<bottom>"
  by (simp add: strictify_conv_if)

lemma strictify2 [simp]: "x \<noteq> \<bottom> \<Longrightarrow> strictify\<cdot>f\<cdot>x = f\<cdot>x"
  by (simp add: strictify_conv_if)

subsection \<open>Continuity of let-bindings\<close>

lemma cont2cont_Let:
  assumes f: "cont (\<lambda>x. f x)"
  assumes g1: "\<And>y. cont (\<lambda>x. g x y)"
  assumes g2: "\<And>x. cont (\<lambda>y. g x y)"
  shows "cont (\<lambda>x. let y = f x in g x y)"
  unfolding Let_def using f g2 g1 by (rule cont_apply)

lemma cont2cont_Let' [simp, cont2cont]:
  assumes f: "cont (\<lambda>x. f x)"
  assumes g: "cont (\<lambda>p. g (fst p) (snd p))"
  shows "cont (\<lambda>x. let y = f x in g x y)"
  using f
proof (rule cont2cont_Let)
  from g show "cont (\<lambda>y. g x y)" for x
    by (simp add: prod_cont_iff)
  from g show "cont (\<lambda>x. g x y)" for y
    by (simp add: prod_cont_iff)
qed

text \<open>The simple version (suggested by Joachim Breitner) is needed if
  the type of the defined term is not a cpo.\<close>

lemma cont2cont_Let_simple [simp, cont2cont]:
  assumes "\<And>y. cont (\<lambda>x. g x y)"
  shows "cont (\<lambda>x. let y = t in g x y)"
  unfolding Let_def using assms .

end


theory TreeStream = Main:

use tactics

method_setup circular_coinduction = "build_tactic (circular_coinduction_fun)" "all"
method_setup coinduction = "build_tactic (coinduction_fun)" "rule_tac R=?Rzero in ga_cogenerated, instantiate_tac Rzero %s1.?R,step"
method_setup coinduction_test = "build_tactic (coinduction_test_fun)" "rule_tac R=?Rzero in ga_cogenerated, instantiate_tac Rzero %s1.?R,step"
method_setup init = "build_tactic (init_fun)" "(simp|(solve,blast))?,init2_fun?"
method_setup breakup = "build_tactic (breakup_fun)" "simp,((exE|conjE)+)?,disjE"
method_setup solve= "build_tactic (solve_fun 1)" "((exE|conjE|conjI)+)?,(simp)?,((exE|conjE|conjI)+)?,(simp)?"
method_setup step = "build_tactic (step_fun)" "((disjI2)+)?,inst r (rcs union (trans r))"
method_setup close= "build_tactic (close_fun)" "((disjI1|disjI2)+)?,((exE|conjE)+)?,force_solve|solve,disji1+,blast"
method_setup close_or_step= "build_tactic (close_or_step_fun)" ""
method_setup force_finish = "build_tactic (force_finish_fun)" "force: inst r false,solve1"

typedecl "BinTree"
typedecl "Elem"
typedecl "Stream"
consts
"tree" :: "BinTree => Elem => BinTree => BinTree"
"left" :: "BinTree => BinTree"
"mirror" :: "BinTree => BinTree"
"node" :: "BinTree => Elem"
"right" :: "BinTree => BinTree"
"cons" :: "BinTree => Stream => Stream"
"hd" :: "Stream => BinTree"
"tl" :: "Stream => Stream"
"const" :: "BinTree => Stream"
"swap" :: "BinTree => BinTree => Stream"

consts
  BinRelImage :: "('a => 'b) => ('a => 'a => bool) => ('b => 'b => bool)"
  Trans_BinTree :: "('a => 'a => bool) => ('b => 'b => bool)"
  Trans_Stream :: "('a => 'a => bool) => ('b => 'b => bool)"
  union :: "('a => 'a => bool)  => ('a => 'a => bool) => ('a => 'a => bool)" (infixl 20)
defs
  BinRelImage_def [simp] : "BinRelImage f R == %x y . EX u v . R u v & x = f u & y = f v"
  Trans_BinTree_def [simp] : "Trans_BinTree R == (BinRelImage left R) union (BinRelImage right R)"
  Trans_Stream_def [simp] : "Trans_Stream R == (BinRelImage tl R)"
  union_def [simp] : "R union S == % x y . R x y | S x y"

axioms
  mirror_left [simp]: "!! bt1 :: BinTree . (left (mirror bt1)) = (mirror (right bt1))"
  mirror_node [simp]: "!! bt1 :: BinTree . (node (mirror bt1)) = (node bt1)"
  mirror_right [simp]: "!! bt1 :: BinTree . (right (mirror bt1)) = (mirror (left bt1))"
  const_hd [simp] : "!! bt :: BinTree . (hd (const bt)) = bt"
  const_tl [simp] : "!! bt :: BinTree . (tl (const bt)) = const bt"
  swap_hd [simp] : "!! bt1 :: BinTree . !! bt2 :: BinTree . (hd (swap bt1 bt2)) = bt1"
  swap_tl [simp] : "!! bt1 :: BinTree . !! bt2 :: BinTree . (tl (swap bt1 bt2)) = (swap bt2 bt1)"
  ga_cogenerated_BinTree: "!! R :: BinTree => BinTree => bool . !! u :: BinTree .  !! v :: BinTree . ! x :: BinTree . ! y :: BinTree .
                           ((R x) y) --> (((R (left x)) (left y)) & (node x) = (node y) & ((R (right x)) (right y))) ==> ((R u) v) ==> u = v"
  ga_selector_left: "!! X1 :: BinTree . !! X2 :: Elem . !! X3 :: BinTree . (left ((tree X1 X2) X3)) = X1"
  ga_selector_node: "!! X1 :: BinTree . !! X2 :: Elem . !! X3 :: BinTree . (node ((tree X1 X2) X3)) = X2"
  ga_selector_right: "!! X1 :: BinTree . !! X2 :: Elem . !! X3 :: BinTree . (right ((tree X1 X2) X3)) = X3"
  ga_cogenerated_Stream: "!! R :: Stream => Stream => bool . !! u :: Stream . !! v :: Stream . ! x :: Stream . ! y :: Stream .
                          ((R x) y) --> ((hd x) = (hd y) & ((R (tl x)) (tl y)))  ==> ((R u) v) ==> u = v"
  ga_selector_hd: "! X1 :: BinTree . ! X2 :: Stream . (hd (cons X1 X2)) = X1"
  ga_selector_tl: "! X1 :: BinTree . ! X2 :: Stream . (tl (cons X1 X2)) = X2"

(*theorem Tree_mirror: "!! b :: BinTree . mirror(mirror b) = b & x y=x y & x= z"
apply(rule conjI)
defer
apply(rule conjI)
defer
defer
apply(rule ga_cogenerated_BinTree)
apply(coinduction_test)
apply(circular_coinduction)
done

declare Tree_mirror [simp]*)

theorem TreeStream_swapmirror_const: "!! b :: BinTree . (swap (mirror(mirror b)) b = const b)"
(*apply(circular_coinduction)*)

apply(coinduction)
apply(init)
apply(breakup)
apply(solve)

(* second coinduction would start here (does not work yet)*)
apply(coinduction_test)

apply(init)

apply(step)
apply(solve)

apply(rule_tac x=x in exI)
apply(rule_tac x=y in exI)

apply(solve)
apply(close)
apply(close)

apply(breakup)

apply(solve)
apply(rule disjI1)
apply(blast)

apply(force_finish)
done

end


theory HC_To_UHC_1
  imports Main Definitions_UHC
begin

subsection\<open>\<open>G \<in> hc \<longrightarrow> hc_to_uhc G \<in> uhc\<close>\<close>

subsubsection\<open>Preliminaries\<close>

fun to_cycle_uhc::"('a, ('a \<times> 'a)) pre_digraph \<Rightarrow> 'a list \<Rightarrow> ('a \<times> nat) list" where
  "to_cycle_uhc G [] = []" |
  "to_cycle_uhc G (v#vs) = [(v, 0), (v, 1), (v, 2)] @ to_cycle_uhc G vs"

context
  fixes G assumes in_hc: "G \<in> hc" "card (verts G) > 1"
  fixes Cycle assumes Cycle_def: "is_hc G Cycle"
  fixes G' assumes G'_def: "G' = hc_to_uhc G"
  fixes Cy assumes Cy_def: "Cy = (hd Cycle, 2) # to_cycle_uhc G (tl Cycle)"
begin

lemma G'_def_2:
  shows "G' = \<lparr>verts = {(v, (0::nat))|v. v \<in> verts G} \<union> {(v, 1)|v. v \<in> verts G}
      \<union> {(v, 2)|v. v \<in> verts G},
    arcs = {((v, 0), (v, 1))|v. v \<in> verts G} \<union>{((v, 1), (v, 0))|v. v \<in> verts G}\<union>
      {((v, 1), (v, 2))|v. v \<in> verts G}\<union>{((v, 2), (v, 1))|v. v \<in> verts G}\<union>
      {((v, 2), (u, 0))|v u e. e \<in> arcs G \<and> v = tail G e \<and> u = head G e \<and> u \<noteq> v}\<union>
      {((u, 0), (v, 2))|v u e. e \<in> arcs G \<and> v = tail G e \<and> u = head G e \<and> u \<noteq> v},
    tail = fst, head = snd\<rparr>"
  using in_hc G'_def
  unfolding hc_def hc_to_uhc_def
  by(auto)

lemma wf_digraph_G:
  shows "wf_digraph G" "((tail G = fst \<and> head G = snd) \<or> arcs G = {})"
  using in_hc hc_def
  by auto

lemma finite_verts_G:
  shows "finite (verts G)"
  using in_hc hc_def
  by auto

lemma wf_digraph_G':
  shows "wf_digraph G'"
  using G'_def_2 wf_digraph_def wf_digraph_G
  by(auto simp add: G'_def_2 wf_digraph_def)

lemma symmetric_G':
  shows "symmetric G'"
  using G'_def_2
  unfolding symmetric_def sym_def arcs_ends_def arc_to_ends_def
  by auto

lemma head_tail_G':
  shows "head G' = snd" "tail G' = fst"
  using G'_def_2
  by auto

lemma Cycle_subset:
  shows "set Cycle \<subseteq> verts G"
  using Cycle_def is_hc_def
  by metis

lemma Cycle_not_empty:
  assumes  "card (verts G) > 1"
  shows "Cycle \<noteq> []"
  using Cycle_def is_hc_def
  by (metis assms leD vwalk_arcs.simps(1) wf_digraph.cycle_conv wf_digraph_G(1))

lemma last_pre_digraph_cas:
  assumes "pre_digraph.cas G u (p) v" "p\<noteq> []" "arcs G \<noteq> {}"
  shows "snd (last p) = v"
  using assms wf_digraph_G
  by (auto simp add: last_pre_digraph_cas)

lemma hd_pre_digraph_cas:
  assumes "pre_digraph.cas G u (p) v" "p\<noteq> []" "arcs G \<noteq> {}"
  shows "fst (hd p) = u"
  using assms wf_digraph_G
  by (auto simp add: hd_pre_digraph_cas)

lemma hd_last_Cycle:
  assumes "card (verts G) > 1" "arcs G \<noteq> {}"
  shows "hd Cycle = last Cycle"
proof (cases "length Cycle = 1")
  case True
  then show ?thesis
    using True assms Cycle_not_empty
    by (metis List.finite_set assms(1) card_length
        contains_two_card_greater_1 last_in_set leD list.set_sel(1))
next
  case False
  have "Cycle \<noteq> []"
    using assms Cycle_not_empty
    by blast
  then have "length Cycle \<noteq> 1" "length Cycle \<noteq> 0"
    using assms False
    by(auto)
  then have "length Cycle \<ge> 2"
    by linarith
  then have arcs_not_epmty: "(vwalk_arcs Cycle) \<noteq> []"
    using vwalk_arcs_empty_length_p
    by force
  then obtain u where u_def: "pre_digraph.awalk G u (vwalk_arcs Cycle) u"
    using Cycle_def in_hc
    unfolding is_hc_def pre_digraph.cycle_def
    by auto
  then have 1: "pre_digraph.cas G u (vwalk_arcs Cycle) u"
    using pre_digraph.awalk_def
    by force
  then have "snd (last (vwalk_arcs Cycle)) = u"
    using arcs_not_epmty last_pre_digraph_cas assms
    by auto
  then have 2: "last Cycle = u"
    by (meson last_vwalk_arcs_last_p arcs_not_epmty)
  have "fst (hd (vwalk_arcs Cycle)) = u"
    using arcs_not_epmty hd_pre_digraph_cas 1 assms
    by auto
  then have 3: "hd Cycle = u"
    by (meson hd_vwalk_arcs_last_p arcs_not_epmty)
  then show ?thesis using 2 3
    by simp
qed

lemma finite_subset_verts_G':
  shows "finite {(v, i) |v. v \<in> verts G}"
  using finite_verts_G
  by simp

lemma distinct_tail_cycle:
  shows "distinct (tl Cycle)"
  using Cycle_def is_hc_def
  by auto

lemma finite_verts_G':
  shows "finite (verts G')"
  using G'_def_2 finite_verts_G finite_subset_verts_G'
  by fastforce

lemma vwalk_arcs_Cycle_subseteq_arcs_G:
  assumes "card (verts G) > 1"
  shows "set (vwalk_arcs Cycle) \<subseteq> arcs G"
  using Cycle_def assms
  unfolding is_hc_def pre_digraph.cycle_def pre_digraph.awalk_def
  by auto

lemma no_arcs_impl_at_most_one_vertex:
  assumes "arcs G = {}"
  shows "card (verts G) \<le> 1"
  using Cycle_def assms
  unfolding is_hc_def pre_digraph.cycle_def pre_digraph.awalk_def
  by auto

lemma arcs_G'_subset_verts_verts:
  shows "arcs G' \<subseteq> (verts G' \<times> verts G')"
  using wf_digraph_G' head_tail_G' wf_digraph.head_in_verts wf_digraph.tail_in_verts
  by fastforce

lemma arcsG_empty_exists_cycleG':
  assumes "arcs G = {}"
  shows "\<exists>Cy. is_uhc G' Cy"
  using no_arcs_impl_at_most_one_vertex assms in_hc
  by simp

lemma non_empty_arcs_card_verts_G:
  assumes "arcs G \<noteq> {}"
  shows "card (verts G) \<ge> 1"
  using assms wf_digraph_G finite_verts_G in_hc
  by simp

lemma card_verts_G'_2:
  assumes "card (verts G) > 1"
  shows "card (verts G') > 1"
proof -
  obtain v where "v \<in> verts G"
    using assms not_one_le_zero
    by fastforce
  then have "(v, 0) \<in> verts G'" "(v, 1) \<in> verts G'"
    using G'_def_2
    by auto
  then show ?thesis
    using finite_verts_G'
    by (meson contains_two_card_greater_1 prod.inject zero_neq_one)
qed

lemma not_in_cycle_not_in_uhc_cycle:
  assumes "a \<notin> set C"
  shows "(a, i) \<notin> set (to_cycle_uhc G C)"
  using assms
  apply(induction C)
  by(auto)

lemma distinct_C_distinct_uhc_cycle:
  assumes "distinct C"
  shows "distinct (to_cycle_uhc G C)"
  using assms by(induction C)(auto simp add: not_in_cycle_not_in_uhc_cycle)

lemma distinct_Cy:
  shows "distinct (tl Cy)"
  using Cy_def distinct_tail_cycle distinct_C_distinct_uhc_cycle
  by simp

lemma subset_G_to_uhc_subset_G':
  assumes "set C \<subseteq> verts G"
  shows "set (to_cycle_uhc G C) \<subseteq> verts G'"
  using assms by(induction C)(auto simp add: G'_def_2)

lemma set_Cy_subset_G':
  assumes  "card (verts G) > 1"
  shows "set Cy \<subseteq> verts G'"
proof -
  have 0: "Cy = (hd Cycle, 2) # to_cycle_uhc G (tl Cycle)"
    using Cy_def
    by simp
  then have 1: "set (to_cycle_uhc G (tl Cycle)) \<subseteq> verts G'"
    using Cycle_subset subset_G_to_uhc_subset_G'
    by (meson list_set_tl subset_code(1))
  have "hd Cycle \<in> verts G"
    using Cycle_subset Cycle_not_empty assms
    by auto
  then have "(hd Cycle, 2) \<in> verts G'"
    using G'_def_2
    by fastforce
  then show ?thesis
    using 1 0
    by auto
qed

lemma x_in_C_impl_x_in_to_cycle_uhc_i:
  assumes "x \<in> set C" "i\<le>2"
  shows "(x, i) \<in> set (to_cycle_uhc G C)"
  using assms by(induction C)(auto)

lemma card_verts_impl_length_Cycle:
  assumes "card (verts G) > 1"  "arcs G \<noteq> {}"
  shows "length Cycle > 2"
proof -
  have hl: "hd Cycle = last Cycle"
    using assms
    by (simp add: hd_last_Cycle)
  obtain u v where 1: "u \<in> verts G" "v \<in> verts G" "u \<noteq> v"
    using assms card_greater_1_contains_two_elements
    by blast
  then have "u \<in> set Cycle" "v \<in> set Cycle"
    using Cycle_def assms is_hc_def
    by fastforce+
  then have "u \<in> set (tl Cycle)" "v \<in> set (tl Cycle)"
    using hl
    by (metis 1(3) Cycle_not_empty List.insert_def hd_Cons_tl in_hc(2) in_set_insert
        insert_Nil last_ConsR last_in_set list.distinct(1) list.sel(1, 3) list.set_cases)+
  then have "card (set (tl Cycle)) > 1"
    using 1
    by (meson List.finite_set contains_two_card_greater_1)
  then have "length (tl Cycle) > 1"
    using  \<open>u \<in> set (tl Cycle)\<close>
    by (metis card_length leD length_pos_if_in_set
        less_numeral_extra(3) less_one linorder_neqE_nat)
  then show ?thesis
    by simp
qed

lemma all_verts_G'_in_Cy:
  assumes  "card (verts G) > 1" "arcs G \<noteq> {}"
  shows "(\<forall>x\<in>verts G'. x \<in> set Cy)"
proof
  fix x assume x_in: "x \<in> verts G'"
  then obtain a where a_def: "x = (a, 0) \<or> x = (a, 1) \<or>  x = (a, 2)"
    using G'_def_2
    by auto
  then have "a \<in> verts G"
    using G'_def_2  x_in
    by force
  then have "a \<in> set (tl Cycle)"
    using hd_last_eq_in_tl hd_last_Cycle assms card_verts_impl_length_Cycle Cycle_def is_hc_def
    by fastforce
  then have "(a, 0) \<in> set ( to_cycle_uhc G (tl Cycle))"
    "(a, 1) \<in> set ( to_cycle_uhc G (tl Cycle))"
    "(a, 2) \<in> set ( to_cycle_uhc G (tl Cycle))"
    using x_in_C_impl_x_in_to_cycle_uhc_i
    by auto
  then show "x\<in> set Cy"
    using a_def Cy_def
    by force
qed

lemma c_not_empty_to_cycle_not_empty:
  assumes "C \<noteq> []"
  shows "to_cycle_uhc G C \<noteq> []"
  using assms
  apply(induction C)
  by(auto)

lemma last_to_cycle_uhc:
  assumes "C \<noteq> []"
  shows "last (to_cycle_uhc G C) = (last C, 2)"
  using assms by(induction C)(auto simp add: c_not_empty_to_cycle_not_empty)

lemma hd_last_Cy:
  assumes "arcs G \<noteq> {}" "card (verts G) > 1"
  shows "hd Cy = last Cy"
proof -
  have 1: "hd Cycle = last Cycle"
    using hd_last_Cycle assms
    by blast
  have 2: "Cycle \<noteq> []"
    using assms Cycle_not_empty
    by blast
  then show ?thesis
  proof(cases "length Cycle = 1")
    case True
    then have "Cy = [(hd Cycle, 2)]"
      using Cy_def 2
      by (metis length_1_set_L list.sel(3) list.set_sel(1) to_cycle_uhc.simps(1))
    then show ?thesis
      by simp
  next
    case False
    then have "length Cycle > 1"
      using 1  2
      by (simp add: nat_neq_iff)
    then have 3: "tl Cycle \<noteq> []"
      by (metis length_tl less_numeral_extra(3) list.size(3) zero_less_diff)
    then have 4: "hd Cycle = last (tl Cycle)"
      using 1
      by (simp add: last_tl)
    have 5: "last Cycle = last (tl Cycle)"
      using 1 4
      by auto
    have 6: "last (to_cycle_uhc G (tl Cycle)) = (last (tl Cycle), 2)"
      using 3 last_to_cycle_uhc
      by(auto simp add:3 last_to_cycle_uhc)
    then have "last Cy =  (last Cycle, 2)"
      using 1 5 6 Cy_def c_not_empty_to_cycle_not_empty
      by auto
    then show ?thesis
      using 1 Cy_def
      by auto
  qed
qed

subsubsection\<open>@{term Cy} is a @{term pre_digraph.cycle}\<close>

lemma vwalk_arcs_Cy_not_empty:
  assumes "arcs G \<noteq> {}" "card (verts G) > 1"
  shows "vwalk_arcs Cy \<noteq> []"
proof -
  have "length Cycle > 2"
    using assms
    by (simp add: card_verts_impl_length_Cycle)
  then have "tl Cycle \<noteq> []"
    using length_geq_2_tt_not_empty
    by force
  then have "to_cycle_uhc G (tl Cycle) \<noteq> []"
    by (simp add: c_not_empty_to_cycle_not_empty)
  then have "length Cy > 1"
    using Cy_def
    by auto
  then show ?thesis
    using length_C_vwalk_arcs_not_empty
    by fast
qed

lemma at_least_two_nodes_vwalk_arcs_awalk_verts:
  assumes "length C > 1"
  shows "(pre_digraph.awalk_verts G' u (vwalk_arcs C)) = C"
  using head_tail_G' at_least_two_nodes_vwalk_arcs_awalk_verts assms
  by fast

lemma distinct_impl_distinct_awalk:
  assumes "distinct (tl C)"
  shows  "distinct (tl (pre_digraph.awalk_verts G' u (vwalk_arcs C)))"
  using assms
proof(induction C)
  case Nil
  then show ?case
    unfolding pre_digraph.awalk_verts_def
    by auto
next
  case (Cons a C)
  then show ?case
  proof(cases "C = []")
    case True
    then show ?thesis
      by (simp add: pre_digraph.awalk_verts.simps(1))
  next
    case False
    then have "length (a#C) > 1"
      by simp
    then show ?thesis
      using at_least_two_nodes_vwalk_arcs_awalk_verts Cons
      by presburger
  qed
qed

lemma distinct_tl_awalk_cy:
  shows"distinct (tl (pre_digraph.awalk_verts G' u (vwalk_arcs Cy)))"
  using distinct_impl_distinct_awalk distinct_Cy
  by simp

lemma cas_to_cycle_uhc:
  assumes "L = (to_cycle_uhc G C)" "L \<noteq> []"
  shows "pre_digraph.cas G' (hd L) (vwalk_arcs L) (last L)"
  using assms
proof(induction C arbitrary: L)
  case Nil
  then show ?case
    by auto
next
  case (Cons a C)
  have L_def: "L = [(a, 0), (a,1), (a,2)] @ (to_cycle_uhc G C)"
    using Cons
    by auto
  then have "hd L = (a, 0)"
    by auto
  then have 1: "(vwalk_arcs L) = ((a, 0), (a, 1))# ((a, 1), (a, 2))#
    (vwalk_arcs ((a, 2) # to_cycle_uhc G C))"
    using L_def vwalk_arcs.simps
    by auto
  then show ?case
  proof(cases "C = []")
    case True
    then have "last L = (a, 2)"
      using L_def
      by simp
    then have "vwalk_arcs L = ((a, 0), (a, 1))# ((a, 1), (a, 2)) # []"
      using 1 True
      by simp
    then have "pre_digraph.cas G' (a, (0::nat)) (vwalk_arcs L) (a, 2)"
      using G'_def_2
      by (simp add: pre_digraph.cas.simps(1, 2))
    then show ?thesis
      by (simp add: \<open>hd L = (a, 0)\<close> \<open>last L = (a, 2)\<close>)
  next
    case False
    then have to_cy_not_empty: "(to_cycle_uhc G C) \<noteq> []"
      by (simp add: c_not_empty_to_cycle_not_empty)
    then have 2: "pre_digraph.cas G'  (hd (to_cycle_uhc G (C)))
        (vwalk_arcs (to_cycle_uhc G (C))) (last (to_cycle_uhc G (C)))"
      using Cons
      by auto
    then have "(vwalk_arcs L) = ((a, 0), (a, 1))# ((a, 1), (a, 2))# ((a, 2), hd (to_cycle_uhc G C))
        # (vwalk_arcs (to_cycle_uhc G C))"
      using 1 to_cy_not_empty
      by auto
    then show ?thesis
      using L_def G'_def_2 2 to_cy_not_empty
      by(simp add: pre_digraph.cas.simps)
  qed
qed

lemma cas_Cy:
  assumes "arcs G \<noteq> {}" "card (verts G) > 1"
  shows  "pre_digraph.cas G' (hd Cycle, 2) (vwalk_arcs Cy) (hd Cycle, 2)"
proof -
  have "Cycle \<noteq> []"
    using assms
    by (simp add: Cycle_not_empty)
  then have tl_Cy_not_empty: "tl Cy \<noteq> []"
    using assms Cy_def vwalk_arcs_Cy_not_empty
    by auto
  then have 1: "pre_digraph.cas G' (hd (tl Cy)) (vwalk_arcs (tl Cy)) (last Cy)"
    using cas_to_cycle_uhc Cy_def
    by simp
  have 2: "hd Cy = (hd Cycle, 2)"
    using Cy_def
    by simp
  then have 3: "last Cy = (hd Cycle, 2)"
    using assms hd_last_Cy by auto
  have "pre_digraph.cas G' (hd Cycle, 2) (vwalk_arcs Cy) (last Cy)"
    using 1 2 G'_def_2
    by (metis (no_types, lifting) Cy_def tl_Cy_not_empty assms hd_vwalk_arcs_last_p
        head_tail_G' list.sel(1) list.sel(3) pre_digraph.cas_simp snd_conv
        vwalk_arcs_Cons vwalk_arcs_Cy_not_empty)
  then show ?thesis
    using 3
    by simp
qed

lemma hd_to_cycle_uhc:
  assumes "C \<noteq> []"
  shows "hd (to_cycle_uhc G C) = (hd C, 0)"
  using assms by(induction C)(auto)

lemma sublist_Cycle_in_arcs:
  assumes "card (verts G) > 1" "sublist [a, b] Cycle"
  shows "(a, b) \<in> arcs G"
proof -
  have 1: "(a, b) \<in> set (vwalk_arcs Cycle)"
    using assms by (simp add: vwalk_sublist_in_arcs)
  have "set (vwalk_arcs Cycle) \<subseteq> arcs G"
    using Cycle_def assms
    unfolding pre_digraph.cycle_def is_hc_def pre_digraph.awalk_def
    by auto
  then show ?thesis
    using 1
    by auto
qed

lemma hd_hd_tl_Cycle_in_arcs:
  assumes "tl Cycle \<noteq> []" "card (verts G) > 1"
  shows "(hd Cycle, hd (tl Cycle)) \<in> arcs G"
proof -
  have 1: "(hd Cycle, hd (tl Cycle)) \<in> set (vwalk_arcs Cycle)"
    using assms
    by (metis Nil_tl in_set_member list.collapse member_rec(1) vwalk_arcs_Cons)
  have "set (vwalk_arcs Cycle) \<subseteq> arcs G"
    using Cycle_def assms
    unfolding pre_digraph.cycle_def is_hc_def pre_digraph.awalk_def
    by auto
  then show ?thesis using 1
    by auto
qed

lemma hd_Cy_noteq_hd_tl_Cy:
  assumes "arcs G \<noteq> {}" "card (verts G) > 1"
  shows "hd (tl Cycle) \<noteq> hd Cycle"
proof (rule ccontr)
  have hl: "hd Cycle = last Cycle"
    using hd_last_Cycle assms
    by simp
  assume a1: "\<not> hd (tl Cycle) \<noteq> hd Cycle"
  then have 1: "hd (tl Cycle) = last Cycle"
    using hl
    by simp
  have "tl Cycle \<noteq> []"
    using card_verts_impl_length_Cycle assms length_geq_2_tt_not_empty
    by force
  then have "tl Cycle = [hd Cycle]"
    using distinct_tail_cycle 1 a1
    by (metis  append.right_neutral last_tl list.set_sel(1) sublist_set_last_ls1_2)
  then have cy_def: "Cycle= [hd Cycle, hd Cycle]"
    using distinct_tail_cycle hl
    by (metis Nil_tl list.discI list.exhaust_sel)
  have "length [hd Cycle, hd Cycle] = 2"
    by simp
  then have "length Cycle = 2"
    using cy_def
    by(auto)
  then show False
    using assms card_verts_impl_length_Cycle
    by auto
qed

lemma uv_in_G_in_G':
  assumes "u\<noteq> v"
    "(u, v) \<in> arcs G"
  shows "((u, 2), (v, 0)) \<in> arcs G'"
  using assms G'_def_2 wf_digraph_G(2)
  by auto

lemma hd_Cy_hd_tl_in_arcs_G':
  assumes "arcs G \<noteq> {}" "card (verts G) > 1" "sublist [a, b] Cy" "a = hd Cy"
  shows "(a, b) \<in> arcs G'"
proof -
  have tail_head_G:
    "tail G = fst" "head G = snd"
    using wf_digraph_G assms by simp+
  have a_def: "a = (hd Cycle, 2)"
    using assms Cy_def
    by simp
  have Cycle_not_empty: "Cycle \<noteq> []"
    using assms
    by (simp add: Cycle_not_empty)
  have tl_Cycle_not_empty: "tl Cycle \<noteq> []"
    using assms Cy_def vwalk_arcs_Cy_not_empty
    by auto
  have "distinct (tl Cy)" "a = last Cy"
    using assms hd_last_Cy
     apply (simp add: distinct_Cy hd_last_Cy)
    using assms hd_last_Cy
    by blast
  then have "b = hd (tl Cy)"
    using sublist_hd_tl_equal_b_hd_tl assms
    by fast
  then have b_def: "b = (hd (tl Cycle), 0)"
    using Cy_def hd_to_cycle_uhc tl_Cycle_not_empty
    by(auto)
  then have "(hd Cycle, hd (tl Cycle)) \<in> arcs G"
    "head G (hd Cycle, hd (tl Cycle)) = (hd (tl Cycle))"
    "tail G (hd Cycle, hd (tl Cycle)) = (hd (Cycle))"
    using assms hd_hd_tl_Cycle_in_arcs tl_Cycle_not_empty
      apply blast
    using assms tail_head_G
    by auto
  then have "((hd Cycle, 2), (hd (tl Cycle), 0)) \<in> arcs G'"
    using G'_def_2 tail_head_G hd_Cy_noteq_hd_tl_Cy uv_in_G_in_G' in_hc(2)
    by auto
  then show ?thesis
    using a_def b_def
    by simp
qed

lemma in_Cycle_in_verts:
  assumes "a \<in> set Cycle"
  shows "a \<in> verts G"
  using Cycle_def is_hc_def assms
  by fast

lemma helper_arcs_first_list:
  assumes "sublist [(a, i), (b, j)] [(c, 0), (c, (1::nat)), (c, 2)]"
  shows "(a = b \<and> a \<in> set (c#C) \<and> b \<in> set (c#C) \<and> ((i = 0 \<and> j = 1) \<or> (i = 1 \<and> j = 2)))"
proof -
  have distinct: "distinct [(c, (0::nat)), (c, 1), (c, 2)]"
    by(auto)
  have in_set: "(a, i) \<in> set [(c, 0), (c, 1), (c, 2)]" "(b, j) \<in> set [(c, 0), (c, 1), (c, 2)]"
    using assms
    by (meson in_sublist_impl_in_list list.set_intros)+
  then have "a = c" "b = c"
    by auto
  then have 1: "a = b" "a \<in> set (c#C)" "b \<in> set (c#C)"
    by auto
  have "((i = 0 \<and> j = 1) \<or> (i = 1 \<and> j = 2))"
  proof(cases "i = 0")
    case True
    then have "[(c, (0::nat)), (c, 1), (c, 2)] = (a, i) #  [(c, 1), (c, 2)]"
      by (simp add: \<open>a = c\<close>)
    then have "(b, j) = (c, 1)"
      using assms vwalk_sublist_in_arcs
      by fastforce
    then show ?thesis
      using True
      by blast
  next
    case False
    then have "i = 1 \<or> i = 2"
      using in_set
      by auto
    then show ?thesis
    proof
      assume "i = 1"
      then have "(b, j) = (c, 2)"
        using \<open>b = c\<close> assms vwalk_sublist_in_arcs
        by fastforce
      then show ?thesis
        using \<open>i = 1\<close>
        by auto
    next
      assume "i = 2"
      then have "False"
        using assms vwalk_sublist_in_arcs
        by fastforce
      then show ?thesis
        by simp
    qed
  qed
  then show ?thesis
    using 1
    by auto
qed

lemma to_cycle_uhc_sublist_sublist_of_C:
  assumes "L = to_cycle_uhc G C" "sublist [(a, i), (b, j)] L" "distinct L"
  shows "(sublist [a, b] C \<and> i = 2 \<and> j = 0) \<or> (a = b \<and> a \<in> set C \<and> b \<in> set C
    \<and> ((i = 0 \<and> j = 1) \<or> (i = 1 \<and> j = 2)))"
  using assms
proof(induction C arbitrary: L)
  case Nil
  then have "L \<noteq> []"
    by (simp add: sublist_def)
  then show ?case using Nil
    by simp
next
  case (Cons c C)
  then have "L = [(c, 0), (c, 1), (c, 2)] @ to_cycle_uhc G C"
    by simp
  then have 1: "sublist [(a, i), (b, j)] ([(c, 0), (c, 1), (c, 2)] @ to_cycle_uhc G C)"
    "distinct ([(c, 0), (c, 1), (c, 2)] @ to_cycle_uhc G C)"
    "[(c, 0), (c, 1), (c, 2)] \<noteq> []"
    using Cons by auto
  then have "sublist [(a, i), (b, j)] [(c, 0), (c, 1), (c, 2)] \<or>
    sublist [(a, i), (b, j)] (to_cycle_uhc G C) \<or>
    (a, i) = (c, 2) \<and> (b, j) = hd (to_cycle_uhc G C)"
    by - (drule sublist_append_using_or, auto)
  then show ?case
  proof
    assume "sublist [(a, i), (b, j)] [(c, 0), (c, 1), (c, 2)]"
    then have "a = b \<and> a \<in> set (c # C) \<and> b \<in> set (c # C) \<and> (i = 0 \<and> j = 1 \<or> i = 1 \<and> j = 2)"
      using helper_arcs_first_list
      by metis
    then show ?thesis using helper_arcs_first_list 1
      by blast
  next
    assume "sublist [(a, i), (b, j)] (to_cycle_uhc G C) \<or> (a, i) = (c, 2)
        \<and> (b, j) = hd (to_cycle_uhc G C)"
    then show ?thesis
    proof
      assume "sublist [(a, i), (b, j)] (to_cycle_uhc G C)"
      then have "(sublist [a, b] C \<and> i = 2 \<and> j = 0) \<or> (a = b \<and> a \<in> set C \<and> b \<in> set C
        \<and> ((i = 0 \<and> j = 1) \<or> (i = 1 \<and> j = 2)))"
        using Cons
        by simp
      then show ?thesis
        by (meson list.set_intros(2) sublist_cons)
    next
      assume a1: "(a, i) = (c, 2) \<and> (b, j) = hd (to_cycle_uhc G C)"
      then have "(to_cycle_uhc G C) \<noteq> []"
        using Cons \<open>L = [(c, 0), (c, 1), (c, 2)] @ to_cycle_uhc G C\<close>
        by (metis append.right_neutral helper_arcs_first_list one_eq_numeral_iff
            semiring_norm(85) zero_neq_numeral)
      then have C_not_empty: "C \<noteq> []"
        by auto
      then have b_def: "(b, j) = (hd C, 0)"
        using hd_to_cycle_uhc a1
        by simp
      then have "[]@[a, b]@(tl C) = c#C"
        using a1 C_not_empty
        by simp
      then have "sublist [a, b] (c # C)"
        using sublist_def by metis
      then show ?thesis
        using a1 b_def
        by force
    qed
  qed
qed

lemma sublist_disitnct_not_eq:
  assumes "sublist [a, b] C" "distinct C"
  shows "a \<noteq> b"
  using assms by(rule sublist_implies_in_set_a)

lemma sublist_ab_a_noteq_b:
  assumes "sublist [a, b] Cycle" "1 < card (verts G)" "arcs G \<noteq> {}"
  shows "a \<noteq> b"
proof(cases "a = hd Cycle")
  case True
  then have "distinct (tl Cycle)" "a = last Cycle"
    using distinct_tail_cycle hd_last_Cycle assms
    by simp+
  then have "b = hd (tl Cycle)"
    using sublist_hd_tl_equal_b_hd_tl assms
    by (simp add: sublist_hd_tl_equal_b_hd_tl local.hd_last_Cycle)
  then show ?thesis
    using True assms(3) hd_Cy_noteq_hd_tl_Cy in_hc(2)
    by auto
next
  case False
  then have "sublist [a, b] (tl Cycle)"
    using assms
    by (metis hd_Cons_tl list.sel(2) sublist_cons_impl_sublist)
  then show ?thesis using distinct_tail_cycle sublist_disitnct_not_eq
    by fastforce
qed

lemma Cy_arcs_in_arcs_G':
  assumes "arcs G \<noteq> {}" "card (verts G) > 1"
  shows "set (vwalk_arcs Cy) \<subseteq> arcs G'"
proof
  have d_tl_C: "distinct (tl Cycle)"
    using assms
    by (simp add: distinct_tail_cycle)
  then have dL: "distinct (to_cycle_uhc G (tl Cycle))"
    using distinct_C_distinct_uhc_cycle
    by simp
  have tail_head_G:
    "tail G = fst" "head G = snd"
    using wf_digraph_G assms
    by simp+
  fix x assume x_def: "x \<in> set (vwalk_arcs Cy)"
  then have "\<exists>a b. x = (a, b)"
    by (meson prod_cases3)
  then obtain a b where ab_def: "x = (a, b)"
    by auto
  then have sublist: "sublist [a, b] Cy"
    using x_def sublist_for_edges
    by metis
  then have "a = hd Cy \<or> sublist [a, b] (tl Cy)"
    by (metis ab_def distinct.simps(2) distinct_singleton hd_Cons_tl
        in_set_vwalk_arcsE sublist_cons_impl_sublist x_def)
  then show "x \<in> arcs G'"
  proof
    assume "a = hd Cy"
    then show ?thesis
      using hd_Cy_hd_tl_in_arcs_G' assms ab_def sublist
      by(auto)
  next
    assume "sublist [a, b] (tl Cy)"
    then have s_tcu: "sublist [a, b] (to_cycle_uhc G (tl Cycle))"
      using Cy_def
      by simp
    obtain a1 a2 b1 b2 where ab_def_2: "a = (a1, a2)" "b = (b1, b2)"
      by fastforce
    then have "(sublist [a1, b1] (tl Cycle) \<and> a2 = 2 \<and> b2 = 0)
      \<or> (a1 = b1 \<and>a1 \<in> set (tl Cycle) \<and> b1 \<in> set (tl Cycle)
      \<and> ((a2 = 0 \<and> b2 = 1) \<or> (a2 = 1 \<and> b2 = 2)))"
      using to_cycle_uhc_sublist_sublist_of_C s_tcu ab_def_2 dL
      by simp
    then show ?thesis
    proof
      assume a1: "(sublist [a1, b1] (tl Cycle) \<and> a2 = 2 \<and> b2 = 0)"
      then have "sublist [a1, b1] Cycle"
        by (metis hd_Cons_tl list.sel(2) sublist_cons)
      then have "(a1, b1) \<in> arcs G" "a1 \<noteq> b1"
        using sublist_Cycle_in_arcs assms sublist_ab_a_noteq_b
        by auto
      then have "((a1, 2), (b1, 0)) \<in> arcs G'"
        using G'_def_2 tail_head_G sublist_ab_a_noteq_b
        by force
      then have "((a1, a2), (b1, b2)) \<in> arcs G'"
        using a1 by auto
      then show ?thesis using ab_def_2 ab_def
        by auto
    next
      assume a1: "(a1 = b1 \<and> a1 \<in> set (tl Cycle) \<and> b1 \<in> set (tl Cycle)
        \<and> ((a2 = 0 \<and> b2 = 1) \<or> (a2 = 1 \<and> b2 = 2)))"
      then have a_eq_b: "a1 = b1" "((a2 = 0 \<and> b2 = 1) \<or> (a2 = 1 \<and> b2 = 2))" "a1 \<in> verts G"
        using in_Cycle_in_verts
        by (auto simp add: a1 in_Cycle_in_verts list_set_tl)
      then have "((a1, 0), (a1, 1)) \<in> arcs G'"  "((a1, 1), (a1, 2)) \<in> arcs G'"
        using G'_def_2
        by simp+
      then show ?thesis
        using a_eq_b ab_def ab_def_2
        by auto
    qed
  qed
qed

lemma pre_digraph_cycle_Cy_G':
  assumes "arcs G \<noteq> {}" "card (verts G) > 1"
  shows "pre_digraph.cycle G' (vwalk_arcs Cy)"
  using assms vwalk_arcs_Cy_not_empty distinct_tl_awalk_cy Cy_def set_Cy_subset_G'
    Cy_arcs_in_arcs_G' cas_Cy
  unfolding pre_digraph.cycle_def pre_digraph.awalk_def
  by fastforce

subsubsection\<open>@{term Cy} is a @{term vwalk_cycle}\<close>

lemma card_verts_length_Cy:
  assumes "card (verts G) > 1"
  shows "length Cy > 1"
  using assms card_verts_G'_2
  by (metis all_verts_G'_in_Cy card_length dual_order.antisym
      le_0_eq less_one no_arcs_impl_at_most_one_vertex
      not_le not_le_imp_less not_less_iff_gr_or_eq set_Cy_subset_G' subsetI
      vwalk_arcs_Cy_not_empty vwalk_arcs_from_length_1)

lemma vwalk_cycle_Cy_G':
  assumes "arcs G \<noteq> {}" "card (verts G) > 1"
  shows "vwalk_cycle G' Cy"
proof -
  have 1: "length Cy > 1"
    using assms card_verts_length_Cy
    by (auto)
  have "pre_digraph.cycle G' (vwalk_arcs Cy)"
    using assms pre_digraph_cycle_Cy_G'
    by auto
  then show ?thesis
    using 1 cycle_implies_vwalk_cycle head_tail_G' wf_digraph_G'
    by fastforce
qed

subsubsection\<open>@{term G'} is in \<open>UHC\<close>\<close>

lemma is_uhc_Cy_G':
  assumes "arcs G \<noteq> {}" "card (verts G) > 1"
  shows "is_uhc G' Cy"
  using assms distinct_Cy set_Cy_subset_G' all_verts_G'_in_Cy vwalk_cycle_Cy_G'
    cycle_implies_vwalk_cycle
  unfolding is_uhc_def
  by presburger

lemma arcsG_non_empty_exists_cycleG':
  assumes "arcs G \<noteq> {}" "card (verts G) > 1"
  shows "\<exists>c.  is_uhc G' c"
  using assms is_uhc_Cy_G'
  by auto

lemma in_uhc: "hc_to_uhc G \<in> uhc"
  using head_tail_G' wf_digraph_G' G'_def symmetric_G' finite_verts_G'
    arcsG_empty_exists_cycleG' in_hc arcsG_non_empty_exists_cycleG'
  unfolding uhc_def by auto

end
end


section\<open>Enum toString Functions\<close>
theory Lib_Enum_toString
imports Main "../../IP_Addresses/Lib_List_toString"
begin

fun bool_toString :: "bool \<Rightarrow> string" where
  "bool_toString True = ''True''" |
  "bool_toString False = ''False''"

subsection\<open>Enum set to string\<close>
  fun enum_set_get_one :: "'a list \<Rightarrow> 'a set \<Rightarrow> 'a option" where
    "enum_set_get_one []     S = None" |
    "enum_set_get_one (s#ss) S = (if s \<in> S then Some s else enum_set_get_one ss S)"

  lemma enum_set_get_one_empty: "enum_set_get_one ss {} = None"
    by(induction ss) simp_all

  lemma enum_set_get_one_None: "S \<subseteq> set ss \<Longrightarrow> enum_set_get_one ss S = None \<longleftrightarrow> S = {}"
    apply(induction ss)
     apply(simp; fail)
    apply(simp)
    apply(intro conjI)
     apply blast
    by fast

  lemma enum_set_get_one_Some: "S \<subseteq> set ss \<Longrightarrow> enum_set_get_one ss S = Some x \<Longrightarrow> x \<in> S"
    apply(induction ss)
     apply(simp; fail)
    apply(simp split: if_split_asm)
    apply(blast)
    done
  corollary enum_set_get_one_enum_Some: "enum_set_get_one enum_class.enum S = Some x \<Longrightarrow> x \<in> S"
    using enum_set_get_one_Some[where ss=enum_class.enum, simplified enum_UNIV] by auto

  lemma enum_set_get_one_Ex_Some: "S \<subseteq> set ss \<Longrightarrow> S \<noteq> {} \<Longrightarrow> \<exists>x. enum_set_get_one ss S = Some x"
    apply(induction ss)
     apply(simp; fail)
    apply(simp split: if_split_asm)
    apply(blast)
    done
  corollary enum_set_get_one_enum_Ex_Some:
    "S \<noteq> {} \<Longrightarrow> \<exists>x. enum_set_get_one enum_class.enum S = Some x"
    using enum_set_get_one_Ex_Some[where ss=enum_class.enum, simplified enum_UNIV] by auto

  function enum_set_to_list :: "('a::enum) set \<Rightarrow> 'a list" where
    "enum_set_to_list S = (if S = {} then [] else
      case enum_set_get_one Enum.enum S of None \<Rightarrow> []
                                        |  Some a \<Rightarrow> a#enum_set_to_list (S - {a}))"
  by(pat_completeness) auto

  termination enum_set_to_list
    apply(relation "measure (\<lambda>(S). card S)")
     apply(simp_all add: card_gt_0_iff)
    apply(drule enum_set_get_one_enum_Some)
    apply(subgoal_tac "finite S")
     prefer 2
     apply force
    apply (meson card_Diff1_less)
    done

  (*this definition is simpler*)
  lemma enum_set_to_list_simps: "enum_set_to_list S =
      (case enum_set_get_one (Enum.enum) S of None \<Rightarrow> []
                                           |  Some a \<Rightarrow> a#enum_set_to_list (S - {a}))"
   by(simp add: enum_set_get_one_empty)
  declare enum_set_to_list.simps[simp del]

  lemma enum_set_to_list: "set (enum_set_to_list A) = A"
    apply(induction A rule: enum_set_to_list.induct)
    apply(case_tac "S = {}")
     apply(simp add: enum_set_to_list.simps; fail)
    apply(simp)
    apply(subst enum_set_to_list_simps)
    apply(simp)
    apply(drule enum_set_get_one_enum_Ex_Some)
    apply(clarify)
    apply(simp)
    apply(drule enum_set_get_one_enum_Some)
    by blast

lemma "list_toString bool_toString (enum_set_to_list {True, False}) = ''[False, True]''" by eval

end


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

theory Indexing_Hoare_Typed
  imports VHDL_Hoare_Typed
begin

datatype sig = IN | OUT

definition index :: "sig conc_stmt" where
  "index \<equiv> process {IN} : Bassign_trans OUT (Bindex IN 3) 1"

abbreviation "bof_wline tw sig n \<equiv> bval_of (wline_of tw sig n)"
abbreviation "lof_wline tw sig n \<equiv> lval_of (wline_of tw sig n)"

definition inv :: "sig assn2" where
  "inv tw \<equiv> (bof_wline tw OUT (fst tw) = (lof_wline tw IN (fst tw - 1)) ! 3)"

definition inv' :: "sig assn2" where
  "inv' tw = (disjnt {IN} (event_of tw) \<longrightarrow> (\<forall>i>fst tw. bof_wline tw OUT i = bof_wline tw OUT (fst tw)))"

lemma potential_tyenv:
  assumes "seq_wt \<Gamma> (Bassign_trans OUT (Bindex IN 3) 1)"
  shows   "\<exists>ki len. 3 < len \<and> \<Gamma> IN = Lty ki len \<and> \<Gamma> OUT = Bty"
proof (rule seq_wt_cases(4)[OF assms])
  assume "bexp_wt \<Gamma> (Bindex IN 3) (\<Gamma> OUT)"
  then obtain ki len where "bexp_wt \<Gamma> (Bsig IN) (Lty ki len) \<and> 3 < len \<and> \<Gamma> OUT = Bty"
    by (meson bexp_wt_cases_slice(3))
  hence "\<Gamma> IN = Lty ki len" and "\<Gamma> OUT = Bty" and "3 < len"
    by (metis bexp_wt_cases_slice(2))+
  thus ?thesis
    by blast
qed

locale indexing =
  fixes \<Gamma> :: "sig tyenv" and len :: nat
  assumes tyin: "\<Gamma> IN =  Lty Neu len" and tyout: "\<Gamma> OUT = Bty" and len3: "3 < len"
begin

lemma inv_next_time:
  fixes tw
  defines "v \<equiv> eval_world_raw2 tw (Bindex IN 3)"
  defines "tw' \<equiv> tw[OUT, 1 :=\<^sub>2 v]"
  assumes "wityping \<Gamma> (snd tw)"
  shows   "inv (fst tw' + 1, snd tw')"
proof -
  have bexpIN: "bexp_wt \<Gamma> (Bsig IN) (Lty Neu len)" using tyin  by (metis bexp_wt.intros(3))
  then obtain bsIN where evalIN: "eval_world_raw (fst tw) (snd tw) (Bsig IN) = Lv Neu bsIN" and "length bsIN = len"
    using eval_world_raw_lv[OF bexpIN assms(3)] by auto
  have "bof_wline tw' OUT (fst tw + 1) \<longleftrightarrow> bval_of v"
    unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
  also have "... = (bsIN ! 3)"
    unfolding v_def using evalIN by auto
  also have "... = lof_wline tw IN (fst tw) ! 3"
    using evalIN by auto
  finally show ?thesis
    unfolding inv_def tw'_def worldline_upd2_def worldline_upd_def  by auto
qed

lemma inv'_next_time:
  fixes tw v
  defines "tw' \<equiv> tw[OUT, 1 :=\<^sub>2 v]"
  shows   "inv' (fst tw' + 1, snd tw')"
  unfolding inv'_def  tw'_def worldline_upd2_def worldline_upd_def by auto

lemma index_conc_hoare:
  "\<And>tw. inv tw \<and> inv' tw \<and> disjnt {IN} (event_of tw) \<Longrightarrow>inv (fst tw + 1, snd tw)"
proof -
  fix tw
  assume "inv tw \<and> inv' tw \<and> disjnt {IN} (event_of tw)"
  hence "inv tw" and "inv' tw" and "disjnt {IN} (event_of tw)"
    by auto
  have "bof_wline tw OUT (fst tw + 1) = bof_wline tw OUT (fst tw)"
    using `inv' tw` `disjnt {IN} (event_of tw)` unfolding inv'_def by auto
  also have "... = lof_wline tw IN (get_time tw - 1) ! 3"
    using `inv tw` unfolding inv_def by auto
  also have "... = lof_wline tw IN (fst tw) ! 3"
    using `disjnt {IN} (event_of tw)`  unfolding event_of_alt_def
    by (smt diff_0_eq_0 disjnt_insert1 mem_Collect_eq)
  finally show "inv (fst tw + 1, snd tw)"
    unfolding inv_def by auto
qed

lemma index_conc_hoare2:
  "\<And>tw. inv' tw \<and> disjnt {IN} (event_of tw) \<Longrightarrow> inv' (fst tw + 1, snd tw)"
  unfolding inv'_def by auto

lemma conc_stmt_wf_index:
  "conc_stmt_wf index"
  unfolding index_def conc_stmt_wf_def by auto

lemma nonneg_delay_conc_index:
  "nonneg_delay_conc index"
  unfolding index_def by auto

lemma nonneg_delay_conc_index':
  "nonneg_delay_conc ( process {IN} : Bassign_trans OUT (Bindex IN 3) 1)"
  using nonneg_delay_conc_index unfolding index_def by auto

lemma conc_wt_index:
  "conc_wt \<Gamma> index"
  unfolding index_def using tyout tyin
  by (intro conc_wt.intros seq_wt.intros)(metis bexp_wt.intros(14) bexp_wt.intros(3) len3)

lemma well_typed:
  "seq_wt \<Gamma> (Bassign_trans OUT (Bindex IN 3) 1)"
  using conc_wt_index unfolding index_def by auto

lemma conc_wt_index':
  "conc_wt \<Gamma> ( process {IN} : Bassign_trans OUT (Bindex IN 3) 1)"
  using conc_wt_index unfolding index_def by auto

lemma index_conc_sim2':
  "\<Gamma> \<turnstile>\<^sub>s \<lbrace>\<lambda>tw. inv tw \<and> inv' tw\<rbrace> index \<lbrace>\<lambda>tw. inv tw \<and> inv' tw\<rbrace>"
  apply (rule While_Suc)
  apply (rule Conseq'[where P="wp3_conc \<Gamma> index (\<lambda>tw. inv  (fst tw + 1, snd tw) \<and>
                                                      inv' (fst tw + 1, snd tw))", rotated])
    apply (rule wp3_conc_is_pre[ OF conc_stmt_wf_index nonneg_delay_conc_index conc_wt_index], simp)
  unfolding index_def wp3_conc_single'[OF conc_wt_index' nonneg_delay_conc_index'] wp3_fun.simps
  using inv_next_time inv'_next_time index_conc_hoare index_conc_hoare2 by presburger

text \<open>Initialisation preserves the invariant\<close>

lemma nonneg_delay_index:
  " nonneg_delay (Bassign_trans OUT (Bindex IN 3) 1)"
  using nonneg_delay_conc_index' by auto

lemma init_sat_index_inv_comb:
  "init_sim2_hoare_wt \<Gamma> (\<lambda>tw. fst tw = 0) index (\<lambda>tw. inv tw \<and> inv' tw)"
  unfolding index_def
  apply (rule AssignI_suc, rule SingleI)
  apply (rule Conseq3[where Q="\<lambda>tw. inv (fst tw + 1, snd tw) \<and> inv' (fst tw + 1, snd tw)", rotated])
  apply (rule wp3_fun_is_pre[OF well_typed nonneg_delay_index], simp)
  unfolding wp3_fun.simps using inv_next_time inv'_next_time by blast

lemma correctness:
  assumes "sim_fin2 w (i + 1) index tw'" and "wityping \<Gamma> w"
  shows   "bof_wline tw' OUT (i + 1) = lof_wline tw' IN i ! 3"
  using grand_correctness[OF assms conc_stmt_wf_index conc_wt_index nonneg_delay_conc_index index_conc_sim2' init_sat_index_inv_comb]
  unfolding index_def inv_def by (metis (no_types, lifting) add_diff_cancel_right' assms(1)
  sim_fin2.cases world_maxtime_lt_fst_tres)

end

end


(*  Title:      HOL/HOLCF/Cprod.thy
    Author:     Franz Regensburger
*)

section \<open>The cpo of cartesian products\<close>

theory Cprod
imports Cfun
begin

default_sort cpo

subsection \<open>Continuous case function for unit type\<close>

definition
  unit_when :: "'a \<rightarrow> unit \<rightarrow> 'a" where
  "unit_when = (\<Lambda> a _. a)"

translations
  "\<Lambda>(). t" == "CONST unit_when\<cdot>t"

lemma unit_when [simp]: "unit_when\<cdot>a\<cdot>u = a"
by (simp add: unit_when_def)

subsection \<open>Continuous version of split function\<close>

definition
  csplit :: "('a \<rightarrow> 'b \<rightarrow> 'c) \<rightarrow> ('a * 'b) \<rightarrow> 'c" where
  "csplit = (\<Lambda> f p. f\<cdot>(fst p)\<cdot>(snd p))"

translations
  "\<Lambda>(CONST Pair x y). t" == "CONST csplit\<cdot>(\<Lambda> x y. t)"

abbreviation
  cfst :: "'a \<times> 'b \<rightarrow> 'a" where
  "cfst \<equiv> Abs_cfun fst"

abbreviation
  csnd :: "'a \<times> 'b \<rightarrow> 'b" where
  "csnd \<equiv> Abs_cfun snd"

subsection \<open>Convert all lemmas to the continuous versions\<close>

lemma csplit1 [simp]: "csplit\<cdot>f\<cdot>\<bottom> = f\<cdot>\<bottom>\<cdot>\<bottom>"
by (simp add: csplit_def)

lemma csplit_Pair [simp]: "csplit\<cdot>f\<cdot>(x, y) = f\<cdot>x\<cdot>y"
by (simp add: csplit_def)

end


theory Tree_Automata_Pumping
  imports Tree_Automata
begin

subsection \<open>Pumping lemma\<close>

(* We need to deal with non deterministic tree automata,
   to show the pumping lemma we need to find cycles on the derivation
   of terms with depth greater than the number of states.

  assumes "card (ta_states A) < depth t" and "finite (ta_states A)"
      and "q \<in> ta_res A t" and "ground t"
    shows "\<exists> s v p. t \<unrhd> s \<and> s \<rhd> v \<and> p \<in> ta_res A v \<and> p \<in> ta_res A s"

  we only get t \<longrightarrow>* q, v \<longrightarrow> p, s \<longrightarrow> p, but we have no chance to conclude
  that the state p appears in the derivation t \<longrightarrow>* q, because our derivation is
  not deterministic and there could be a cycle in the derivation of t which does not
  end in state q.
 *)

abbreviation "derivation_ctxt ts Cs \<equiv> Suc (length Cs) = length ts \<and>
  (\<forall> i < length Cs. (Cs ! i) \<langle>ts ! i\<rangle> = ts ! Suc i)"

abbreviation "derivation_ctxt_st A ts Cs qs \<equiv> length qs = length ts \<and> Suc (length Cs) = length ts \<and>
  (\<forall> i < length Cs. qs ! Suc i |\<in>| ta_der A (Cs ! i)\<langle>Var (qs ! i)\<rangle>)"

abbreviation "derivation_sound A ts qs \<equiv> length qs = length ts \<and>
  (\<forall> i < length qs. qs ! i |\<in>| ta_der A (ts ! i))"

definition "derivation A ts Cs qs \<longleftrightarrow> derivation_ctxt ts Cs \<and>
  derivation_ctxt_st A ts Cs qs \<and> derivation_sound A ts qs"

(* Context compositions from left *)
lemma ctxt_comp_lhs_not_hole:
  assumes "C \<noteq> \<box>"
  shows "C \<circ>\<^sub>c D \<noteq> \<box>"
  using assms by (cases C; cases D) auto

lemma ctxt_comp_rhs_not_hole:
  assumes "D \<noteq> \<box>"
  shows "C \<circ>\<^sub>c D \<noteq> \<box>"
  using assms by (cases C; cases D) auto

lemma fold_ctxt_comp_nt_empty_acc:
  assumes "D \<noteq> \<box>"
  shows "fold (\<circ>\<^sub>c) Cs D \<noteq> \<box>"
  using assms by (induct Cs arbitrary: D) (auto simp add: ctxt_comp_rhs_not_hole)

lemma fold_ctxt_comp_nt_empty:
  assumes "C \<in> set Cs" and "C \<noteq> \<box>"
  shows "fold (\<circ>\<^sub>c) Cs D \<noteq> \<box>" using assms
  by (induct Cs arbitrary: D) (auto simp: ctxt_comp_lhs_not_hole fold_ctxt_comp_nt_empty_acc)

(* Rep of context *)

lemma empty_ctxt_power [simp]:
  "\<box> ^ n = \<box>"
  by (induct n) auto

lemma ctxt_comp_not_hole:
  assumes "C \<noteq> \<box>" and "n \<noteq> 0"
  shows "C^n \<noteq> \<box>"
  using assms by (induct n arbitrary: C) (auto elim!: ctxt_compose.elims)

lemma ctxt_comp_n_suc [simp]:
  shows "(C^(Suc n))\<langle>t\<rangle> = (C^n)\<langle>C\<langle>t\<rangle>\<rangle>"
  by (induct n arbitrary: C) auto

lemma ctxt_comp_reach:
  assumes "p |\<in>| ta_der A C\<langle>Var p\<rangle>"
  shows "p |\<in>| ta_der A (C^n)\<langle>Var p\<rangle>"
  using assms by (induct n arbitrary: C) (auto intro: ta_der_ctxt)

(* Connecting positions to term depth and trivial depth lemmas *)

lemma args_depth_less [simp]:
  assumes "u \<in> set ss"
  shows "depth u < depth (Fun f ss)" using assms
  by (cases ss) (auto simp: less_Suc_eq_le)

lemma subterm_depth_less:
  assumes "s \<rhd> t"
  shows "depth t < depth s"
  using assms by (induct s t rule: supt.induct) (auto intro: less_trans)

lemma poss_length_depth:
  shows "\<exists> p \<in> poss t. length p = depth t"
proof (induct t)
  case (Fun f ts)
  then show ?case
  proof (cases ts)
    case [simp]: (Cons a list)
    have "ts \<noteq> [] \<Longrightarrow> \<exists> s. f s = Max (f ` set ts) \<and> s \<in> set ts" for ts f
    using Max_in[of "f ` set ts"] by (auto simp: image_iff)
    from this[of ts depth] obtain s where s: "depth s = Max (depth ` set ts) \<and> s \<in> set ts"
      by auto
    then show ?thesis using Fun[of s] in_set_idx[OF conjunct2[OF s]]
      by fastforce
  qed auto
qed auto

lemma poss_length_bounded_by_depth:
  assumes "p \<in> poss t"
  shows "length p \<le> depth t" using assms
  by (induct t arbitrary: p) (auto intro!: Suc_leI, meson args_depth_less dual_order.strict_trans2 nth_mem)

(* Connecting depth to ctxt repetition *)

lemma depth_ctxt_nt_hole_inc:
  assumes "C \<noteq> \<box>"
  shows "depth t < depth C\<langle>t\<rangle>" using assms
  using subterm_depth_less[of t "C\<langle>t\<rangle>"]
  by (simp add: nectxt_imp_supt_ctxt subterm_depth_less)

lemma depth_ctxt_less_eq:
  "depth t \<le> depth C\<langle>t\<rangle>" using depth_ctxt_nt_hole_inc less_imp_le
  by (cases C, simp) blast

lemma ctxt_comp_n_not_hole_depth_inc:
  assumes "C \<noteq> \<box>"
  shows "depth (C^n)\<langle>t\<rangle> < depth (C^(Suc n))\<langle>t\<rangle>"
  using assms by (induct n arbitrary: C t) (auto simp: ctxt_comp_not_hole depth_ctxt_nt_hole_inc)

lemma ctxt_comp_n_lower_bound:
  assumes "C \<noteq> \<box>"
  shows "n < depth (C^(Suc n))\<langle>t\<rangle>"
  using assms
proof (induct n arbitrary: C)
  case 0 then show ?case using ctxt_comp_not_hole depth_ctxt_nt_hole_inc gr_implies_not_zero by blast
next
  case (Suc n) then show ?case using ctxt_comp_n_not_hole_depth_inc less_trans_Suc by blast
qed

lemma ta_der_ctxt_n_loop:
  assumes "q |\<in>| ta_der \<A> t" "q |\<in>| ta_der \<A> C\<langle>Var q\<rangle>"
  shows " q |\<in>| ta_der \<A> (C^n)\<langle>t\<rangle>"
  using assms by (induct n) (auto simp: ta_der_ctxt)

lemma ctxt_compose_funs_ctxt [simp]:
  "funs_ctxt (C \<circ>\<^sub>c D) = funs_ctxt C \<union> funs_ctxt D"
  by (induct C arbitrary: D) auto

lemma ctxt_compose_vars_ctxt [simp]:
  "vars_ctxt (C \<circ>\<^sub>c D) = vars_ctxt C \<union> vars_ctxt D"
  by (induct C arbitrary: D) auto

lemma ctxt_power_funs_vars_0 [simp]:
  assumes "n = 0"
  shows "funs_ctxt (C^n) = {}" "vars_ctxt (C^n) = {}"
  using assms by auto

lemma ctxt_power_funs_vars_n [simp]:
  assumes "n \<noteq> 0"
  shows "funs_ctxt (C^n) = funs_ctxt C" "vars_ctxt (C^n) = vars_ctxt C"
  using assms by (induct n arbitrary: C, auto) fastforce+

(* Collect all terms in a path via positions *)

fun terms_pos where
  "terms_pos s [] = [s]"
| "terms_pos s (p # ps) = terms_pos (s |_ [p]) ps @ [s]"

lemma subt_at_poss [simp]:
  assumes "a # p \<in> poss s"
  shows "p \<in> poss (s |_ [a])"
  using assms by (metis append_Cons append_self_conv2 poss_append_poss)

lemma terms_pos_length [simp]:
  shows "length (terms_pos t p) = Suc (length p)"
  by (induct p arbitrary: t) auto

lemma terms_pos_last [simp]:
  assumes "i = length p"
  shows "terms_pos t p ! i = t" using assms
  by (induct p arbitrary: t) (auto simp add: append_Cons_nth_middle)

lemma terms_pos_subterm:
  assumes "p \<in> poss t" and "s \<in> set (terms_pos t p)"
  shows "t \<unrhd> s" using assms
  using assms
proof (induct p arbitrary: t s)
  case (Cons a p)
  from Cons(2) have st: "t \<unrhd> t |_ [a]" by auto
  from Cons(1)[of "t |_ [a]"] Cons(2-) show ?case
    using supteq_trans[OF st] by fastforce
qed auto

lemma terms_pos_differ_subterm:
  assumes "p \<in> poss t" and "i < length (terms_pos t p)"
     and "j < length (terms_pos t p)" and "i < j"
   shows "terms_pos t p ! i \<lhd> terms_pos t p ! j"
  using assms
proof (induct p arbitrary: t i j)
  case (Cons a p)
  from Cons(2-) have "t |_ [a] \<unrhd> terms_pos (t |_ [a]) p ! i"
    by (intro terms_pos_subterm[of p]) auto
  from subterm.order.strict_trans1[OF this, of t] Cons(1)[of "t |_ [a]" i j] Cons(2-) show ?case
    by (cases "j = length (a # p)") (force simp add: append_Cons_nth_middle append_Cons_nth_left)+
qed auto

lemma distinct_terms_pos:
  assumes "p \<in> poss t"
  shows "distinct (terms_pos t p)" using assms
proof (induct p arbitrary: t)
  case (Cons a p)
  have "\<And>i. i < Suc (length p) \<Longrightarrow> t \<rhd> (terms_pos (t |_ [a]) p) ! i"
    using terms_pos_differ_subterm[OF Cons(2), of _  "Suc (length p)"] by (auto simp: nth_append)
  then show ?case using  Cons(1)[of "t |_ [a]"] Cons(2-)
    by (auto simp: in_set_conv_nth) (metis supt_not_sym)
qed auto

lemma term_chain_depth:
  assumes "depth t = n"
  shows "\<exists> p \<in> poss t. length (terms_pos t p) = (n + 1)"
proof -
  obtain p where p: "p \<in> poss t" "length p = depth t"
    using poss_length_depth[of t] by blast
  from terms_pos_length[of t p] this show ?thesis using assms
    by auto
qed

lemma ta_der_derivation_chain_terms_pos_exist:
  assumes "p \<in> poss t" and "q |\<in>| ta_der A t"
  shows "\<exists> Cs qs. derivation A (terms_pos t p) Cs qs \<and> last qs = q"
  using assms
proof (induct p arbitrary: t q)
  case Nil
  then show ?case by (auto simp: derivation_def intro!: exI[of _ "[q]"])
next
  case (Cons a p)
  from Cons(2) have poss: "p \<in> poss (t |_ [a])" by auto
  from Cons(2) obtain C where C: "C\<langle>t |_ [a]\<rangle> = t"
    using ctxt_at_pos_subt_at_id poss_Cons by blast
  from C ta_der_ctxt_decompose Cons(3) obtain q' where
    res: "q' |\<in>| ta_der A (t |_ [a])" "q |\<in>| ta_der A C\<langle>Var q'\<rangle>"
    by metis
  from Cons(1)[OF _ res(1)] Cons(2-) C obtain Cs qs where
    der: "derivation A (terms_pos (t |_ [a]) p) Cs qs \<and> last qs = q'"
    by (auto simp del: terms_pos.simps)
  {fix i assume "i < Suc (length Cs)"
    then have "derivation_ctxt (terms_pos (t |_ [a]) p @ [t]) (Cs @ [C])"
      using der C[symmetric] unfolding derivation_def
      by (cases "i = length Cs") (auto simp: nth_append_Cons)}
  note der_ctxt = this
  {fix i assume "i < Suc (length Cs)"
    then have "derivation_ctxt_st A (terms_pos (t |_ [a]) p @ [t]) (Cs @ [C]) (qs @ [q])"
      using der poss C res(2) last_conv_nth[of qs]
      by (cases "i = length Cs", auto 0 0 simp: derivation_def nth_append not_less less_Suc_eq) fastforce+}
  then show ?case using C poss res(1) der_ctxt der
    by (auto simp: derivation_def intro!: exI[of _ "Cs @ [C]"] exI[of _ "qs @ [q]"])
      (simp add: Cons.prems(2) nth_append_Cons)
qed

lemma derivation_ctxt_terms_pos_nt_empty:
  assumes "p \<in> poss t" and "derivation_ctxt (terms_pos t p) Cs" and "C \<in> set Cs"
  shows "C \<noteq> \<box>"
  using assms by (auto simp: in_set_conv_nth)
    (metis Suc_mono assms(2) ctxt_apply_term.simps(1) distinct_terms_pos lessI less_SucI less_irrefl_nat nth_eq_iff_index_eq)

lemma derivation_ctxt_terms_pos_sub_list_nt_empty:
  assumes "p \<in> poss t" and "derivation_ctxt (terms_pos t p) Cs"
    and "i < length Cs" and "j \<le> length Cs" and "i < j"
  shows "fold (\<circ>\<^sub>c) (take (j - i) (drop i Cs)) \<box> \<noteq> \<box>"
proof -
  have "\<exists> C. C \<in> set (take (j - i) (drop i Cs))"
    using assms(3-) not_le by fastforce
  then obtain C where w: "C \<in> set (take (j - i) (drop i Cs))" by blast
  then have "C \<noteq> \<box>"
    by auto (meson assms(1, 2) derivation_ctxt_terms_pos_nt_empty in_set_dropD in_set_takeD)
  then show ?thesis by (auto simp: fold_ctxt_comp_nt_empty[OF w])
qed

lemma derivation_ctxt_comp_term:
  assumes "derivation_ctxt ts Cs"
    and "i < length Cs" and "j \<le> length Cs" and "i < j"
  shows "(fold (\<circ>\<^sub>c) (take (j - i) (drop i Cs)) \<box>)\<langle>ts ! i\<rangle> = ts ! j"
  using assms
proof (induct "j - i" arbitrary: j i)
  case (Suc x)
  then obtain n where j [simp]: "j = Suc n" by (meson lessE)
  then have r: "x = n - i" "Suc n - i = 1 + (n - i)" using Suc(2, 6) by linarith+
  then show ?case using Suc(1)[OF r(1)] Suc(2-) unfolding j r(2) take_add[of "n - i" 1]
    by (cases "i = n") (auto simp: take_Suc_conv_app_nth)
qed auto

lemma derivation_ctxt_comp_states:
  assumes "derivation_ctxt_st A ts Cs qs"
    and "i < length Cs" and "j \<le> length Cs" and "i < j"
  shows "qs ! j |\<in>| ta_der A (fold (\<circ>\<^sub>c) (take (j - i) (drop i Cs)) \<box>)\<langle>Var (qs ! i)\<rangle>"
  using assms
proof (induct "j - i" arbitrary: j i)
  case (Suc x)
  then obtain n where j [simp]: "j = Suc n" by (meson lessE)
  then have r: "x = n - i" "Suc n - i = 1 + (n - i)" using Suc(2, 6) by linarith+
  then show ?case using Suc(1)[OF r(1)] Suc(2-) unfolding j r(2) take_add[of "n - i" 1]
    by (cases "i = n") (auto simp: take_Suc_conv_app_nth ta_der_ctxt)
qed auto

lemma terms_pos_ground:
  assumes "ground t" and "p \<in> poss t"
  shows "\<forall> s \<in> set (terms_pos t p). ground s"
  using terms_pos_subterm[OF assms(2)] subterm_eq_pres_ground[OF assms(1)] by simp

lemma list_card_smaller_contains_eq_elemens:
  assumes "length qs = n" and "card (set qs) < n"
  shows "\<exists> i < length qs. \<exists> j < length qs. i < j \<and> qs ! i = qs ! j"
  using assms by auto (metis distinct_card distinct_conv_nth linorder_neqE_nat)

lemma length_remdups_less_eq:
  assumes "set xs \<subseteq> set ys"
  shows "length (remdups xs) \<le> length (remdups ys)" using assms
  by (auto simp: length_remdups_card_conv card_mono)

(* Main lemma *)

lemma pigeonhole_tree_automata:
  assumes "fcard (\<Q> A) < depth t" and "q |\<in>| ta_der A t" and "ground t"
  shows "\<exists> C C2 v p. C2 \<noteq> \<box> \<and> C\<langle>C2\<langle>v\<rangle>\<rangle> = t \<and> p |\<in>| ta_der A v \<and>
     p |\<in>| ta_der A C2\<langle>Var p\<rangle> \<and> q |\<in>| ta_der A C\<langle>Var p\<rangle>"
proof -
  obtain p n where p: "p \<in> poss t"  "depth t = n" and
    card: "fcard (\<Q> A) < n" "length (terms_pos t p) = (n + 1)"
    using assms(1) term_chain_depth by blast
  from ta_der_derivation_chain_terms_pos_exist[OF p(1) assms(2)] obtain Cs qs where
    derivation: "derivation A (terms_pos t p) Cs qs \<and> last qs = q" by blast
  then have d_ctxt: "derivation_ctxt_st A (terms_pos t p) Cs qs" "derivation_ctxt (terms_pos t p) Cs"
    by (auto simp: derivation_def)
  then have l: "length Cs = length qs - 1" by (auto simp: derivation_def)
  from derivation have sub: "fset_of_list qs |\<subseteq>| \<Q> A" "length qs = length (terms_pos t p)"
    unfolding derivation_def
    using ta_der_states[of A "t |_ i" for i] terms_pos_ground[OF assms(3) p(1)]
    by auto (metis derivation derivation_def gterm_of_term_inv gterm_ta_der_states in_fset_conv_nth nth_mem)
  then have "\<exists> i < length (butlast qs). \<exists> j < length (butlast qs). i < j \<and> (butlast qs) ! i = (butlast qs) ! j"
    using card(1, 2) assms(1) fcard_mono[OF sub(1)] length_remdups_less_eq[of "butlast qs" qs]
    by (intro list_card_smaller_contains_eq_elemens[of "butlast qs" n])
       (auto simp: card_set fcard_fset in_set_butlastD subsetI
                 intro!: le_less_trans[of "length (remdups (butlast qs))" "fcard (\<Q> A)" "length p"])
  then obtain i j where len: "i < length Cs" "j < length Cs" and less: "i < j" and st: "qs ! i = qs ! j"
    unfolding l length_butlast by (auto simp: nth_butlast)
  then have gt_0: "0 < length Cs" and gt_j: "0 < j" using len less less_trans by auto
  have "fold (\<circ>\<^sub>c) (take (j - i) (drop i Cs)) \<box> \<noteq> \<box>"
    using derivation_ctxt_terms_pos_sub_list_nt_empty[OF p(1) d_ctxt(2) len(1) order.strict_implies_order[OF len(2)] less] .
  moreover have "(fold (\<circ>\<^sub>c) (take (length Cs - j) (drop j Cs)) \<box>)\<langle>terms_pos t p ! j\<rangle> = terms_pos t p ! length Cs"
    using derivation_ctxt_comp_term[OF d_ctxt(2) len(2) _ len(2)] len(2) by auto
  moreover have "(fold (\<circ>\<^sub>c) (take (j - i) (drop i Cs)) \<box>)\<langle>terms_pos t p ! i\<rangle> = terms_pos t p ! j"
    using derivation_ctxt_comp_term[OF d_ctxt(2) len(1) _ less] len(2) by auto
  moreover have "qs ! j |\<in>| ta_der A (terms_pos t p ! i)" using derivation len
    by (auto simp: derivation_def st[symmetric])
  moreover have "qs ! j |\<in>| ta_der A (fold (\<circ>\<^sub>c) (take (j - i) (drop i Cs)) \<box>)\<langle>Var (qs ! i)\<rangle>"
    using derivation_ctxt_comp_states[OF d_ctxt(1) len(1) _ less] len(2) st by simp
  moreover have "q |\<in>| ta_der A (fold (\<circ>\<^sub>c) (take (length Cs - j) (drop j Cs)) \<box>)\<langle>Var (qs ! j)\<rangle>"
    using derivation_ctxt_comp_states[OF d_ctxt(1) len(2) _ len(2)] conjunct2[OF derivation]
    by (auto simp: l sub(2)) (metis Suc_inject Zero_not_Suc d_ctxt(1) l last_conv_nth list.size(3) terms_pos_length)
  ultimately show ?thesis using st d_ctxt(1) by (metis Suc_inject terms_pos_last terms_pos_length)
qed

end