(*  Title:    HOL/Analysis/Generalised_Binomial_Theorem.thy
    Author:   Manuel Eberl, TU München
*)

section \<open>Generalised Binomial Theorem\<close>

text \<open>
  The proof of the Generalised Binomial Theorem and related results.
  We prove the generalised binomial theorem for complex numbers, following the proof at:
  \url{https://proofwiki.org/wiki/Binomial_Theorem/General_Binomial_Theorem}
\<close>

theory Generalised_Binomial_Theorem
imports
  Complex_Main
  Complex_Transcendental
  Summation_Tests
begin

lemma gbinomial_ratio_limit:
  fixes a :: "'a :: real_normed_field"
  assumes "a \<notin> \<nat>"
  shows "(\<lambda>n. (a gchoose n) / (a gchoose Suc n)) \<longlonglongrightarrow> -1"
proof (rule Lim_transform_eventually)
  let ?f = "\<lambda>n. inverse (a / of_nat (Suc n) - of_nat n / of_nat (Suc n))"
  from eventually_gt_at_top[of "0::nat"]
    show "eventually (\<lambda>n. ?f n = (a gchoose n) /(a gchoose Suc n)) sequentially"
  proof eventually_elim
    fix n :: nat assume n: "n > 0"
    then obtain q where q: "n = Suc q" by (cases n) blast
    let ?P = "\<Prod>i=0..<n. a - of_nat i"
    from n have "(a gchoose n) / (a gchoose Suc n) = (of_nat (Suc n) :: 'a) *
                   (?P / (\<Prod>i=0..n. a - of_nat i))"
      by (simp add: gbinomial_prod_rev atLeastLessThanSuc_atLeastAtMost)
    also from q have "(\<Prod>i=0..n. a - of_nat i) = ?P * (a - of_nat n)"
      by (simp add: prod.atLeast0_atMost_Suc atLeastLessThanSuc_atLeastAtMost)
    also have "?P / \<dots> = (?P / ?P) / (a - of_nat n)" by (rule divide_divide_eq_left[symmetric])
    also from assms have "?P / ?P = 1" by auto
    also have "of_nat (Suc n) * (1 / (a - of_nat n)) =
                   inverse (inverse (of_nat (Suc n)) * (a - of_nat n))" by (simp add: field_simps)
    also have "inverse (of_nat (Suc n)) * (a - of_nat n) = a / of_nat (Suc n) - of_nat n / of_nat (Suc n)"
      by (simp add: field_simps del: of_nat_Suc)
    finally show "?f n = (a gchoose n) / (a gchoose Suc n)" by simp
  qed

  have "(\<lambda>n. norm a / (of_nat (Suc n))) \<longlonglongrightarrow> 0"
    unfolding divide_inverse
    by (intro tendsto_mult_right_zero LIMSEQ_inverse_real_of_nat)
  hence "(\<lambda>n. a / of_nat (Suc n)) \<longlonglongrightarrow> 0"
    by (subst tendsto_norm_zero_iff[symmetric]) (simp add: norm_divide del: of_nat_Suc)
  hence "?f \<longlonglongrightarrow> inverse (0 - 1)"
    by (intro tendsto_inverse tendsto_diff LIMSEQ_n_over_Suc_n) simp_all
  thus "?f \<longlonglongrightarrow> -1" by simp
qed

lemma conv_radius_gchoose:
  fixes a :: "'a :: {real_normed_field,banach}"
  shows "conv_radius (\<lambda>n. a gchoose n) = (if a \<in> \<nat> then \<infinity> else 1)"
proof (cases "a \<in> \<nat>")
  assume a: "a \<in> \<nat>"
  have "eventually (\<lambda>n. (a gchoose n) = 0) sequentially"
    using eventually_gt_at_top[of "nat \<lfloor>norm a\<rfloor>"]
    by eventually_elim (insert a, auto elim!: Nats_cases simp: binomial_gbinomial[symmetric])
  from conv_radius_cong[OF this] a show ?thesis by simp
next
  assume a: "a \<notin> \<nat>"
  from tendsto_norm[OF gbinomial_ratio_limit[OF this]]
    have "conv_radius (\<lambda>n. a gchoose n) = 1"
    by (intro conv_radius_ratio_limit_nonzero[of _ 1]) (simp_all add: norm_divide)
  with a show ?thesis by simp
qed

lemma gen_binomial_complex:
  fixes z :: complex
  assumes "norm z < 1"
  shows   "(\<lambda>n. (a gchoose n) * z^n) sums (1 + z) powr a"
proof -
  define K where "K = 1 - (1 - norm z) / 2"
  from assms have K: "K > 0" "K < 1" "norm z < K"
     unfolding K_def by (auto simp: field_simps intro!: add_pos_nonneg)
  let ?f = "\<lambda>n. a gchoose n" and ?f' = "diffs (\<lambda>n. a gchoose n)"
  have summable_strong: "summable (\<lambda>n. ?f n * z ^ n)" if "norm z < 1" for z using that
    by (intro summable_in_conv_radius) (simp_all add: conv_radius_gchoose)
  with K have summable: "summable (\<lambda>n. ?f n * z ^ n)" if "norm z < K" for z using that by auto
  hence summable': "summable (\<lambda>n. ?f' n * z ^ n)" if "norm z < K" for z using that
    by (intro termdiff_converges[of _ K]) simp_all

  define f f' where [abs_def]: "f z = (\<Sum>n. ?f n * z ^ n)" "f' z = (\<Sum>n. ?f' n * z ^ n)" for z
  {
    fix z :: complex assume z: "norm z < K"
    from summable_mult2[OF summable'[OF z], of z]
      have summable1: "summable (\<lambda>n. ?f' n * z ^ Suc n)" by (simp add: mult_ac)
    hence summable2: "summable (\<lambda>n. of_nat n * ?f n * z^n)"
      unfolding diffs_def by (subst (asm) summable_Suc_iff)

    have "(1 + z) * f' z = (\<Sum>n. ?f' n * z^n) + (\<Sum>n. ?f' n * z^Suc n)"
      unfolding f_f'_def using summable' z by (simp add: algebra_simps suminf_mult)
    also have "(\<Sum>n. ?f' n * z^n) = (\<Sum>n. of_nat (Suc n) * ?f (Suc n) * z^n)"
      by (intro suminf_cong) (simp add: diffs_def)
    also have "(\<Sum>n. ?f' n * z^Suc n) = (\<Sum>n. of_nat n * ?f n * z ^ n)"
      using summable1 suminf_split_initial_segment[OF summable1] unfolding diffs_def
      by (subst suminf_split_head, subst (asm) summable_Suc_iff) simp_all
    also have "(\<Sum>n. of_nat (Suc n) * ?f (Suc n) * z^n) + (\<Sum>n. of_nat n * ?f n * z^n) =
                 (\<Sum>n. a * ?f n * z^n)"
      by (subst gbinomial_mult_1, subst suminf_add)
         (insert summable'[OF z] summable2,
          simp_all add: summable_powser_split_head algebra_simps diffs_def)
    also have "\<dots> = a * f z" unfolding f_f'_def
      by (subst suminf_mult[symmetric]) (simp_all add: summable[OF z] mult_ac)
    finally have "a * f z = (1 + z) * f' z" by simp
  } note deriv = this

  have [derivative_intros]: "(f has_field_derivative f' z) (at z)" if "norm z < of_real K" for z
    unfolding f_f'_def using K that
    by (intro termdiffs_strong[of "?f" K z] summable_strong) simp_all
  have "f 0 = (\<Sum>n. if n = 0 then 1 else 0)" unfolding f_f'_def by (intro suminf_cong) simp
  also have "\<dots> = 1" using sums_single[of 0 "\<lambda>_. 1::complex"] unfolding sums_iff by simp
  finally have [simp]: "f 0 = 1" .

  have "\<exists>c. \<forall>z\<in>ball 0 K. f z * (1 + z) powr (-a) = c"
  proof (rule has_field_derivative_zero_constant)
    fix z :: complex assume z': "z \<in> ball 0 K"
    hence z: "norm z < K" by simp
    with K have nz: "1 + z \<noteq> 0" by (auto dest!: minus_unique)
    from z K have "norm z < 1" by simp
    hence "(1 + z) \<notin> \<real>\<^sub>\<le>\<^sub>0" by (cases z) (auto simp: complex_nonpos_Reals_iff)
    hence "((\<lambda>z. f z * (1 + z) powr (-a)) has_field_derivative
              f' z * (1 + z) powr (-a) - a * f z * (1 + z) powr (-a-1)) (at z)" using z
      by (auto intro!: derivative_eq_intros)
    also from z have "a * f z = (1 + z) * f' z" by (rule deriv)
    finally show "((\<lambda>z. f z * (1 + z) powr (-a)) has_field_derivative 0) (at z within ball 0 K)"
      using nz by (simp add: field_simps powr_diff_complex at_within_open[OF z'])
  qed simp_all
  then obtain c where c: "\<And>z. z \<in> ball 0 K \<Longrightarrow> f z * (1 + z) powr (-a) = c" by blast
  from c[of 0] and K have "c = 1" by simp
  with c[of z] have "f z = (1 + z) powr a" using K
    by (simp add: powr_minus_complex field_simps dist_complex_def)
  with summable K show ?thesis unfolding f_f'_def by (simp add: sums_iff)
qed

lemma gen_binomial_complex':
  fixes x y :: real and a :: complex
  assumes "\<bar>x\<bar> < \<bar>y\<bar>"
  shows   "(\<lambda>n. (a gchoose n) * of_real x^n * of_real y powr (a - of_nat n)) sums
               of_real (x + y) powr a" (is "?P x y")
proof -
  {
    fix x y :: real assume xy: "\<bar>x\<bar> < \<bar>y\<bar>" "y \<ge> 0"
    hence "y > 0" by simp
    note xy = xy this
    from xy have "(\<lambda>n. (a gchoose n) * of_real (x / y) ^ n) sums (1 + of_real (x / y)) powr a"
        by (intro gen_binomial_complex) (simp add: norm_divide)
    hence "(\<lambda>n. (a gchoose n) * of_real (x / y) ^ n * y powr a) sums
               ((1 + of_real (x / y)) powr a * y powr a)"
      by (rule sums_mult2)
    also have "(1 + complex_of_real (x / y)) = complex_of_real (1 + x/y)" by simp
    also from xy have "\<dots> powr a * of_real y powr a = (\<dots> * y) powr a"
      by (subst powr_times_real[symmetric]) (simp_all add: field_simps)
    also from xy have "complex_of_real (1 + x / y) * complex_of_real y = of_real (x + y)"
      by (simp add: field_simps)
    finally have "?P x y" using xy by (simp add: field_simps powr_diff_complex powr_nat)
  } note A = this

  show ?thesis
  proof (cases "y < 0")
    assume y: "y < 0"
    with assms have xy: "x + y < 0" by simp
    with assms have "\<bar>-x\<bar> < \<bar>-y\<bar>" "-y \<ge> 0" by simp_all
    note A[OF this]
    also have "complex_of_real (-x + -y) = - complex_of_real (x + y)" by simp
    also from xy assms have "... powr a = (-1) powr -a * of_real (x + y) powr a"
      by (subst powr_neg_real_complex) (simp add: abs_real_def split: if_split_asm)
    also {
      fix n :: nat
      from y have "(a gchoose n) * of_real (-x) ^ n * of_real (-y) powr (a - of_nat n) =
                       (a gchoose n) * (-of_real x / -of_real y) ^ n * (- of_real y) powr a"
        by (subst power_divide) (simp add: powr_diff_complex powr_nat)
      also from y have "(- of_real y) powr a = (-1) powr -a * of_real y powr a"
        by (subst powr_neg_real_complex) simp
      also have "-complex_of_real x / -complex_of_real y = complex_of_real x / complex_of_real y"
        by simp
      also have "... ^ n = of_real x ^ n / of_real y ^ n" by (simp add: power_divide)
      also have "(a gchoose n) * ... * ((-1) powr -a * of_real y powr a) =
                   (-1) powr -a * ((a gchoose n) * of_real x ^ n * of_real y powr (a - n))"
        by (simp add: algebra_simps powr_diff_complex powr_nat)
      finally have "(a gchoose n) * of_real (- x) ^ n * of_real (- y) powr (a - of_nat n) =
                      (-1) powr -a * ((a gchoose n) * of_real x ^ n * of_real y powr (a - of_nat n))" .
    }
    note sums_cong[OF this]
    finally show ?thesis by (simp add: sums_mult_iff)
  qed (insert A[of x y] assms, simp_all add: not_less)
qed

lemma gen_binomial_complex'':
  fixes x y :: real and a :: complex
  assumes "\<bar>y\<bar> < \<bar>x\<bar>"
  shows   "(\<lambda>n. (a gchoose n) * of_real x powr (a - of_nat n) * of_real y ^ n) sums
               of_real (x + y) powr a"
  using gen_binomial_complex'[OF assms] by (simp add: mult_ac add.commute)

lemma gen_binomial_real:
  fixes z :: real
  assumes "\<bar>z\<bar> < 1"
  shows   "(\<lambda>n. (a gchoose n) * z^n) sums (1 + z) powr a"
proof -
  from assms have "norm (of_real z :: complex) < 1" by simp
  from gen_binomial_complex[OF this]
    have "(\<lambda>n. (of_real a gchoose n :: complex) * of_real z ^ n) sums
              (of_real (1 + z)) powr (of_real a)" by simp
  also have "(of_real (1 + z) :: complex) powr (of_real a) = of_real ((1 + z) powr a)"
    using assms by (subst powr_of_real) simp_all
  also have "(of_real a gchoose n :: complex) = of_real (a gchoose n)" for n
    by (simp add: gbinomial_prod_rev)
  hence "(\<lambda>n. (of_real a gchoose n :: complex) * of_real z ^ n) =
           (\<lambda>n. of_real ((a gchoose n) * z ^ n))" by (intro ext) simp
  finally show ?thesis by (simp only: sums_of_real_iff)
qed

lemma gen_binomial_real':
  fixes x y a :: real
  assumes "\<bar>x\<bar> < y"
  shows   "(\<lambda>n. (a gchoose n) * x^n * y powr (a - of_nat n)) sums (x + y) powr a"
proof -
  from assms have "y > 0" by simp
  note xy = this assms
  from assms have "\<bar>x / y\<bar> < 1" by simp
  hence "(\<lambda>n. (a gchoose n) * (x / y) ^ n) sums (1 + x / y) powr a"
    by (rule gen_binomial_real)
  hence "(\<lambda>n. (a gchoose n) * (x / y) ^ n * y powr a) sums ((1 + x / y) powr a * y powr a)"
    by (rule sums_mult2)
  with xy show ?thesis
    by (simp add: field_simps powr_divide powr_divide2[symmetric] powr_realpow)
qed

lemma one_plus_neg_powr_powser:
  fixes z s :: complex
  assumes "norm (z :: complex) < 1"
  shows "(\<lambda>n. (-1)^n * ((s + n - 1) gchoose n) * z^n) sums (1 + z) powr (-s)"
    using gen_binomial_complex[OF assms, of "-s"] by (simp add: gbinomial_minus)

lemma gen_binomial_real'':
  fixes x y a :: real
  assumes "\<bar>y\<bar> < x"
  shows   "(\<lambda>n. (a gchoose n) * x powr (a - of_nat n) * y^n) sums (x + y) powr a"
  using gen_binomial_real'[OF assms] by (simp add: mult_ac add.commute)

lemma sqrt_series':
  "\<bar>z\<bar> < a \<Longrightarrow> (\<lambda>n. ((1/2) gchoose n) * a powr (1/2 - real_of_nat n) * z ^ n) sums
                  sqrt (a + z :: real)"
  using gen_binomial_real''[of z a "1/2"] by (simp add: powr_half_sqrt)

lemma sqrt_series:
  "\<bar>z\<bar> < 1 \<Longrightarrow> (\<lambda>n. ((1/2) gchoose n) * z ^ n) sums sqrt (1 + z)"
  using gen_binomial_real[of z "1/2"] by (simp add: powr_half_sqrt)

end


(*  Title:      FOL/ex/Miniscope.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge

Classical First-Order Logic.
Conversion to nnf/miniscope format: pushing quantifiers in.
Demonstration of formula rewriting by proof.
*)

theory Miniscope
imports FOL
begin

lemmas ccontr = FalseE [THEN classical]

subsection \<open>Negation Normal Form\<close>

subsubsection \<open>de Morgan laws\<close>

lemma demorgans1:
  \<open>\<not> (P \<and> Q) \<longleftrightarrow> \<not> P \<or> \<not> Q\<close>
  \<open>\<not> (P \<or> Q) \<longleftrightarrow> \<not> P \<and> \<not> Q\<close>
  \<open>\<not> \<not> P \<longleftrightarrow> P\<close>
  by blast+

lemma demorgans2:
  \<open>\<And>P. \<not> (\<forall>x. P(x)) \<longleftrightarrow> (\<exists>x. \<not> P(x))\<close>
  \<open>\<And>P. \<not> (\<exists>x. P(x)) \<longleftrightarrow> (\<forall>x. \<not> P(x))\<close>
  by blast+

lemmas demorgans = demorgans1 demorgans2

(*** Removal of --> and <-> (positive and negative occurrences) ***)
(*Last one is important for computing a compact CNF*)
lemma nnf_simps:
  \<open>(P \<longrightarrow> Q) \<longleftrightarrow> (\<not> P \<or> Q)\<close>
  \<open>\<not> (P \<longrightarrow> Q) \<longleftrightarrow> (P \<and> \<not> Q)\<close>
  \<open>(P \<longleftrightarrow> Q) \<longleftrightarrow> (\<not> P \<or> Q) \<and> (\<not> Q \<or> P)\<close>
  \<open>\<not> (P \<longleftrightarrow> Q) \<longleftrightarrow> (P \<or> Q) \<and> (\<not> P \<or> \<not> Q)\<close>
  by blast+

(* BEWARE: rewrite rules for <-> can confuse the simplifier!! *)

subsubsection \<open>Pushing in the existential quantifiers\<close>

lemma ex_simps:
  \<open>(\<exists>x. P) \<longleftrightarrow> P\<close>
  \<open>\<And>P Q. (\<exists>x. P(x) \<and> Q) \<longleftrightarrow> (\<exists>x. P(x)) \<and> Q\<close>
  \<open>\<And>P Q. (\<exists>x. P \<and> Q(x)) \<longleftrightarrow> P \<and> (\<exists>x. Q(x))\<close>
  \<open>\<And>P Q. (\<exists>x. P(x) \<or> Q(x)) \<longleftrightarrow> (\<exists>x. P(x)) \<or> (\<exists>x. Q(x))\<close>
  \<open>\<And>P Q. (\<exists>x. P(x) \<or> Q) \<longleftrightarrow> (\<exists>x. P(x)) \<or> Q\<close>
  \<open>\<And>P Q. (\<exists>x. P \<or> Q(x)) \<longleftrightarrow> P \<or> (\<exists>x. Q(x))\<close>
  by blast+

subsubsection \<open>Pushing in the universal quantifiers\<close>

lemma all_simps:
  \<open>(\<forall>x. P) \<longleftrightarrow> P\<close>
  \<open>\<And>P Q. (\<forall>x. P(x) \<and> Q(x)) \<longleftrightarrow> (\<forall>x. P(x)) \<and> (\<forall>x. Q(x))\<close>
  \<open>\<And>P Q. (\<forall>x. P(x) \<and> Q) \<longleftrightarrow> (\<forall>x. P(x)) \<and> Q\<close>
  \<open>\<And>P Q. (\<forall>x. P \<and> Q(x)) \<longleftrightarrow> P \<and> (\<forall>x. Q(x))\<close>
  \<open>\<And>P Q. (\<forall>x. P(x) \<or> Q) \<longleftrightarrow> (\<forall>x. P(x)) \<or> Q\<close>
  \<open>\<And>P Q. (\<forall>x. P \<or> Q(x)) \<longleftrightarrow> P \<or> (\<forall>x. Q(x))\<close>
  by blast+

lemmas mini_simps = demorgans nnf_simps ex_simps all_simps

ML \<open>
val mini_ss = simpset_of (\<^context> addsimps @{thms mini_simps});
fun mini_tac ctxt =
  resolve_tac ctxt @{thms ccontr} THEN' asm_full_simp_tac (put_simpset mini_ss ctxt);
\<close>

end


section \<open>Composing functions\label{s:tm-composing}\<close>

theory Composing
  imports Elementary
begin

text \<open>
For a Turing machine $M_1$ computing $f_1$ in time $T_1$ and a TM $M_2$
computing $f_2$ in time $T_2$ there is a TM $M$ computing $f_2 \circ f_1$ in
time $O(T_1(n) + \max_{m \le T_1(n)} T_2(m))$. If $T_1$ is monotone
the time bound is $O(T_1 + T_2 \circ T_1)$; if $T_1$ and $T_2$ are
polynomially bounded the running-time of $M$ is polynomially bounded, too.

The Turing machines $M_1$ and $M_2$ can have both a different alphabet and
number of tapes, so generally they cannot be composed by the $;;$ operator. To
get around this we enlarge the alphabet and prepend and append tapes, so $M$ has
as many tapes as $M_1$ and $M_2$ combined. The following function returns the
combined Turing machine $M$.

\null
\<close>

definition "compose_machines k1 G1 M1 k2 G2 M2 \<equiv>
  enlarged G1 (append_tapes k1 (k1 + k2) M1) ;;
  tm_start 1 ;;
  tm_cp_until 1 k1 {\<box>} ;;
  tm_erase_cr 1 ;;
  tm_start k1 ;;
  prepend_tapes k1 (enlarged G2 M2) ;;
  tm_cr (k1 + 1) ;;
  tm_cp_until (k1 + 1) 1 {\<box>}"

locale compose =
  fixes k1 k2 G1 G2 :: nat
    and M1 M2 :: machine
    and T1 T2 :: "nat \<Rightarrow> nat"
    and f1 f2 :: "string \<Rightarrow> string"
  assumes tm_M1: "turing_machine k1 G1 M1"
    and tm_M2: "turing_machine k2 G2 M2"
    and computes1: "computes_in_time k1 M1 f1 T1"
    and computes2: "computes_in_time k2 M2 f2 T2"
begin

definition "tm1 \<equiv> enlarged G1 (append_tapes k1 (k1 + k2) M1)"
definition "tm2 \<equiv> tm1 ;; tm_start 1"
definition "tm3 \<equiv> tm2 ;; tm_cp_until 1 k1 {\<box>}"
definition "tm4 \<equiv> tm3 ;; tm_erase_cr 1"
definition "tm5 \<equiv> tm4 ;; tm_start k1"
definition "tm56 \<equiv> prepend_tapes k1 (enlarged G2 M2)"
definition "tm6 \<equiv> tm5 ;; tm56"
definition "tm7 \<equiv> tm6 ;; tm_cr (k1 + 1)"
definition "tm8 \<equiv> tm7 ;; tm_cp_until (k1 + 1) 1 {\<box>}"

definition G :: nat where
  "G \<equiv> max G1 G2"

lemma G1: "G1 \<le> G" and G2: "G2 \<le> G"
  using G_def by simp_all

lemma k_ge: "k1 \<ge> 2" "k2 \<ge> 2"
  using tm_M1 tm_M2 turing_machine_def by simp_all

lemma tm1_tm: "turing_machine (k1 + k2) G tm1"
  unfolding tm1_def using turing_machine_enlarged append_tapes_tm tm_M1 G1 by simp

lemma tm2_tm: "turing_machine (k1 + k2) G tm2"
  unfolding tm2_def using tm1_tm tm_start_tm turing_machine_def by blast

lemma tm3_tm: "turing_machine (k1 + k2) G tm3"
  unfolding tm3_def
  using tm2_tm tm_cp_until_tm turing_machine_def k_ge turing_machine_sequential_turing_machine
  by (metis add_leD1 less_add_same_cancel1 less_le_trans less_numeral_extra(1) nat_1_add_1)

lemma tm4_tm: "turing_machine (k1 + k2) G tm4"
  unfolding tm4_def
  using tm3_tm tm_erase_cr_tm turing_machine_def turing_machine_sequential_turing_machine
  by (metis Suc_1 Suc_le_lessD tm_erase_cr_tm zero_less_one)

lemma tm5_tm: "turing_machine (k1 + k2) G tm5"
  unfolding tm5_def
  using tm4_tm tm_start_tm turing_machine_def turing_machine_sequential_turing_machine
  by auto

lemma tm6_tm: "turing_machine (k1 + k2) G tm6"
  unfolding tm6_def
  using tm5_tm tm56_def turing_machine_enlarged prepend_tapes_tm tm_M2 G2
  by simp

lemma tm7_tm: "turing_machine (k1 + k2) G tm7"
  unfolding tm7_def using tm6_tm tm_cr_tm turing_machine_def by blast

lemma tm8_tm: "turing_machine (k1 + k2) G tm8"
  unfolding tm8_def
  using tm7_tm tm_cp_until_tm turing_machine_def turing_machine_sequential_turing_machine k_ge(2)
  by (metis add.commute add_less_cancel_right add_strict_increasing nat_1_add_1
    verit_comp_simplify1(3) zero_less_one)

context
  fixes x :: string
begin

definition "zs \<equiv> string_to_symbols x"

lemma bit_symbols_zs: "bit_symbols zs"
  using zs_def by simp

abbreviation "n \<equiv> length x"

lemma length_zs [simp]: "length zs = n"
  using zs_def by simp

definition "tps0 \<equiv> snd (start_config (k1 + k2) zs)"

definition tps1a :: "tape list" where
  "tps1a \<equiv> SOME tps. tps ::: 1 = string_to_contents (f1 x) \<and>
       transforms M1 (snd (start_config k1 (string_to_symbols x))) (T1 n) tps"

lemma tps1a_aux:
  "tps1a ::: 1 = string_to_contents (f1 x)"
  "transforms M1 (snd (start_config k1 (string_to_symbols x))) (T1 n) tps1a"
  using tps1a_def someI_ex[OF computes_in_timeD[OF computes1, of x]]
  by simp_all

lemma tps1a:
  "tps1a ::: 1 = string_to_contents (f1 x)"
  "transforms M1 (snd (start_config k1 zs)) (T1 n) tps1a"
  using tps1a_aux zs_def by simp_all

lemma length_tps1a [simp]: "length tps1a = k1"
  using tps1a(2) tm_M1 start_config_length execute_num_tapes transforms_def transits_def turing_machine_def
  by (smt (verit, del_insts) Suc_1 add_pos_pos less_le_trans less_numeral_extra(1) plus_1_eq_Suc snd_conv)

definition tps1b :: "tape list" where
  "tps1b \<equiv> replicate k2 (\<lfloor>[]\<rfloor>, 0)"

definition tps1 :: "tape list" where
  "tps1 \<equiv> tps1a @ tps1b"

lemma tps1_at_1: "tps1 ! 1 = tps1a ! 1"
  using tps1_def length_tps1a k_ge by (metis Suc_1 Suc_le_lessD nth_append)

lemma tps1_at_1': "tps1 ::: 1 = string_to_contents (f1 x)"
  using tps1_at_1 tps1a by simp

lemma tps1_pos_le: "tps1 :#: 1 \<le> T1 n"
proof -
  have "execute M1 (start_config k1 zs) (T1 n) = (length M1, tps1a)"
    using transforms_def transits_def tps1a(2)
    by (metis (no_types, lifting) execute_after_halting_ge fst_conv start_config_def snd_conv)
  moreover have "execute M1 (start_config k1 zs) (T1 n) <#> 1 \<le> T1 n"
    using head_pos_le_time[OF tm_M1, of 1] k_ge by fastforce
  ultimately show ?thesis
    using tps1_at_1 by simp
qed

lemma length_f1_x: "length (f1 x) \<le> T1 n"
proof -
  have "execute M1 (start_config k1 zs) (T1 n) = (length M1, tps1a)"
    using transforms_def transits_def tps1a(2)
    by (metis (no_types, lifting) execute_after_halting_ge fst_conv start_config_def snd_conv)
  moreover have "(execute M1 (start_config k1 zs) (T1 n) <:> 1) i = \<box>" if "i > T1 n" for i
    using blank_after_time[OF that _ _ tm_M1] k_ge(1) by simp
  ultimately have "(tps1a ::: 1) i = \<box>" if "i > T1 n" for i
    using that by simp
  then have "(string_to_contents (f1 x)) i = \<box>" if "i > T1 n" for i
    using that tps1a(1) by simp
  then have "length (string_to_symbols (f1 x)) \<le> T1 n"
    by (metis length_map order_refl verit_comp_simplify1(3) zero_neq_numeral zero_neq_one)
  then show ?thesis
    by simp
qed

lemma start_config_append:
  "start_config (k1 + k2) zs = (0, snd (start_config k1 zs) @ tps1b)"
proof
  have "k1 > 0"
    using tm_M1 turing_machine_def by simp
  show "fst (start_config (k1 + k2) zs) = fst (0, snd (start_config k1 zs) @ tps1b)"
    using start_config_def by simp
  show "snd (start_config (k1 + k2) zs) = snd (0, snd (start_config k1 zs) @ tps1b)"
    (is "?l = ?r")
  proof (rule nth_equalityI)
    have len: "||start_config k1 zs|| = k1"
      using start_config_length by (simp add: \<open>0 < k1\<close>)
    show "length ?l = length ?r"
      using start_config_length tps1b_def tm_M1 turing_machine_def by simp
    show "?l ! j = ?r ! j" if "j < length ?l" for j
    proof (cases "j < k1")
      case True
      show ?thesis
      proof (cases "j = 0")
        case True
        then show ?thesis
          using start_config_def `k1 > 0` by simp
      next
        case False
        then have 1: "?l ! j = (\<lambda>i. if i = 0 then \<triangleright> else \<box>, 0)"
          using start_config_def `k1 > 0` True by auto
        have "?r ! j = snd (start_config k1 zs) ! j"
          using True len by (simp add: nth_append)
        then have "?r ! j = (\<lambda>i. if i = 0 then \<triangleright> else \<box>, 0)"
          using start_config4 `k1 > 0` False True by simp
        then show ?thesis
          using 1 by simp
      qed
    next
      case False
      then have j: "j < k1 + k2" "k1 \<le> j"
        using that \<open>0 < k1\<close> add_gr_0 start_config_length by simp_all
      then have "?r ! j = (\<lfloor>[]\<rfloor>, 0)"
        using tps1b_def by (simp add: False len nth_append)
      moreover have "?l ! j = (\<lambda>i. if i = 0 then \<triangleright> else \<box>, 0)"
        using start_config4 `k1 > 0` j by simp
      ultimately show ?thesis
        by auto
    qed
  qed
qed

lemma tm1 [transforms_intros]: "transforms tm1 tps0 (T1 n) tps1"
proof -
  let ?M = "append_tapes k1 (k1 + length tps1b) M1"
  have len: "||start_config k1 zs|| = k1"
    using start_config_length[of k1 zs] tm_M1 turing_machine_def by simp
  have "transforms ?M (snd (start_config k1 zs) @ tps1b) (T1 n) (tps1a @ tps1b)"
    using transforms_append_tapes[OF tm_M1 len tps1a(2), of tps1b] .
  moreover have "tps0 = snd (start_config k1 zs) @ tps1b"
    unfolding tps0_def using start_config_append by simp
  ultimately have *: "transforms ?M tps0 (T1 n) tps1"
    using tps1_def by simp

  have "symbols_lt G1 zs"
    using bit_symbols_zs tm_M1 turing_machine_def by auto
  moreover have "turing_machine (k1 + k2) G1 ?M"
    using append_tapes_tm[OF tm_M1, of "k1 + k2"] by (simp add: tps1b_def)
  ultimately have "transforms (enlarged G1 ?M) tps0 (T1 n) tps1"
    using transforms_enlarged * tps0_def by simp
  then show ?thesis
    using tm1_def tps1b_def by simp
qed

lemma clean_string_to_contents: "clean_tape (string_to_contents xs, i)"
  using clean_tape_def by simp

definition tps2 :: "tape list" where
  "tps2 \<equiv> tps1 [1 := tps1 ! 1 |#=| 0]"

lemma length_tps2 [simp]: "length tps2 = k1 + k2"
  using tps2_def tps1_def by (simp add: tps1b_def)

lemma tm2:
  assumes "t = Suc (T1 n + tps1 :#: Suc 0)"
  shows "transforms tm2 tps0 t tps2"
  unfolding tm2_def
proof (tform tps: assms tps2_def)
  show "1 < length tps1"
    using tm_M1 turing_machine_def tps1_def by simp
  show "clean_tape (tps1 ! 1)"
      using tps1a(1) tps1_at_1 clean_tape_def by simp
qed

corollary tm2' [transforms_intros]:
  assumes "t = Suc (2 * T1 n)"
  shows "transforms tm2 tps0 t tps2"
  using assms tm2 tps1_pos_le transforms_monotone by simp

definition tps3 :: "tape list" where
  "tps3 \<equiv> tps2 [1 := tps2 ! 1 |#=| (Suc (length (f1 x))), k1 := tps2 ! 1 |#=| (Suc (length (f1 x)))]"

lemma tm3:
  assumes "t = Suc (Suc (2 * T1 n + Suc (length (f1 x))))"
  shows "transforms tm3 tps0 t tps3"
  unfolding tm3_def
proof (tform tps: k_ge)
  have "Suc 0 < k1 + k2" "0 < k2"
    using k_ge by simp_all
  then have *: "tps2 ! 1 = tps1 ! 1 |#=| 0"
    using tps2_def by (simp add: tps1_def tps1b_def)
  let ?i = "Suc (length (f1 x))"
  show "rneigh (tps2 ! 1) {0} ?i"
    using * tps1_at_1 tps1a by (intro rneighI) auto
  show "tps3 = tps2
    [1 := tps2 ! 1 |+| Suc (length (f1 x)),
     k1 := implant (tps2 ! 1) (tps2 ! k1) (Suc (length (f1 x)))]"
  proof -
    have "tps2 ! 1 |#=| (Suc (length (f1 x))) = tps2 ! 1 |#=| Suc (tps2 :#: 1 + length (f1 x))"
      by (metis "*" One_nat_def add_Suc plus_1_eq_Suc snd_conv)
    moreover have "tps2 ! 1 |#=| ?i = implant (tps2 ! 1) (tps2 ! k1) ?i"
    proof
      have 1: "tps2 ! 1 = (string_to_contents (f1 x), 0)"
        using tps1_at_1' * by simp
      have "tps1 ! k1 = (\<lfloor>[]\<rfloor>, 0)"
        using tps1_def tps1b_def by (simp add: \<open>0 < k2\<close> nth_append)
      then have 2: "tps2 ! k1 = (\<lfloor>[]\<rfloor>, 0)"
        using tps2_def k_ge by simp
      then show "snd (tps2 ! 1 |#=| ?i) = snd (implant (tps2 ! 1) (tps2 ! k1) ?i)"
        using implant by simp
      have "fst (implant (tps2 ! 1) (tps2 ! k1) ?i) i = fst (tps2 ! 1 |#=| ?i) i" for i
        using 1 2 implant by simp
      then show "fst (tps2 ! 1 |#=| ?i) = fst (implant (tps2 ! 1) (tps2 ! k1) ?i)"
        by auto
    qed
    ultimately show ?thesis
      using tps3_def by simp
  qed
  show "t = Suc (2 * T1 n) + Suc (Suc (length (f1 x)))"
    using assms by simp
qed

definition "tps3' \<equiv> tps1a
  [1 := (string_to_contents (f1 x), Suc (length (f1 x)))] @
   ((string_to_contents (f1 x), Suc (length (f1 x))) #
    replicate (k2 - 1) (\<lfloor>[]\<rfloor>, 0))"

lemma tps3': "tps3 = tps3'"
proof (rule nth_equalityI)
  have "length tps3 = k1 + k2"
    using tps3_def by simp
  moreover have "length tps3' = k1 + k2"
    using k_ge(2) tps3'_def by simp
  ultimately show "length tps3 = length tps3'"
    by simp
  show "tps3 ! j = tps3' ! j" if "j < length tps3" for j
  proof (cases "j < k1")
    case True
    then have rhs: "tps3' ! j = (tps1a [1 := (string_to_contents (f1 x), Suc (length (f1 x)))]) ! j"
      by (simp add: tps3'_def nth_append)
    show ?thesis
    proof (cases "j = 1")
      case True
      then have "tps3 ! j = tps2 ! 1 |#=| (Suc (length (f1 x)))"
        using tps3_def Suc_1 Suc_n_not_le_n \<open>length tps3 = k1 + k2\<close> k_ge(1)
          length_tps2 nth_list_update_eq nth_list_update_neq that
        by auto
      then have "tps3 ! j = tps1 ! 1 |#=| (Suc (length (f1 x)))"
        using tps2_def True \<open>length tps3 = k1 + k2\<close> length_tps2 that by auto
      then have "tps3 ! j = (string_to_contents (f1 x), Suc (length (f1 x)))"
        using tps1_at_1 tps1a(1) by simp
      then show ?thesis
        using rhs True k_ge(1) by auto
    next
      case False
      then have "tps3 ! j = tps2 ! j"
        using tps3_def True by simp
      then have "tps3 ! j = tps1 ! j"
        using tps2_def False by simp
      then have "tps3 ! j = tps1a ! j"
        using length_tps1a tps1_def False True by (simp add: nth_append)
      moreover have "tps3' ! j = tps1a ! j"
        using False rhs by simp
      ultimately show ?thesis
        by simp
    qed
  next
    case j_ge: False
    show ?thesis
    proof (cases "j = k1")
      case True
      then have "tps3 ! j = tps2 ! 1 |#=| (Suc (length (f1 x)))"
        using tps3_def that by simp
      then have "tps3 ! j = tps1 ! 1 |#=| (Suc (length (f1 x)))"
        using tps2_def \<open>length tps3 = k1 + k2\<close> length_tps2 Suc_1 Suc_le_lessD tm1_tm turing_machine_def
        by simp
      then have "tps3 ! j = (string_to_contents (f1 x), Suc (length (f1 x)))"
        using tps1_at_1 tps1a(1) by simp
      moreover have "tps3' ! j = (string_to_contents (f1 x), Suc (length (f1 x)))"
        using True tps3'_def
        by (metis (no_types, lifting) length_list_update length_tps1a nth_append_length)
      ultimately show ?thesis
        by simp
    next
      case False
      then have "j > k1"
        using j_ge by simp
      then have "tps3' ! j = ((string_to_contents (f1 x), Suc (length (f1 x))) #
          replicate (k2 - 1) (\<lfloor>[]\<rfloor>, 0)) ! (j - k1)"
        by (simp add: tps3'_def nth_append)
      moreover have "j - k1 < k2"
        by (metis \<open>k1 < j\<close> \<open>length tps3 = k1 + k2\<close> add.commute less_diff_conv2 less_imp_le that)
      ultimately have *: "tps3' ! j = (\<lfloor>[]\<rfloor>, 0)"
        by (metis (no_types, lifting) Suc_leI \<open>k1 < j\<close> add_leD1 le_add_diff_inverse2 less_diff_conv2
          nth_Cons_pos nth_replicate plus_1_eq_Suc zero_less_diff)
      have "tps3 ! j = tps2 ! j"
        using tps3_def \<open>k1 < j\<close> k_ge(1) by simp
      then have "tps3 ! j = tps1 ! j"
        using tps2_def \<open>k1 < j\<close> k_ge(1) by simp
      then have "tps3 ! j = tps1b ! (j - k1)"
        using tps1_def by (simp add: j_ge nth_append)
      then have "tps3 ! j = (\<lfloor>[]\<rfloor>, 0)"
        using tps1b_def by (simp add: \<open>j - k1 < k2\<close>)
      then show ?thesis
        using * by simp
    qed
  qed
qed

lemma tm3' [transforms_intros]:
  assumes "t = Suc (Suc (Suc (3 * T1 n)))"
  shows "transforms tm3 tps0 t tps3'"
proof -
  have "transforms tm3 tps0 (Suc (Suc (2 * T1 n + Suc (length (f1 x))))) tps3"
    using tm3 by simp
  moreover have "t \<ge> Suc (Suc (2 * T1 n + Suc (length (f1 x))))"
    using assms length_f1_x by simp
  ultimately show ?thesis
    using tps3' transforms_monotone by auto
qed

definition "tps4 \<equiv>
  tps1a [1 := (\<lfloor>[]\<rfloor>, 1)] @
  ((string_to_contents (f1 x), Suc (length (f1 x))) #
   replicate (k2 - 1) (\<lfloor>[]\<rfloor>, 0))"

lemma tm4:
  assumes "t = 9 + (3 * T1 n + (Suc (3 * length (string_to_symbols (f1 x)))))"
  shows "transforms tm4 tps0 t tps4"
  unfolding tm4_def
proof (tform)
  show "1 < length tps3'"
    using tps3'_def using tm1_tm turing_machine_def by auto
  let ?zs = "string_to_symbols (f1 x)"
  show "proper_symbols ?zs"
    by simp
  show "tps4 = tps3'[1 := (\<lfloor>[]\<rfloor>, 1)]"
    using tps4_def tps3'_def k_ge(1) length_tps1a by (simp add: list_update_append1)
  show "tps3' ::: 1 = \<lfloor>string_to_symbols (f1 x)\<rfloor>"
  proof -
    have "tps3' ! 1 = (string_to_contents (f1 x), Suc (length (f1 x)))"
      using tps3'_def k_ge(1) length_tps1a by (simp add: nth_append)
    then show ?thesis
      by auto
  qed
  have "tps3' :#: 1 = Suc (length (f1 x))"
    using tps3'_def k_ge(1) length_tps1a by (simp add: nth_append)
  then show "t = Suc (Suc (Suc (3 * T1 n))) +
      (tps3' :#: 1 + 2 * length (string_to_symbols (f1 x)) + 6)"
    using assms by simp
qed

lemma tm4' [transforms_intros]:
  assumes "t = 10 + (6 * T1 n)"
  shows "transforms tm4 tps0 t tps4"
proof (rule transforms_monotone[OF tm4], simp)
  show "10 + (3 * T1 n + 3 * length (f1 x)) \<le> t"
    using length_f1_x assms by simp
qed

definition "tps5 \<equiv>
  tps1a [1 := (\<lfloor>[]\<rfloor>, 1)] @
  ((string_to_contents (f1 x), 0) #
   replicate (k2 - 1) (\<lfloor>[]\<rfloor>, 0))"

lemma tm5:
  assumes "t = 11 + (6 * T1 n + tps4 :#: k1)"
  shows "transforms tm5 tps0 t tps5"
  unfolding tm5_def
proof (tform time: assms)
  show "k1 < length tps4"
    using tps4_def length_tps1a by simp
  show "tps5 = tps4[k1 := tps4 ! k1 |#=| 0]"
    using tps4_def tps5_def length_tps1a
    by (metis (no_types, lifting) fst_conv length_list_update list_update_length nth_append_length)
  show "clean_tape (tps4 ! k1)"
    using tps4_def length_tps1a clean_tape_def
    by (smt (z3) Suc_eq_plus1 add.commute add_cancel_right_right
      fst_conv length_list_update nat.distinct(1) nat_1_add_1 nth_append_length numeral_3_eq_3)
qed

abbreviation "ys \<equiv> string_to_symbols (f1 x)"

abbreviation "m \<equiv> length (f1 x)"

definition "tps5' \<equiv>
  tps1a [1 := (\<lfloor>[]\<rfloor>, 1)] @
  snd (start_config k2 ys)"

lemma tps5': "tps5 = tps5'"
  using tps5_def tps5'_def start_config_def by auto

lemma tm5' [transforms_intros]:
  assumes "t = 12 + 7 * T1 n"
  shows "transforms tm5 tps0 t tps5'"
proof -
  have "tps4 :#: k1 = Suc (length (f1 x))"
    using tps4_def
    by (metis (no_types, lifting) length_list_update length_tps1a nth_append_length snd_conv)
  then have "tps4 :#: k1 \<le> Suc (T1 n)"
    using length_f1_x by simp
  then have "t \<ge> 11 + (6 * T1 n + tps4 :#: k1)"
    using assms by simp
  then show ?thesis
    using tm5 transforms_monotone tps5' by simp
qed

definition tps6b :: "tape list" where
  "tps6b \<equiv> SOME tps. tps ::: 1 = string_to_contents (f2 (f1 x)) \<and>
       transforms M2 (snd (start_config k2 ys)) (T2 m) tps"

lemma tps6b:
  "tps6b ::: 1 = string_to_contents (f2 (f1 x))"
  "transforms M2 (snd (start_config k2 ys)) (T2 m) tps6b"
  using tps6b_def someI_ex[OF computes_in_timeD[OF computes2, of "f1 x"]]
  by simp_all

lemma tps6b_pos_le: "tps6b :#: 1 \<le> T2 m"
proof -
  have "execute M2 (start_config k2 ys) (T2 m) = (length M2, tps6b)"
    using transforms_def transits_def tps6b(2)
    by (metis (no_types, lifting) execute_after_halting_ge fst_conv start_config_def snd_conv)
  moreover have "execute M2 (start_config k2 ys) (T2 m) <#> 1 \<le> T2 m"
    using head_pos_le_time[OF tm_M2, of 1] k_ge by simp
  ultimately show ?thesis
    by simp
qed

lemma length_tps6b: "length tps6b = k2"
  using tm_M2 execute_num_tapes k_ge(2) tps5' tps5'_def tps5_def tps6b(2) transforms_def transits_def
  by (smt (verit, ccfv_threshold) One_nat_def Suc_diff_Suc length_Cons length_replicate less_le_trans
    minus_nat.diff_0 numeral_2_eq_2 prod.sel(2) same_append_eq zero_less_Suc)

lemma length_f2_f1_x: "length (f2 (f1 x)) \<le> T2 m"
proof -
  have "execute M2 (start_config k2 ys) (T2 m) = (length M2, tps6b)"
    using transforms_def transits_def tps6b(2)
    by (metis (no_types, lifting) execute_after_halting_ge fst_conv start_config_def snd_conv)
  moreover have "(execute M2 (start_config k2 ys) (T2 m) <:> 1) i = 0" if "i > T2 m" for i
    using blank_after_time[OF that _ _ tm_M2] k_ge(2) by simp
  ultimately have "(tps6b ::: 1) i = \<box>" if "i > T2 m" for i
    using that by simp
  then have "(string_to_contents (f2 (f1 x))) i = \<box>" if "i > T2 m" for i
    using that tps6b(1) by simp
  then have "length (string_to_symbols (f2 (f1 x))) \<le> T2 m"
    by (metis length_map order_refl verit_comp_simplify1(3) zero_neq_numeral zero_neq_one)
  then show ?thesis
    by simp
qed

lemma enlarged_M2: "transforms (enlarged G2 M2) (snd (start_config k2 ys)) (T2 m) tps6b"
proof -
  have "symbols_lt G2 (string_to_symbols (f1 x))"
    using tm_M2 turing_machine_def by simp
  then show ?thesis
    using transforms_enlarged[OF tm_M2 _ tps6b(2)] by simp
qed

lemma enlarged_M2_tm: "turing_machine k2 G (enlarged G2 M2)"
  using turing_machine_enlarged tm_M2 G2 by simp

definition "tps6 \<equiv> tps1a[1 := (\<lfloor>[]\<rfloor>, 1)] @ tps6b"

lemma tm56 [transforms_intros]: "transforms tm56 tps5' (T2 m) tps6"
  using transforms_prepend_tapes[OF enlarged_M2_tm _ _ enlarged_M2, of "tps1a [1 := (\<lfloor>[]\<rfloor>, 1)]" k1]
    tps5'_def tps6_def tm56_def start_config_length k_ge(2)
  by auto

lemma tps6_at_Suc_k1: "tps6 ::: (k1 + 1) = string_to_contents (f2 (f1 x))"
  and tps6_pos_le: "tps6 :#: (k1 + 1) \<le> T2 m"
proof -
  have "tps6 ! (k1 + 1) = tps6b ! 1"
    using tps6_def length_tps1a length_tps6b by (simp add: nth_append)
  then show
    "tps6 ::: (k1 + 1) = string_to_contents (f2 (f1 x))"
    "tps6 :#: (k1 + 1) \<le> T2 m"
    using tps6b(1) tps6b_pos_le by simp_all
qed

lemma tm6 [transforms_intros]:
  assumes "t = 12 + 7 * T1 n + T2 m"
  shows "transforms tm6 tps0 t tps6"
  unfolding tm6_def by (tform tps: assms)

definition "tps7 \<equiv>
  tps1a[1 := (\<lfloor>[]\<rfloor>, 1)] @
  tps6b[1 := (string_to_contents (f2 (f1 x)), 1)]"

lemma tps7_at_Suc_k1: "tps7 ! (k1 + 1) = (string_to_contents (f2 (f1 x)), 1)"
  using tps7_def k_ge(2) length_tps1a length_tps6b
  by (metis (no_types, lifting) One_nat_def Suc_le_lessD add.commute diff_add_inverse
    length_list_update not_add_less2 nth_append nth_list_update_eq numeral_2_eq_2)

lemma tm7:
  assumes "t = 14 + (7 * T1 n + (T2 m + tps6 :#: Suc k1))"
  shows "transforms tm7 tps0 t tps7"
  unfolding tm7_def
proof (tform time: assms)
  show "k1 + 1 < length tps6"
    using tps6_def k_ge(2) length_tps1a length_tps6b by simp
  show "clean_tape (tps6 ! (k1 + 1))"
    using tps6_at_Suc_k1 clean_tape_def by simp
  show "tps7 = tps6[k1 + 1 := tps6 ! (k1 + 1) |#=| 1]"
  proof -
    have "tps6 ! (k1 + 1) |#=| 1 = (string_to_contents (f2 (f1 x)), 1)"
      using tps6_at_Suc_k1 by simp
    then show ?thesis
      using tps6_def tps7_def length_tps1a length_tps6b k_ge tps7_at_Suc_k1
      by (metis (no_types, lifting) add.commute diff_add_inverse length_list_update
        list_update_append not_add_less2 plus_1_eq_Suc)
  qed
qed

corollary tm7' [transforms_intros]:
  assumes "t = 14 + 7 * T1 n + 2 * T2 m"
  shows "transforms tm7 tps0 t tps7"
proof (rule transforms_monotone[OF tm7], simp)
  show "14 + (7 * T1 n + (T2 (length (f1 x)) + tps6 :#: Suc k1)) \<le> t"
    using assms tps6_pos_le by simp
qed

definition "tps8 \<equiv>
  tps1a[1 := (string_to_contents (f2 (f1 x)), Suc (length (f2 (f1 x))))] @
  tps6b[1 := (string_to_contents (f2 (f1 x)), Suc (length (f2 (f1 x))))]"

lemma tps8_at_1: "tps8 ::: 1 = string_to_contents (f2 (f1 x))"
  using tps8_def length_tps1a k_ge(1)
  by (metis (no_types, lifting) One_nat_def Suc_le_lessD length_list_update nth_append
    nth_list_update_eq numeral_2_eq_2 prod.sel(1))

lemma tm8:
  assumes "t = 15 + 7 * T1 n + 2 * T2 m + length (f2 (f1 x))"
  shows "transforms tm8 tps0 t tps8"
  unfolding tm8_def
proof (tform tps: assms)
  show "k1 + 1 < length tps7"
    using tps7_def length_tps1a length_tps6b k_ge(2) by simp
  show "1 < length tps7"
    using tps7_def length_tps6b k_ge(2) by simp
  let ?n = "length (f2 (f1 x))"
  show "rneigh (tps7 ! (k1 + 1)) {\<box>} ?n"
  proof (rule rneighI)
   show "(tps7 ::: (k1 + 1)) (tps7 :#: (k1 + 1) + ?n) \<in> {\<box>}"
     using tps7_at_Suc_k1 by simp
   show "\<And>n'. n' < ?n \<Longrightarrow> (tps7 ::: (k1 + 1)) (tps7 :#: (k1 + 1) + n') \<notin> {\<box>}"
     using tps7_at_Suc_k1 by simp
  qed
  show "tps8 = tps7
    [k1 + 1 := tps7 ! (k1 + 1) |+| ?n,
     1 := implant (tps7 ! (k1 + 1)) (tps7 ! 1) ?n]"
     (is "tps8 = ?tps")
  proof (rule nth_equalityI)
    show "length tps8 = length ?tps"
      using tps8_def tps7_def by simp
    have len: "length tps8 = k1 + k2"
      using tps8_def length_tps6b by simp
    show "tps8 ! j = ?tps ! j" if "j < length tps8" for j
    proof (cases "j < k1")
      case j_less: True
      then have lhs: "tps8 ! j = tps1a[1 := (string_to_contents (f2 (f1 x)), Suc (length (f2 (f1 x))))] ! j"
        using tps8_def length_tps1a length_tps6b k_ge by (simp add: nth_append)
      show ?thesis
      proof (cases "j = 1")
        case True
        then have 1: "?tps ! j = implant (tps7 ! (k1 + 1)) (tps7 ! 1) ?n"
          using \<open>1 < length tps7\<close> by simp
        have 2: "tps8 ! j = (string_to_contents (f2 (f1 x)), Suc (length (f2 (f1 x))))"
          using lhs True j_less by simp
        have 3: "tps7 ! 1 = (\<lfloor>[]\<rfloor>, 1)"
          using tps7_def length_tps1a
          by (metis (no_types, lifting) True j_less length_list_update nth_append nth_list_update_eq)
        have "implant (string_to_contents (f2 (f1 x)), 1) (\<lfloor>[]\<rfloor>, 1) ?n =
            (string_to_contents (f2 (f1 x)), Suc ?n)"
          using implant contents_def by auto
        then show ?thesis
          using 1 2 3 tps7_at_Suc_k1 by simp
      next
        case False
        then have "?tps ! j = tps7 ! j"
          by (metis One_nat_def Suc_eq_plus1 add.commute j_less not_add_less2 nth_list_update_neq)
        then have "?tps ! j = tps1a ! j"
          using False j_less tps7_def length_tps1a
          by (metis (no_types, lifting) length_list_update nth_append nth_list_update_neq)
        moreover have "tps8 ! j = tps1a ! j"
          using False j_less tps8_def lhs by simp
        ultimately show ?thesis
          by simp
      qed
    next
      case j_ge: False
      then have lhs: "tps8 ! j = tps6b[1 := (string_to_contents (f2 (f1 x)), Suc (length (f2 (f1 x))))] ! (j - k1)"
        using tps8_def length_tps1a length_tps6b k_ge by (simp add: nth_append)
      show ?thesis
      proof (cases "j = Suc k1")
        case True
        then have "tps8 ! j = (string_to_contents (f2 (f1 x)), Suc (length (f2 (f1 x))))"
          using lhs len that length_tps6b by simp
        moreover have "?tps ! j = tps7 ! Suc k1 |+| ?n"
          using True \<open>k1 + 1 < length tps7\<close> k_ge(1) by simp
        ultimately show ?thesis
          using tps7_at_Suc_k1 True by simp
      next
        case False
        then have "tps8 ! j = tps6b ! (j - k1)"
          using lhs by simp
        moreover have "?tps ! j = tps7 ! j"
          using False j_ge that k_ge(1) by simp
        ultimately show ?thesis
          using tps7_def j_ge False length_tps1a
          by (metis (no_types, lifting) add.commute add_diff_inverse_nat length_list_update
            nth_append nth_list_update_neq plus_1_eq_Suc)
      qed
    qed
  qed
qed

lemma tm8':
  assumes "t = 15 + 7 * T1 n + 3 * T2 m"
  shows "transforms tm8 tps0 t tps8"
proof (rule transforms_monotone[OF tm8], simp)
  show "15 + 7 * T1 n + 2 * T2 m + length (f2 (f1 x)) \<le> t"
    using length_f2_f1_x assms by simp
qed

lemma tm8'_mono:
  assumes "mono T2"
    and "t = 15 + 7 * T1 n + 3 * T2 (T1 n)"
  shows "transforms tm8 tps0 t tps8"
proof (rule transforms_monotone[OF tm8'], simp)
  have "T2 (T1 n) \<ge> T2 m"
    using assms(1) length_f1_x monoE by auto
  then show "15 + 7 * T1 n + 3 * T2 m \<le> t"
    using assms(2) by simp
qed

end  (* context x *)

lemma computes_composed_mono:
  assumes "mono T2" and "T = (\<lambda>n. 15 + 7 * T1 n + 3 * T2 (T1 n))"
  shows "computes_in_time (k1 + k2) tm8 (f2 \<circ> f1) T"
proof
  fix x
  have "tps8 x ::: 1 = string_to_contents (f2 (f1 x))"
    using tps8_at_1 by simp
  moreover have "transforms tm8 (snd (start_config (k1 + k2) (string_to_symbols x))) (T (length x)) (tps8 x)"
    using tm8'_mono assms tps0_def zs_def by simp
  ultimately show "\<exists>tps.
      tps ::: 1 = string_to_contents ((f2 \<circ> f1) x) \<and>
      transforms tm8 (snd (start_config (k1 + k2) (string_to_symbols x))) (T (length x)) tps"
    by force
qed

end  (* locale compose *)

lemma computes_composed_poly:
  assumes tm_M1: "turing_machine k1 G1 M1"
    and tm_M2: "turing_machine k2 G2 M2"
    and computes1: "computes_in_time k1 M1 f1 T1"
    and computes2: "computes_in_time k2 M2 f2 T2"
  assumes "big_oh_poly T1" and "big_oh_poly T2"
  shows "\<exists>T k G M. big_oh_poly T \<and> turing_machine k G M \<and> computes_in_time k M (f2 \<circ> f1) T"
proof -
  obtain d1 :: nat where "big_oh T1 (\<lambda>n. n ^ d1)"
    using assms(5) big_oh_poly_def by auto
  obtain b c d2 :: nat where cm: "d2 > 0" "\<forall>n. T2 n \<le> b + c * n ^ d2"
    using big_oh_poly_offset[OF assms(6)] by auto
  let ?U = "\<lambda>n. b + c * n ^ d2"
  have U: "T2 n \<le> ?U n" for n
    using cm by simp
  have "mono ?U"
    by standard (simp add: cm(1))
  have computesU: "computes_in_time k2 M2 f2 ?U"
    using computes_in_time_mono[OF computes2 U] .
  interpret compo: compose k1 k2 G1 G2 M1 M2 T1 ?U f1 f2
    using assms computesU compose.intro by simp
  let ?M = "compo.tm8"
  let ?T = "(\<lambda>n. 15 + 7 * T1 n + 3 * (b + c * T1 n ^ d2))"
  have "computes_in_time (k1 + k2) ?M (f2 \<circ> f1) ?T"
    using compo.computes_composed_mono[OF `mono ?U`, of ?T] by simp
  moreover have "big_oh_poly ?T"
  proof -
    have "big_oh_poly (\<lambda>n. n ^ d2)"
      using big_oh_poly_poly by simp
    moreover have "(\<lambda>n. T1 n ^ d2) = (\<lambda>n. n ^ d2) \<circ> T1"
      by auto
    ultimately have "big_oh_poly (\<lambda>n. T1 n ^ d2)"
      using big_oh_poly_composition[OF assms(5)] by auto
    then have "big_oh_poly (\<lambda>n. 3 * (b + c * T1 n ^ d2))"
      using big_oh_poly_const big_oh_poly_prod big_oh_poly_sum by simp
    then show ?thesis
      using assms(5) big_oh_poly_const big_oh_poly_prod big_oh_poly_sum by simp
  qed
  moreover have "turing_machine (k1 + k2) compo.G ?M"
    using compo.tm8_tm .
  ultimately show ?thesis
    by auto
qed

end


theory Normalization
imports
  Main
  "HOL-IMP.Star"
  "List-Index.List_Index"
  "HOL-Eisbach.Eisbach"
  "HOL-Eisbach.Eisbach_Tools"
begin

datatype ltype=
  A | Fun ltype ltype (infixr "\<rightarrow>"  225)

datatype lterm=
  LVar nat | LApp lterm lterm | LAbs ltype lterm | ValA

fun shift_L :: "int \<Rightarrow> nat \<Rightarrow> lterm \<Rightarrow> lterm" where
 "shift_L d c ValA = ValA" |
 "shift_L d c (LVar k)    = LVar (if k < c then k else nat (int k + d))" |
 "shift_L d c (LApp t t1) = LApp (shift_L d c t) (shift_L d c t1)" |
 "shift_L d c (LAbs T t)  = LAbs T (shift_L d (Suc c) t)"

fun subst_L :: "nat \<Rightarrow> lterm \<Rightarrow> lterm \<Rightarrow> lterm" where
  "subst_L j s ValA = ValA" |
  "subst_L j s (LApp t1 t2) = LApp (subst_L j s t1) (subst_L j s t2)" |
  "subst_L j s (LVar k) = (if k = j then s else LVar k)" |
  "subst_L j s (LAbs T t) = LAbs T (subst_L (Suc j) (shift_L 1 0 s) t)"

fun FV ::"lterm \<Rightarrow> nat set" where
  "FV (LVar k) = {k}"|
  "FV (LApp t1 t2) = FV t1 \<union> FV t2"|
  "FV (LAbs T t) =  image (\<lambda>x. x - 1) (FV t - {0})" |
  "FV ValA = {}"

inductive is_value_L:: "lterm \<Rightarrow> bool" where
  "is_value_L ValA"
| "is_value_L (LAbs T t)"

inductive eval1_L :: "lterm \<Rightarrow> lterm \<Rightarrow> bool" where
  \<comment> \<open>Rules relating to the evaluation of function application\<close>
  eval1_LApp1:
    "eval1_L t1 t1' \<Longrightarrow> eval1_L (LApp t1 t2) (LApp t1' t2)" |
  eval1_LApp2:
    "is_value_L v1 \<Longrightarrow> eval1_L t2 t2' \<Longrightarrow> eval1_L (LApp v1 t2) (LApp v1 t2')" |
  eval1_LApp_LAbs:
    "is_value_L v2 \<Longrightarrow> eval1_L (LApp (LAbs T' t12) v2)
      (shift_L (-1) 0 (subst_L 0 (shift_L 1 0 v2) t12))"

inductive_cases eval1_LAppE: "eval1_L (LApp t1 t2) t'"

type_synonym lcontext = "ltype list"

notation Nil ("\<emptyset>")
abbreviation cons :: "lcontext \<Rightarrow> ltype \<Rightarrow> lcontext" (infixl "|,|" 200) where
  "cons \<Gamma> T' \<equiv> T' # \<Gamma>"
abbreviation elem' :: "(nat \<times> ltype) \<Rightarrow> lcontext \<Rightarrow> bool" (infix "|\<in>|" 200) where
  "elem' p \<Gamma> \<equiv> fst p < length \<Gamma> \<and> snd p = nth \<Gamma> (fst p)"

text{*  For the typing rule of letbinder, we require to replace the type
        of the variable by the expected type
    *}

inductive has_type_L :: "lcontext \<Rightarrow> lterm \<Rightarrow> ltype \<Rightarrow> bool" ("((_)/ \<turnstile> (_)/ |:| (_))" [150,150, 150] 150) where
  \<comment> \<open>Rules relating to the type of A\<close>
  has_type_LValA:
    "\<Gamma> \<turnstile> ValA |:| A"|

  \<comment> \<open>Rules relating to the type of the constructs of the $\lambda$-calculus\<close>
  has_type_LVar:
    "(x, T') |\<in>| \<Gamma> \<Longrightarrow> \<Gamma> \<turnstile> LVar x |:| (T')" |
  has_type_LAbs:
    "(\<Gamma> |,| T1) \<turnstile> t2 |:| T2 \<Longrightarrow> \<Gamma> \<turnstile> LAbs T1 t2 |:| (T1 \<rightarrow> T2)" |
  has_type_LApp:
    "\<Gamma> \<turnstile> t1 |:| T11 \<rightarrow> T12 \<Longrightarrow> \<Gamma> \<turnstile> t2 |:| T11 \<Longrightarrow> \<Gamma> \<turnstile> LApp t1 t2 |:| T12"

lemma canonical_forms:
  "is_value_L v \<Longrightarrow> \<Gamma> \<turnstile> v |:| A \<Longrightarrow> v = ValA"
  "is_value_L v \<Longrightarrow> \<Gamma> \<turnstile> v |:| T1 \<rightarrow> T2 \<Longrightarrow> \<exists>t. v = LAbs T1 t"
by (auto elim: has_type_L.cases is_value_L.cases)

abbreviation closed ::"lterm \<Rightarrow> bool" where
  "closed t \<equiv> FV t={}"

abbreviation halts :: "lterm \<Rightarrow> bool" where
  "halts t \<equiv> (\<exists>t'. star eval1_L t t' \<and> (\<forall>t1. \<not> eval1_L t' t1))"

lemma value_characterisation:
  "\<emptyset> \<turnstile> t |:| T \<Longrightarrow> \<forall>t1. \<not> eval1_L t t1 \<Longrightarrow> is_value_L t"
proof (induction "\<emptyset>::ltype list" t T rule:"has_type_L.induct")
  case (has_type_LApp t1 T1 T2 t2)
    have "\<exists>t. eval1_L (LApp t1 t2) t"
      proof (cases "\<exists>t1'. eval1_L t1 t1'")
        case (True)
          thus ?thesis
            by (auto intro: eval1_LApp1)
      next
        case (False)
          thus ?thesis
            using has_type_LApp(2-4)
                  canonical_forms(2)[OF _ has_type_LApp(1)]
            by (cases "\<exists>t2'. eval1_L t2 t2'", auto intro: eval1_L.intros)
      qed
    with has_type_LApp(5) show ?case by blast
qed (auto intro: "is_value_L.intros")

lemma gr_Suc_conv: "Suc x \<le> n \<longleftrightarrow> (\<exists>m. n = Suc m \<and> x \<le> m)"
  by (cases n) auto

lemma FV_shift:
  "FV (shift_L (int d) c t) = image (\<lambda>x. if x \<ge> c then x + d else x) (FV t)"
proof (induction t arbitrary: c rule: lterm.induct)
  case (LAbs T t)
  thus ?case  by (auto simp: gr_Suc_conv image_iff) force+
qed auto

lemmas int_1 = of_nat_1[where 'a=int]

lemma FV_subst:
  "FV (subst_L n t u) = (if n \<in> FV u then (FV u - {n}) \<union> FV t else FV u)"
proof (induction u arbitrary: n t rule: lterm.induct)
  case (LAbs T u)
  thus ?case
    by (auto simp: gr0_conv_Suc image_iff FV_shift[of 1, unfolded int_1],
        (metis DiffI One_nat_def UnCI diff_Suc_1 empty_iff imageI insert_iff nat.distinct(1))+)
qed (auto simp: gr0_conv_Suc image_iff FV_shift[of 1, unfolded int_1])

theorem eval_det:
  "eval1_L t t1 \<Longrightarrow> eval1_L t t2 \<Longrightarrow> t1=t2"
proof (induction t t1 arbitrary: t2 rule: eval1_L.induct)
  case (eval1_LApp1 t1 t1' t2)
    from eval1_LApp1.hyps eval1_LApp1.prems show ?case
      by (auto elim: eval1_L.cases is_value_L.cases intro: eval1_LApp1.IH)
next
  case (eval1_LApp2 t1 t2 t2')
    from eval1_LApp2.hyps eval1_LApp2.prems show ?case
      by (auto elim: eval1_L.cases is_value_L.cases intro: eval1_LApp2.IH)
next
  case (eval1_LApp_LAbs v2 t12)
    thus ?case by (auto elim: eval1_L.cases simp: is_value_L.simps)
qed

lemma weakening:
  "\<Gamma> \<turnstile> t |:| T \<Longrightarrow> n \<le> length \<Gamma> \<Longrightarrow> insert_nth n S \<Gamma> \<turnstile> shift_L 1 n t |:| T"
proof (induction \<Gamma> t T arbitrary: n rule: has_type_L.induct)
  case (has_type_LAbs \<Gamma> T1 t2 T2)
    from has_type_LAbs.prems has_type_LAbs.hyps
      has_type_LAbs.IH[where n="Suc n"]
    show ?case
      by (auto intro: has_type_L.intros)
qed (auto simp: nth_append min_def intro: has_type_L.intros)

lemma substitution:
  "\<Gamma> \<turnstile> t |:| T \<Longrightarrow>  \<Gamma> \<turnstile> LVar n |:| S \<Longrightarrow> \<Gamma> \<turnstile> s |:| S \<Longrightarrow> \<Gamma> \<turnstile> subst_L n s t |:| T"
proof (induction \<Gamma> t T arbitrary: s n rule: has_type_L.induct)
  case (has_type_LAbs \<Gamma> T1 t T2)
  thus ?case by (fastforce
    intro: has_type_L.intros weakening[where n=0, unfolded insert_nth_def nat.rec]
    simp: has_type_L.simps[of _ "LVar n" _, simplified])
qed (auto intro!: has_type_L.intros
          simp: has_type_L.simps[of _ "LVar _" _, simplified])

lemma shift_down:
  "insert_nth n U \<Gamma> \<turnstile> t |:| T \<Longrightarrow> n \<le> length \<Gamma> \<Longrightarrow>
   (\<And>x. x \<in> FV t \<Longrightarrow> x \<noteq> n) \<Longrightarrow> \<Gamma> \<turnstile> shift_L (- 1) n t |:| T"
proof (induction "insert_nth n U \<Gamma>" t T arbitrary: \<Gamma> n rule: has_type_L.induct)
  case (has_type_LAbs V t T)
  from this(1,3,4) show ?case
    by (fastforce intro: has_type_L.intros has_type_LAbs.hyps(2)[where n="Suc n"])+
qed (fastforce intro: has_type_L.intros simp: nth_append min_def)+

theorem preservation:
  "\<Gamma>\<turnstile> t|:| T \<Longrightarrow> eval1_L t t' \<Longrightarrow> \<Gamma> \<turnstile> t'|:| T"
proof (induction \<Gamma> t T arbitrary: t' rule: has_type_L.induct)
  case (has_type_LApp \<Gamma> t1 T11 T12 t2)
    note hyps = this and has_T_Abs= has_type_L.simps[of _ "LAbs _ _", simplified]

    have "\<And>T' t12.
        t' = shift_L (- 1) 0 (subst_L 0 (shift_L 1 0 t2) t12)
        \<Longrightarrow> t1 = LAbs T' t12 \<Longrightarrow> ?case"
      proof -
        fix T' t12
        assume t'_def:"t' = shift_L (- 1) 0 (subst_L 0 (shift_L 1 0 t2) t12)"
               and Abs_t1: "t1 = LAbs T' t12"
        have t12_type:"\<Gamma> |,| T11 \<turnstile> t12 |:| T12"
          using hyps(1)[unfolded Abs_t1 has_T_Abs, simplified]
          by blast
        have not_free0:"\<And>x. x \<in> FV (subst_L 0 (shift_L 1 0 t2) t12) \<Longrightarrow> x \<noteq> 0"
          using FV_subst[of 0 "shift_L 1 0 t2" t12]
                FV_shift[of 1 0 t2, unfolded int_1]
          by (cases "0\<in>FV t12") force+
        from t'_def show ?case
          using substitution[OF t12_type, of 0 T11 "shift_L 1 0 t2"]
            shift_down[of 0 T11 \<Gamma> _ T12, simplified, unfolded neq0_conv[symmetric]]
            weakening[OF hyps(2),of 0 T11, simplified]
            not_free0
            "has_type_L.simps"[of "\<Gamma>|,|T11" "LVar 0" T11, simplified]
          by blast
      qed
    then show ?case
      using has_type_L.intros(4)
            eval1_LAppE[OF hyps(5), of ?case] hyps(1-4)
      by blast
qed (auto elim: eval1_L.cases)

lemma halting_evalL:
  "eval1_L t t1 \<Longrightarrow> halts t \<Longrightarrow> halts t1"
proof (induction rule: eval1_L.induct)
  case (eval1_LApp1 t1 t1' t2)
    thus ?case
      using star.simps[of "eval1_L" "LApp t1 t2"]
            eval1_L.intros(1)
            eval_det
      by metis
next
  case (eval1_LApp2 v t2 t2')
    then show ?case
      using star.simps[of "eval1_L" "LApp v t2"] eval1_L.intros(2) eval_det
      by metis
next
  case (eval1_LApp_LAbs v T t)
    thus ?case
      using star.simps[of "eval1_L" "LApp (LAbs T t) v"]
            eval1_L.intros(3) eval_det
      by metis
qed

lemma shift_shift_invert: "a>0 \<Longrightarrow> shift_L (-a) b (shift_L a b t) = t"
by (induction t arbitrary: a b, auto)

lemma halting_evalR:
  "eval1_L t t1 \<Longrightarrow> halts t1 \<Longrightarrow> halts t"
by (induction rule: eval1_L.induct) (metis eval1_L.intros star_trans star_step1)+

theorem halting_eval:
  "eval1_L t t1 \<Longrightarrow> halts t = halts t1"
using halting_evalL halting_evalR by blast

lemma preservation_step:
  "star eval1_L t t' \<Longrightarrow> \<Gamma> \<turnstile> t |:| T \<Longrightarrow> \<Gamma> \<turnstile> t' |:| T"
by (induction rule: star.induct, auto intro: preservation)

lemma shift_only_FV:
  "(\<forall>x\<in>FV t. x < c) \<Longrightarrow> shift_L d c t = t"
proof (induction t arbitrary: d c)
  case (LAbs T t)
    show ?case
      using LAbs(2)[simplified]
            LAbs(1)[of "Suc c" d]
      by force
qed auto

lemma FV_ctx:
  "\<Gamma> \<turnstile> t |:| B \<Longrightarrow> FV t \<subseteq> {k. k<length \<Gamma>}"
by (induction rule: "has_type_L.induct") auto

method invert_type = (match premises in H:"\<emptyset> \<turnstile> Te |:| B" for Te::lterm and B::ltype\<Rightarrow>
                      \<open> insert has_type_L.simps[of \<emptyset> Te B, simplified]\<close>)

lemma closedness_preservation1:
  "eval1_L t t' \<Longrightarrow> \<emptyset> \<turnstile> t |:| B \<Longrightarrow> closed t = closed t'"
using FV_ctx[of \<emptyset> _ B, simplified] preservation
by blast

lemma closedness_preservation:
 "star eval1_L t t'\<Longrightarrow> \<emptyset> \<turnstile> t |:| B  \<Longrightarrow> closed t = closed t'"
proof (induction rule: star.induct)
  case (step x y z)
    show ?case
      using closedness_preservation1[OF step(1)] step(3,4)
            preservation[OF step(4,1)]
      by auto
qed auto

locale rel_reasoning =
  fixes R::"lterm \<Rightarrow> ltype \<Rightarrow> bool" ("(_)\<in>\<^sub>R(_)" [150,150] 200)
  assumes R\<^sub>A: " halts t = t \<in>\<^sub>R A" and
          R_fun: " (halts t \<and>
            (\<forall>s. s \<in>\<^sub>R T1 \<longrightarrow> (LApp t s) \<in>\<^sub>R T2)) = t \<in>\<^sub>R T1\<rightarrow>T2" and
          R_def: "t\<in>\<^sub>RT \<Longrightarrow> closed t \<and> \<emptyset> \<turnstile> t |:| T"

abbreviation C::"ltype \<Rightarrow> lterm set" where
"C T \<equiv> {t. closed t \<and> \<emptyset> \<turnstile> t |:| T}"

fun R::"lterm \<Rightarrow> ltype \<Rightarrow> bool" ("(_)\<in>\<^sub>R(_)" [150,150] 200) where
  "R t A = (t \<in> C A \<and> halts t)"|
  "R t (T1\<rightarrow>T2) = ( t \<in> C (T1\<rightarrow>T2) \<and> halts t \<and> (\<forall>s. R s T1 \<longrightarrow> R (LApp t s) T2))"

lemma R\<^sub>A: "t \<in>\<^sub>R A \<Longrightarrow> halts t " by auto

lemma R_halts:
  "t \<in>\<^sub>R T \<Longrightarrow> halts t"
by (induction T, auto)

lemma R_def: "t\<in>\<^sub>RT \<Longrightarrow> closed t \<and> \<emptyset> \<turnstile> t |:| T" by (auto elim: R.elims)

lemma halt_val:
  "t \<in>\<^sub>R T \<Longrightarrow>\<exists>v. is_value_L v \<and> star eval1_L t v"
proof -
  assume Rt: "t \<in>\<^sub>R T"

  have 1: "\<And>t'. star eval1_L t t' \<Longrightarrow> \<forall>t1. \<not> eval1_L t' t1 \<Longrightarrow> \<exists>v. is_value_L v \<and> star eval1_L t v"
    using value_characterisation[of _ T]
          preservation_step[OF _ R_def[OF Rt, THEN conjunct2]]
    by auto
  have "\<forall>t1.\<not> eval1_L t t1 \<Longrightarrow> \<exists>v. is_value_L v \<and> star eval1_L t v"
    using value_characterisation[OF R_def[OF Rt, THEN conjunct2]]
          star.refl[of "eval1_L"]
    by auto

  with 1 show "\<exists>v. is_value_L v \<and> star eval1_L t v" using R_halts[OF Rt] by auto
qed

lemma eval_preserves_R:
  "\<emptyset> \<turnstile> t|:|T \<Longrightarrow> eval1_L t t' \<Longrightarrow> t \<in>\<^sub>R T = t'\<in>\<^sub>R T"
proof (induction T arbitrary: t t')
  case (A)
    then show ?case
      using halting_eval[OF A(2)]
            preservation[OF A]
            closedness_preservation[OF star_step1[of "eval1_L",OF A(2)]]
      by auto
next
  case (Fun T1 T2)
    note hyps=this
    have "\<forall>s. s\<in>\<^sub>RT1 \<longrightarrow> ( LApp t' s\<in>\<^sub>RT2 = LApp t s\<in>\<^sub>RT2)"
      proof (rule, rule)
        fix s
        assume Rs: "s\<in>\<^sub>RT1"
        have "LApp t' s\<in>\<^sub>RT2 \<Longrightarrow> LApp t s\<in>\<^sub>RT2"
          using hyps(2)[OF _ eval1_LApp1[OF hyps(4)],of s]
                has_type_L.simps[of \<emptyset> "LApp t s"] hyps(3) R_def[OF Rs]
          by auto
        then show "LApp t' s\<in>\<^sub>RT2 = LApp t s\<in>\<^sub>RT2"
          using hyps(2)[OF _ eval1_LApp1[OF hyps(4)],of s]
                R_def[of "LApp t s" T2]
          by fast
      qed
    then show ?case
      using halting_eval[OF hyps(4)]
            preservation[OF hyps(3,4)]
            hyps(3)
            closedness_preservation1[OF hyps(4)]
      by auto
qed

lemma star_eval_preserves_R:
  "star eval1_L t t' \<Longrightarrow> \<emptyset> \<turnstile> t|:|T \<Longrightarrow> t \<in>\<^sub>R T = t'\<in>\<^sub>R T"
proof (induction rule: star.induct)
  case (step x y z)
    show ?case
      using eval_preserves_R[OF step(4,1)]
            step(3) preservation[OF step(4,1)]
      by auto
qed auto

fun subst_all :: "nat \<Rightarrow> lterm list \<Rightarrow> lterm \<Rightarrow> lterm" where
  "subst_all n V ValA = ValA" |
  "subst_all n V (LApp s t) = LApp (subst_all n V s) (subst_all n V t)"|
  "subst_all n V (LAbs T t) = LAbs T (subst_all (Suc n) (map (shift_L 1 0) V) t)"|
  "subst_all n V (LVar k) = (if (k\<ge>n \<and> (k-n)<length V) then (V!(k-n)) else LVar k)"

lemma subst_all_empty[simp]:
  "subst_all n [] t = t"
by (induction t arbitrary: n, auto)

lemma subst_free_var_only: "x\<notin>FV t \<Longrightarrow> subst_L x t1 t = t"
by (induction t arbitrary:t1 x, force+)

lemma subst_comp_subst_all:
  "subst_L n v (subst_all (Suc n) (map (shift_L ((int n) + 1) 0) V) t) = subst_all n (v#map (shift_L ((int n) + 1) 0) V) t"
proof (induction t arbitrary: n v)
  case (LVar k)
    have H:"\<And>s. n \<notin> FV (shift_L ((int n) + 1) 0 s)"
      proof (rule)
        fix s

        assume H:"n \<in> FV (shift_L ((int n) + 1) 0 s)"
        have H1:"1+int n = int n +1" by auto

        show "False"
          using FV_shift[of "n+1" 0 s, simplified]
                image_iff[of n "\<lambda>x. Suc (x + n)" "FV s"]
                H[unfolded H1[symmetric]]
          by force
      qed

    from LVar show ?case
      using subst_free_var_only[OF H]
      by auto
next
  case (LAbs T t)
    have H:"\<And>k. shift_L 1 k \<circ> shift_L (int n + 1) k= shift_L (int (Suc n) + 1) k"
      proof
        fix k s
        show "(shift_L 1 k \<circ> shift_L (int n + 1) k) s= shift_L (int (Suc n) + 1) k s"
          by (induction s arbitrary:k, auto)
      qed
    then show ?case using LAbs[of "Suc n"] by simp
qed auto

lemma weakening_closed:
  "\<emptyset> \<turnstile> t |:| T \<Longrightarrow> \<Gamma> \<turnstile> t |:| T"
proof (induction \<Gamma>)
  case (Cons B \<Gamma>')
    thus ?case
      using weakening[of \<Gamma>' t T 0 B]
            shift_only_FV[of t 0 1]
            FV_ctx[of \<emptyset> t T, simplified]
      by force
qed auto

lemma substitution_all:
  "\<Gamma> \<turnstile> t |:| T \<Longrightarrow> k+length V = length \<Gamma> \<Longrightarrow> (\<And>i. i<length V \<Longrightarrow> \<emptyset> \<turnstile> (V!i) |:| (\<Gamma>!(i+k))) \<Longrightarrow>
    (take k \<Gamma> @ drop (k + length V) \<Gamma>) \<turnstile> subst_all k V t |:| T"
proof (induction \<Gamma> t T arbitrary: k V rule: has_type_L.induct)
  case (has_type_LAbs \<Gamma> T1 t T2)
    note H=this
    have "\<And>i. i < length V \<Longrightarrow>
           \<emptyset>  \<turnstile> shift_L 1 0 (V ! i) |:| (\<Gamma> ! (i + k))"
      proof -
        fix i
        assume inf_len: "i < length V"
        show "\<emptyset>  \<turnstile> shift_L 1 0 (V ! i) |:| (\<Gamma> ! (i + k))"
          using  H(4)[OF inf_len]
                 FV_ctx[of \<emptyset> "V!i"] shift_only_FV[of "V!i" 0 1]
          by force
      qed
    then show ?case
      using H(2)[of "Suc k" "map (shift_L 1 0) V", simplified] H(3)
      by (auto intro:"has_type_L.has_type_LAbs")
next
  case (has_type_LVar k1 A \<Gamma>)
    note H=this
    show ?case
      using H(1,2)
            H(3)[of "k1-k"]
            weakening_closed[of "V!(k1-k)" A]
      by (auto intro: has_type_L.has_type_LVar less_diff_conv2)

qed (auto intro!: has_type_L.intros simp: has_type_L.simps[of _ "LVar _" _, simplified])

lemma  subst_R:
  "\<Gamma> \<turnstile> t |:| T \<Longrightarrow> length V = length \<Gamma> \<Longrightarrow> (\<And>i. i<length V \<Longrightarrow>is_value_L (V!i) \<and> (V!i) \<in>\<^sub>R (\<Gamma>!i)) \<Longrightarrow>
    subst_all 0 V t \<in>\<^sub>R T"
proof (induction arbitrary: V rule:has_type_L.induct)
  case (has_type_LVar x T \<Gamma>)
    have "V\<noteq>\<emptyset> \<Longrightarrow> \<exists>v V'. V= v#V'"
      by (meson list.exhaust)
    with has_type_LVar show ?case
      by(cases "V=\<emptyset>", auto)
next
  case (has_type_LApp \<Gamma> t1 T1 T2 t2)
    note hyps=this
    show ?case
      using hyps(3)[OF hyps(5,6), simplified,
                    THEN conjunct2]
            hyps(4)[OF hyps(5,6),simplified]
      by auto
next
  case (has_type_LAbs \<Gamma> T1 t T2)
    note hyps=this
    have B:"\<emptyset> |,| T1 \<turnstile> subst_all (Suc 0) (map (shift_L 1 0) V) t |:| T2"
      using substitution_all[OF hyps(1),of "Suc 0" "map (shift_L 1 0) V",
            simplified] FV_ctx[of \<emptyset>, simplified] shift_only_FV[of "V!_" 0 1]
            R_def[OF hyps(4)[THEN conjunct2], THEN conjunct2]
            hyps(3)
      by force
    have "\<And>s. s\<in>\<^sub>RT1 \<Longrightarrow> LApp (LAbs T1 (subst_all (Suc 0) (map (shift_L 1 0) V) t)) s\<in>\<^sub>RT2"
      proof -
        fix s
        assume Rs: "s \<in>\<^sub>R T1"
        obtain v where v_prop:"is_value_L v" "star eval1_L s v"
          using halt_val[OF Rs]
          by auto
        from this(2) have Rv:"v \<in>\<^sub>R T1"
          using Rs
          proof (induction rule:star.induct)
            case (step x y z)
              thus ?case using eval_preserves_R R_def
                by force
          qed force

        have R_sub:"subst_all 0 (v # V) t\<in>\<^sub>RT2"
          using v_prop(1) Rv hyps(4)[unfolded hyps(3)]
                hyps(2)[of "v#V", simplified, OF hyps(3)]
                less_Suc_eq_0_disj nth_Cons_0 nth_Cons_Suc
          by force

        have V_no_shift: "map (shift_L 1 0) V = V"
          using shift_only_FV[of _ 0 1, simplified]
                R_def[OF hyps(4)[THEN conjunct2], THEN conjunct1]
          by (simp add: nth_equalityI)
        have ev1:"star eval1_L (LApp (LAbs T1 (subst_all (Suc 0) (map (shift_L 1 0) V) t)) v)
                             (subst_all 0 (v # V) t)"
          using eval1_LApp_LAbs[OF v_prop(1),of T1 "subst_all (Suc 0) (map (shift_L 1 0) V) t", unfolded
                subst_comp_subst_all[of 0 "shift_L 1 0 v" V t, simplified]]
                shift_only_FV[of "subst_all 0 (v # V) t" 0 "-1",
                               simplified]
                R_def[OF R_sub, THEN conjunct1]
                shift_only_FV[of _ 0 1, simplified, OF R_def[OF Rv, THEN conjunct1]]
                V_no_shift
          by simp

        have ev0:"star eval1_L (LApp (LAbs T1 (subst_all (Suc 0) (map (shift_L 1 0) V) t)) s)
                (LApp (LAbs T1 (subst_all (Suc 0) (map (shift_L 1 0) V) t)) v)"
          using v_prop(2,1)
          proof (induction rule: star.induct)
            case (step x y z)
              show ?case
                using star.intros(2)[OF _ step(3)[OF step(4)]]
                      "is_value_L.intros"(2) eval1_LApp2[OF _ step(1)]
                by blast
          qed auto
        with ev1 have eval:"star eval1_L (LApp (LAbs T1 (subst_all (Suc 0) (map (shift_L 1 0) V) t)) s)
                            (subst_all 0 (v # V) t)"
          using star_trans[of "eval1_L"]
          by meson
        have type: "\<emptyset> \<turnstile> LApp (LAbs T1 (subst_all (Suc 0) (map (shift_L 1 0) V) t)) s |:| T2"
          using B R_def[OF Rs, simplified]
          by (auto intro: "has_type_L.intros")

        show "LApp (LAbs T1 (subst_all (Suc 0) (map (shift_L 1 0) V) t)) s\<in>\<^sub>RT2"
          using star_eval_preserves_R[OF star_trans[OF ev0 ev1] type] R_sub
          by metis
      qed

    then show ?case
      using eval1_L.simps[of "LAbs T1 _", simplified]
            has_type_L.intros(3)[OF B]
            FV_ctx[of \<emptyset> "LAbs T1 (subst_all (Suc 0) (map (shift_L 1 0) V) t)"]
      by auto
qed (insert R\<^sub>A, auto intro!: has_type_L.intros eval1_L.simps[of ValA, simplified])

theorem Normalization:
  "\<emptyset>\<turnstile> t |:| T \<Longrightarrow> halts t"
using subst_R[of \<emptyset> t T \<emptyset>] R_halts[of t T]
by auto

end


section \<open> Iverson Bracket \<close>

theory utp_iverson_bracket
  imports "UTP2.utp"
          "infsum_laws"
begin

unbundle UTP_Syntax
print_bundles

(* Switch off lattice syntax from UTP *)
bundle no_UTP_lattice_syntax
begin

no_notation
  bot ("\<top>") and
  top ("\<bottom>") and
  inf  (infixl "\<squnion>" 70) and
  sup  (infixl "\<sqinter>" 65) and
  Inf  ("\<Squnion> _" [900] 900) and
  Sup  ("\<Sqinter> _" [900] 900)

no_syntax
  "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Squnion>_./ _)" [0, 10] 10)
  "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Squnion>_\<in>_./ _)" [0, 0, 10] 10)
  "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Sqinter>_./ _)" [0, 10] 10)
  "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sqinter>_\<in>_./ _)" [0, 0, 10] 10)
end
unbundle no_UTP_lattice_syntax
(* unbundle no_lattice_syntax *)
print_bundles

(* This wouldn't be parsed correctly
term "\<bottom>"
*)

(* Switch on lattice syntax from HOL *)
unbundle lattice_syntax
term "\<bottom>"

declare [[show_types]]

subsection \<open> Iverson Bracket \<close>

definition iverson_bracket :: "'s pred \<Rightarrow> ('s \<Rightarrow> \<real>)"  where
[expr_defs]: "iverson_bracket P = (if P then 1 else 0)\<^sub>e"

syntax
  "_e_iverson_bracket" :: "logic \<Rightarrow> logic" ("\<lbrakk>_\<rbrakk>\<^sub>\<I>\<^sub>e" 150)
  "_iverson_bracket" :: "logic \<Rightarrow> logic" ("\<lbrakk>_\<rbrakk>\<^sub>\<I>" 150)

translations
  "_e_iverson_bracket P" == "CONST iverson_bracket (P)\<^sub>e"
  "_iverson_bracket P" == "CONST iverson_bracket P"

(* Declare your Iverson brackets operator as an expression constructor, to stop it being lifted *)
expr_constructor iverson_bracket

lemma iverson_bracket_true: "\<lbrakk>true\<rbrakk>\<^sub>\<I> = (1)\<^sub>e"
  apply (simp add: iverson_bracket_def)
  by (simp add: true_pred_def)

lemma iverson_bracket_false: "\<lbrakk>false\<rbrakk>\<^sub>\<I> = (0)\<^sub>e"
  apply (simp add: iverson_bracket_def)
  by (simp add: false_pred_def)

lemma iverson_bracket_mono: "\<lbrakk> (P) \<sqsupseteq> (Q) \<rbrakk> \<Longrightarrow> \<lbrakk>P\<rbrakk>\<^sub>\<I> \<le> \<lbrakk>Q\<rbrakk>\<^sub>\<I>"
  apply (simp add: ref_by_pred_is_leq)
  apply (simp add: iverson_bracket_def)
  apply (intro le_funI)
  by auto

lemma iverson_bracket_conj: "\<lbrakk>P \<and> Q\<rbrakk>\<^sub>\<I>\<^sub>e = (\<lbrakk>P\<rbrakk>\<^sub>\<I>\<^sub>e * \<lbrakk>Q\<rbrakk>\<^sub>\<I>\<^sub>e)\<^sub>e"
  by (expr_auto)

lemma iverson_bracket_conj1 : "\<lbrakk>\<lambda>s. (a \<le> s \<and> s \<le> b)\<rbrakk>\<^sub>\<I> = (\<lbrakk>\<lambda>s. a \<le> s\<rbrakk>\<^sub>\<I> * \<lbrakk>\<lambda>s. s \<le> b\<rbrakk>\<^sub>\<I>)\<^sub>e"
  by (expr_auto)

lemma iverson_bracket_disj: "\<lbrakk>P \<or> Q\<rbrakk>\<^sub>\<I>\<^sub>e = (\<lbrakk>P\<rbrakk>\<^sub>\<I>\<^sub>e + \<lbrakk>Q\<rbrakk>\<^sub>\<I>\<^sub>e - (\<lbrakk>P\<rbrakk>\<^sub>\<I>\<^sub>e * \<lbrakk>Q\<rbrakk>\<^sub>\<I>\<^sub>e))\<^sub>e"
  by (expr_auto)

lemma iverson_bracket_not: "\<lbrakk>\<not>P\<rbrakk>\<^sub>\<I>\<^sub>e = (1 - \<lbrakk>P\<rbrakk>\<^sub>\<I>\<^sub>e)\<^sub>e"
  by (expr_auto)

lemma iverson_bracket_plus: "(\<lbrakk>\<lambda>s. s \<in> A\<rbrakk>\<^sub>\<I> + \<lbrakk>\<lambda>s. s \<in> B\<rbrakk>\<^sub>\<I>)\<^sub>e = (\<lbrakk>\<lambda>s. s \<in> A \<inter> B\<rbrakk>\<^sub>\<I> + \<lbrakk>\<lambda>s. s \<in> A \<union> B\<rbrakk>\<^sub>\<I>)\<^sub>e"
  by (expr_auto)

lemma iverson_bracket_inter : "\<lbrakk>\<lambda>s. s \<in> A \<inter> B\<rbrakk>\<^sub>\<I> = (\<lbrakk>\<lambda>s. s \<in> A\<rbrakk>\<^sub>\<I> * \<lbrakk>\<lambda>s. s \<in> B\<rbrakk>\<^sub>\<I>)\<^sub>e"
  by (expr_auto)

(* Infinite products give 1 (instead of 0), no matter how P is defined. *)
lemma infinite_prod_is_1:
  fixes P::"'b \<Rightarrow> \<real>"
  assumes "\<not> finite (UNIV::'b set)"
  shows "(\<Prod> m|True. (P m)) = (1::\<real>)"
  using assms by force

(* Infinite sums give 0, no matter how P is defined. *)
lemma infinite_sum_is_0:
  fixes P::"'b \<Rightarrow> \<real>"
  assumes "\<not> finite (UNIV::'b set)"
  shows "(\<Sum> m|True. (P m)) = (0::\<real>)"
  using assms by auto

(* TODO: is this theorem only valid for finite (type of m)? *)
lemma iverson_bracket_forall_prod:
  fixes P::"'a \<Rightarrow> 'b \<Rightarrow> bool"
  assumes "finite (UNIV::'b set)"
  shows "\<lbrakk>(\<forall>m. P m)\<rbrakk>\<^sub>\<I>\<^sub>e = (\<Prod> m|True. (\<lbrakk>(P \<guillemotleft>m\<guillemotright>)\<rbrakk>\<^sub>\<I>\<^sub>e))\<^sub>e"
  apply (expr_auto)
proof -
  fix x::"'a" and xa::"'b"
  assume a1: "\<not> P x xa"
  show "(\<Prod>m::'b\<in>UNIV. if P x m then 1::\<real> else (0::\<real>)) = (0::\<real>)"
    apply (rule prod_zero)
    apply (simp add: assms)
    using a1 by auto
qed

text \<open> We use @{text "\<Sum>\<^sub>\<infinity>"} (@{term "infsum"}) to take into account infinite sets that satisfy @{text "P"}.
For this case, the summation is just equal to 0. Then this lemma is not true, and so we have added
a finite assumption.
\<close>
lemma iverson_bracket_exist_sum:
  fixes P::"'a \<Rightarrow> 'b \<Rightarrow> bool"
  assumes "`finite {m. P m}`"
  shows "\<lbrakk>(\<exists>m. P m)\<rbrakk>\<^sub>\<I>\<^sub>e = (\<lambda>s. (min (1::\<real>) ((\<Sum>\<^sub>\<infinity> m. (\<lbrakk>(P \<guillemotleft>m\<guillemotright>)\<rbrakk>\<^sub>\<I>\<^sub>e))\<^sub>e s)))"
  apply (expr_auto)
  apply (subst infsum_constant_finite_states)
  using assms apply (simp add: taut_def)
  by (smt (verit, del_insts) assms SEXP_def taut_def mem_Collect_eq real_of_card sum_nonneg_leq_bound)

lemma iverson_bracket_exist_sum_1:
  fixes P::"'a \<Rightarrow> 'b \<Rightarrow> bool"
  assumes "finite (UNIV::'b set)"
  shows "\<lbrakk>(\<exists>m. P m)\<rbrakk>\<^sub>\<I>\<^sub>e = (1 - (\<Prod> m|True. (\<lbrakk>(\<not>P \<guillemotleft>m\<guillemotright>)\<rbrakk>\<^sub>\<I>\<^sub>e)))\<^sub>e"
  apply (expr_auto)
  using assms by auto

(* The use of @{term card} implies finite *)
lemma iverson_bracket_card:
  fixes P::"'a \<Rightarrow> 'b \<Rightarrow> bool"
  assumes "`finite ({m::'b. P m})`"
  shows "(card {m. P m})\<^sub>e = (\<Sum>\<^sub>\<infinity> m. (\<lbrakk>(P \<guillemotleft>m\<guillemotright>)\<rbrakk>\<^sub>\<I>\<^sub>e))\<^sub>e"
  apply (expr_auto)
  apply (subst infsum_constant_finite_states)
  using assms apply (simp add: taut_def)
  by force

text \<open> With the Iverson bracket, summation with index (LHS) can be defined without its index (RHS).
As Donald E. Knuth mentioned in ``Two Notes on Notation'', the summation without indices (or limits)
is better (not easily make a mistake when dealing with its index). \<close>
lemma iverson_bracket_summation:
  fixes P::"'s \<Rightarrow> bool" and f :: "'s \<Rightarrow> \<real>"
  shows "(\<Sum>\<^sub>\<infinity> k|P k. (f)\<^sub>e k) = (\<Sum>\<^sub>\<infinity> k. (f * \<lbrakk>P\<rbrakk>\<^sub>\<I>)\<^sub>e k)"
  by (simp add: infsum_mult_subset_right iverson_bracket_def)

definition nat_of_real_1 :: "\<real> \<Rightarrow> nat" where
"nat_of_real_1 r = (if r = (1::\<real>) then (1) else 0)"

lemma iverson_bracket_product:
  fixes P::"'s \<Rightarrow> bool"
  assumes "finite (UNIV::'s set)"
  shows "(\<Prod> m|P m. f m) = (\<Prod> m|True. (f ^ (\<guillemotleft>nat_of_real_1\<guillemotright> (\<lbrakk>P\<rbrakk>\<^sub>\<I>\<^sub>e)))\<^sub>e m)"
proof -
  let ?P = "\<lambda>m. (if P m then 1::\<real> else (0::\<real>))"
  let ?Q = "\<lambda>r. (if r = (1::\<real>) then 1::\<nat> else (0::\<nat>))"
  have f1: "(\<Prod>m::'s\<in>UNIV. f m ^ (?Q (?P m))) = (\<Prod>m::'s\<in>{m. \<not> P m} \<union> {m. P m}. f m ^ (?Q (?P m)))"
    by (simp add: Un_def)
  have f2: "... = (\<Prod>m::'s\<in>{m. \<not> P m}. f m ^ (?Q (?P m))) * (\<Prod>m::'s\<in>{m. P m}. f m ^ (?Q (?P m)))"
    apply (subst prod.union_inter_neutral)
    apply (meson assms rev_finite_subset subset_UNIV)
    apply (meson assms rev_finite_subset subset_UNIV)
    apply force
    by auto
  show ?thesis
    apply (simp add: expr_defs)
    apply (simp add: nat_of_real_1_def)
    using f1 f2 by auto
qed

lemma max_iverson_bracket:
  "(max x y)\<^sub>e = (x * (\<lbrakk>x > y\<rbrakk>\<^sub>\<I>\<^sub>e) + y * (\<lbrakk>x \<le> y\<rbrakk>\<^sub>\<I>\<^sub>e))\<^sub>e"
  by (expr_auto)

lemma min_iverson_bracket:
  "(min x y)\<^sub>e = (x * (\<lbrakk>x \<le> y\<rbrakk>\<^sub>\<I>\<^sub>e) + y * (\<lbrakk>x > y\<rbrakk>\<^sub>\<I>\<^sub>e))\<^sub>e"
  by (expr_auto)

lemma floor_iverson_bracket:
  "(real_of_int \<lfloor>x\<rfloor>)\<^sub>e = (\<Sum>\<^sub>\<infinity> n. n * \<lbrakk>((real_of_int) \<guillemotleft>n\<guillemotright> \<le> x \<and> x < (real_of_int) (\<guillemotleft>n\<guillemotright> + 1))\<rbrakk>\<^sub>\<I>\<^sub>e)\<^sub>e"
  apply (expr_auto)
  apply (subst infsum_mult_subset_right)
proof -
  fix xa
  have "{v\<^sub>0::\<int>. real_of_int v\<^sub>0 \<le> x xa \<and> x xa < real_of_int v\<^sub>0 + (1::\<real>)} = {\<lfloor>x xa\<rfloor>}"
    by (smt (verit) Collect_cong floor_split singleton_conv)
  then show "real_of_int \<lfloor>x xa\<rfloor> =
       infsum real_of_int {v\<^sub>0::\<int>. real_of_int v\<^sub>0 \<le> x xa \<and> x xa < real_of_int v\<^sub>0 + (1::\<real>)}"
    by simp
qed

lemma ceiling_iverson_bracket:
  "(real_of_int \<lceil>x\<rceil>)\<^sub>e = (\<Sum>\<^sub>\<infinity> n. n * \<lbrakk>((real_of_int) \<guillemotleft>n - 1\<guillemotright> < x \<and> x \<le> (real_of_int) (\<guillemotleft>n\<guillemotright>))\<rbrakk>\<^sub>\<I>\<^sub>e)\<^sub>e"
  apply (expr_auto)
  apply (subst infsum_mult_subset_right)
proof -
  fix xa
  have "{v\<^sub>0::\<int>. real_of_int v\<^sub>0 - (1::\<real>) < x xa \<and> x xa \<le> real_of_int v\<^sub>0} = {\<lceil>x xa\<rceil>}"
    by (smt (verit) Collect_cong ceiling_split singleton_conv)
  then show "real_of_int \<lceil>x xa\<rceil> =
       infsum real_of_int {v\<^sub>0::\<int>. real_of_int v\<^sub>0 - (1::\<real>) < x xa \<and> x xa \<le> real_of_int v\<^sub>0}"
    by simp
qed

subsection \<open> Inverse Iverson Bracket \<close>
(* Simon: maybe we need to find out a definition for inverse bracket using THE etc.
TODO: leave this mechanisation as is now.
*)
axiomatization iverson_bracket_inv :: "('s \<Rightarrow> \<real>) \<Rightarrow> 's pred" ("\<^bold>\<langle>_\<^bold>\<rangle>\<^sub>\<I>") where
iverson_bracket_inv_def: "(\<^bold>\<langle>N\<^bold>\<rangle>\<^sub>\<I> \<sqsupseteq> (P)) = `(N \<le> \<lbrakk>P\<rbrakk>\<^sub>\<I>\<^sub>e)`"

expr_constructor iverson_bracket_inv

lemma false_0: "\<lbrakk>false\<rbrakk>\<^sub>\<I> = (0)\<^sub>e"
  by (pred_simp)

lemma iverson_bracket_inv_1: "\<^bold>\<langle>(1)\<^sub>e\<^bold>\<rangle>\<^sub>\<I> = true"
  by (smt (verit, best) SEXP_def false_pred_def iverson_bracket_def iverson_bracket_inv_def le_funI
      le_fun_def order_antisym_conv pred_ba.order_eq_iff pred_ba.order_refl ref_by_fun_def
      ref_lattice.bot_least ref_lattice.top_greatest ref_preorder.order_refl taut_True taut_def true_pred_def zero_neq_one)

lemma iverson_bracket_inv_0: "\<^bold>\<langle>(0)\<^sub>e\<^bold>\<rangle>\<^sub>\<I> = false"
  by (smt (verit, ccfv_SIG) SEXP_def false_0 iverson_bracket_inv_def pred_ba.bot.extremum
      pred_ba.order_eq_iff taut_def)

lemma iverson_bracket_approximate_inverse: "`N \<le> \<lbrakk>\<^bold>\<langle>N\<^bold>\<rangle>\<^sub>\<I>\<rbrakk>\<^sub>\<I>\<^sub>e`"
  by (metis SEXP_def iverson_bracket_inv_def pred_ba.order_refl)

lemma iverson_bracket_inv_approximate_inverse: "\<^bold>\<langle>\<lbrakk>P\<rbrakk>\<^sub>\<I>\<^bold>\<rangle>\<^sub>\<I> \<sqsupseteq> P"
  using iverson_bracket_inv_def by (smt (verit, ccfv_SIG) SEXP_def taut_def)

lemma iverson_bracket_inv_N_0:
  assumes "`N \<ge> 0`"
  shows "`\<not>(\<^bold>\<langle>N\<^bold>\<rangle>\<^sub>\<I>)` = `N = 0`"
  by (smt (verit, best) SEXP_def assms false_pred_def iverson_bracket_approximate_inverse
      iverson_bracket_def iverson_bracket_inv_def order_antisym_conv pred_ba.bot.extremum_unique taut_def)

lemma iverson_bracket_inv_mono: "\<lbrakk> `(M \<le> N)` \<rbrakk> \<Longrightarrow> \<^bold>\<langle>M\<^bold>\<rangle>\<^sub>\<I> \<sqsupseteq> \<^bold>\<langle>N\<^bold>\<rangle>\<^sub>\<I>"
  by (smt (verit) SEXP_def dual_order.trans iverson_bracket_approximate_inverse iverson_bracket_inv_def taut_def)

end