(*  Title:       Preliminaries for hybrid systems verification
    Author:      Jonathan Julián Huerta y Munive, 2019
    Maintainer:  Jonathan Julián Huerta y Munive <jjhuertaymunive1@sheffield.ac.uk>
*)

section \<open> Hybrid Systems Preliminaries \<close>

text \<open>Hybrid systems combine continuous dynamics with discrete control. This section contains
auxiliary lemmas for verification of hybrid systems.\<close>

theory HS_Preliminaries
  imports "Ordinary_Differential_Equations.Picard_Lindeloef_Qualitative"
begin

subsection \<open> Real numbers \<close>

lemma abs_le_eq:
  shows "(r::real) > 0 \<Longrightarrow> (\<bar>x\<bar> < r) = (-r < x \<and> x < r)"
    and "(r::real) > 0 \<Longrightarrow> (\<bar>x\<bar> \<le> r) = (-r \<le> x \<and> x \<le> r)"
  by linarith+

lemma real_ivl_eqs:
  assumes "0 < r"
  shows "ball x r = {x-r<--< x+r}"         and "{x-r<--< x+r} = {x-r<..< x+r}"
    and "ball (r / 2) (r / 2) = {0<--<r}"  and "{0<--<r} = {0<..<r}"
    and "ball 0 r = {-r<--<r}"             and "{-r<--<r} = {-r<..<r}"
    and "cball x r = {x-r--x+r}"           and "{x-r--x+r} = {x-r..x+r}"
    and "cball (r / 2) (r / 2) = {0--r}"   and "{0--r} = {0..r}"
    and "cball 0 r = {-r--r}"              and "{-r--r} = {-r..r}"
  unfolding open_segment_eq_real_ivl closed_segment_eq_real_ivl
  using assms by (auto simp: cball_def ball_def dist_norm field_simps)

lemma norm_rotate_eq[simp]:
  fixes x :: "'a:: {banach,real_normed_field}"
  shows "(x * cos t - y * sin t)\<^sup>2 + (x * sin t + y * cos t)\<^sup>2 = x\<^sup>2 + y\<^sup>2"
    and "(x * cos t + y * sin t)\<^sup>2 + (y * cos t - x * sin t)\<^sup>2 = x\<^sup>2 + y\<^sup>2"
proof-
  have "(x * cos t - y * sin t)\<^sup>2 = x\<^sup>2 * (cos t)\<^sup>2 + y\<^sup>2 * (sin t)\<^sup>2 - 2 * (x * cos t) * (y * sin t)"
    by(simp add: power2_diff power_mult_distrib)
  also have "(x * sin t + y * cos t)\<^sup>2 = y\<^sup>2 * (cos t)\<^sup>2 + x\<^sup>2 * (sin t)\<^sup>2 + 2 * (x * cos t) * (y * sin t)"
    by(simp add: power2_sum power_mult_distrib)
  ultimately show "(x * cos t - y * sin t)\<^sup>2 + (x * sin t + y * cos t)\<^sup>2 = x\<^sup>2 + y\<^sup>2"
    by (simp add: Groups.mult_ac(2) Groups.mult_ac(3) right_diff_distrib sin_squared_eq)
  thus "(x * cos t + y * sin t)\<^sup>2 + (y * cos t - x * sin t)\<^sup>2 = x\<^sup>2 + y\<^sup>2"
    by (simp add: add.commute add.left_commute power2_diff power2_sum)
qed

subsection \<open> Single variable derivatives \<close>

notation has_derivative ("(1(D _ \<mapsto> (_))/ _)" [65,65] 61)
notation has_vderiv_on ("(1 D _ = (_)/ on _)" [65,65] 61)
notation norm ("(1\<parallel>_\<parallel>)" [65] 61)

thy_deps

named_theorems poly_derivatives "compilation of optimised miscellaneous derivative rules."

declare has_vderiv_on_const [poly_derivatives]
    and has_vderiv_on_id [poly_derivatives]
    and has_vderiv_on_add[THEN has_vderiv_on_eq_rhs, poly_derivatives]
    and has_vderiv_on_diff[THEN has_vderiv_on_eq_rhs, poly_derivatives]
    and has_vderiv_on_mult[THEN has_vderiv_on_eq_rhs, poly_derivatives]

lemma has_vderiv_on_compose_eq:
  assumes "D f = f' on g ` T"
    and " D g = g' on T"
    and "h = (\<lambda>x. g' x *\<^sub>R f' (g x))"
  shows "D (\<lambda>t. f (g t)) = h on T"
  apply(subst ssubst[of h], simp)
  using assms has_vderiv_on_compose by auto

lemma vderiv_on_compose_add [derivative_intros]:
  assumes "D x = x' on (\<lambda>\<tau>. \<tau> + t) ` T"
  shows "D (\<lambda>\<tau>. x (\<tau> + t)) = (\<lambda>\<tau>. x' (\<tau> + t)) on T"
  apply(rule has_vderiv_on_compose_eq[OF assms])
  by(auto intro: derivative_intros)

lemma has_vderiv_on_divide_cnst: "a \<noteq> 0 \<Longrightarrow> D (\<lambda>t. t/a) = (\<lambda>t. 1/a) on T"
  unfolding has_vderiv_on_def has_vector_derivative_def
  apply clarify
  apply(rule_tac f'1="\<lambda>t. t" and g'1="\<lambda> x. 0" in has_derivative_divide[THEN has_derivative_eq_rhs])
  by(auto intro: derivative_eq_intros)

lemma has_vderiv_on_power: "n \<ge> 1 \<Longrightarrow> D (\<lambda>t. t ^ n) = (\<lambda>t. n * (t ^ (n - 1))) on T"
  unfolding has_vderiv_on_def has_vector_derivative_def
  by (auto intro!: derivative_eq_intros)

lemma has_vderiv_on_exp: "D (\<lambda>t. exp t) = (\<lambda>t. exp t) on T"
  unfolding has_vderiv_on_def has_vector_derivative_def by (auto intro: derivative_intros)

lemma has_vderiv_on_cos_comp:
  "D (f::real \<Rightarrow> real) = f' on T \<Longrightarrow> D (\<lambda>t. cos (f t)) = (\<lambda>t. - (f' t) * sin (f t)) on T"
  apply(rule has_vderiv_on_compose_eq[of "\<lambda>t. cos t"])
  unfolding has_vderiv_on_def has_vector_derivative_def
    apply clarify
  by(auto intro!: derivative_eq_intros simp: fun_eq_iff)

lemma has_vderiv_on_sin_comp:
  "D (f::real \<Rightarrow> real) = f' on T \<Longrightarrow> D (\<lambda>t. sin (f t)) = (\<lambda>t. (f' t) * cos (f t)) on T"
  apply(rule has_vderiv_on_compose_eq[of "\<lambda>t. sin t"])
  unfolding has_vderiv_on_def has_vector_derivative_def
    apply clarify
  by(auto intro!: derivative_eq_intros simp: fun_eq_iff)

lemma has_vderiv_on_exp_comp:
  "D (f::real \<Rightarrow> real) = f' on T \<Longrightarrow> D (\<lambda>t. exp (f t)) = (\<lambda>t. (f' t) * exp (f t)) on T"
  apply(rule has_vderiv_on_compose_eq[of "\<lambda>t. exp t"])
  by (rule has_vderiv_on_exp, simp_all add: mult.commute)

lemma vderiv_uminus_intro [poly_derivatives]:
  "D f = f' on T \<Longrightarrow> g = (\<lambda>t. - f' t) \<Longrightarrow> D (\<lambda>t. - f t) = g on T"
  using has_vderiv_on_uminus by auto

lemma vderiv_div_cnst_intro [poly_derivatives]:
  assumes "(a::real) \<noteq> 0" and "D f = f' on T" and "g = (\<lambda>t. (f' t)/a)"
  shows "D (\<lambda>t. (f t)/a) = g on T"
  apply(rule has_vderiv_on_compose_eq[of "\<lambda>t. t/a" "\<lambda>t. 1/a"])
  using assms by(auto intro: has_vderiv_on_divide_cnst)

lemma vderiv_npow_intro [poly_derivatives]:
  fixes f::"real \<Rightarrow> real"
  assumes "n \<ge> 1" and "D f = f' on T" and "g = (\<lambda>t. n * (f' t) * (f t)^(n-1))"
  shows "D (\<lambda>t. (f t)^n) = g on T"
  apply(rule has_vderiv_on_compose_eq[of "\<lambda>t. t^n"])
  using assms(1)
    apply(rule has_vderiv_on_power)
  using assms by auto

lemma vderiv_cos_intro [poly_derivatives]:
  assumes "D (f::real \<Rightarrow> real) = f' on T" and "g = (\<lambda>t. - (f' t) * sin (f t))"
  shows "D (\<lambda>t. cos (f t)) = g on T"
  using assms and has_vderiv_on_cos_comp by auto

lemma vderiv_sin_intro [poly_derivatives]:
  assumes "D (f::real \<Rightarrow> real) = f' on T" and "g = (\<lambda>t. (f' t) * cos (f t))"
  shows "D (\<lambda>t. sin (f t)) = g on T"
  using assms and has_vderiv_on_sin_comp by auto

lemma vderiv_exp_intro [poly_derivatives]:
  assumes "D (f::real \<Rightarrow> real) = f' on T" and "g = (\<lambda>t. (f' t) * exp (f t))"
  shows "D (\<lambda>t. exp (f t)) = g on T"
  using assms and has_vderiv_on_exp_comp by auto

\<comment> \<open>Examples for checking derivatives\<close>

lemma "D (\<lambda>t. a * t\<^sup>2 / 2 + v * t + x) = (\<lambda>t. a * t + v) on T"
  by(auto intro!: poly_derivatives)

lemma "D (\<lambda>t. v * t - a * t\<^sup>2 / 2 + x) = (\<lambda>x. v - a * x) on T"
  by(auto intro!: poly_derivatives)

lemma "c \<noteq> 0 \<Longrightarrow> D (\<lambda>t. a5 * t^5 + a3 * (t^3 / c) - a2 * exp (t^2) + a1 * cos t + a0) =
  (\<lambda>t. 5 * a5 * t^4 + 3 * a3 * (t^2 / c) - 2 * a2 * t * exp (t^2) - a1 * sin t) on T"
  by(auto intro!: poly_derivatives)

lemma "c \<noteq> 0 \<Longrightarrow> D (\<lambda>t. - a3 * exp (t^3 / c) + a1 * sin t + a2 * t^2) =
  (\<lambda>t. a1 * cos t + 2 * a2 * t - 3 * a3 * t^2 / c * exp (t^3 / c)) on T"
  apply(intro poly_derivatives)
  using poly_derivatives(1,2) by force+

lemma "c \<noteq> 0 \<Longrightarrow> D (\<lambda>t. exp (a * sin (cos (t^4) / c))) =
(\<lambda>t. - 4 * a * t^3 * sin (t^4) / c * cos (cos (t^4) / c) * exp (a * sin (cos (t^4) / c))) on T"
  apply(intro poly_derivatives)
  using poly_derivatives(1,2) by force+

subsection \<open> Intermediate Value Theorem \<close>

lemma IVT_two_functions:
  fixes f :: "('a::{linear_continuum_topology, real_vector}) \<Rightarrow>
  ('b::{linorder_topology,real_normed_vector,ordered_ab_group_add})"
  assumes conts: "continuous_on {a..b} f" "continuous_on {a..b} g"
      and ahyp: "f a < g a" and bhyp: "g b < f b " and "a \<le> b"
    shows "\<exists>x\<in>{a..b}. f x = g x"
proof-
  let "?h x" = "f x - g x"
  have "?h a \<le> 0" and "?h b \<ge> 0"
    using ahyp bhyp by simp_all
  also have "continuous_on {a..b} ?h"
    using conts continuous_on_diff by blast
  ultimately obtain x where "a \<le> x" "x \<le> b" and "?h x = 0"
    using IVT'[of "?h"] \<open>a \<le> b\<close> by blast
  thus ?thesis
    using \<open>a \<le> b\<close> by auto
qed

lemma IVT_two_functions_real_ivl:
  fixes f :: "real \<Rightarrow> real"
  assumes conts: "continuous_on {a--b} f" "continuous_on {a--b} g"
      and ahyp: "f a < g a" and bhyp: "g b < f b "
    shows "\<exists>x\<in>{a--b}. f x = g x"
proof(cases "a \<le> b")
  case True
  then show ?thesis
    using IVT_two_functions assms
    unfolding closed_segment_eq_real_ivl by auto
next
  case False
  hence "a \<ge> b"
    by auto
  hence "continuous_on {b..a} f" "continuous_on {b..a} g"
    using conts False unfolding closed_segment_eq_real_ivl by auto
  hence "\<exists>x\<in>{b..a}. g x = f x"
    using IVT_two_functions[of b a g f] assms(3,4) False by auto
  then show ?thesis
    using \<open>a \<ge> b\<close> unfolding closed_segment_eq_real_ivl by auto force
qed

subsection \<open> Filters \<close>

lemma eventually_at_within_mono:
  assumes "t \<in> interior T" and "T \<subseteq> S"
    and "eventually P (at t within T)"
  shows "eventually P (at t within S)"
  by (meson assms eventually_within_interior interior_mono subsetD)

lemma netlimit_at_within_mono:
  fixes t::"'a::{perfect_space,t2_space}"
  assumes "t \<in> interior T" and "T \<subseteq> S"
  shows "netlimit (at t within S) = t"
  using assms(1) interior_mono[OF \<open>T \<subseteq> S\<close>] netlimit_within_interior by auto

lemma has_derivative_at_within_mono:
  assumes "(t::real) \<in> interior T" and "T \<subseteq> S"
    and "D f \<mapsto> f' at t within T"
  shows "D f \<mapsto> f' at t within S"
  using assms(3) apply(unfold has_derivative_def tendsto_iff, safe)
  unfolding netlimit_at_within_mono[OF assms(1,2)] netlimit_within_interior[OF assms(1)]
  by (rule eventually_at_within_mono[OF assms(1,2)]) simp

lemma eventually_all_finite2:
  fixes P :: "('a::finite) \<Rightarrow> 'b \<Rightarrow> bool"
  assumes h:"\<forall>i. eventually (P i) F"
  shows "eventually (\<lambda>x. \<forall>i. P i x) F"
proof(unfold eventually_def)
  let ?F = "Rep_filter F"
  have obs: "\<forall>i. ?F (P i)"
    using h by auto
  have "?F (\<lambda>x. \<forall>i \<in> UNIV. P i x)"
    apply(rule finite_induct)
    by(auto intro: eventually_conj simp: obs h)
  thus "?F (\<lambda>x. \<forall>i. P i x)"
    by simp
qed

lemma eventually_all_finite_mono:
  fixes P :: "('a::finite) \<Rightarrow> 'b \<Rightarrow> bool"
  assumes h1: "\<forall>i. eventually (P i) F"
      and h2: "\<forall>x. (\<forall>i. (P i x)) \<longrightarrow> Q x"
  shows "eventually Q F"
proof-
  have "eventually (\<lambda>x. \<forall>i. P i x) F"
    using h1 eventually_all_finite2 by blast
  thus "eventually Q F"
    unfolding eventually_def
    using h2 eventually_mono by auto
qed

subsection \<open> Multivariable derivatives \<close>

lemma frechet_vec_lambda:
  fixes f::"real \<Rightarrow> ('a::banach)^('m::finite)" and x::real and T::"real set"
  defines "x\<^sub>0 \<equiv> netlimit (at x within T)" and "m \<equiv> real CARD('m)"
  assumes "\<forall>i. ((\<lambda>y. (f y $ i - f x\<^sub>0 $ i - (y - x\<^sub>0) *\<^sub>R f' x $ i) /\<^sub>R (\<parallel>y - x\<^sub>0\<parallel>)) \<longlongrightarrow> 0) (at x within T)"
  shows "((\<lambda>y. (f y - f x\<^sub>0 - (y - x\<^sub>0) *\<^sub>R f' x) /\<^sub>R (\<parallel>y - x\<^sub>0\<parallel>)) \<longlongrightarrow> 0) (at x within T)"
proof(simp add: tendsto_iff, clarify)
  fix \<epsilon>::real assume "0 < \<epsilon>"
  let "?\<Delta>" = "\<lambda>y. y - x\<^sub>0" and "?\<Delta>f" = "\<lambda>y. f y - f x\<^sub>0"
  let "?P" = "\<lambda>i e y. inverse \<bar>?\<Delta> y\<bar> * (\<parallel>f y $ i - f x\<^sub>0 $ i - ?\<Delta> y *\<^sub>R f' x $ i\<parallel>) < e"
    and "?Q" = "\<lambda>y. inverse \<bar>?\<Delta> y\<bar> * (\<parallel>?\<Delta>f y - ?\<Delta> y *\<^sub>R f' x\<parallel>) < \<epsilon>"
  have "0 < \<epsilon> / sqrt m"
    using \<open>0 < \<epsilon>\<close> by (auto simp: assms)
  hence "\<forall>i. eventually (\<lambda>y. ?P i (\<epsilon> / sqrt m) y) (at x within T)"
    using assms unfolding tendsto_iff by simp
  thus "eventually ?Q (at x within T)"
  proof(rule eventually_all_finite_mono, simp add: norm_vec_def L2_set_def, clarify)
    fix t::real
    let ?c = "inverse \<bar>t - x\<^sub>0\<bar>" and "?u t" = "\<lambda>i. f t $ i - f x\<^sub>0 $ i - ?\<Delta> t *\<^sub>R f' x $ i"
    assume hyp:"\<forall>i. ?c * (\<parallel>?u t i\<parallel>) < \<epsilon> / sqrt m"
    hence "\<forall>i. (?c *\<^sub>R (\<parallel>?u t i\<parallel>))\<^sup>2 < (\<epsilon> / sqrt m)\<^sup>2"
      by (simp add: power_strict_mono)
    hence "\<forall>i. ?c\<^sup>2 * ((\<parallel>?u t i\<parallel>))\<^sup>2 < \<epsilon>\<^sup>2 / m"
      by (simp add: power_mult_distrib power_divide assms)
    hence "\<forall>i. ?c\<^sup>2 * ((\<parallel>?u t i\<parallel>))\<^sup>2 < \<epsilon>\<^sup>2 / m"
      by (auto simp: assms)
    also have "({}::'m set) \<noteq> UNIV \<and> finite (UNIV :: 'm set)"
      by simp
    ultimately have "(\<Sum>i\<in>UNIV. ?c\<^sup>2 * ((\<parallel>?u t i\<parallel>))\<^sup>2) < (\<Sum>(i::'m)\<in>UNIV. \<epsilon>\<^sup>2 / m)"
      by (metis (lifting) sum_strict_mono)
    moreover have "?c\<^sup>2 * (\<Sum>i\<in>UNIV. (\<parallel>?u t i\<parallel>)\<^sup>2) = (\<Sum>i\<in>UNIV. ?c\<^sup>2 *  (\<parallel>?u t i\<parallel>)\<^sup>2)"
      using sum_distrib_left by blast
    ultimately have "?c\<^sup>2 * (\<Sum>i\<in>UNIV. (\<parallel>?u t i\<parallel>)\<^sup>2) < \<epsilon>\<^sup>2"
      by (simp add: assms)
    hence "sqrt (?c\<^sup>2 * (\<Sum>i\<in>UNIV. (\<parallel>?u t i\<parallel>)\<^sup>2)) < sqrt (\<epsilon>\<^sup>2)"
      using real_sqrt_less_iff by blast
    also have "... = \<epsilon>"
      using \<open>0 < \<epsilon>\<close> by auto
    moreover have "?c * sqrt (\<Sum>i\<in>UNIV. (\<parallel>?u t i\<parallel>)\<^sup>2) = sqrt (?c\<^sup>2 * (\<Sum>i\<in>UNIV. (\<parallel>?u t i\<parallel>)\<^sup>2))"
      by (simp add: real_sqrt_mult)
    ultimately show "?c * sqrt (\<Sum>i\<in>UNIV. (\<parallel>?u t i\<parallel>)\<^sup>2) < \<epsilon>"
      by simp
  qed
qed

lemma tendsto_norm_bound:
  "\<forall>x. \<parallel>G x - L\<parallel> \<le> \<parallel>F x - L\<parallel> \<Longrightarrow> (F \<longlongrightarrow> L) net \<Longrightarrow> (G \<longlongrightarrow> L) net"
  apply(unfold tendsto_iff dist_norm, clarsimp)
  apply(rule_tac P="\<lambda>x. \<parallel>F x - L\<parallel> < e" in eventually_mono, simp)
  by (rename_tac e z) (erule_tac x=z in allE, simp)

lemma tendsto_zero_norm_bound:
  "\<forall>x. \<parallel>G x\<parallel> \<le> \<parallel>F x\<parallel> \<Longrightarrow> (F \<longlongrightarrow> 0) net \<Longrightarrow> (G \<longlongrightarrow> 0) net"
  apply(unfold tendsto_iff dist_norm, clarsimp)
  apply(rule_tac P="\<lambda>x. \<parallel>F x\<parallel> < e" in eventually_mono, simp)
  by (rename_tac e z) (erule_tac x=z in allE, simp)

lemma frechet_vec_nth:
  fixes f::"real \<Rightarrow> ('a::real_normed_vector)^'m"
  assumes "((\<lambda>x. (f x - f x\<^sub>0 - (x - x\<^sub>0) *\<^sub>R f' t) /\<^sub>R (\<parallel>x - x\<^sub>0\<parallel>)) \<longlongrightarrow> 0) (at t within T)"
  shows "((\<lambda>x. (f x $ i - f x\<^sub>0 $ i - (x - x\<^sub>0) *\<^sub>R f' t $ i) /\<^sub>R (\<parallel>x - x\<^sub>0\<parallel>)) \<longlongrightarrow> 0) (at t within T)"
  apply(rule_tac F="(\<lambda>x. (f x - f x\<^sub>0 - (x - x\<^sub>0) *\<^sub>R f' t) /\<^sub>R (\<parallel>x - x\<^sub>0\<parallel>))" in tendsto_zero_norm_bound)
   apply(clarsimp, rule mult_left_mono)
    apply (metis Finite_Cartesian_Product.norm_nth_le vector_minus_component vector_scaleR_component)
  using assms by simp_all

lemma has_derivative_vec_lambda:
  fixes f::"real \<Rightarrow> ('a::banach)^('n::finite)"
  assumes "\<forall>i. D (\<lambda>t. f t $ i) \<mapsto> (\<lambda> h. h *\<^sub>R f' x $ i) (at x within T)"
  shows "D f \<mapsto> (\<lambda>h. h *\<^sub>R f' x) at x within T"
  apply(unfold has_derivative_def, safe)
   apply(force simp: bounded_linear_def bounded_linear_axioms_def)
  using assms frechet_vec_lambda[of x T ] unfolding has_derivative_def by auto

lemma has_derivative_vec_nth:
  assumes "D f \<mapsto> (\<lambda>h. h *\<^sub>R f' x) at x within T"
  shows "D (\<lambda>t. f t $ i) \<mapsto> (\<lambda>h. h *\<^sub>R f' x $ i) at x within T"
  apply(unfold has_derivative_def, safe)
   apply(force simp: bounded_linear_def bounded_linear_axioms_def)
  using frechet_vec_nth assms unfolding has_derivative_def by auto

lemma has_vderiv_on_vec_eq[simp]:
  fixes x::"real \<Rightarrow> ('a::banach)^('n::finite)"
  shows "(D x = x' on T) = (\<forall>i. D (\<lambda>t. x t $ i) = (\<lambda>t. x' t $ i) on T)"
  unfolding has_vderiv_on_def has_vector_derivative_def apply safe
  using has_derivative_vec_nth has_derivative_vec_lambda by blast+

end


(*
 * Copyright Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(* Author: Jeremy Dawson and Gerwin Klein, NICTA *)

theory Rsplit
  imports "HOL-Library.Word" Bits_Int
begin

definition word_rsplit :: "'a::len word \<Rightarrow> 'b::len word list"
  where "word_rsplit w = map word_of_int (bin_rsplit (LENGTH('b)) (LENGTH('a), uint w))"

lemma word_rsplit_no:
  "(word_rsplit (numeral bin :: 'b::len word) :: 'a word list) =
    map word_of_int (bin_rsplit (LENGTH('a::len))
      (LENGTH('b), take_bit (LENGTH('b)) (numeral bin)))"
  by (simp add: word_rsplit_def of_nat_take_bit)

lemmas word_rsplit_no_cl [simp] = word_rsplit_no
  [unfolded bin_rsplitl_def bin_rsplit_l [symmetric]]

text \<open>
  This odd result arises from the fact that the statement of the
  result implies that the decoded words are of the same type,
  and therefore of the same length, as the original word.\<close>

lemma word_rsplit_same: "word_rsplit w = [w]"
  apply (simp add: word_rsplit_def bin_rsplit_all)
  apply transfer
  apply simp
  done

lemma word_rsplit_empty_iff_size: "word_rsplit w = [] \<longleftrightarrow> size w = 0"
  by (simp add: word_rsplit_def bin_rsplit_def word_size bin_rsplit_aux_simp_alt Let_def
      split: prod.split)

lemma test_bit_rsplit:
  "sw = word_rsplit w \<Longrightarrow> m < size (hd sw) \<Longrightarrow>
    k < length sw \<Longrightarrow> (rev sw ! k) !! m = w !! (k * size (hd sw) + m)"
  for sw :: "'a::len word list"
  apply (unfold word_rsplit_def word_test_bit_def)
  apply (rule trans)
   apply (rule_tac f = "\<lambda>x. bin_nth x m" in arg_cong)
   apply (rule nth_map [symmetric])
   apply simp
  apply (rule bin_nth_rsplit)
     apply simp_all
  apply (simp add : word_size rev_map)
  apply (rule trans)
   defer
   apply (rule map_ident [THEN fun_cong])
  apply (rule refl [THEN map_cong])
  apply simp
  using bin_rsplit_size_sign take_bit_int_eq_self_iff by blast

lemma test_bit_rsplit_alt:
  \<open>(word_rsplit w  :: 'b::len word list) ! i !! m \<longleftrightarrow>
    w !! ((length (word_rsplit w :: 'b::len word list) - Suc i) * size (hd (word_rsplit w :: 'b::len word list)) + m)\<close>
  if \<open>i < length (word_rsplit w :: 'b::len word list)\<close> \<open>m < size (hd (word_rsplit w :: 'b::len word list))\<close> \<open>0 < length (word_rsplit w :: 'b::len word list)\<close>
  for w :: \<open>'a::len word\<close>
  apply (rule trans)
   apply (rule test_bit_cong)
   apply (rule rev_nth [of _ \<open>rev (word_rsplit w)\<close>, simplified rev_rev_ident])
  apply simp
   apply (rule that(1))
  apply simp
  apply (rule test_bit_rsplit)
    apply (rule refl)
  apply (rule asm_rl)
   apply (rule that(2))
  apply (rule diff_Suc_less)
  apply (rule that(3))
  done

lemma word_rsplit_len_indep [OF refl refl refl refl]:
  "[u,v] = p \<Longrightarrow> [su,sv] = q \<Longrightarrow> word_rsplit u = su \<Longrightarrow>
    word_rsplit v = sv \<Longrightarrow> length su = length sv"
  by (auto simp: word_rsplit_def bin_rsplit_len_indep)

lemma length_word_rsplit_size:
  "n = LENGTH('a::len) \<Longrightarrow>
    length (word_rsplit w :: 'a word list) \<le> m \<longleftrightarrow> size w \<le> m * n"
  by (auto simp: word_rsplit_def word_size bin_rsplit_len_le)

lemmas length_word_rsplit_lt_size =
  length_word_rsplit_size [unfolded Not_eq_iff linorder_not_less [symmetric]]

lemma length_word_rsplit_exp_size:
  "n = LENGTH('a::len) \<Longrightarrow>
    length (word_rsplit w :: 'a word list) = (size w + n - 1) div n"
  by (auto simp: word_rsplit_def word_size bin_rsplit_len)

lemma length_word_rsplit_even_size:
  "n = LENGTH('a::len) \<Longrightarrow> size w = m * n \<Longrightarrow>
    length (word_rsplit w :: 'a word list) = m"
  by (cases \<open>LENGTH('a)\<close>) (simp_all add: length_word_rsplit_exp_size div_nat_eqI)

lemmas length_word_rsplit_exp_size' = refl [THEN length_word_rsplit_exp_size]

\<comment> \<open>alternative proof of \<open>word_rcat_rsplit\<close>\<close>
lemmas tdle = times_div_less_eq_dividend
lemmas dtle = xtrans(4) [OF tdle mult.commute]

lemma word_rcat_rsplit: "word_rcat (word_rsplit w) = w"
  apply (rule word_eqI)
  apply (clarsimp simp: test_bit_rcat word_size)
  apply (subst refl [THEN test_bit_rsplit])
    apply (simp_all add: word_size
      refl [THEN length_word_rsplit_size [simplified not_less [symmetric], simplified]])
   apply safe
   apply (erule xtrans(7), rule dtle)+
  done

lemma size_word_rsplit_rcat_size:
  "word_rcat ws = frcw \<Longrightarrow> size frcw = length ws * LENGTH('a)
    \<Longrightarrow> length (word_rsplit frcw::'a word list) = length ws"
  for ws :: "'a::len word list" and frcw :: "'b::len word"
  by (cases \<open>LENGTH('a)\<close>) (simp_all add: word_size length_word_rsplit_exp_size' div_nat_eqI)

lemma msrevs:
  "0 < n \<Longrightarrow> (k * n + m) div n = m div n + k"
  "(k * n + m) mod n = m mod n"
  for n :: nat
  by (auto simp: add.commute)

lemma word_rsplit_rcat_size [OF refl]:
  "word_rcat ws = frcw \<Longrightarrow>
    size frcw = length ws * LENGTH('a) \<Longrightarrow> word_rsplit frcw = ws"
  for ws :: "'a::len word list"
  apply (frule size_word_rsplit_rcat_size, assumption)
  apply (clarsimp simp add : word_size)
  apply (rule nth_equalityI, assumption)
  apply clarsimp
  apply (rule word_eqI [rule_format])
  apply (rule trans)
   apply (rule test_bit_rsplit_alt)
     apply (clarsimp simp: word_size)+
  apply (rule trans)
   apply (rule test_bit_rcat [OF refl refl])
  apply (simp add: word_size)
  apply (subst rev_nth)
   apply arith
  apply (simp add: le0 [THEN [2] xtrans(7), THEN diff_Suc_less])
  apply safe
  apply (simp add: diff_mult_distrib)
   apply (cases "size ws")
    apply simp_all
  done

lemma word_rsplit_upt:
  "\<lbrakk> size x = LENGTH('a :: len) * n; n \<noteq> 0 \<rbrakk>
    \<Longrightarrow> word_rsplit x = map (\<lambda>i. ucast (x >> i * len_of TYPE ('a)) :: 'a word) (rev [0 ..< n])"
  apply (subgoal_tac "length (word_rsplit x :: 'a word list) = n")
   apply (rule nth_equalityI, simp)
   apply (intro allI word_eqI impI)
   apply (simp add: test_bit_rsplit_alt word_size)
   apply (simp add: nth_ucast nth_shiftr rev_nth field_simps)
  apply (simp add: length_word_rsplit_exp_size)
  apply transfer
  apply (metis (no_types, lifting) Nat.add_diff_assoc Suc_leI add_0_left diff_Suc_less div_less len_gt_0 msrevs(1) mult.commute)
  done

end


(*  Title:       Coinductive natural numbers
    Author:      Andreas Lochbihler
    Maintainer:  Andreas Lochbihler
*)

section {* Extended natural numbers as a codatatype *}

theory Coinductive_Nat imports
  "HOL-Library.Extended_Nat"
  "HOL-Library.Complete_Partial_Order2"
begin

lemma inj_enat [simp]: "inj_on enat A"
by(simp add: inj_on_def)

lemma Sup_range_enat [simp]: "Sup (range enat) = \<infinity>"
by(auto dest: finite_imageD simp add: Sup_enat_def)

lemmas eSuc_plus = iadd_Suc

lemmas plus_enat_eq_0_conv = iadd_is_0

lemma enat_add_sub_same:
  fixes a b :: enat shows "a \<noteq> \<infinity> \<Longrightarrow> a + b - a = b"
by(cases b) auto

lemma enat_the_enat: "n \<noteq> \<infinity> \<Longrightarrow> enat (the_enat n) = n"
by auto

lemma enat_min_eq_0_iff:
  fixes a b :: enat
  shows "min a b = 0 \<longleftrightarrow> a = 0 \<or> b = 0"
by(auto simp add: min_def)

lemma enat_le_plus_same: "x \<le> (x :: enat) + y" "x \<le> y + x"
by(auto simp add: less_eq_enat_def plus_enat_def split: enat.split)

lemma the_enat_0 [simp]: "the_enat 0 = 0"
by(simp add: zero_enat_def)

lemma the_enat_eSuc: "n \<noteq> \<infinity> \<Longrightarrow> the_enat (eSuc n) = Suc (the_enat n)"
by(cases n)(simp_all add: eSuc_enat)

coinductive_set enat_set :: "enat set"
where "0 \<in> enat_set"
  | "n \<in> enat_set \<Longrightarrow> (eSuc n) \<in> enat_set"

lemma enat_set_eq_UNIV [simp]: "enat_set = UNIV"
proof
  show "enat_set \<subseteq> UNIV" by blast
  show "UNIV \<subseteq> enat_set"
  proof
    fix x :: enat
    assume "x \<in> UNIV"
    thus "x \<in> enat_set"
    proof coinduct
      case (enat_set x)
      show ?case
      proof(cases "x = 0")
        case True thus ?thesis by simp
      next
        case False
        then obtain n where "x = eSuc n"
          by(cases x)(fastforce simp add: eSuc_def zero_enat_def gr0_conv_Suc
                               split: enat.splits)+
        thus ?thesis by auto
      qed
    qed
  qed
qed

subsection {* Case operator *}

lemma enat_coexhaust:
  obtains (0) "n = 0"
     | (eSuc) n' where "n = eSuc n'"
proof -
  have "n \<in> enat_set" by auto
  thus thesis by cases (erule that)+
qed

locale co begin

free_constructors (plugins del: code) case_enat for
    "0::enat"
  | eSuc epred
where
  "epred 0 = 0"
  apply (erule enat_coexhaust, assumption)
 apply (rule eSuc_inject)
by (rule zero_ne_eSuc)

end

lemma enat_cocase_0 [simp]: "co.case_enat z s 0 = z"
by (rule co.enat.case(1))

lemma enat_cocase_eSuc [simp]: "co.case_enat z s (eSuc n) = s n"
by (rule co.enat.case(2))

lemma neq_zero_conv_eSuc: "n \<noteq> 0 \<longleftrightarrow> (\<exists>n'. n = eSuc n')"
by(cases n rule: enat_coexhaust) simp_all

lemma enat_cocase_cert:
  assumes "CASE \<equiv> co.case_enat c d"
  shows "(CASE 0 \<equiv> c) &&& (CASE (eSuc n) \<equiv> d n)"
  using assms by simp_all

lemma enat_cosplit_asm:
  "P (co.case_enat c d n) = (\<not> (n = 0 \<and> \<not> P c \<or> (\<exists>m. n = eSuc m \<and> \<not> P (d m))))"
by (rule co.enat.split_asm)

lemma enat_cosplit:
  "P (co.case_enat c d n) = ((n = 0 \<longrightarrow> P c) \<and> (\<forall>m. n = eSuc m \<longrightarrow> P (d m)))"
by (rule co.enat.split)

abbreviation epred :: "enat => enat" where "epred \<equiv> co.epred"

lemma epred_0 [simp]: "epred 0 = 0" by(rule co.enat.sel(1))
lemma epred_eSuc [simp]: "epred (eSuc n) = n" by(rule co.enat.sel(2))
declare co.enat.collapse[simp]
lemma epred_conv_minus: "epred n = n - 1"
by(cases n rule: co.enat.exhaust)(simp_all)

subsection {* Corecursion for @{typ enat} *}

lemma case_enat_numeral [simp]: "case_enat f i (numeral v) = (let n = numeral v in f n)"
by(simp add: numeral_eq_enat)

lemma case_enat_0 [simp]: "case_enat f i 0 = f 0"
by(simp add: zero_enat_def)

definition epred_numeral :: "num \<Rightarrow> enat"
where [code del]: "epred_numeral = enat \<circ> pred_numeral"

lemma numeral_eq_eSuc: "numeral k = eSuc (epred_numeral k)"
by(simp add: numeral_eq_Suc eSuc_def epred_numeral_def numeral_eq_enat)

lemma epred_numeral_simps [simp]:
  "epred_numeral num.One = 0"
  "epred_numeral (num.Bit0 k) = numeral (Num.BitM k)"
  "epred_numeral (num.Bit1 k) = numeral (num.Bit0 k)"
by(simp_all add: epred_numeral_def enat_numeral zero_enat_def)

lemma [simp]:
  shows eq_numeral_eSuc: "numeral k = eSuc n \<longleftrightarrow> epred_numeral k = n"
  and Suc_eq_numeral: "eSuc n = numeral k \<longleftrightarrow> n = epred_numeral k"
  and less_numeral_Suc: "numeral k < eSuc n \<longleftrightarrow> epred_numeral k < n"
  and less_eSuc_numeral: "eSuc n < numeral k \<longleftrightarrow> n < epred_numeral k"
  and le_numeral_eSuc: "numeral k \<le> eSuc n \<longleftrightarrow> epred_numeral k \<le> n"
  and le_eSuc_numeral: "eSuc n \<le> numeral k \<longleftrightarrow> n \<le> epred_numeral k"
  and diff_eSuc_numeral: "eSuc n - numeral k = n - epred_numeral k"
  and diff_numeral_eSuc: "numeral k - eSuc n = epred_numeral k - n"
  and max_eSuc_numeral: "max (eSuc n) (numeral k) = eSuc (max n (epred_numeral k))"
  and max_numeral_eSuc: "max (numeral k) (eSuc n) = eSuc (max (epred_numeral k) n)"
  and min_eSuc_numeral: "min (eSuc n) (numeral k) = eSuc (min n (epred_numeral k))"
  and min_numeral_eSuc: "min (numeral k) (eSuc n) = eSuc (min (epred_numeral k) n)"
by(simp_all add: numeral_eq_eSuc)

lemma enat_cocase_numeral [simp]:
  "co.case_enat a f (numeral v) = (let pv = epred_numeral v in f pv)"
by(simp add: numeral_eq_eSuc)

lemma enat_cocase_add_eq_if [simp]:
  "co.case_enat a f ((numeral v) + n) = (let pv = epred_numeral v in f (pv + n))"
by(simp add: numeral_eq_eSuc iadd_Suc)

lemma [simp]:
  shows epred_1: "epred 1 = 0"
  and epred_numeral: "epred (numeral i) = epred_numeral i"
  and epred_Infty: "epred \<infinity> = \<infinity>"
  and epred_enat: "epred (enat m) = enat (m - 1)"
by(simp_all add: epred_conv_minus one_enat_def zero_enat_def eSuc_def epred_numeral_def numeral_eq_enat split: enat.split)

lemmas epred_simps = epred_0 epred_1 epred_numeral epred_eSuc epred_Infty epred_enat

lemma epred_iadd1: "a \<noteq> 0 \<Longrightarrow> epred (a + b) = epred a + b"
apply(cases a b rule: enat.exhaust[case_product enat.exhaust])
apply(simp_all add: epred_conv_minus eSuc_def one_enat_def zero_enat_def split: enat.splits)
done

lemma epred_min [simp]: "epred (min a b) = min (epred a) (epred b)"
by(cases a b rule: enat_coexhaust[case_product enat_coexhaust]) simp_all

lemma epred_le_epredI: "n \<le> m \<Longrightarrow> epred n \<le> epred m"
by(cases m n rule: enat_coexhaust[case_product enat_coexhaust]) simp_all

lemma epred_minus_epred [simp]:
  "m \<noteq> 0 \<Longrightarrow> epred n - epred m = n - m"
by(cases n m rule: enat_coexhaust[case_product enat_coexhaust])(simp_all add: epred_conv_minus)

lemma eSuc_epred: "n \<noteq> 0 \<Longrightarrow> eSuc (epred n) = n"
by(cases n rule: enat_coexhaust) simp_all

lemma epred_inject: "\<lbrakk> x \<noteq> 0; y \<noteq> 0 \<rbrakk> \<Longrightarrow> epred x = epred y \<longleftrightarrow> x = y"
by(cases x y rule: enat.exhaust[case_product enat.exhaust])(auto simp add: zero_enat_def)

lemma monotone_fun_eSuc[partial_function_mono]:
    "monotone (fun_ord (\<lambda>y x. x \<le> y)) (\<lambda>y x. x \<le> y) (\<lambda>f. eSuc (f x))"
  by (auto simp: monotone_def fun_ord_def)

partial_function (gfp) enat_unfold :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> enat" where
  enat_unfold [code, nitpick_simp]:
  "enat_unfold stop next a = (if stop a then 0 else eSuc (enat_unfold stop next (next a)))"

lemma enat_unfold_stop [simp]: "stop a \<Longrightarrow> enat_unfold stop next a = 0"
by(simp add: enat_unfold)

lemma enat_unfold_next: "\<not> stop a \<Longrightarrow> enat_unfold stop next a = eSuc (enat_unfold stop next (next a))"
by(simp add: enat_unfold)

lemma enat_unfold_eq_0 [simp]:
  "enat_unfold stop next a = 0 \<longleftrightarrow> stop a"
by(simp add: enat_unfold)

lemma epred_max: "epred (max x y) = max (epred x) (epred y)"
by(cases x y rule: enat.exhaust[case_product enat.exhaust]) simp_all

lemma epred_Max:
  assumes "finite A" "A \<noteq> {}"
  shows "epred (Max A) = Max (epred ` A)"
using assms
proof induction
  case (insert x A)
  thus ?case by(cases "A = {}")(simp_all add: epred_max)
qed simp

lemma finite_imageD2: "\<lbrakk> finite (f ` A); inj_on f (A - B); finite B \<rbrakk> \<Longrightarrow> finite A"
by (metis Diff_subset finite_Diff2 image_mono inj_on_finite)

lemma epred_Sup: "epred (Sup A) = Sup (epred ` A)"
by(auto 4 4 simp add: bot_enat_def Sup_enat_def epred_Max inj_on_def neq_zero_conv_eSuc dest: finite_imageD2[where B="{0}"])

subsection {* Less as greatest fixpoint *}

coinductive_set Le_enat :: "(enat \<times> enat) set"
where
  Le_enat_zero: "(0, n) \<in> Le_enat"
| Le_enat_add: "\<lbrakk> (m, n) \<in> Le_enat; k \<noteq> 0 \<rbrakk> \<Longrightarrow> (eSuc m, n + k) \<in> Le_enat"

lemma ile_into_Le_enat:
  "m \<le> n \<Longrightarrow> (m, n) \<in> Le_enat"
proof -
  assume "m \<le> n"
  hence "(m, n) \<in> {(m, n)|m n. m \<le> n}" by simp
  thus ?thesis
  proof coinduct
    case (Le_enat m n)
    hence "m \<le> n" by simp
    show ?case
    proof(cases "m = 0")
      case True
      hence ?Le_enat_zero by simp
      thus ?thesis ..
    next
      case False
      with `m \<le> n` obtain m' n' where "m = eSuc m'" "n = n' + 1" "m' \<le> n'"
        by(cases m rule: enat_coexhaust, simp)
          (cases n rule: enat_coexhaust, auto simp add: eSuc_plus_1[symmetric])
      hence ?Le_enat_add by fastforce
      thus ?thesis ..
    qed
  qed
qed

lemma Le_enat_imp_ile_enat_k:
  "(m, n) \<in> Le_enat \<Longrightarrow> n < enat l \<Longrightarrow> m < enat l"
proof(induct l arbitrary: m n)
  case 0
  thus ?case by(simp add: zero_enat_def[symmetric])
next
  case (Suc l)
  from `(m, n) \<in> Le_enat` show ?case
  proof cases
    case Le_enat_zero
    with `n < enat (Suc l)` show ?thesis by auto
  next
    case (Le_enat_add M N K)
    from `n = N + K` `n < enat (Suc l)` `K \<noteq> 0`
    have "N < enat l" by(cases N)(cases K, auto simp add: zero_enat_def)
    with `(M, N) \<in> Le_enat` have "M < enat l" by(rule Suc)
    with `m = eSuc M` show ?thesis by(simp add: eSuc_enat[symmetric])
  qed
qed

lemma enat_less_imp_le:
  assumes k: "!!k. n < enat k \<Longrightarrow> m < enat k"
  shows "m \<le> n"
proof(cases n)
  case (enat n')
  with k[of "Suc n'"] show ?thesis by(cases m) simp_all
qed simp

lemma Le_enat_imp_ile:
  "(m, n) \<in> Le_enat \<Longrightarrow> m \<le> n"
by(rule enat_less_imp_le)(erule Le_enat_imp_ile_enat_k)

lemma Le_enat_eq_ile:
  "(m, n) \<in> Le_enat \<longleftrightarrow> m \<le> n"
by(blast intro: Le_enat_imp_ile ile_into_Le_enat)

lemma enat_leI [consumes 1, case_names Leenat, case_conclusion Leenat zero eSuc]:
  assumes major: "(m, n) \<in> X"
  and step:
    "\<And>m n. (m, n) \<in> X
     \<Longrightarrow> m = 0 \<or> (\<exists>m' n' k. m = eSuc m' \<and> n = n' + enat k \<and> k \<noteq> 0 \<and>
                           ((m', n') \<in> X \<or> m' \<le> n'))"
  shows "m \<le> n"
apply(rule Le_enat.coinduct[unfolded Le_enat_eq_ile, where X="\<lambda>x y. (x, y) \<in> X"])
apply(fastforce simp add: zero_enat_def dest: step intro: major)+
done

lemma enat_le_coinduct[consumes 1, case_names le, case_conclusion le 0 eSuc]:
  assumes P: "P m n"
  and step:
    "\<And>m n. P m n
     \<Longrightarrow> (n = 0 \<longrightarrow> m = 0) \<and>
         (m \<noteq> 0 \<longrightarrow> n \<noteq> 0 \<longrightarrow> (\<exists>k n'. P (epred m) n' \<and> epred n = n' + k) \<or> epred m \<le> epred n)"
  shows "m \<le> n"
proof -
  from P have "(m, n) \<in> {(m, n). P m n}" by simp
  thus ?thesis
  proof(coinduct rule: enat_leI)
    case (Leenat m n)
    hence "P m n" by simp
    show ?case
    proof(cases m rule: enat_coexhaust)
      case 0
      thus ?thesis by simp
    next
      case (eSuc m')
      with step[OF `P m n`]
      have "n \<noteq> 0" and disj: "(\<exists>k n'. P m' n' \<and> epred n = n' + k) \<or> m' \<le> epred n" by auto
      from `n \<noteq> 0` obtain n' where n': "n = eSuc n'"
        by(cases n rule: enat_coexhaust) auto
      from disj show ?thesis
      proof
        assume "m' \<le> epred n"
        with eSuc n' show ?thesis
          by(auto 4 3 intro: exI[where x="Suc 0"] simp add: eSuc_enat[symmetric] iadd_Suc_right zero_enat_def[symmetric])
      next
        assume "\<exists>k n'. P m' n' \<and> epred n = n' + k"
        then obtain k n'' where n'': "epred n = n'' + k" and k: "P m' n''" by blast
        show ?thesis using eSuc k n' n''
          by(cases k)(auto 4 3 simp add: iadd_Suc_right[symmetric] eSuc_enat intro: exI[where x=\<infinity>])
      qed
    qed
  qed
qed

subsection {* Equality as greatest fixpoint *}

lemma enat_equalityI [consumes 1, case_names Eq_enat,
                                  case_conclusion Eq_enat zero eSuc]:
  assumes major: "(m, n) \<in> X"
  and step:
    "\<And>m n. (m, n) \<in> X
     \<Longrightarrow> m = 0 \<and> n = 0 \<or> (\<exists>m' n'. m = eSuc m' \<and> n = eSuc n' \<and> ((m', n') \<in> X \<or> m' = n'))"
  shows "m = n"
proof(rule antisym)
  from major show "m \<le> n"
    by(coinduct rule: enat_leI)
      (drule step, auto simp add: eSuc_plus_1 enat_1[symmetric])

  from major have "(n, m) \<in> {(n, m). (m, n) \<in> X}" by simp
  thus "n \<le> m"
  proof(coinduct rule: enat_leI)
    case (Leenat n m)
    hence "(m, n) \<in> X" by simp
    from step[OF this] show ?case
      by(auto simp add: eSuc_plus_1 enat_1[symmetric])
  qed
qed

lemma enat_coinduct [consumes 1, case_names Eq_enat, case_conclusion Eq_enat zero eSuc]:
  assumes major: "P m n"
  and step: "\<And>m n. P m n
    \<Longrightarrow> (m = 0 \<longleftrightarrow> n = 0) \<and>
       (m \<noteq> 0 \<longrightarrow> n \<noteq> 0 \<longrightarrow> P (epred m) (epred n) \<or> epred m = epred n)"
  shows "m = n"
proof -
  from major have "(m, n) \<in> {(m, n). P m n}" by simp
  thus ?thesis
  proof(coinduct rule: enat_equalityI)
    case (Eq_enat m n)
    hence "P m n" by simp
    from step[OF this] show ?case
      by(cases m n rule: enat_coexhaust[case_product enat_coexhaust]) auto
  qed
qed

lemma enat_coinduct2 [consumes 1, case_names zero eSuc]:
  "\<lbrakk> P m n; \<And>m n. P m n \<Longrightarrow> m = 0 \<longleftrightarrow> n = 0;
     \<And>m n. \<lbrakk> P m n; m \<noteq> 0; n \<noteq> 0 \<rbrakk> \<Longrightarrow> P (epred m) (epred n) \<or> epred m = epred n \<rbrakk>
  \<Longrightarrow> m = n"
by(erule enat_coinduct) blast

subsection {* Uniqueness of corecursion *}

lemma enat_unfold_unique:
  assumes h: "!!x. h x = (if stop x then 0 else eSuc (h (next x)))"
  shows "h x = enat_unfold stop next x"
by(coinduction arbitrary: x rule: enat_coinduct)(subst (1 3) h, auto)

subsection {* Setup for partial\_function *}

lemma enat_diff_cancel_left: "\<lbrakk> m \<le> x; m \<le> y \<rbrakk> \<Longrightarrow> x - m = y - m \<longleftrightarrow> x = (y :: enat)"
by(cases x y m rule: enat.exhaust[case_product enat.exhaust[case_product enat.exhaust]])(simp_all, arith)

lemma finite_lessThan_enatI:
  assumes "m \<noteq> \<infinity>"
  shows "finite {..<m :: enat}"
proof -
  from assms obtain m' where m: "m = enat m'" by auto
  have "{..<enat m'} \<subseteq> enat ` {..<m'}"
    by(rule subsetI)(case_tac x, auto)
  thus ?thesis unfolding m by(rule finite_subset) simp
qed

lemma infinite_lessThan_infty: "\<not> finite {..<\<infinity> :: enat}"
proof
  have "range enat \<subseteq> {..<\<infinity>}" by auto
  moreover assume "finite {..<\<infinity> :: enat}"
  ultimately have "finite (range enat)" by(rule finite_subset)
  hence "finite (UNIV :: nat set)"
    by(rule finite_imageD)(simp add: inj_on_def)
  thus False by simp
qed

lemma finite_lessThan_enat_iff:
  "finite {..<m :: enat} \<longleftrightarrow> m \<noteq> \<infinity>"
by(cases m)(auto intro: finite_lessThan_enatI simp add: infinite_lessThan_infty)

lemma enat_minus_mono1: "x \<le> y \<Longrightarrow> x - m \<le> y - (m :: enat)"
by(cases m x y rule: enat.exhaust[case_product enat.exhaust[case_product enat.exhaust]]) simp_all

lemma max_enat_minus1: "max n m - k = max (n - k) (m - k :: enat)"
by(cases n m k rule: enat.exhaust[case_product enat.exhaust[case_product enat.exhaust]]) simp_all

lemma Max_enat_minus1:
  assumes "finite A" "A \<noteq> {}"
  shows "Max A - m = Max ((\<lambda>n :: enat. n - m) ` A)"
using assms proof induct
  case (insert x A)
  thus ?case by(cases "A = {}")(simp_all add: max_enat_minus1)
qed simp

lemma Sup_enat_minus1:
  assumes "m \<noteq> \<infinity>"
  shows "\<Squnion>A - m = \<Squnion>((\<lambda>n :: enat. n - m) ` A)"
proof -
  from assms obtain m' where "m = enat m'" by auto
  thus ?thesis
    by(auto simp add: Sup_enat_def Max_enat_minus1 finite_lessThan_enat_iff enat_diff_cancel_left inj_on_def dest!: finite_imageD2[where B="{..<enat m'}"])
qed

lemma Sup_image_eadd1:
  assumes "Y \<noteq> {}"
  shows "Sup ((\<lambda>y :: enat. x + y) ` Y) = x + Sup Y"
proof(cases "finite Y")
  case True
  have "op + x ` Y = {x + m |m. m \<in> Y}" by auto
  thus ?thesis using True by(simp add: Sup_enat_def add_Max_commute assms)
next
  case False
  thus ?thesis
  proof(cases x)
    case (enat x')
    hence "\<not> finite (op + x ` Y)" using False
      by(auto dest!: finite_imageD intro: inj_onI)
    with False show ?thesis by(simp add: Sup_enat_def assms)
  next
    case infinity
    hence "op + x ` Y = {\<infinity>}" using assms by auto
    thus ?thesis using infinity by(simp add: image_constant_conv assms)
  qed
qed

lemma Sup_image_eadd2:
  "Y \<noteq> {} \<Longrightarrow> Sup ((\<lambda>y :: enat. y + x) ` Y) = Sup Y + x"
by(subst (1 2) add.commute)(rule Sup_image_eadd1)

lemma mono2mono_eSuc [THEN lfp.mono2mono, cont_intro, simp]:
  shows monotone_eSuc: "monotone op \<le> op \<le> eSuc"
by(rule monotoneI) simp

lemma mcont2mcont_eSuc [THEN lfp.mcont2mcont, cont_intro, simp]:
  shows mcont_eSuc: "mcont Sup op \<le> Sup op \<le> eSuc"
by(intro mcontI contI)(simp_all add: monotone_eSuc eSuc_Sup)

lemma mono2mono_epred [THEN lfp.mono2mono, cont_intro, simp]:
  shows monotone_epred: "monotone op \<le> op \<le> epred"
by(rule monotoneI)(simp add: epred_le_epredI)

lemma mcont2mcont_epred [THEN lfp.mcont2mcont, cont_intro, simp]:
  shows mcont_epred: "mcont Sup op \<le> Sup op \<le> epred"
by(simp add: mcont_def monotone_epred cont_def epred_Sup)

lemma enat_cocase_mono [partial_function_mono, cont_intro]:
  "\<lbrakk> monotone orda ordb zero; \<And>n. monotone orda ordb (\<lambda>f. esuc f n) \<rbrakk>
  \<Longrightarrow> monotone orda ordb (\<lambda>f. co.case_enat (zero f) (esuc f) x)"
by(cases x rule: co.enat.exhaust) simp_all

lemma enat_cocase_mcont [cont_intro, simp]:
  "\<lbrakk> mcont luba orda lubb ordb zero; \<And>n. mcont luba orda lubb ordb (\<lambda>f. esuc f n) \<rbrakk>
  \<Longrightarrow> mcont luba orda lubb ordb (\<lambda>f. co.case_enat (zero f) (esuc f) x)"
by(cases x rule: co.enat.exhaust) simp_all

lemma eSuc_mono [partial_function_mono]:
  "monotone (fun_ord op \<le>) op \<le> f \<Longrightarrow> monotone (fun_ord op \<le>) op \<le> (\<lambda>x. eSuc (f x))"
by(rule mono2mono_eSuc)

lemma mono2mono_enat_minus1 [THEN lfp.mono2mono, cont_intro, simp]:
  shows monotone_enat_minus1: "monotone op \<le> op \<le> (\<lambda>n. n - m :: enat)"
by(rule monotoneI)(rule enat_minus_mono1)

lemma mcont2mcont_enat_minus [THEN lfp.mcont2mcont, cont_intro, simp]:
  shows mcont_enat_minus: "m \<noteq> \<infinity> \<Longrightarrow> mcont Sup op \<le> Sup op \<le> (\<lambda>n. n - m :: enat)"
by(rule mcontI)(simp_all add: monotone_enat_minus1 contI Sup_enat_minus1)

lemma monotone_eadd1: "monotone op \<le> op \<le> (\<lambda>x. x + y :: enat)"
by(auto intro!: monotoneI)

lemma monotone_eadd2: "monotone op \<le> op \<le> (\<lambda>y. x + y :: enat)"
by(auto intro!: monotoneI)

lemma mono2mono_eadd[THEN lfp.mono2mono2, cont_intro, simp]:
  shows monotone_eadd: "monotone (rel_prod op \<le> op \<le>) op \<le> (\<lambda>(x, y). x + y :: enat)"
by(simp add: monotone_eadd1 monotone_eadd2)

lemma mcont_eadd2: "mcont Sup op \<le> Sup op \<le> (\<lambda>y. x + y :: enat)"
by(auto intro: mcontI monotone_eadd2 contI Sup_image_eadd1[symmetric])

lemma mcont_eadd1: "mcont Sup op \<le> Sup op \<le> (\<lambda>x. x + y :: enat)"
by(auto intro: mcontI monotone_eadd1 contI Sup_image_eadd2[symmetric])

lemma mcont2mcont_eadd [cont_intro, simp]:
  "\<lbrakk> mcont lub ord Sup op \<le> (\<lambda>x. f x);
    mcont lub ord Sup op \<le> (\<lambda>x. g x) \<rbrakk>
  \<Longrightarrow> mcont lub ord Sup op \<le> (\<lambda>x. f x + g x :: enat)"
by(best intro: ccpo.mcont2mcont'[OF complete_lattice_ccpo] mcont_eadd1 mcont_eadd2 ccpo.mcont_const[OF complete_lattice_ccpo])

lemma eadd_partial_function_mono [partial_function_mono]:
  "\<lbrakk> monotone (fun_ord op \<le>) op \<le> f; monotone (fun_ord op \<le>) op \<le> g \<rbrakk>
  \<Longrightarrow> monotone (fun_ord op \<le>) op \<le> (\<lambda>x. f x + g x :: enat)"
by(rule mono2mono_eadd)

lemma monotone_max_enat1: "monotone op \<le> op \<le> (\<lambda>x. max x y :: enat)"
by(auto intro!: monotoneI simp add: max_def)

lemma monotone_max_enat2: "monotone op \<le> op \<le> (\<lambda>y. max x y :: enat)"
by(auto intro!: monotoneI simp add: max_def)

lemma mono2mono_max_enat[THEN lfp.mono2mono2, cont_intro, simp]:
  shows monotone_max_enat: "monotone (rel_prod op \<le> op \<le>) op \<le> (\<lambda>(x, y). max x y :: enat)"
by(simp add: monotone_max_enat1 monotone_max_enat2)

lemma max_Sup_enat2:
  assumes "Y \<noteq> {}"
  shows "max x (Sup Y) = Sup ((\<lambda>y :: enat. max x y) ` Y)"
proof(cases "finite Y")
  case True
  hence "max x (Max Y) = Max (max x ` Y)" using assms
  proof(induct)
    case (insert y Y)
    thus ?case
      by(cases "Y = {}")(simp_all, metis max.assoc max.left_commute max.left_idem)
  qed simp
  thus ?thesis using True by(simp add: Sup_enat_def assms)
next
  case False
  show ?thesis
  proof(cases x)
    case infinity
    hence "max x ` Y = {\<infinity>}" using assms by auto
    thus ?thesis using False by(simp add: Sup_enat_def assms)
  next
    case (enat x')
    { assume "finite (max x ` Y)"
      hence "finite (max x ` {y \<in> Y. y > x})"
        by(rule finite_subset[rotated]) auto
      hence "finite {y \<in> Y. y > x}"
        by(rule finite_imageD)(auto intro!: inj_onI simp add: max_def split: if_split_asm)
      moreover have "finite {y \<in> Y. y \<le> x}"
        by(rule finite_enat_bounded)(auto simp add: enat)
      ultimately have "finite ({y \<in> Y. y > x} \<union> {y \<in> Y. y \<le> x})" by simp
      also have "{y \<in> Y. y > x} \<union> {y \<in> Y. y \<le> x} = Y" by auto
      finally have "finite Y" . }
    thus ?thesis using False by(auto simp add: Sup_enat_def assms)
  qed
qed

lemma max_Sup_enat1:
  "Y \<noteq> {} \<Longrightarrow> max (Sup Y) x = Sup ((\<lambda>y :: enat. max y x) ` Y)"
by(subst (1 2) max.commute)(rule max_Sup_enat2)

lemma mcont_max_enat1: "mcont Sup op \<le> Sup op \<le> (\<lambda>x. max x y :: enat)"
by(auto intro!: mcontI contI max_Sup_enat1 simp add: monotone_max_enat1)

lemma mcont_max_enat2: "mcont Sup op \<le> Sup op \<le> (\<lambda>y. max x y :: enat)"
by(auto intro!: mcontI contI max_Sup_enat2 simp add: monotone_max_enat2)

lemma mcont2mcont_max_enat [cont_intro, simp]:
  "\<lbrakk> mcont lub ord Sup op \<le> (\<lambda>x. f x);
    mcont lub ord Sup op \<le> (\<lambda>x. g x) \<rbrakk>
  \<Longrightarrow> mcont lub ord Sup op \<le> (\<lambda>x. max (f x) (g x) :: enat)"
by(best intro: ccpo.mcont2mcont'[OF complete_lattice_ccpo] mcont_max_enat1 mcont_max_enat2 ccpo.mcont_const[OF complete_lattice_ccpo])

lemma max_enat_partial_function_mono [partial_function_mono]:
  "\<lbrakk> monotone (fun_ord op \<le>) op \<le> f; monotone (fun_ord op \<le>) op \<le> g \<rbrakk>
  \<Longrightarrow> monotone (fun_ord op \<le>) op \<le> (\<lambda>x. max (f x) (g x) :: enat)"
by(rule mono2mono_max_enat)

lemma chain_epredI:
  "Complete_Partial_Order.chain op \<le> Y
  \<Longrightarrow> Complete_Partial_Order.chain op \<le> (epred ` (Y \<inter> {x. x \<noteq> 0}))"
by(auto intro: chainI dest: chainD)

lemma monotone_enat_le_case:
  fixes bot
  assumes mono: "monotone op \<le> ord (\<lambda>x. f x (eSuc x))"
  and ord: "\<And>x. ord bot (f x (eSuc x))"
  and bot: "ord bot bot"
  shows "monotone op \<le> ord (\<lambda>x. case x of 0 \<Rightarrow> bot | eSuc x' \<Rightarrow> f x' x)"
proof -
  have "monotone op \<le> ord (\<lambda>x. if x \<le> 0 then bot else f (epred x) x)"
  proof(rule monotone_if_bot)
    fix x y :: enat
    assume "x \<le> y" "\<not> x \<le> 0"
    thus "ord (f (epred x) x) (f (epred y) y)"
      by(cases x y rule: co.enat.exhaust[case_product co.enat.exhaust])(auto intro: monotoneD[OF mono])
  next
    fix x :: enat
    assume "\<not> x \<le> 0"
    thus "ord bot (f (epred x) x)"
      by(cases x rule: co.enat.exhaust)(auto intro: ord)
  qed(rule bot)
  also have "(\<lambda>x. if x \<le> 0 then bot else f (epred x) x) = (\<lambda>x. case x of 0 \<Rightarrow> bot | eSuc x' \<Rightarrow> f x' x)"
    by(auto simp add: fun_eq_iff split: co.enat.split)
  finally show ?thesis .
qed

lemma mcont_enat_le_case:
  fixes bot
  assumes ccpo: "class.ccpo lub ord (mk_less ord)"
  and mcont: "mcont Sup op \<le> lub ord (\<lambda>x. f x (eSuc x))"
  and ord: "\<And>x. ord bot (f x (eSuc x))"
  shows "mcont Sup op \<le> lub ord (\<lambda>x. case x of 0 \<Rightarrow> bot | eSuc x' \<Rightarrow> f x' x)"
proof -
  from ccpo
  have "mcont Sup op \<le> lub ord (\<lambda>x. if x \<le> 0 then bot else f (epred x) x)"
  proof(rule mcont_if_bot)
    fix x y :: enat
    assume "x \<le> y" "\<not> x \<le> 0"
    thus "ord (f (epred x) x) (f (epred y) y)"
      by(cases x y rule: co.enat.exhaust[case_product co.enat.exhaust])(auto intro: mcont_monoD[OF mcont])
  next
    fix Y :: "enat set"
    assume chain: "Complete_Partial_Order.chain op \<le> Y"
      and Y: "Y \<noteq> {}" "\<And>x. x \<in> Y \<Longrightarrow> \<not> x \<le> 0"
    from Y have Y': "Y \<inter> {x. x \<noteq> 0} \<noteq> {}" by auto
    from Y(2) have eq: "Y = eSuc ` (epred ` (Y \<inter> {x. x \<noteq> 0}))"
      by(fastforce intro: rev_image_eqI)
    let ?Y = "epred ` (Y \<inter> {x. x \<noteq> 0})"
    from chain_epredI [OF chain] Y'
    have "f (\<Squnion>?Y) (eSuc (\<Squnion>?Y)) = lub ((\<lambda>x. f x (eSuc x)) ` ?Y)"
      using mcont [THEN mcont_contD] by blast
    moreover from chain_epredI [OF chain] Y'
      have "SUPREMUM ?Y eSuc = eSuc (\<Squnion>?Y)"
      using mcont_eSuc [THEN mcont_contD, symmetric] by blast
    ultimately show "f (epred (Sup Y)) (Sup Y) = lub ((\<lambda>x. f (epred x) x) ` Y)"
      by (subst (1 2 3) eq) (simp add: image_image)
  next
    fix x :: enat
    assume "\<not> x \<le> 0"
    thus "ord bot (f (epred x) x)"
      by(cases x rule: co.enat.exhaust)(auto intro: ord)
  qed
  also have "(\<lambda>x. if x \<le> 0 then bot else f (epred x) x) = (\<lambda>x. case x of 0 \<Rightarrow> bot | eSuc x' \<Rightarrow> f x' x)"
    by(auto simp add: fun_eq_iff split: co.enat.split)
  finally show ?thesis .
qed

subsection {* Misc. *}

lemma enat_add_mono [simp]:
  "enat x + y < enat x + z \<longleftrightarrow> y < z"
by(cases y)(case_tac [!] z, simp_all)

lemma enat_add1_eq [simp]: "enat x + y = enat x + z \<longleftrightarrow> y = z"
by (metis enat_add_mono add.commute neq_iff)

lemma enat_add2_eq [simp]: "y + enat x = z + enat x \<longleftrightarrow> y = z"
by (metis enat_add1_eq add.commute)

lemma enat_less_enat_plusI: "x < y \<Longrightarrow> enat x < enat y + z"
by(cases z) simp_all

lemma enat_less_enat_plusI2:
  "enat y < z \<Longrightarrow> enat (x + y) < enat x + z"
by (metis enat_add_mono plus_enat_simps(1))

lemma min_enat1_conv_enat: "\<And>a b. min (enat a) b = enat (case b of enat b' \<Rightarrow> min a b' | \<infinity> \<Rightarrow> a)"
  and min_enat2_conv_enat: "\<And>a b. min a (enat b) = enat (case a of enat a' \<Rightarrow> min a' b | \<infinity> \<Rightarrow> b)"
by(simp_all split: enat.split)

lemma eSuc_le_iff: "eSuc x \<le> y \<longleftrightarrow> (\<exists>y'. y = eSuc y' \<and> x \<le> y')"
by(cases y rule: co.enat.exhaust) simp_all

lemma eSuc_eq_infinity_iff: "eSuc n = \<infinity> \<longleftrightarrow> n = \<infinity>"
by(cases n)(simp_all add: zero_enat_def eSuc_enat)

lemma infinity_eq_eSuc_iff: "\<infinity> = eSuc n \<longleftrightarrow> n = \<infinity>"
by(cases n)(simp_all add: zero_enat_def eSuc_enat)

lemma enat_cocase_inf: "(case \<infinity> of 0 \<Rightarrow> a | eSuc b \<Rightarrow> f b) = f \<infinity>"
by(auto split: co.enat.split simp add: infinity_eq_eSuc_iff)

lemma eSuc_Inf: "eSuc (Inf A) = Inf (eSuc ` A)"
proof -
  { assume "A \<noteq> {}"
    then obtain a where "a \<in> A" by blast
    then have "eSuc (LEAST a. a \<in> A) = (LEAST a. a \<in> eSuc ` A)"
    proof (rule LeastI2_wellorder)
      fix a assume "a \<in> A" and b: "\<forall>b. b \<in> A \<longrightarrow> a \<le> b"
      then have a: "eSuc a \<in> eSuc ` A"
        by auto
      then show "eSuc a = (LEAST a. a \<in> eSuc ` A)"
        by (rule LeastI2_wellorder) (metis (full_types) b a antisym eSuc_le_iff imageE)
    qed }
  then show ?thesis
    by (simp add: Inf_enat_def)
qed

end


theory Fold_Assn
  imports Base
begin

definition fold_assn :: "assn list \<Rightarrow> assn" where
  "fold_assn assns = foldr (*) assns emp"

lemma fold_assn_emp [simp]: "fold_assn [] = emp"
  unfolding fold_assn_def by simp

lemma fold_assn_cons [simp]: "fold_assn (x#xs) = x * fold_assn xs"
  unfolding fold_assn_def by simp_all

lemma fold_assn_app [simp]: "fold_assn (xs@ys) = fold_assn xs * fold_assn ys"
  by(induction xs)(auto simp: algebra_simps)

lemma fold_assn_remove1: "x \<in>\<^sub>L xs \<Longrightarrow> fold_assn xs = x * fold_assn (remove1 x xs)"
  by(induction xs)(auto simp: algebra_simps)

lemma fold_assn_false [simp]: "false \<in>\<^sub>L xs \<Longrightarrow> fold_assn xs = false"
  using fold_assn_remove1 by auto

lemma fold_assn_emp_remove1 [simp]: "fold_assn (remove1 emp xs) = fold_assn xs"
  by(induction xs) auto

lemma fold_assn_emp_removeAll [simp]: "fold_assn (removeAll emp xs) = fold_assn xs"
  by(induction xs) auto

lemma fold_assn_remove1_map: "x \<in>\<^sub>L xs
   \<Longrightarrow> fold_assn (remove1 (f x) (map f xs)) = fold_assn (map f (remove1 x xs))"
proof(induction xs)
  case Nil
  then show ?case
    by simp
next
  case (Cons a xs)
  then show ?case
    using fold_assn_remove1[of "f a" "map f xs"] image_iff
    by fastforce
qed

end


section {* Augmented Type Syntax for Concrete Checker *}

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

datatype ct =
    TAny
  | TSome t

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

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

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

definition ct_list_compat :: "ct list \<Rightarrow> ct list \<Rightarrow> bool" where
  "ct_list_compat ct1s ct2s = list_all2 ct_compat ct1s ct2s"

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

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

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

lemma ct_compat_flip: "ct_compat\<inverse>\<inverse> = ct_compat"
  using ct_compat_commute
  by fastforce

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

lemma ct_list_compat_commute:
  assumes "ct_list_compat xs ys"
  shows "ct_list_compat ys xs"
  using assms ct_compat_commute List.List.list.rel_flip ct_compat_flip
  unfolding ct_list_compat_def
  by fastforce

lemma ct_list_compat_refl: "ct_list_compat xs xs"
  unfolding ct_list_compat_def
  by (metis ct_compat.elims(3) ct_compat.simps(1) list_all2_refl)

lemma ct_list_compat_length:
  assumes "ct_list_compat xs ys"
  shows "length xs = length ys"
  using assms list_all2_lengthD
  unfolding ct_list_compat_def
  by blast

lemma ct_list_compat_concat:
  assumes "ct_list_compat xs ys"
          "ct_list_compat xs' ys'"
  shows "ct_list_compat (xs@xs') (ys@ys')"
  using assms
  unfolding ct_list_compat_def
  by (simp add: list_all2_appendI)

lemma ct_list_compat_ts_conv_eq:
  "ct_list_compat (to_ct_list ts) (to_ct_list ts') = (ts = ts')"
  unfolding ct_list_compat_def to_ct_list_def
            list_all2_map1 list_all2_map2
            ct_compat.simps(1)
  by (simp add: list_all2_eq)

lemma ct_list_compat_exists: "\<exists>ys. ct_list_compat xs (to_ct_list ys)"
proof (induction xs)
  case Nil
  thus ?case
    unfolding ct_list_compat_def to_ct_list_def
    by (simp)
next
  case (Cons a xs)
  thus ?case
    unfolding ct_list_compat_def to_ct_list_def
    apply (cases a)
     apply (metis ct_compat.simps(3) ct_compat_commute list.rel_intros(2) list.simps(9))
    apply (metis ct_compat.simps(1) list.rel_intros(2) list.simps(9))
    done
qed

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

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

lemma ct_list_compat_cons_ct_list1:
  assumes "ct_list_compat (to_ct_list as) (xs @ (to_ct_list ys))"
  shows "\<exists>bs. as = bs @ ys \<and> ct_list_compat (to_ct_list bs) xs"
  using ct_list_compat_cons_ct_list[OF assms] ct_list_compat_ts_conv_eq
  by fastforce

lemma ct_list_compat_shared:
  assumes "ct_list_compat xs (to_ct_list as)"
          "ct_list_compat ys (to_ct_list as)"
  shows "ct_list_compat xs ys"
  using assms ct_list_compat_def
  by (meson ct_list_compat_common_tsome_list ct_list_compat_commute)

lemma ct_list_compat_take:
  assumes "ct_list_compat xs ys"
  shows "ct_list_compat (take n xs) (take n ys)"
  using assms list_all2_takeI
  unfolding ct_list_compat_def
  by blast

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

lemma ct_suffix_cons2:
  assumes "ct_suffix (xs) (ys@zs)"
          "length xs = length zs"
  shows "ct_list_compat xs zs"
  using assms
  by (metis append_eq_append_conv ct_list_compat_commute ct_list_compat_def ct_suffix_def list_all2_lengthD)

lemma ct_suffix_imp_ct_list_compat:
  assumes "ct_suffix xs ys"
  shows "ct_list_compat (drop (length ys - length xs) ys) xs"
  using assms ct_list_compat_def list_all2_lengthD
  unfolding ct_suffix_def
  by fastforce

lemma ct_suffix_extend_ct_list_compat:
  assumes "ct_suffix xs ys"
          "ct_list_compat xs' ys'"
  shows "ct_suffix (xs@xs') (ys@ys')"
  using assms
  unfolding ct_suffix_def ct_list_compat_def
  by (meson append.assoc ct_list_compat_commute ct_list_compat_def list_all2_appendI)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end