(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_NStoogeSortSorts
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

(*fun did not finish the proof*)
function third :: "int => int" where
  "third y =
   (if (y = 2) then 0 else
      (if (y = 1) then 0 else
         (if (y = 0) then 0 else 1 + (third (y - 3)))))"
  by pat_completeness auto

fun take :: "int => 'a list => 'a list" where
  "take y z =
   (if y <= 0 then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => cons2 z2 (take (y - 1) xs)))"

fun sort2 :: "int => int => int list" where
  "sort2 y z =
   (if y <= z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun reverse :: "'a list => 'a list" where
  "reverse (nil2) = nil2"
| "reverse (cons2 z xs) = x (reverse xs) (cons2 z (nil2))"

fun ordered :: "int list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 z (nil2)) = True"
| "ordered (cons2 z (cons2 y2 xs)) =
     ((z <= y2) & (ordered (cons2 y2 xs)))"

fun length :: "'a list => int" where
  "length (nil2) = 0"
| "length (cons2 z l) = 1 + (length l)"

fun drop :: "int => 'a list => 'a list" where
  "drop y z =
   (if y <= 0 then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => drop (y - 1) xs1))"

fun splitAt :: "int => 'a list =>
                (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function nstooge1sort2 :: "int list => int list"
  and nstoogesort :: "int list => int list"
  and nstooge1sort1 :: "int list => int list" where
  "nstooge1sort2 y =
   (case splitAt (third (length y)) (reverse y) of
      pair2 ys2 zs2 => x (nstoogesort zs2) (reverse ys2))"
| "nstoogesort (nil2) = nil2"
| "nstoogesort (cons2 z (nil2)) = cons2 z (nil2)"
| "nstoogesort (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "nstoogesort (cons2 z (cons2 y2 (cons2 x3 x4))) =
     nstooge1sort2
       (nstooge1sort1 (nstooge1sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "nstooge1sort1 y =
     (case splitAt (third (length y)) y of
        pair2 ys2 zs1 => x ys2 (nstoogesort zs1))"
  by pat_completeness auto

theorem property0 :
  "ordered (nstoogesort xs)"
  oops

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_list_nat_elem_map
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun map :: "('a => 'b) => 'a list => 'b list" where
"map f (nil2) = nil2"
| "map f (cons2 y xs) = cons2 (f y) (map f xs)"

fun elem :: "'a => 'a list => bool" where
"elem x (nil2) = False"
| "elem x (cons2 z xs) = ((z = x) | (elem x xs))"

theorem property0 :
  "((elem y (map f xs)) ==>
      (? (x :: 'a) . (((f x) = y) & (elem y xs))))"
  oops

end


(*  Title:       Mathematical Preliminaries
    Author:      Jonathan Julián Huerta y Munive, 2020
    Maintainer:  Jonathan Julián Huerta y Munive <jonjulian23@gmail.com>
*)

section \<open> Mathematical Preliminaries \<close>

text \<open>This section adds useful syntax, abbreviations and theorems to the Isabelle distribution. \<close>

theory MTX_Preliminaries
  imports "../HS_Preliminaries"

begin

subsection \<open> Syntax \<close>

abbreviation "\<e> k \<equiv> axis k 1"

syntax
  "_ivl_integral" :: "real \<Rightarrow> real \<Rightarrow> 'a \<Rightarrow> pttrn \<Rightarrow> bool" ("(3\<integral>\<^sub>_\<^sup>_ (_)\<partial>/_)" [0, 0, 10] 10)

translations
  "\<integral>\<^sub>a\<^sup>b f \<partial>x" \<rightleftharpoons> "CONST ivl_integral a b (\<lambda>x. f)"

notation matrix_inv ("_\<^sup>-\<^sup>1" [90])

abbreviation "entries (A::'a^'n^'m) \<equiv> {A $ i $ j | i j. i \<in> UNIV \<and> j \<in> UNIV}"

subsection \<open> Topology and sets \<close>

lemmas compact_imp_bdd_above = compact_imp_bounded[THEN bounded_imp_bdd_above]

lemma comp_cont_image_spec: "continuous_on T f \<Longrightarrow> compact T \<Longrightarrow> compact {f t |t. t \<in> T}"
  using compact_continuous_image by (simp add: Setcompr_eq_image)

lemmas bdd_above_cont_comp_spec = compact_imp_bdd_above[OF comp_cont_image_spec]

lemmas bdd_above_norm_cont_comp = continuous_on_norm[THEN bdd_above_cont_comp_spec]

lemma open_cballE: "t\<^sub>0 \<in> T \<Longrightarrow> open T \<Longrightarrow> \<exists>e>0. cball t\<^sub>0 e \<subseteq> T"
  using open_contains_cball by blast

lemma open_ballE: "t\<^sub>0 \<in> T \<Longrightarrow> open T \<Longrightarrow> \<exists>e>0. ball t\<^sub>0 e \<subseteq> T"
  using open_contains_ball by blast

lemma funcset_UNIV: "f \<in> A \<rightarrow> UNIV"
  by auto

lemma finite_image_of_finite[simp]:
  fixes f::"'a::finite \<Rightarrow> 'b"
  shows "finite {x. \<exists>i. x = f i}"
  using finite_Atleast_Atmost_nat by force

lemma finite_image_of_finite2:
  fixes f :: "'a::finite \<Rightarrow> 'b::finite \<Rightarrow> 'c"
  shows "finite {f x y |x y. P x y}"
proof-
  have "finite (\<Union>x. {f x y|y. P x y})"
    by simp
  moreover have "{f x y|x y. P x y} = (\<Union>x. {f x y|y. P x y})"
    by auto
  ultimately show ?thesis
    by simp
qed

subsection \<open> Functions \<close>

lemma finite_sum_univ_singleton: "(sum g UNIV) = sum g {i::'a::finite} + sum g (UNIV - {i})"
  by (metis add.commute finite_class.finite_UNIV sum.subset_diff top_greatest)

lemma suminfI:
  fixes f :: "nat \<Rightarrow> 'a::{t2_space,comm_monoid_add}"
  shows "f sums k \<Longrightarrow> suminf f = k"
  unfolding sums_iff by simp

lemma suminf_eq_sum:
  fixes f :: "nat \<Rightarrow> ('a::real_normed_vector)"
  assumes "\<And>n. n > m \<Longrightarrow> f n = 0"
  shows "(\<Sum>n. f n) = (\<Sum>n \<le> m. f n)"
  using assms by (meson atMost_iff finite_atMost not_le suminf_finite)

lemma suminf_multr: "summable f \<Longrightarrow> (\<Sum>n. f n * c) = (\<Sum>n. f n) * c" for c::"'a::real_normed_algebra"
  by (rule bounded_linear.suminf [OF bounded_linear_mult_left, symmetric])

lemma sum_if_then_else_simps[simp]:
  fixes q :: "('a::semiring_0)" and i :: "'n::finite"
  shows "(\<Sum>j\<in>UNIV. f j * (if j = i then q else 0)) = f i * q"
    and "(\<Sum>j\<in>UNIV. f j * (if i = j then q else 0)) = f i * q"
    and "(\<Sum>j\<in>UNIV. (if i = j then q else 0) * f j) = q * f i"
    and "(\<Sum>j\<in>UNIV. (if j = i then q else 0) * f j) = q * f i"
  by (auto simp: finite_sum_univ_singleton[of _ i])

subsection \<open> Suprema \<close>

lemma le_max_image_of_finite[simp]:
  fixes f::"'a::finite \<Rightarrow> 'b::linorder"
  shows "(f i) \<le> Max {x. \<exists>i. x = f i}"
  by (rule Max.coboundedI, simp_all) (rule_tac x=i in exI, simp)

lemma cSup_eq:
  fixes c::"'a::conditionally_complete_lattice"
  assumes "\<forall>x \<in> X. x \<le> c" and "\<exists>x \<in> X. c \<le> x"
  shows "Sup X = c"
  by (metis assms cSup_eq_maximum order_class.order.antisym)

lemma cSup_mem_eq:
  "c \<in> X \<Longrightarrow> \<forall>x \<in> X. x \<le> c \<Longrightarrow> Sup X = c" for c::"'a::conditionally_complete_lattice"
  by (rule cSup_eq, auto)

lemma cSup_finite_ex:
  "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> \<exists>x\<in>X. Sup X = x" for X::"'a::conditionally_complete_linorder set"
  by (metis (full_types) bdd_finite(1) cSup_upper finite_Sup_less_iff order_less_le)

lemma cMax_finite_ex:
  "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> \<exists>x\<in>X. Max X = x" for X::"'a::conditionally_complete_linorder set"
  apply(subst cSup_eq_Max[symmetric])
  using cSup_finite_ex by auto

lemma finite_nat_minimal_witness:
  fixes P :: "('a::finite) \<Rightarrow> nat \<Rightarrow> bool"
  assumes "\<forall>i. \<exists>N::nat. \<forall>n \<ge> N. P i n"
  shows "\<exists>N. \<forall>i. \<forall>n \<ge> N. P i n"
proof-
  let "?bound i" = "(LEAST N. \<forall>n \<ge> N. P i n)"
  let ?N = "Max {?bound i |i. i \<in> UNIV}"
  {fix n::nat and i::'a
    assume "n \<ge> ?N"
    obtain M where "\<forall>n \<ge> M. P i n"
      using assms by blast
    hence obs: "\<forall> m \<ge> ?bound i. P i m"
      using LeastI[of "\<lambda>N. \<forall>n \<ge> N. P i n"] by blast
    have "finite {?bound i |i. i \<in> UNIV}"
      by simp
    hence "?N \<ge> ?bound i"
      using Max_ge by blast
    hence "n \<ge> ?bound i"
      using \<open>n \<ge> ?N\<close> by linarith
    hence "P i n"
      using obs by blast}
  thus "\<exists>N. \<forall>i n. N \<le> n \<longrightarrow> P i n"
    by blast
qed

subsection \<open> Real numbers \<close>

named_theorems field_power_simps "simplification rules for powers to the nth"

declare semiring_normalization_rules(18) [field_power_simps]
    and semiring_normalization_rules(26) [field_power_simps]
    and semiring_normalization_rules(27) [field_power_simps]
    and semiring_normalization_rules(28) [field_power_simps]
    and semiring_normalization_rules(29) [field_power_simps]

text \<open>WARNING: Adding @{thm semiring_normalization_rules(27)} to our tactic makes
its combination with simp to loop infinitely in some proofs.\<close>

lemma sq_le_cancel:
  shows "(a::real) \<ge> 0 \<Longrightarrow> b \<ge> 0 \<Longrightarrow> a^2 \<le> b * a \<Longrightarrow> a \<le> b"
  and "(a::real) \<ge> 0 \<Longrightarrow> b \<ge> 0 \<Longrightarrow> a^2 \<le> a * b \<Longrightarrow> a \<le> b"
   apply (metis less_eq_real_def mult.commute mult_le_cancel_left semiring_normalization_rules(29))
  by (metis less_eq_real_def mult_le_cancel_left semiring_normalization_rules(29))

lemma frac_diff_eq1: "a \<noteq> b \<Longrightarrow> a / (a - b) - b / (a - b) = 1" for a::real
  by (metis (no_types, hide_lams) ab_left_minus add.commute add_left_cancel
      diff_divide_distrib diff_minus_eq_add div_self)

lemma exp_add: "x * y - y * x = 0 \<Longrightarrow> exp (x + y) = exp x * exp y"
  by (rule exp_add_commuting) (simp add: ac_simps)

lemmas mult_exp_exp = exp_add[symmetric]

subsection \<open> Vectors and matrices \<close>

lemma sum_axis[simp]:
  fixes q :: "('a::semiring_0)"
  shows "(\<Sum>j\<in>UNIV. f j * axis i q $ j) = f i * q"
    and "(\<Sum>j\<in>UNIV. axis i q $ j * f j) = q * f i"
  unfolding axis_def by(auto simp: vec_eq_iff)

lemma sum_scalar_nth_axis: "sum (\<lambda>i. (x $ i) *s \<e> i) UNIV = x" for x :: "('a::semiring_1)^'n"
  unfolding vec_eq_iff axis_def by simp

lemma scalar_eq_scaleR[simp]: "c *s x = c *\<^sub>R x"
  unfolding vec_eq_iff by simp

lemma matrix_add_rdistrib: "((B + C) ** A) = (B ** A) + (C ** A)"
  by (vector matrix_matrix_mult_def sum.distrib[symmetric] field_simps)

lemma vec_mult_inner: "(A *v v) \<bullet> w = v \<bullet> (transpose A *v w)" for A :: "real ^'n^'n"
  unfolding matrix_vector_mult_def transpose_def inner_vec_def
  apply(simp add: sum_distrib_right sum_distrib_left)
  apply(subst sum.swap)
  apply(subgoal_tac "\<forall>i j. A $ i $ j * v $ j * w $ i = v $ j * (A $ i $ j * w $ i)")
  by presburger simp

lemma uminus_axis_eq[simp]: "- axis i k = axis i (-k)" for k :: "'a::ring"
  unfolding axis_def by(simp add: vec_eq_iff)

lemma norm_axis_eq[simp]: "\<parallel>axis i k\<parallel> = \<parallel>k\<parallel>"
proof(simp add: axis_def norm_vec_def L2_set_def)
  let "?\<delta>\<^sub>K" = "\<lambda>i j k. if i = j then k else 0"
  have "(\<Sum>j\<in>UNIV. (\<parallel>(?\<delta>\<^sub>K j i k)\<parallel>)\<^sup>2) = (\<Sum>j\<in>{i}. (\<parallel>(?\<delta>\<^sub>K j i k)\<parallel>)\<^sup>2) + (\<Sum>j\<in>(UNIV-{i}). (\<parallel>(?\<delta>\<^sub>K j i k)\<parallel>)\<^sup>2)"
    using finite_sum_univ_singleton by blast
  also have "... = (\<parallel>k\<parallel>)\<^sup>2"
    by simp
  finally show "sqrt (\<Sum>j\<in>UNIV. (norm (if j = i then k else 0))\<^sup>2) = norm k"
    by simp
qed

lemma matrix_axis_0:
  fixes A :: "('a::idom)^'n^'m"
  assumes "k \<noteq> 0 " and h:"\<forall>i. (A *v (axis i k)) = 0"
  shows "A = 0"
proof-
  {fix i::'n
    have "0 = (\<Sum>j\<in>UNIV. (axis i k) $ j *s column j A)"
      using h matrix_mult_sum[of A "axis i k"] by simp
    also have "... = k *s column i A"
      by (simp add: axis_def vector_scalar_mult_def column_def vec_eq_iff mult.commute)
    finally have "k *s column i A = 0"
      unfolding axis_def by simp
    hence "column i A = 0"
      using vector_mul_eq_0 \<open>k \<noteq> 0\<close> by blast}
  thus "A = 0"
    unfolding column_def vec_eq_iff by simp
qed

lemma scaleR_norm_sgn_eq: "(\<parallel>x\<parallel>) *\<^sub>R sgn x = x"
  by (metis divideR_right norm_eq_zero scale_eq_0_iff sgn_div_norm)

lemma vector_scaleR_commute: "A *v c *\<^sub>R x = c *\<^sub>R (A *v x)" for x :: "('a::real_normed_algebra_1)^'n"
  unfolding scaleR_vec_def matrix_vector_mult_def by(auto simp: vec_eq_iff scaleR_right.sum)

lemma scaleR_vector_assoc: "c *\<^sub>R (A *v x) = (c *\<^sub>R A) *v x" for x :: "('a::real_normed_algebra_1)^'n"
  unfolding matrix_vector_mult_def by(auto simp: vec_eq_iff scaleR_right.sum)

lemma mult_norm_matrix_sgn_eq:
  fixes x :: "('a::real_normed_algebra_1)^'n"
  shows "(\<parallel>A *v sgn x\<parallel>) * (\<parallel>x\<parallel>) = \<parallel>A *v x\<parallel>"
proof-
  have "\<parallel>A *v x\<parallel> = \<parallel>A *v ((\<parallel>x\<parallel>) *\<^sub>R sgn x)\<parallel>"
    by(simp add: scaleR_norm_sgn_eq)
  also have "... = (\<parallel>A *v sgn x\<parallel>) * (\<parallel>x\<parallel>)"
    by(simp add: vector_scaleR_commute)
  finally show ?thesis ..
qed

subsection\<open> Diagonalization \<close>

lemma invertibleI: "A ** B = mat 1 \<Longrightarrow> B ** A = mat 1 \<Longrightarrow> invertible A"
  unfolding invertible_def by auto

lemma invertibleD[simp]:
  assumes "invertible A"
  shows "A\<^sup>-\<^sup>1 ** A = mat 1" and "A ** A\<^sup>-\<^sup>1 = mat 1"
  using assms unfolding matrix_inv_def invertible_def
  by (simp_all add: verit_sko_ex')

lemma matrix_inv_unique:
  assumes "A ** B = mat 1" and "B ** A = mat 1"
  shows "A\<^sup>-\<^sup>1 = B"
  by (metis assms invertibleD(2) invertibleI matrix_mul_assoc matrix_mul_lid)

lemma invertible_matrix_inv: "invertible A \<Longrightarrow> invertible (A\<^sup>-\<^sup>1)"
  using invertibleD invertibleI by blast

lemma matrix_inv_idempotent[simp]: "invertible A \<Longrightarrow> A\<^sup>-\<^sup>1\<^sup>-\<^sup>1 = A"
  using invertibleD matrix_inv_unique by blast

lemma matrix_inv_matrix_mul:
  assumes "invertible A" and "invertible B"
  shows "(A ** B)\<^sup>-\<^sup>1 = B\<^sup>-\<^sup>1 ** A\<^sup>-\<^sup>1"
proof(rule matrix_inv_unique)
  have "A ** B ** (B\<^sup>-\<^sup>1 ** A\<^sup>-\<^sup>1) = A ** (B ** B\<^sup>-\<^sup>1) ** A\<^sup>-\<^sup>1"
    by (simp add: matrix_mul_assoc)
  also have "... = mat 1"
    using assms by simp
  finally show "A ** B ** (B\<^sup>-\<^sup>1 ** A\<^sup>-\<^sup>1) = mat 1" .
next
  have "B\<^sup>-\<^sup>1 ** A\<^sup>-\<^sup>1 ** (A ** B) = B\<^sup>-\<^sup>1 ** (A\<^sup>-\<^sup>1 ** A) ** B"
    by (simp add: matrix_mul_assoc)
  also have "... = mat 1"
    using assms by simp
  finally show "B\<^sup>-\<^sup>1 ** A\<^sup>-\<^sup>1 ** (A ** B) = mat 1" .
qed

lemma mat_inverse_simps[simp]:
  fixes c :: "'a::division_ring"
  assumes "c \<noteq> 0"
  shows "mat (inverse c) ** mat c = mat 1"
    and "mat c ** mat (inverse c) = mat 1"
  unfolding matrix_matrix_mult_def mat_def by (auto simp: vec_eq_iff assms)

lemma matrix_inv_mat[simp]: "c \<noteq> 0 \<Longrightarrow> (mat c)\<^sup>-\<^sup>1 = mat (inverse c)" for c :: "'a::division_ring"
  by (simp add: matrix_inv_unique)

lemma invertible_mat[simp]: "c \<noteq> 0 \<Longrightarrow> invertible (mat c)" for c :: "'a::division_ring"
  using invertibleI mat_inverse_simps(1) mat_inverse_simps(2) by blast

lemma matrix_inv_mat_1: "(mat (1::'a::division_ring))\<^sup>-\<^sup>1 = mat 1"
  by simp

lemma invertible_mat_1: "invertible (mat (1::'a::division_ring))"
  by simp

definition similar_matrix :: "('a::semiring_1)^'m^'m \<Rightarrow> ('a::semiring_1)^'n^'n \<Rightarrow> bool" (infixr "\<sim>" 25)
  where "similar_matrix A B \<longleftrightarrow> (\<exists> P. invertible P \<and> A = P\<^sup>-\<^sup>1 ** B ** P)"

lemma similar_matrix_refl[simp]: "A \<sim> A" for A :: "'a::division_ring^'n^'n"
  by (unfold similar_matrix_def, rule_tac x="mat 1" in exI, simp)

lemma similar_matrix_simm: "A \<sim> B \<Longrightarrow> B \<sim> A" for A B :: "('a::semiring_1)^'n^'n"
  apply(unfold similar_matrix_def, clarsimp)
  apply(rule_tac x="P\<^sup>-\<^sup>1" in exI, simp add: invertible_matrix_inv)
  by (metis invertible_def matrix_inv_unique matrix_mul_assoc matrix_mul_lid matrix_mul_rid)

lemma similar_matrix_trans: "A \<sim> B \<Longrightarrow> B \<sim> C \<Longrightarrow> A \<sim> C" for A B C :: "('a::semiring_1)^'n^'n"
proof(unfold similar_matrix_def, clarsimp)
  fix P Q
  assume "A = P\<^sup>-\<^sup>1 ** (Q\<^sup>-\<^sup>1 ** C ** Q) ** P" and "B = Q\<^sup>-\<^sup>1 ** C ** Q"
  let ?R = "Q ** P"
  assume inverts: "invertible Q" "invertible P"
  hence "?R\<^sup>-\<^sup>1 = P\<^sup>-\<^sup>1 ** Q\<^sup>-\<^sup>1"
    by (rule matrix_inv_matrix_mul)
  also have "invertible ?R"
    using inverts invertible_mult by blast
  ultimately show "\<exists>R. invertible R \<and> P\<^sup>-\<^sup>1 ** (Q\<^sup>-\<^sup>1 ** C ** Q) ** P = R\<^sup>-\<^sup>1 ** C ** R"
    by (metis matrix_mul_assoc)
qed

lemma mat_vec_nth_simps[simp]:
  "i = j \<Longrightarrow> mat c $ i $ j = c"
  "i \<noteq> j \<Longrightarrow> mat c $ i $ j = 0"
  by (simp_all add: mat_def)

definition "diag_mat f = (\<chi> i j. if i = j then f i else 0)"

lemma diag_mat_vec_nth_simps[simp]:
  "i = j \<Longrightarrow> diag_mat f $ i $ j = f i"
  "i \<noteq> j \<Longrightarrow> diag_mat f $ i $ j = 0"
  unfolding diag_mat_def by simp_all

lemma diag_mat_const_eq[simp]: "diag_mat (\<lambda>i. c) = mat c"
  unfolding mat_def diag_mat_def by simp

lemma matrix_vector_mul_diag_mat: "diag_mat f *v s = (\<chi> i. f i * s$i)"
  unfolding diag_mat_def matrix_vector_mult_def by simp

lemma matrix_vector_mul_diag_axis[simp]: "diag_mat f *v (axis i k) = axis i (f i * k)"
  by (simp add: matrix_vector_mul_diag_mat axis_def fun_eq_iff)

lemma matrix_mul_diag_matl: "diag_mat f ** A = (\<chi> i j. f i * A$i$j)"
  unfolding diag_mat_def matrix_matrix_mult_def by simp

lemma matrix_matrix_mul_diag_matr: "A ** diag_mat f = (\<chi> i j. A$i$j * f j)"
  unfolding diag_mat_def matrix_matrix_mult_def apply(clarsimp simp: fun_eq_iff)
  subgoal for i j
    by (auto simp: finite_sum_univ_singleton[of _ j])
  done

lemma matrix_mul_diag_diag: "diag_mat f ** diag_mat g = diag_mat (\<lambda>i. f i * g i)"
  unfolding diag_mat_def matrix_matrix_mult_def vec_eq_iff by simp

lemma compow_matrix_mul_diag_mat_eq: "((**) (diag_mat f) ^^ n) (mat 1) = diag_mat (\<lambda>i. f i^n)"
  apply(induct n, simp_all add: matrix_mul_diag_matl)
  by (auto simp: vec_eq_iff diag_mat_def)

lemma compow_similar_diag_mat_eq:
  assumes "invertible P"
      and "A = P\<^sup>-\<^sup>1 ** (diag_mat f) ** P"
    shows "((**) A ^^ n) (mat 1) = P\<^sup>-\<^sup>1 ** (diag_mat (\<lambda>i. f i^n)) ** P"
proof(induct n, simp_all add: assms)
  fix n::nat
  have "P\<^sup>-\<^sup>1 ** diag_mat f ** P ** (P\<^sup>-\<^sup>1 ** diag_mat (\<lambda>i. f i ^ n) ** P) =
  P\<^sup>-\<^sup>1 ** diag_mat f ** diag_mat (\<lambda>i. f i ^ n) ** P" (is "?lhs = _")
    by (metis (no_types, lifting) assms(1) invertibleD(2) matrix_mul_rid matrix_mul_assoc)
  also have "... = P\<^sup>-\<^sup>1 ** diag_mat (\<lambda>i. f i * f i ^ n) ** P" (is "_ = ?rhs")
    by (metis (full_types) matrix_mul_assoc matrix_mul_diag_diag)
  finally show "?lhs = ?rhs" .
qed

lemma compow_similar_diag_mat:
  assumes "A \<sim> (diag_mat f)"
  shows "((**) A ^^ n) (mat 1) \<sim> diag_mat (\<lambda>i. f i^n)"
proof(unfold similar_matrix_def)
  obtain P where "invertible P" and "A = P\<^sup>-\<^sup>1 ** (diag_mat f) ** P"
    using assms unfolding similar_matrix_def by blast
  thus "\<exists>P. invertible P \<and> ((**) A ^^ n) (mat 1) = P\<^sup>-\<^sup>1 ** diag_mat (\<lambda>i. f i ^ n) ** P"
    using compow_similar_diag_mat_eq by blast
qed

no_notation matrix_inv ("_\<^sup>-\<^sup>1" [90])
        and similar_matrix (infixr "\<sim>" 25)

end


theory Expression
imports Type "../Utilities/Index"
begin

datatype expr =
  Var nat
| Abs type expr
| App expr expr
| Let expr expr
| Rec "nat list"
| Proj expr nat
| Inj nat "type list" nat
| Case expr type "expr list"
| Fold type nat
| Unfold type expr
| TyAbs kind expr
| TyApp expr type
| TyLet type expr

primrec incr\<^sub>t\<^sub>e :: "nat \<Rightarrow> expr \<Rightarrow> expr" where
  "incr\<^sub>t\<^sub>e x (Var y) = Var y"
| "incr\<^sub>t\<^sub>e x (Abs t e) = Abs (incr\<^sub>t\<^sub>t x t) (incr\<^sub>t\<^sub>e x e)"
| "incr\<^sub>t\<^sub>e x (App e\<^sub>1 e\<^sub>2) = App (incr\<^sub>t\<^sub>e x e\<^sub>1) (incr\<^sub>t\<^sub>e x e\<^sub>2)"
| "incr\<^sub>t\<^sub>e x (Let e\<^sub>1 e\<^sub>2) = Let (incr\<^sub>t\<^sub>e x e\<^sub>1) (incr\<^sub>t\<^sub>e x e\<^sub>2)"
| "incr\<^sub>t\<^sub>e x (Rec xs) = Rec xs"
| "incr\<^sub>t\<^sub>e x (Proj e l) = Proj (incr\<^sub>t\<^sub>e x e) l"
| "incr\<^sub>t\<^sub>e x (Inj l ts y) = Inj l (map (incr\<^sub>t\<^sub>t x) ts) y"
| "incr\<^sub>t\<^sub>e x (Case e t cs) = Case (incr\<^sub>t\<^sub>e x e) (incr\<^sub>t\<^sub>t x t) (map (incr\<^sub>t\<^sub>e x) cs)"
| "incr\<^sub>t\<^sub>e x (Fold t y) = Fold (incr\<^sub>t\<^sub>t (Suc x) t) y"
| "incr\<^sub>t\<^sub>e x (Unfold t e) = Unfold (incr\<^sub>t\<^sub>t (Suc x) t) (incr\<^sub>t\<^sub>e x e)"
| "incr\<^sub>t\<^sub>e x (TyAbs k e) = TyAbs k (incr\<^sub>t\<^sub>e (Suc x) e)"
| "incr\<^sub>t\<^sub>e x (TyApp e t) = TyApp (incr\<^sub>t\<^sub>e x e) (incr\<^sub>t\<^sub>t x t)"
| "incr\<^sub>t\<^sub>e x (TyLet t e) = TyLet (incr\<^sub>t\<^sub>t x t) (incr\<^sub>t\<^sub>e (Suc x) e)"

primrec subst\<^sub>t\<^sub>e :: "nat \<Rightarrow> type \<Rightarrow> expr \<Rightarrow> expr" where
  "subst\<^sub>t\<^sub>e x t' (Var y) = Var y"
| "subst\<^sub>t\<^sub>e x t' (Abs t e) = Abs (subst\<^sub>t\<^sub>t x t' t) (subst\<^sub>t\<^sub>e x t' e)"
| "subst\<^sub>t\<^sub>e x t' (App e\<^sub>1 e\<^sub>2) = App (subst\<^sub>t\<^sub>e x t' e\<^sub>1) (subst\<^sub>t\<^sub>e x t' e\<^sub>2)"
| "subst\<^sub>t\<^sub>e x t' (Let e\<^sub>1 e\<^sub>2) = Let (subst\<^sub>t\<^sub>e x t' e\<^sub>1) (subst\<^sub>t\<^sub>e x t' e\<^sub>2)"
| "subst\<^sub>t\<^sub>e x t' (Rec xs) = Rec xs"
| "subst\<^sub>t\<^sub>e x t' (Proj e l) = Proj (subst\<^sub>t\<^sub>e x t' e) l"
| "subst\<^sub>t\<^sub>e x t' (Inj l ts y) = Inj l (map (subst\<^sub>t\<^sub>t x t') ts) y"
| "subst\<^sub>t\<^sub>e x t' (Case e t cs) = Case (subst\<^sub>t\<^sub>e x t' e) (subst\<^sub>t\<^sub>t x t' t) (map (subst\<^sub>t\<^sub>e x t') cs)"
| "subst\<^sub>t\<^sub>e x t' (Fold t y) = Fold (subst\<^sub>t\<^sub>t (Suc x) (incr\<^sub>t\<^sub>t 0 t') t) y"
| "subst\<^sub>t\<^sub>e x t' (Unfold t e) = Unfold (subst\<^sub>t\<^sub>t (Suc x) (incr\<^sub>t\<^sub>t 0 t') t) (subst\<^sub>t\<^sub>e x t' e)"
| "subst\<^sub>t\<^sub>e x t' (TyAbs k e) = TyAbs k (subst\<^sub>t\<^sub>e (Suc x) (incr\<^sub>t\<^sub>t 0 t') e)"
| "subst\<^sub>t\<^sub>e x t' (TyApp e t) = TyApp (subst\<^sub>t\<^sub>e x t' e) (subst\<^sub>t\<^sub>t x t' t)"
| "subst\<^sub>t\<^sub>e x t' (TyLet t e) = TyLet (subst\<^sub>t\<^sub>t x t' t) (subst\<^sub>t\<^sub>e (Suc x) (incr\<^sub>t\<^sub>t 0 t') e)"

primrec subst\<^sub>x\<^sub>e :: "nat \<Rightarrow> nat \<Rightarrow> expr \<Rightarrow> expr" where
  "subst\<^sub>x\<^sub>e x x' (Var y) = Var (if x = y then x' else decr x y)"
| "subst\<^sub>x\<^sub>e x x' (Abs t e) = Abs t (subst\<^sub>x\<^sub>e (Suc x) (Suc x') e)"
| "subst\<^sub>x\<^sub>e x x' (App e\<^sub>1 e\<^sub>2) = App (subst\<^sub>x\<^sub>e x x' e\<^sub>1) (subst\<^sub>x\<^sub>e x x' e\<^sub>2)"
| "subst\<^sub>x\<^sub>e x x' (Let e\<^sub>1 e\<^sub>2) = Let (subst\<^sub>x\<^sub>e x x' e\<^sub>1) (subst\<^sub>x\<^sub>e (Suc x) (Suc x') e\<^sub>2)"
| "subst\<^sub>x\<^sub>e x x' (Rec ys) = Rec (map (\<lambda>y. if x = y then x' else decr x y) ys)"
| "subst\<^sub>x\<^sub>e x x' (Proj e l) = Proj (subst\<^sub>x\<^sub>e x x' e) l"
| "subst\<^sub>x\<^sub>e x x' (Inj l ts y) = Inj l ts (if x = y then x' else decr x y)"
| "subst\<^sub>x\<^sub>e x x' (Case e t cs) = Case (subst\<^sub>x\<^sub>e x x' e) t (map (subst\<^sub>x\<^sub>e (Suc x) (Suc x')) cs)"
| "subst\<^sub>x\<^sub>e x x' (Fold t y) = Fold t (if x = y then x' else decr x y)"
| "subst\<^sub>x\<^sub>e x x' (Unfold t e) = Unfold t (subst\<^sub>x\<^sub>e x x' e)"
| "subst\<^sub>x\<^sub>e x x' (TyAbs k e) = TyAbs k (subst\<^sub>x\<^sub>e x x' e)"
| "subst\<^sub>x\<^sub>e x x' (TyApp e t) = TyApp (subst\<^sub>x\<^sub>e x x' e) t"
| "subst\<^sub>x\<^sub>e x x' (TyLet t e) = TyLet t (subst\<^sub>x\<^sub>e x x' e)"

primrec incr\<^sub>e\<^sub>e :: "nat \<Rightarrow> expr \<Rightarrow> expr" where
  "incr\<^sub>e\<^sub>e x (Var y) = Var (incr x y)"
| "incr\<^sub>e\<^sub>e x (Abs t e) = Abs t (incr\<^sub>e\<^sub>e (Suc x) e)"
| "incr\<^sub>e\<^sub>e x (App e\<^sub>1 e\<^sub>2) = App (incr\<^sub>e\<^sub>e x e\<^sub>1) (incr\<^sub>e\<^sub>e x e\<^sub>2)"
| "incr\<^sub>e\<^sub>e x (Let e\<^sub>1 e\<^sub>2) = Let (incr\<^sub>e\<^sub>e x e\<^sub>1) (incr\<^sub>e\<^sub>e (Suc x) e\<^sub>2)"
| "incr\<^sub>e\<^sub>e x (Rec ys) = Rec (map (incr x) ys)"
| "incr\<^sub>e\<^sub>e x (Proj e l) = Proj (incr\<^sub>e\<^sub>e x e) l"
| "incr\<^sub>e\<^sub>e x (Inj l ts y) = Inj l ts (incr x y)"
| "incr\<^sub>e\<^sub>e x (Case e t cs) = Case (incr\<^sub>e\<^sub>e x e) t (map (incr\<^sub>e\<^sub>e (Suc x)) cs)"
| "incr\<^sub>e\<^sub>e x (Fold t y) = Fold t (incr x y)"
| "incr\<^sub>e\<^sub>e x (Unfold t e) = Unfold t (incr\<^sub>e\<^sub>e x e)"
| "incr\<^sub>e\<^sub>e x (TyAbs k e) = TyAbs k (incr\<^sub>e\<^sub>e x e)"
| "incr\<^sub>e\<^sub>e x (TyApp e t) = TyApp (incr\<^sub>e\<^sub>e x e) t"
| "incr\<^sub>e\<^sub>e x (TyLet t e) = TyLet t (incr\<^sub>e\<^sub>e x e)"

primrec subst\<^sub>e\<^sub>e :: "nat \<Rightarrow> expr \<Rightarrow> expr \<Rightarrow> expr" where
  "subst\<^sub>e\<^sub>e x e' (Var y) = (if x = y then e' else Var y)"
| "subst\<^sub>e\<^sub>e x e' (Abs t e) = Abs t (subst\<^sub>e\<^sub>e (Suc x) (incr\<^sub>e\<^sub>e 0 e') e)"
| "subst\<^sub>e\<^sub>e x e' (App e\<^sub>1 e\<^sub>2) = App (subst\<^sub>e\<^sub>e x e' e\<^sub>1) (subst\<^sub>e\<^sub>e x e' e\<^sub>2)"
| "subst\<^sub>e\<^sub>e x e' (Let e\<^sub>1 e\<^sub>2) = Let (subst\<^sub>e\<^sub>e x e' e\<^sub>1) (subst\<^sub>e\<^sub>e (Suc x) (incr\<^sub>e\<^sub>e 0 e') e\<^sub>2)"
| "subst\<^sub>e\<^sub>e x e' (Rec ys) = Rec ys"
| "subst\<^sub>e\<^sub>e x e' (Proj e l) = Proj (subst\<^sub>e\<^sub>e x e' e) l"
| "subst\<^sub>e\<^sub>e x e' (Inj l ts y) = Inj l ts y"
| "subst\<^sub>e\<^sub>e x e' (Case e t cs) = Case (subst\<^sub>e\<^sub>e x e' e) t (map (subst\<^sub>e\<^sub>e (Suc x) (incr\<^sub>e\<^sub>e 0 e')) cs)"
| "subst\<^sub>e\<^sub>e x e' (Fold t y) = Fold t y"
| "subst\<^sub>e\<^sub>e x e' (Unfold t e) = Unfold t (subst\<^sub>e\<^sub>e x e' e)"
| "subst\<^sub>e\<^sub>e x e' (TyAbs k e) = TyAbs k (subst\<^sub>e\<^sub>e x (incr\<^sub>t\<^sub>e 0 e') e)"
| "subst\<^sub>e\<^sub>e x e' (TyApp e t) = TyApp (subst\<^sub>e\<^sub>e x e' e) t"
| "subst\<^sub>e\<^sub>e x e' (TyLet t e) = TyLet t (subst\<^sub>e\<^sub>e x (incr\<^sub>t\<^sub>e 0 e') e)"

primrec is_value :: "expr \<Rightarrow> bool" where
  "is_value (Var x) = False"
| "is_value (Abs t e) = True"
| "is_value (App e\<^sub>1 e\<^sub>2) = False"
| "is_value (Let e\<^sub>1 e\<^sub>2) = is_value e\<^sub>2"
| "is_value (Rec fs) = True"
| "is_value (Proj e l) = False"
| "is_value (Inj l ts e) = True"
| "is_value (Case e t cs) = False"
| "is_value (Fold t e) = True"
| "is_value (Unfold t e) = False"
| "is_value (TyAbs k e) = True"
| "is_value (TyApp e t) = False"
| "is_value (TyLet t e) = False"

primrec head_var :: "expr \<Rightarrow> nat option" where
  "head_var (Var x) = Some x"
| "head_var (Abs t e) = None"
| "head_var (App e\<^sub>1 e\<^sub>2) = head_var e\<^sub>1"
| "head_var (Let e\<^sub>1 e\<^sub>2) = (case head_var e\<^sub>2 of
      Some (Suc n) \<Rightarrow> Some n
    | Some 0 \<Rightarrow> head_var e\<^sub>1
    | None \<Rightarrow> None)"
| "head_var (Rec fs) = None"
| "head_var (Proj e l) = head_var e"
| "head_var (Inj l ts e) = None"
| "head_var (Case e t cs) = head_var e"
| "head_var (Fold t e) = None"
| "head_var (Unfold t e) = head_var e"
| "head_var (TyAbs k e) = None"
| "head_var (TyApp e t) = head_var e"
| "head_var (TyLet t e) = None"

fun free_vars :: "expr \<Rightarrow> nat set"
and free_vars\<^sub>c :: "expr list \<Rightarrow> nat set" where
  "free_vars (Var x) = {x}"
| "free_vars (Abs t e) = var_reduce 0 (free_vars e)"
| "free_vars (App e\<^sub>1 e\<^sub>2) = free_vars e\<^sub>1 \<union> free_vars e\<^sub>2"
| "free_vars (Let e\<^sub>1 e\<^sub>2) = free_vars e\<^sub>1 \<union> var_reduce 0 (free_vars e\<^sub>2)"
| "free_vars (Rec xs) = set xs"
| "free_vars (Proj e l) = free_vars e"
| "free_vars (Inj l ts x) = {x}"
| "free_vars (Case e t cs) = free_vars e \<union> free_vars\<^sub>c cs"
| "free_vars (Fold t x) = {x}"
| "free_vars (Unfold t e) = free_vars e"
| "free_vars (TyAbs k e) = free_vars e"
| "free_vars (TyApp e t) = free_vars e"
| "free_vars (TyLet t e) = free_vars e"
| "free_vars\<^sub>c [] = {}"
| "free_vars\<^sub>c (c # cs) = var_reduce 0 (free_vars c) \<union> free_vars\<^sub>c cs"

lemma [simp]: "free_vars (subst\<^sub>t\<^sub>e x t e) = free_vars e"
  and [simp]: "free_vars\<^sub>c (map (subst\<^sub>t\<^sub>e x t) c) = free_vars\<^sub>c c"
  by (induction e and c arbitrary: x t and x t rule: free_vars_free_vars\<^sub>c.induct) simp_all

lemma [simp]: "free_vars (subst\<^sub>x\<^sub>e x y e) =
    var_reduce x (free_vars e) \<union> (if x \<in> free_vars e then {y} else {})"
  and [simp]: "free_vars\<^sub>c (map (subst\<^sub>x\<^sub>e (Suc x) (Suc y)) c) =
    var_reduce x (free_vars\<^sub>c c) \<union> (if x \<in> free_vars\<^sub>c c then {y} else {})"
  proof (induction e and c arbitrary: x y and x y rule: free_vars_free_vars\<^sub>c.induct)
  case 5
    thus ?case by (auto simp add: var_reduce_def)
  qed auto

lemma [simp]: "free_vars (incr\<^sub>e\<^sub>e x e) = incr x ` free_vars e"
  and [simp]: "free_vars\<^sub>c (map (incr\<^sub>e\<^sub>e (Suc x)) c) = incr x ` free_vars\<^sub>c c"
  by (induction e and c arbitrary: x and x rule: free_vars_free_vars\<^sub>c.induct) auto

lemma [simp]: "x \<notin> free_vars\<^sub>c cs \<Longrightarrow> c \<in> set cs \<Longrightarrow> Suc x \<notin> free_vars c"
  by (induction cs) auto

lemma [simp]: "finite (free_vars e)"
  and [simp]: "finite (free_vars\<^sub>c c)"
  by (induction e and c rule: free_vars_free_vars\<^sub>c.induct) simp_all

lemma [elim]: "head_var e = Some x \<Longrightarrow> is_value e \<Longrightarrow> False"
  by (induction e arbitrary: x) (auto split: option.splits nat.splits)

end


theory FSA_Example_1
  imports FSA_Semantics
begin

text \<open> We have names at both the meta-logic and logic level. Isabelle records don't support default
  field values, though we could add syntax to support this. \<close>

definition "S = \<lparr> State.name = STR ''S'', initial = True \<rparr>"
definition "A = \<lparr> State.name = STR ''A'', initial = False \<rparr>"
definition "B = \<lparr> State.name = STR ''B'', initial = False \<rparr>"
definition "C = \<lparr> State.name = STR ''C'', initial = False \<rparr>"

definition "t1 = \<lparr> label = STR ''a'', from = State.name S, to = State.name A \<rparr>"
definition "t2 = \<lparr> label = STR ''a'', from = State.name A, to = State.name S \<rparr>"
definition "t3 = \<lparr> label = STR ''b'', from = State.name A, to = State.name B \<rparr>"
definition "t4 = \<lparr> label = STR ''b'', from = State.name B, to = State.name A \<rparr>"
definition "t5 = \<lparr> label = STR ''a'', from = State.name C, to = State.name A \<rparr>"
definition "t6 = \<lparr> label = STR ''c'', from = State.name C, to = State.name B \<rparr>"

definition ABC :: Automaton where
"ABC = \<lparr> name = STR ''ABC''
       , states = [S, A, B, C]
       , transitions = [ t1, t2, t3, t4, t5, t6 ]
       \<rparr>"

text \<open> We can use the following line to check well-formedness, which internally uses the code
  generator for efficient execution. \<close>

value "wf_Automaton ABC"

lemma "\<not> reachable ABC STR ''C''"
  apply (rule unreachable_by_invariant[where I="{STR ''S'', STR ''A'', STR ''B''}"])
  apply (auto simp add: ABC_def fsa_init_sem_def S_def A_def B_def C_def fsa_trans_sem_def t1_def t2_def t3_def t4_def t5_def t6_def)
  done

end


chapter \<open>Time complexity\label{s:TC}\<close>

theory NP
  imports Elementary Composing Symbol_Ops
begin

text \<open>
In order to formulate the Cook-Levin theorem we need to formalize \SAT{} and
$\NP$-completeness. This chapter is devoted to the latter and hence introduces
the complexity class $\NP$ and the concept of polynomial-time many-one
reduction. Moreover, although not required for the Cook-Levin theorem, it
introduces the class $\mathcal{P}$ and contains a proof of $\mathcal{P}
\subseteq \NP$ (see Section~\ref{s:TC-subseteq}). The chapter concludes with
some easy results about $\mathcal{P}$, $\NP$ and reducibility in
Section~\ref{s:TC-more}.
\<close>

section \<open>The time complexity classes DTIME, $\mathcal{P}$, and $\NP$\label{s:TC-NP}\<close>

text \<open>
Arora and Barak~\cite[Definitions 1.12, 1.13]{ccama} define
$\mathrm{DTIME}(T(n))$ as the set of all languages that can be decided in time
$c \cdot T(n)$ for some $c > 0$ and $\mathcal{P} =
\bigcup_{c\geq1}\mathrm{DTIME}(n^c)$. However since $0^c = 0$ for $c\geq 1$,
this means that for a language $L$ to be in $\mathcal{P}$, the Turing machine
deciding $L$ must check the empty string in zero steps. For a Turing machine to
halt in zero steps, it must start in the halting state, which limits its
usefulness. Because of this technical issue we define $\mathrm{DTIME}(T(n))$ as
the set of all languages that can be decided with a running time in $O(T(n))$,
which seems a common enough alternative~\cite{lv-aikc,sipser2006,cz-dtime}.
\<close>

text \<open>
Languages are sets of strings, and deciding a language means computing its
characteristic function.
\<close>

type_synonym language = "string set"

definition characteristic :: "language \<Rightarrow> (string \<Rightarrow> string)" where
  "characteristic L \<equiv> (\<lambda>x. [x \<in> L])"

definition DTIME :: "(nat \<Rightarrow> nat) \<Rightarrow> language set" where
  "DTIME T \<equiv> {L. \<exists>k G M T'.
    turing_machine k G M \<and>
    big_oh T' T \<and>
    computes_in_time k M (characteristic L) T'}"

definition complexity_class_P :: "language set" ("\<P>") where
  "\<P> \<equiv> \<Union>c\<in>{1..}. DTIME (\<lambda>n. n ^ c)"

text \<open>
A language $L$ is in $\NP$ if there is a polynomial $p$ and a polynomial-time
Turing machine, called the \emph{verifier}, such that for all strings
$x\in\bbOI^*$,
\[
  x\in L \longleftrightarrow
    \exists u\in\bbOI^{p(|x|)}: M(\langle x, u\rangle) = \bbbI.
\]
The string $u$ does not seem to have a name in general, but in case the verifier
outputs $\bbbI$ on input $\langle x, u\rangle$ it is called a
\emph{certificate} for $x$~\cite[Definition~2.1]{ccama}.
\<close>

definition complexity_class_NP :: "language set" ("\<N>\<P>") where
  "\<N>\<P> \<equiv> {L. \<exists>k G M p T fverify.
    turing_machine k G M \<and>
    polynomial p \<and>
    big_oh_poly T \<and>
    computes_in_time k M fverify T \<and>
    (\<forall>x. x \<in> L \<longleftrightarrow> (\<exists>u. length u = p (length x) \<and> fverify \<langle>x, u\<rangle> = [\<bbbI>]))}"

text \<open>
The definition of $\NP$ is the one place where we need an actual polynomial
function, namely $p$, rather than a function that is merely bounded by a
polynomial. This raises the question as to the definition of a polynomial
function. Arora and Barak~\cite{ccama} do not seem to give a definition in the
context of $\NP$ but explicitly state that polynomial functions are mappings
$\nat \to \nat$.  Presumably they also have the form $f(n) = \sum_{i=0}^d
a_i\cdot n^i$, as polynomials do.  We have filled in the gap in this definition
in Section~\ref{s:tm-basic-bigoh} by letting the coefficients $a_i$ be natural
numbers.

Regardless of whether this is the meaning intended by Arora and Barak, the
choice is justified because with it the verifier-based definition of $\NP$ is
equivalent to the original definition via nondeterministic Turing machines
(NTMs). In the usual equivalence proof (for example, Arora and
Barak~\cite[Theorem~2.6]{ccama}) a verifier TM and an NTM are constructed.

For the one direction, if a language is decided by a polynomial-time NTM then a
verifier TM can be constructed that simulates the NTM on input $x$ by using the
bits in the string $u$ for the nondeterministic choices. The strings $u$ have
the length $p(|x|)$. So for this construction to work, there must be a polynomial
$p$ that bounds the running time of the NTM. Clearly, a polynomial function with
natural coefficients exists with that property.

For the other direction, assume a language has a verifier TM where $p$ is a
polynomial function with natural coefficients. An NTM deciding this language
receives $x$ as input, then ``guesses'' a string $u$ of length $p(|x|)$, and
then runs the verifier on the pair $\langle x, u\rangle$. For this NTM to run in
polynomial time, $p$ must be computable in time polynomial in $|x|$. We have
shown this to be the case in lemma @{thm [source] transforms_tm_polynomialI} in
Section~\ref{s:tm-arithmetic-poly}.
\<close>

text \<open>
A language $L_1$ is polynomial-time many-one reducible to a language $L_2$ if
there is a polynomial-time computable function $f_\mathit{reduce}$ such that for all
$x$, $x\in L_1$ iff.\ $f_\mathit{reduce}(x) \in L_2$.
\<close>

definition reducible (infix "\<le>\<^sub>p" 50) where
  "L\<^sub>1 \<le>\<^sub>p L\<^sub>2 \<equiv> \<exists>k G M T freduce.
    turing_machine k G M \<and>
    big_oh_poly T \<and>
    computes_in_time k M freduce T \<and>
    (\<forall>x. x \<in> L\<^sub>1 \<longleftrightarrow> freduce x \<in> L\<^sub>2)"

abbreviation NP_hard :: "language \<Rightarrow> bool" where
  "NP_hard L \<equiv> \<forall>L'\<in>\<N>\<P>. L' \<le>\<^sub>p L"

definition NP_complete :: "language \<Rightarrow> bool" where
  "NP_complete L \<equiv> L \<in> \<N>\<P> \<and> NP_hard L"

text \<open>
Requiring $c \geq 1$ in the definition of $\mathcal{P}$ is not essential:
\<close>

lemma in_P_iff: "L \<in> \<P> \<longleftrightarrow> (\<exists>c. L \<in> DTIME (\<lambda>n. n ^ c))"
proof
  assume "L \<in> \<P>"
  then show "\<exists>c. L \<in> DTIME (\<lambda>n. n ^ c)"
    unfolding complexity_class_P_def using Suc_le_eq by auto
next
  assume "\<exists>c. L \<in> DTIME (\<lambda>n. n ^ c)"
  then obtain c where "L \<in> DTIME (\<lambda>n. n ^ c)"
    by auto
  then obtain k G M T where M:
    "turing_machine k G M"
    "big_oh T (\<lambda>n. n ^ c)"
    "computes_in_time k M (characteristic L) T"
    using DTIME_def by auto
  moreover have "big_oh T (\<lambda>n. n ^ Suc c)"
  proof -
    obtain c0 n0 :: nat where c0n0: "\<forall>n>n0. T n \<le> c0 * n ^ c"
      using M(2) big_oh_def by auto
    have "\<forall>n>n0. T n \<le> c0 * n ^ Suc c"
    proof standard+
      fix n assume "n0 < n"
      then have "n ^ c \<le> n ^ Suc c"
        using pow_mono by simp
      then show "T n \<le> c0 * n ^ Suc c"
        using c0n0 by (metis \<open>n0 < n\<close> add.commute le_Suc_ex mult_le_mono2 trans_le_add2)
    qed
    then show ?thesis
      using big_oh_def by auto
  qed
  ultimately have "\<exists>c>0. L \<in> DTIME (\<lambda>n. n ^ c)"
    using DTIME_def by blast
  then show "L \<in> \<P>"
    unfolding complexity_class_P_def by auto
qed

section \<open>Restricting verifiers to one-bit output\label{s:np-alt}\<close>

text \<open>
The verifier Turing machine in the definition of $\NP$ can output any symbol
sequence. In this section we restrict it to outputting only the symbol sequence
\textbf{1} or \textbf{0}. This is equivalent to the definition because it is
easy to check if a symbol sequence differs from \textbf{1} and if so change it
to \textbf{0}, as we show below.

The advantage of this restriction is that if we can make the TM halt with the
output tape head on cell number~1, the output tape symbol read in the final step
equals the output of the TM. We will exploit this in Chapter~\ref{s:Reducing},
where we show how to reduce any language $L\in\NP$ to \SAT{}.

The next Turing machine checks if the symbol sequence on tape $j$ differs from
the one-symbol sequence \textbf{1} and if so turns it into \textbf{0}. It thus
ensures that the tape contains only one bit symbol.

\null
\<close>

definition tm_make_bit :: "tapeidx \<Rightarrow> machine" where
  "tm_make_bit j \<equiv>
    tm_cr j ;;
    IF \<lambda>rs. rs ! j = \<one> THEN
      tm_right j ;;
      IF \<lambda>rs. rs ! j = \<box> THEN
        []
      ELSE
        tm_set j [\<zero>]
      ENDIF
    ELSE
      tm_set j [\<zero>]
    ENDIF"

lemma tm_make_bit_tm:
  assumes "G \<ge> 4" and "0 < j" and "j < k"
  shows "turing_machine k G (tm_make_bit j)"
  unfolding tm_make_bit_def
  using assms tm_right_tm tm_set_tm tm_cr_tm Nil_tm turing_machine_branch_turing_machine
  by simp

locale turing_machine_make_bit =
  fixes j :: tapeidx
begin

definition "tm1 \<equiv> tm_cr j"
definition "tmT1 \<equiv> tm_right j"
definition "tmT12 \<equiv> IF \<lambda>rs. rs ! j = \<box> THEN [] ELSE tm_set j [\<zero>] ENDIF"
definition "tmT2 \<equiv> tmT1 ;; tmT12"
definition "tm12 \<equiv> IF \<lambda>rs. rs ! j = \<one> THEN tmT2 ELSE tm_set j [\<zero>] ENDIF"
definition "tm2 \<equiv> tm1 ;; tm12"

lemma tm2_eq_tm_make_bit: "tm2 \<equiv> tm_make_bit j"
  unfolding tm_make_bit_def tm2_def tm12_def tmT2_def tmT12_def tmT1_def tm1_def by simp

context
  fixes tps0 :: "tape list" and zs :: "symbol list"
  assumes jk: "j < length tps0"
    and zs: "proper_symbols zs"
  assumes tps0: "tps0 ::: j = \<lfloor>zs\<rfloor>"
begin

lemma clean: "clean_tape (tps0 ! j)"
  using zs tps0 contents_clean_tape' by simp

definition "tps1 \<equiv> tps0[j := (\<lfloor>zs\<rfloor>, 1)]"

lemma tm1 [transforms_intros]:
  assumes "ttt = tps0 :#: j + 2"
  shows "transforms tm1 tps0 ttt tps1"
  unfolding tm1_def by (tform tps: assms jk clean tps0 tps1_def)

definition "tpsT1 \<equiv> tps0[j := (\<lfloor>zs\<rfloor>, 2)]"

lemma tmT1 [transforms_intros]:
  assumes "ttt = 1"
  shows "transforms tmT1 tps1 ttt tpsT1"
  unfolding tmT1_def
proof (tform tps: assms tps1_def jk)
  show "tpsT1 = tps1[j := tps1 ! j |+| 1] "
    using tps1_def tpsT1_def jk
    by (metis Suc_1 fst_conv list_update_overwrite nth_list_update_eq plus_1_eq_Suc snd_conv)
qed

definition "tpsT2 \<equiv> tps0
  [j := if length zs \<le> 1 then (\<lfloor>zs\<rfloor>, 2) else (\<lfloor>[\<zero>]\<rfloor>, 1)]"

lemma tmT12 [transforms_intros]:
  assumes "ttt = 14 + 2 * length zs"
  shows "transforms tmT12 tpsT1 ttt tpsT2"
  unfolding tmT12_def
proof (tform tps: assms tpsT1_def tps0 jk zs)
  show "8 + tpsT1 :#: j + 2 * length zs + Suc (2 * length [\<zero>]) + 1 \<le> ttt"
    using tpsT1_def jk assms by simp
  have "read tpsT1 ! j = \<lfloor>zs\<rfloor> 2"
    using tpsT1_def jk tapes_at_read' by (metis fst_conv length_list_update nth_list_update_eq snd_conv)
  moreover have "\<lfloor>zs\<rfloor> 2 = \<box> \<longleftrightarrow> length zs \<le> 1"
    using zs contents_def
    by (metis Suc_1 diff_Suc_1 less_imp_le_nat linorder_le_less_linear not_less_eq_eq zero_neq_numeral)
  ultimately have "read tpsT1 ! j = \<box> \<longleftrightarrow> length zs \<le> 1"
    by simp
  then show
      "read tpsT1 ! j \<noteq> \<box> \<Longrightarrow> tpsT2 = tpsT1[j := (\<lfloor>[\<zero>]\<rfloor>, 1)]"
      "read tpsT1 ! j = \<box> \<Longrightarrow> tpsT2 = tpsT1"
    using tpsT1_def tpsT2_def jk by simp_all
qed

lemma tmT2 [transforms_intros]:
  assumes "ttt = 15 + 2 * length zs"
  shows "transforms tmT2 tps1 ttt tpsT2"
  unfolding tmT2_def by (tform time: assms)

definition "tps2 \<equiv> tps0
  [j := if zs = [\<one>] then (\<lfloor>zs\<rfloor>, 2) else (\<lfloor>[\<zero>]\<rfloor>, 1)]"

lemma tm12 [transforms_intros]:
  assumes "ttt = 17 + 2 * length zs"
  shows "transforms tm12 tps1 ttt tps2"
  unfolding tm12_def
proof (tform tps: assms tps0 jk zs tps1_def)
  have "read tps1 ! j = \<lfloor>zs\<rfloor> 1"
    using tps1_def jk tapes_at_read' by (metis fst_conv length_list_update nth_list_update_eq snd_conv)
  then have *: "read tps1 ! j = \<one> \<longleftrightarrow> \<lfloor>zs\<rfloor> 1 = \<one>"
    by simp
  show "read tps1 ! j \<noteq> \<one> \<Longrightarrow> tps2 = tps1[j := (\<lfloor>[\<zero>]\<rfloor>, 1)]"
    using * tps2_def tps1_def by auto
  show "tps2 = tpsT2" if "read tps1 ! j = \<one>"
  proof (cases "zs = [\<one>]")
    case True
    then show ?thesis
      using * tps2_def tpsT2_def by simp
  next
    case False
    then have "\<lfloor>zs\<rfloor> 1 = \<one>"
      using * that by simp
    then have "length zs > 1"
      using False contents_def contents_outofbounds
      by (metis One_nat_def Suc_length_conv diff_Suc_1 length_0_conv linorder_neqE_nat nth_Cons_0 zero_neq_numeral)
    then show ?thesis
      using * tps2_def tpsT2_def by auto
  qed
  show "8 + tps1 :#: j + 2 * length zs + Suc (2 * length [\<zero>]) + 1 \<le> ttt"
    using tps1_def jk assms by simp
qed

lemma tm2:
  assumes "ttt = 19 + 2 * length zs + tps0 :#: j"
  shows "transforms tm2 tps0 ttt tps2"
  unfolding tm2_def by (tform tps: assms tps0 jk zs tps1_def)

end

end  (* locale *)

lemma transforms_tm_make_bitI [transforms_intros]:
  fixes j :: tapeidx
  fixes tps tps' :: "tape list" and zs :: "symbol list" and ttt :: nat
  assumes "j < length tps" and "proper_symbols zs"
  assumes "tps ::: j = \<lfloor>zs\<rfloor>"
  assumes "ttt = 19 + 2 * length zs + tps :#: j"
  assumes "tps' = tps
    [j := if zs = [\<one>] then (\<lfloor>zs\<rfloor>, 2) else (\<lfloor>[\<zero>]\<rfloor>, 1)]"
  shows "transforms (tm_make_bit j) tps ttt tps'"
proof -
  interpret loc: turing_machine_make_bit j .
  show ?thesis
    using assms loc.tps2_def loc.tm2 loc.tm2_eq_tm_make_bit by simp
qed

lemma output_length_le_time:
  assumes "turing_machine k G M"
    and "tps ::: 1 = \<lfloor>zs\<rfloor>"
    and "proper_symbols zs"
    and "transforms M (snd (start_config k xs)) t tps"
  shows "length zs \<le> t"
proof -
  have 1: "execute M (start_config k xs) t = (length M, tps)"
    using assms transforms_def transits_def
    by (metis (no_types, lifting) execute_after_halting_ge fst_conv start_config_def sndI)
  moreover have "k > 1"
    using assms(1) turing_machine_def by simp
  ultimately have "((execute M (start_config k xs) t) <:> 1) i = \<box>" if "i > t" for i
    using assms blank_after_time that by (meson zero_less_one)
  then have "(tps ::: 1) i = \<box>" if "i > t" for i
    using 1 that by simp
  then have *: "\<lfloor>zs\<rfloor> i = \<box>" if "i > t" for i
    using assms(2) that by simp
  show ?thesis
  proof (rule ccontr)
    assume "\<not> length zs \<le> t"
    then have "length zs > t"
      by simp
    then have "\<lfloor>zs\<rfloor> (Suc t) \<noteq> \<box>"
      using contents_inbounds assms(3) contents_def proper_symbols_ne0 by simp
    then show False
      using * by simp
  qed
qed

text \<open>
This is the alternative definition of $\NP$, which restricts the verifier
to output only strings of length one:
\<close>

lemma NP_output_len_1:
  "\<N>\<P> = {L. \<exists>k G M p T fverify.
    turing_machine k G M \<and>
    polynomial p \<and>
    big_oh_poly T \<and>
    computes_in_time k M fverify T \<and>
    (\<forall>y. length (fverify y) = 1) \<and>
    (\<forall>x. x \<in> L \<longleftrightarrow> (\<exists>u. length u = p (length x) \<and> fverify \<langle>x, u\<rangle> = [\<bbbI>]))}"
  (is "_ = ?M")
proof
  show "?M \<subseteq> \<N>\<P>"
    using complexity_class_NP_def by fast
  define Q where "Q = (\<lambda>L k G M p T fverify.
    turing_machine k G M \<and>
    polynomial p \<and>
    big_oh_poly T \<and>
    computes_in_time k M fverify T \<and>
    (\<forall>x. (x \<in> L) = (\<exists>u. length u = p (length x) \<and> fverify \<langle>x, u\<rangle> = [\<bbbI>])))"
  have alt: "complexity_class_NP = {L::language. \<exists>k G M p T fverify. Q L k G M p T fverify}"
    unfolding complexity_class_NP_def Q_def by simp
  show "\<N>\<P> \<subseteq> ?M"
  proof
    fix L assume "L \<in> \<N>\<P>"
    then obtain k G M p T fverify where "Q L k G M p T fverify"
      using alt by blast
    then have ex:
      "turing_machine k G M \<and>
       polynomial p \<and>
       big_oh_poly T \<and>
       computes_in_time k M fverify T \<and>
       (\<forall>x. (x \<in> L) = (\<exists>u. length u = p (length x) \<and> fverify \<langle>x, u\<rangle> = [\<bbbI>]))"
      using Q_def by simp

    have "k \<ge> 2" and "G \<ge> 4"
      using ex turing_machine_def by simp_all

    define M' where "M' = M ;; tm_make_bit 1"
    define f' where "f' = (\<lambda>y. if fverify y = [\<bbbI>] then [\<bbbI>] else [\<bbbO>])"
    define T' where "T' = (\<lambda>n. 19 + 4 * T n)"

    have "turing_machine k G M'"
      unfolding M'_def using \<open>2 \<le> k\<close> \<open>4 \<le> G\<close> ex tm_make_bit_tm by simp
    moreover have "polynomial p"
      using ex by simp
    moreover have "big_oh_poly T'"
      using T'_def ex big_oh_poly_const big_oh_poly_prod big_oh_poly_sum by simp
    moreover have "computes_in_time k M' f' T'"
    proof
      fix y
      let ?cfg = "start_config k (string_to_symbols y)"
      obtain tps where
        1: "tps ::: 1 = string_to_contents (fverify y)" and
        2: "transforms M (snd ?cfg) (T (length y)) tps"
        using ex computes_in_timeD by blast
      have len_tps: "length tps \<ge> 2"
        by (smt (z3) "2" \<open>2 \<le> k\<close> ex execute_num_tapes start_config_length less_le_trans numeral_2_eq_2
          prod.sel(2) transforms_def transits_def zero_less_Suc)
      define zs where "zs = string_to_symbols (fverify y)"
      then have zs: "tps ::: 1 = \<lfloor>zs\<rfloor>" "proper_symbols zs"
        using 1 by auto
      have transforms_MI [transforms_intros]: "transforms M (snd ?cfg) (T (length y)) tps"
        using 2 by simp
      define tps' where
        "tps' = tps[1 := if zs = [\<one>] then (\<lfloor>zs\<rfloor>, 2) else (\<lfloor>[\<zero>]\<rfloor>, 1)]"

      have "transforms M' (snd ?cfg) (T (length y) + (19 + (tps :#: Suc 0 + 2 * length zs))) tps'"
        unfolding M'_def by (tform tps: zs len_tps tps'_def)
      moreover have "T (length y) + (19 + (tps :#: Suc 0 + 2 * length zs)) \<le> T' (length y)"
      proof -
        have "tps :#: Suc 0 \<le> T (length y)"
          using 2 transforms_def transits_def start_config_def ex head_pos_le_time `2 \<le> k`
          by (smt (verit, ccfv_threshold) One_nat_def Suc_1 Suc_le_lessD leD linorder_le_less_linear
            order_less_le_trans prod.sel(2))
        moreover have "length zs \<le> T (length y)"
          using zs 2 ex output_length_le_time by auto
        ultimately show ?thesis
          using T'_def 1 2 by simp
      qed
      ultimately have *: "transforms M' (snd ?cfg) (T' (length y)) tps'"
        using transforms_monotone by simp

      have "tps' ::: 1 = (if zs = [\<one>] then tps ::: 1 else \<lfloor>[\<zero>]\<rfloor>)"
        using tps'_def len_tps zs(1) by simp
      also have "... = (if zs = [\<one>] then \<lfloor>[\<one>]\<rfloor> else \<lfloor>[\<zero>]\<rfloor>)"
        using zs(1) by simp
      also have "... = (if string_to_symbols (fverify y) = [3] then \<lfloor>[3]\<rfloor> else \<lfloor>[2]\<rfloor>)"
        using zs_def by simp
      also have "... = (if fverify y = [\<bbbI>] then \<lfloor>[\<one>]\<rfloor> else \<lfloor>[\<zero>]\<rfloor>)"
        by auto
      also have "... = (if fverify y = [\<bbbI>] then string_to_contents [\<bbbI>] else string_to_contents [\<bbbO>])"
        by auto
      also have "... = string_to_contents (if fverify y = [\<bbbI>] then [\<bbbI>] else [\<bbbO>])"
        by simp
      also have "... = string_to_contents (f' y)"
        using f'_def by auto
      finally have "tps' ::: 1 = string_to_contents (f' y)" .

      then show "\<exists>tps'. tps' ::: 1 = string_to_contents (f' y) \<and>
          transforms M' (snd ?cfg) (T' (length y)) tps'"
        using * by auto
    qed
    moreover have "\<forall>y. length (f' y) = 1"
      using f'_def by simp
    moreover have "(\<forall>x. x \<in> L \<longleftrightarrow> (\<exists>u. length u = p (length x) \<and> f' \<langle>x, u\<rangle> = [\<bbbI>]))"
      using ex f'_def by auto
    ultimately show "L \<in> ?M"
      by blast
  qed
qed

section \<open>$\mathcal{P}$ is a subset of $\NP$\label{s:TC-subseteq}\<close>

text \<open>
Let $L\in\mathcal{P}$ be a language and $M$ a Turing machine that decides $L$ in
polynomial time. To show $L\in\NP$ we could use a TM that extracts the first
element from the input $\langle x, u\rangle$ and runs $M$ on $x$. We do not have
to construct such a TM explicitly because we have shown that the extraction of
the first pair element is computable in polynomial time (lemma~@{thm [source]
tm_first_computes}), and by assumption the characteristic function of $L$ is
computable in polynomial time, too.  The composition of these two functions is
the verifier function required by the definition of $\NP$. And by lemma~@{thm
[source] computes_composed_poly} the composition of polynomial-time functions is
polynomial-time, too.

\null
\<close>

theorem P_subseteq_NP: "\<P> \<subseteq> \<N>\<P>"
proof
  fix L :: language
  assume "L \<in> \<P>"
  then obtain c where c: "L \<in> DTIME (\<lambda>n. n ^ c)"
    using complexity_class_P_def by auto
  then obtain k G M T' where M:
    "turing_machine k G M"
    "computes_in_time k M (characteristic L) T'"
    "big_oh T' (\<lambda>n. n ^ c)"
    using DTIME_def by auto
  then have 4: "big_oh_poly T'"
    using big_oh_poly_def by auto

  define f where "f = (\<lambda>x. symbols_to_string (first (bindecode (string_to_symbols x))))"
  define T :: "nat \<Rightarrow> nat" where "T = (\<lambda>n. 9 + 4 * n)"
  have 1: "turing_machine 3 6 tm_first"
    by (simp add: tm_first_tm)
  have 2: "computes_in_time 3 tm_first f T"
    using f_def T_def tm_first_computes by simp
  have 3: "big_oh_poly T"
  proof -
    have "big_oh_poly (\<lambda>n. 9)"
      using big_oh_poly_const by simp
    moreover have "big_oh_poly (\<lambda>n. 4 * n)"
      using big_oh_poly_const big_oh_poly_prod big_oh_poly_poly[of 1] by simp
    ultimately show ?thesis
      using big_oh_poly_sum T_def by simp
  qed

  define fverify where "fverify = characteristic L \<circ> f"
  then have *: "\<exists>T k G M. big_oh_poly T \<and> turing_machine k G M \<and> computes_in_time k M fverify T"
    using M 1 2 3 4 computes_composed_poly by simp

  then have fverify: "fverify \<langle>x, u\<rangle> = [x \<in> L]" for x u
    using f_def first_pair symbols_to_string_to_symbols fverify_def characteristic_def
    by simp

  define p :: "nat \<Rightarrow> nat" where "p = (\<lambda>_. 0)"
  then have "polynomial p"
    using const_polynomial by simp
  moreover have "\<forall>x. x \<in> L \<longleftrightarrow> (\<exists>u. length u = p (length x) \<and> fverify \<langle>x, u\<rangle> = [\<bbbI>])"
    using fverify p_def by simp
  ultimately show "L \<in> \<N>\<P>"
    using * complexity_class_NP_def by fast
qed

section \<open>More about $\mathcal{P}$, $\NP$, and reducibility\label{s:TC-more}\<close>

text \<open>
We prove some low-hanging fruits about the concepts introduced in this chapter.
None of the results are needed to show the Cook-Levin theorem.
\<close>

text \<open>
A language can be reduced to itself by the identity function. Hence reducibility
is a reflexive relation.

\null
\<close>

lemma reducible_refl: "L \<le>\<^sub>p L"
proof -
  let ?M = "tm_id"
  let ?T = "\<lambda>n. Suc (Suc n)"
  have "turing_machine 2 4 ?M"
    using tm_id_tm by simp
  moreover have "big_oh_poly ?T"
  proof -
    have "big_oh_poly (\<lambda>n. n + 2)"
      using big_oh_poly_const big_oh_poly_id big_oh_poly_sum by blast
    then show ?thesis
      by simp
  qed
  moreover have "computes_in_time 2 ?M id ?T"
    using computes_id by simp
  moreover have "\<forall>x. x \<in> L \<longleftrightarrow> id x \<in> L"
    by simp
  ultimately show "L \<le>\<^sub>p L"
    using reducible_def by metis
qed

text \<open>
Reducibility is also transitive. If $L_1 \leq_p L_2$ by a TM $M_1$ and $L_2
\leq_p L_3$ by a TM $M_2$ we merely have to run $M_2$ on the output of $M_1$ to
show that $L_1 \leq_p L_3$. Again this is merely the composition of two
polynomial-time computable functions.
\<close>

lemma reducible_trans:
  assumes "L\<^sub>1 \<le>\<^sub>p L\<^sub>2" and "L\<^sub>2 \<le>\<^sub>p L\<^sub>3"
  shows "L\<^sub>1 \<le>\<^sub>p L\<^sub>3"
proof -
  obtain k1 G1 M1 T1 f1 where 1:
     "turing_machine k1 G1 M1 \<and>
      big_oh_poly T1 \<and>
      computes_in_time k1 M1 f1 T1 \<and>
      (\<forall>x. x \<in> L\<^sub>1 \<longleftrightarrow> f1 x \<in> L\<^sub>2)"
    using assms(1) reducible_def by metis
  moreover obtain k2 G2 M2 T2 f2 where 2:
     "turing_machine k2 G2 M2 \<and>
      big_oh_poly T2 \<and>
      computes_in_time k2 M2 f2 T2 \<and>
      (\<forall>x. x \<in> L\<^sub>2 \<longleftrightarrow> f2 x \<in> L\<^sub>3)"
    using assms(2) reducible_def by metis
  ultimately obtain T k G M where
      "big_oh_poly T \<and> turing_machine k G M \<and> computes_in_time k M (f2 \<circ> f1) T"
    using computes_composed_poly by metis
  moreover have "\<forall>x. x \<in> L\<^sub>1 \<longleftrightarrow> f2 (f1 x) \<in> L\<^sub>3"
    using 1 2 by simp
  ultimately show ?thesis
    using reducible_def by fastforce
qed

text \<open>
The usual way to show that a language is $\NP$-hard is to reduce another $\NP$-hard
language to it.
\<close>

lemma ex_reducible_imp_NP_hard:
  assumes "NP_hard L'" and "L' \<le>\<^sub>p L"
  shows "NP_hard L"
  using reducible_trans assms by auto

text \<open>
The converse is also true because reducibility is a reflexive relation.
\<close>

lemma NP_hard_iff_reducible: "NP_hard L \<longleftrightarrow> (\<exists>L'. NP_hard L' \<and> L' \<le>\<^sub>p L)"
proof
  show "NP_hard L \<Longrightarrow> \<exists>L'. NP_hard L' \<and> L' \<le>\<^sub>p L"
    using reducible_refl by auto
  show "\<exists>L'. NP_hard L' \<and> L' \<le>\<^sub>p L \<Longrightarrow> NP_hard L"
    using ex_reducible_imp_NP_hard by blast
qed

lemma NP_complete_reducible:
  assumes "NP_complete L'" and "L \<in> \<N>\<P>" and "L' \<le>\<^sub>p L"
  shows "NP_complete L"
  using assms NP_complete_def reducible_trans by blast

text \<open>
In a sense the complexity class $\mathcal{P}$ is closed under reduction.
\<close>

lemma P_closed_reduction:
  assumes "L \<in> \<P>" and "L' \<le>\<^sub>p L"
  shows "L' \<in> \<P>"
proof -
  obtain c where c: "L \<in> DTIME (\<lambda>n. n ^ c)"
    using assms(1) complexity_class_P_def by auto
  then obtain k G M T where M:
    "turing_machine k G M"
    "computes_in_time k M (characteristic L) T"
    "big_oh T (\<lambda>n. n ^ c)"
    using DTIME_def by auto
  then have T: "big_oh_poly T"
    using big_oh_poly_def by auto

  obtain k' G' M' T' freduce where M':
    "turing_machine k' G' M'"
    "big_oh_poly T'"
    "computes_in_time k' M' freduce T'"
    "(\<forall>x. x \<in> L' \<longleftrightarrow> freduce x \<in> L)"
    using reducible_def assms(2) by auto

  obtain T2 k2 G2 M2 where M2:
    "big_oh_poly T2"
    "turing_machine k2 G2 M2"
    "computes_in_time k2 M2 (characteristic L \<circ> freduce) T2"
    using M T M' computes_composed_poly by metis

  obtain d where d: "big_oh T2 (\<lambda>n. n ^ d)"
    using big_oh_poly_def M2(1) by auto

  have "characteristic L \<circ> freduce = characteristic L'"
    using characteristic_def M'(4) by auto
  then have "\<exists>k G M T'. turing_machine k G M \<and> big_oh T' (\<lambda>n. n ^ d) \<and> computes_in_time k M (characteristic L') T'"
    using M2 d by auto
  then have "L' \<in> DTIME (\<lambda>n. n ^ d)"
    using DTIME_def by simp
  then show ?thesis
    using in_P_iff by auto
qed

text \<open>
The next lemmas are items~2 and~3 of Theorem~2.8 of the textbook~\cite{ccama}.
Item~1 is the transitivity of the reduction, already proved in lemma @{thm
[source] reducible_trans}.
\<close>

lemma P_eq_NP:
  assumes "NP_hard L" and "L \<in> \<P>"
  shows "\<P> = \<N>\<P>"
  using assms P_closed_reduction P_subseteq_NP by auto

lemma NP_complete_imp:
  assumes "NP_complete L"
  shows "L \<in> \<P> \<longleftrightarrow> \<P> = \<N>\<P>"
  using assms NP_complete_def P_eq_NP by auto

end


chapter\<open>Models\<close>
text\<open>In this chapter, we present our formalisation of EFSMs from \cite{foster2018}. We first
define transitions, before defining EFSMs as finite sets of transitions between states. Finally,
we provide a framework of function definitions and key lemmas such that LTL properties over EFSMs
can be more easily specified and proven.\<close>

section\<open>Transitions\<close>
text\<open>Here we define the transitions which make up EFSMs. As per \cite{foster2018}, each transition
has a label and an arity and, optionally, guards, outputs, and updates. To implement this, we use
the record type such that each component of the transition can be accessed.\<close>

theory Transition
imports GExp
begin

type_synonym label = String.literal
type_synonym arity = nat
type_synonym guard = "vname gexp"
type_synonym inputs = "value list"
type_synonym outputs = "value option list"
type_synonym output_function = "vname aexp"
type_synonym update_function = "nat \<times> vname aexp"

text_raw\<open>\snip{transitiontype}{1}{2}{%\<close>
record transition =
  Label :: String.literal
  Arity :: nat
  Guards :: "guard list"
  Outputs :: "output_function list"
  Updates :: "update_function list"
text_raw\<open>}%endsnip\<close>

definition same_structure :: "transition \<Rightarrow> transition \<Rightarrow> bool" where
  "same_structure t1 t2 = (
    Label t1 = Label t2 \<and>
    Arity t1 = Arity t2 \<and>
    length (Outputs t1) = length (Outputs t2)
  )"

definition enumerate_inputs :: "transition \<Rightarrow> nat set" where
  "enumerate_inputs t = (\<Union> (set (map enumerate_gexp_inputs (Guards t)))) \<union>
                        (\<Union> (set (map enumerate_aexp_inputs (Outputs t)))) \<union>
                        (\<Union> (set (map (\<lambda>(_, u). enumerate_aexp_inputs u) (Updates t))))"

definition max_input :: "transition \<Rightarrow> nat option" where
  "max_input t = (if enumerate_inputs t = {} then None else Some (Max (enumerate_inputs t)))"

definition total_max_input :: "transition \<Rightarrow> nat" where
  "total_max_input t = (case max_input t of None \<Rightarrow> 0 | Some a \<Rightarrow> a)"

definition enumerate_regs :: "transition \<Rightarrow> nat set" where
  "enumerate_regs t = (\<Union> (set (map GExp.enumerate_regs (Guards t)))) \<union>
                      (\<Union> (set (map AExp.enumerate_regs (Outputs t)))) \<union>
                      (\<Union> (set (map (\<lambda>(_, u). AExp.enumerate_regs u) (Updates t)))) \<union>
                      (\<Union> (set (map (\<lambda>(r, _). AExp.enumerate_regs (V (R r))) (Updates t))))"

definition max_reg :: "transition \<Rightarrow> nat option" where
  "max_reg t = (if enumerate_regs t = {} then None else Some (Max (enumerate_regs t)))"

definition total_max_reg :: "transition \<Rightarrow> nat" where
  "total_max_reg t = (case max_reg t of None \<Rightarrow> 0 | Some a \<Rightarrow> a)"

definition enumerate_ints :: "transition \<Rightarrow> int set" where
  "enumerate_ints t = (\<Union> (set (map enumerate_gexp_ints (Guards t)))) \<union>
                      (\<Union> (set (map enumerate_aexp_ints (Outputs t)))) \<union>
                      (\<Union> (set (map (\<lambda>(_, u). enumerate_aexp_ints u) (Updates t)))) \<union>
                      (\<Union> (set (map (\<lambda>(r, _). enumerate_aexp_ints (V (R r))) (Updates t))))"

definition valid_transition :: "transition \<Rightarrow> bool" where
  "valid_transition t = (\<forall>i \<in> enumerate_inputs t. i < Arity t)"

definition can_take :: "nat \<Rightarrow> vname gexp list \<Rightarrow> inputs \<Rightarrow> registers \<Rightarrow> bool" where
  "can_take a g i r = (length i = a \<and> apply_guards g (join_ir i r))"

lemma can_take_empty [simp]: "length i = a \<Longrightarrow> can_take a [] i c"
  by (simp add: can_take_def)

lemma can_take_subset_append:
  assumes "set (Guards t) \<subseteq> set (Guards t')"
  shows "can_take a (Guards t @ Guards t') i c = can_take a (Guards t') i c"
  using assms
  by (simp add: apply_guards_subset_append can_take_def)

definition "can_take_transition t i r = can_take (Arity t) (Guards t) i r"

lemmas can_take = can_take_def can_take_transition_def

lemma can_take_transition_empty_guard:
  "Guards t = [] \<Longrightarrow> \<exists>i. can_take_transition t i c"
  by (simp add: can_take_transition_def can_take_def Ex_list_of_length)

lemma can_take_subset: "length i = Arity t \<Longrightarrow>
   Arity t = Arity t' \<Longrightarrow>
   set (Guards t') \<subseteq> set (Guards t) \<Longrightarrow>
   can_take_transition t i r \<Longrightarrow>
   can_take_transition t' i r"
  by (simp add: can_take_transition_def can_take_def apply_guards_subset)

lemma valid_list_can_take:
  "\<forall>g \<in> set (Guards t). valid g \<Longrightarrow> \<exists>i. can_take_transition t i c"
  by (simp add: can_take_transition_def can_take_def apply_guards_def valid_def Ex_list_of_length)

lemma cant_take_if:
  "\<exists>g \<in> set (Guards t). gval g (join_ir i r) \<noteq> true \<Longrightarrow>
   \<not> can_take_transition t i r"
  using apply_guards_cons apply_guards_rearrange can_take_def can_take_transition_def by blast

definition apply_outputs :: "'a aexp list \<Rightarrow> 'a datastate \<Rightarrow> value option list" where
  "apply_outputs p s = map (\<lambda>p. aval p s) p"

abbreviation "evaluate_outputs t i r \<equiv> apply_outputs (Outputs t) (join_ir i r)"

lemma apply_outputs_nth:
  "i < length p \<Longrightarrow> apply_outputs p s ! i = aval (p ! i) s"
  by (simp add: apply_outputs_def)

lemmas apply_outputs = datastate apply_outputs_def value_plus_def value_minus_def value_times_def

lemma apply_outputs_empty [simp]: "apply_outputs [] s = []"
  by (simp add: apply_outputs_def)

lemma apply_outputs_preserves_length: "length (apply_outputs p s) = length p"
  by (simp add: apply_outputs_def)

lemma apply_outputs_literal: assumes "P ! r = L v"
      and "r < length P"
    shows "apply_outputs P s ! r = Some v"
  by (simp add: assms apply_outputs_nth)

lemma apply_outputs_register: assumes "r < length P"
  shows "apply_outputs (list_update P r (V (R p))) (join_ir i c) ! r = c $ p"
  by (metis apply_outputs_nth assms aval.simps(2) join_ir_R length_list_update nth_list_update_eq)

lemma apply_outputs_unupdated: assumes "ia \<noteq> r"
      and "ia < length P"
    shows "apply_outputs P j ! ia = apply_outputs (list_update P r v)j ! ia"
  by (metis apply_outputs_nth assms(1) assms(2) length_list_update nth_list_update_neq)

definition apply_updates :: "update_function list \<Rightarrow> vname datastate \<Rightarrow> registers \<Rightarrow> registers" where
  "apply_updates u old = fold (\<lambda>h r. r(fst h $:= aval (snd h) old)) u"

abbreviation "evaluate_updates t i r \<equiv> apply_updates (Updates t) (join_ir i r) r"

lemma apply_updates_cons: "ra \<noteq> r \<Longrightarrow>
       apply_updates u (join_ir ia c) c $ ra = apply_updates ((r, a) # u) (join_ir ia c) c $ ra"
proof(induct u rule: rev_induct)
  case Nil
  then show ?case
    by (simp add: apply_updates_def)
next
  case (snoc u us)
  then show ?case
    apply (cases u)
    apply (simp add: apply_updates_def)
    by (case_tac "ra = aa", auto)
qed

lemma update_twice:
  "apply_updates [(r, a), (r, b)] s regs = regs (r $:= aval b s)"
  by (simp add: apply_updates_def)

lemma r_not_updated_stays_the_same:
  "r \<notin> fst ` set U \<Longrightarrow> apply_updates U c d $ r = d $ r"
  using apply_updates_def
  by (induct U rule: rev_induct, auto)

definition rename_regs :: "(nat \<Rightarrow> nat) \<Rightarrow> transition \<Rightarrow> transition" where
  "rename_regs f t = t\<lparr>
      Guards  := map (GExp.rename_regs f) (Guards t),
      Outputs := map (AExp.rename_regs f) (Outputs t),
      Updates := map (\<lambda>(r, u). (f r, AExp.rename_regs f u)) (Updates t)
    \<rparr>"

definition eq_upto_rename_strong :: "transition \<Rightarrow> transition \<Rightarrow> bool" where
  "eq_upto_rename_strong t1 t2 = (\<exists>f. bij f \<and> rename_regs f t1 = t2)"

inductive eq_upto_rename :: "transition \<Rightarrow> transition \<Rightarrow> bool" where
  "Label t1 = Label t2 \<Longrightarrow>
   Arity t2 = Arity t2 \<Longrightarrow>
   apply_guards (map (GExp.rename_regs f) (Guards t1)) = apply_guards (Guards t2) \<Longrightarrow>

   apply_outputs (map (AExp.rename_regs f) (Outputs t1)) = apply_outputs (Outputs t2) \<Longrightarrow>

   apply_updates (map (\<lambda>(r, u). (f r, AExp.rename_regs f u)) (Updates t1)) = apply_updates (Updates t2) \<Longrightarrow>

   eq_upto_rename t1 t2"

end


theory Relations imports Main begin

(*Id is only used in UNITY*)
(*refl, antisym,trans,univalent,\<dots> ho hum*)

text\<open>
@{thm[display] Id_def[no_vars]}
\rulename{Id_def}
\<close>

text\<open>
@{thm[display] relcomp_unfold[no_vars]}
\rulename{relcomp_unfold}
\<close>

text\<open>
@{thm[display] R_O_Id[no_vars]}
\rulename{R_O_Id}
\<close>

text\<open>
@{thm[display] relcomp_mono[no_vars]}
\rulename{relcomp_mono}
\<close>

text\<open>
@{thm[display] converse_iff[no_vars]}
\rulename{converse_iff}
\<close>

text\<open>
@{thm[display] converse_relcomp[no_vars]}
\rulename{converse_relcomp}
\<close>

text\<open>
@{thm[display] Image_iff[no_vars]}
\rulename{Image_iff}
\<close>

text\<open>
@{thm[display] Image_UN[no_vars]}
\rulename{Image_UN}
\<close>

text\<open>
@{thm[display] Domain_iff[no_vars]}
\rulename{Domain_iff}
\<close>

text\<open>
@{thm[display] Range_iff[no_vars]}
\rulename{Range_iff}
\<close>

text\<open>
@{thm[display] relpow.simps[no_vars]}
\rulename{relpow.simps}

@{thm[display] rtrancl_refl[no_vars]}
\rulename{rtrancl_refl}

@{thm[display] r_into_rtrancl[no_vars]}
\rulename{r_into_rtrancl}

@{thm[display] rtrancl_trans[no_vars]}
\rulename{rtrancl_trans}

@{thm[display] rtrancl_induct[no_vars]}
\rulename{rtrancl_induct}

@{thm[display] rtrancl_idemp[no_vars]}
\rulename{rtrancl_idemp}

@{thm[display] r_into_trancl[no_vars]}
\rulename{r_into_trancl}

@{thm[display] trancl_trans[no_vars]}
\rulename{trancl_trans}

@{thm[display] trancl_into_rtrancl[no_vars]}
\rulename{trancl_into_rtrancl}

@{thm[display] trancl_converse[no_vars]}
\rulename{trancl_converse}
\<close>

text\<open>Relations.  transitive closure\<close>

lemma rtrancl_converseD: "(x,y) \<in> (r\<inverse>)\<^sup>* \<Longrightarrow> (y,x) \<in> r\<^sup>*"
apply (erule rtrancl_induct)
txt\<open>
@{subgoals[display,indent=0,margin=65]}
\<close>
 apply (rule rtrancl_refl)
apply (blast intro: rtrancl_trans)
done

lemma rtrancl_converseI: "(y,x) \<in> r\<^sup>* \<Longrightarrow> (x,y) \<in> (r\<inverse>)\<^sup>*"
apply (erule rtrancl_induct)
 apply (rule rtrancl_refl)
apply (blast intro: rtrancl_trans)
done

lemma rtrancl_converse: "(r\<inverse>)\<^sup>* = (r\<^sup>*)\<inverse>"
by (auto intro: rtrancl_converseI dest: rtrancl_converseD)

lemma rtrancl_converse: "(r\<inverse>)\<^sup>* = (r\<^sup>*)\<inverse>"
apply (intro equalityI subsetI)
txt\<open>
after intro rules

@{subgoals[display,indent=0,margin=65]}
\<close>
apply clarify
txt\<open>
after splitting
@{subgoals[display,indent=0,margin=65]}
\<close>
oops

lemma "(\<forall>u v. (u,v) \<in> A \<longrightarrow> u=v) \<Longrightarrow> A \<subseteq> Id"
apply (rule subsetI)
txt\<open>
@{subgoals[display,indent=0,margin=65]}

after subsetI
\<close>
apply clarify
txt\<open>
@{subgoals[display,indent=0,margin=65]}

subgoals after clarify
\<close>
by blast

text\<open>rejects\<close>

lemma "(a \<in> {z. P z} \<union> {y. Q y}) = P a \<or> Q a"
apply (blast)
done

text\<open>Pow, Inter too little used\<close>

lemma "(A \<subset> B) = (A \<subseteq> B \<and> A \<noteq> B)"
apply (simp add: psubset_eq)
done

end


section {* The Proof System *}

theory OG_Hoare imports OG_Tran begin

primrec assertions :: "'a ann_com \<Rightarrow> ('a assn) set" where
  "assertions (AnnBasic r f) = {r}"
| "assertions (AnnSeq c1 c2) = assertions c1 \<union> assertions c2"
| "assertions (AnnCond1 r b c1 c2) = {r} \<union> assertions c1 \<union> assertions c2"
| "assertions (AnnCond2 r b c) = {r} \<union> assertions c"
| "assertions (AnnWhile r b i c) = {r, i} \<union> assertions c"
| "assertions (AnnAwait r b c) = {r}"

primrec atomics :: "'a ann_com \<Rightarrow> ('a assn \<times> 'a com) set" where
  "atomics (AnnBasic r f) = {(r, Basic f)}"
| "atomics (AnnSeq c1 c2) = atomics c1 \<union> atomics c2"
| "atomics (AnnCond1 r b c1 c2) = atomics c1 \<union> atomics c2"
| "atomics (AnnCond2 r b c) = atomics c"
| "atomics (AnnWhile r b i c) = atomics c"
| "atomics (AnnAwait r b c) = {(r \<inter> b, c)}"

primrec com :: "'a ann_triple_op \<Rightarrow> 'a ann_com_op" where
  "com (c, q) = c"

primrec post :: "'a ann_triple_op \<Rightarrow> 'a assn" where
  "post (c, q) = q"

definition interfree_aux :: "('a ann_com_op \<times> 'a assn \<times> 'a ann_com_op) \<Rightarrow> bool" where
  "interfree_aux \<equiv> \<lambda>(co, q, co'). co'= None \<or>
                    (\<forall>(r,a) \<in> atomics (the co'). \<parallel>= (q \<inter> r) a q \<and>
                    (co = None \<or> (\<forall>p \<in> assertions (the co). \<parallel>= (p \<inter> r) a p)))"

definition interfree :: "(('a ann_triple_op) list) \<Rightarrow> bool" where
  "interfree Ts \<equiv> \<forall>i j. i < length Ts \<and> j < length Ts \<and> i \<noteq> j \<longrightarrow>
                         interfree_aux (com (Ts!i), post (Ts!i), com (Ts!j)) "

inductive
  oghoare :: "'a assn \<Rightarrow> 'a com \<Rightarrow> 'a assn \<Rightarrow> bool"  ("(3\<parallel>- _//_//_)" [90,55,90] 50)
  and ann_hoare :: "'a ann_com \<Rightarrow> 'a assn \<Rightarrow> bool"  ("(2\<turnstile> _// _)" [60,90] 45)
where
  AnnBasic: "r \<subseteq> {s. f s \<in> q} \<Longrightarrow> \<turnstile> (AnnBasic r f) q"

| AnnSeq:   "\<lbrakk> \<turnstile> c0 pre c1; \<turnstile> c1 q \<rbrakk> \<Longrightarrow> \<turnstile> (AnnSeq c0 c1) q"

| AnnCond1: "\<lbrakk> r \<inter> b \<subseteq> pre c1; \<turnstile> c1 q; r \<inter> -b \<subseteq> pre c2; \<turnstile> c2 q\<rbrakk>
              \<Longrightarrow> \<turnstile> (AnnCond1 r b c1 c2) q"
| AnnCond2: "\<lbrakk> r \<inter> b \<subseteq> pre c; \<turnstile> c q; r \<inter> -b \<subseteq> q \<rbrakk> \<Longrightarrow> \<turnstile> (AnnCond2 r b c) q"

| AnnWhile: "\<lbrakk> r \<subseteq> i; i \<inter> b \<subseteq> pre c; \<turnstile> c i; i \<inter> -b \<subseteq> q \<rbrakk>
              \<Longrightarrow> \<turnstile> (AnnWhile r b i c) q"

| AnnAwait:  "\<lbrakk> atom_com c; \<parallel>- (r \<inter> b) c q \<rbrakk> \<Longrightarrow> \<turnstile> (AnnAwait r b c) q"

| AnnConseq: "\<lbrakk>\<turnstile> c q; q \<subseteq> q' \<rbrakk> \<Longrightarrow> \<turnstile> c q'"

| Parallel: "\<lbrakk> \<forall>i<length Ts. \<exists>c q. Ts!i = (Some c, q) \<and> \<turnstile> c q; interfree Ts \<rbrakk>
           \<Longrightarrow> \<parallel>- (\<Inter>i\<in>{i. i<length Ts}. pre(the(com(Ts!i))))
                     Parallel Ts
                  (\<Inter>i\<in>{i. i<length Ts}. post(Ts!i))"

| Basic:   "\<parallel>- {s. f s \<in>q} (Basic f) q"

| Seq:    "\<lbrakk> \<parallel>- p c1 r; \<parallel>- r c2 q \<rbrakk> \<Longrightarrow> \<parallel>- p (Seq c1 c2) q "

| Cond:   "\<lbrakk> \<parallel>- (p \<inter> b) c1 q; \<parallel>- (p \<inter> -b) c2 q \<rbrakk> \<Longrightarrow> \<parallel>- p (Cond b c1 c2) q"

| While:  "\<lbrakk> \<parallel>- (p \<inter> b) c p \<rbrakk> \<Longrightarrow> \<parallel>- p (While b i c) (p \<inter> -b)"

| Conseq: "\<lbrakk> p' \<subseteq> p; \<parallel>- p c q ; q \<subseteq> q' \<rbrakk> \<Longrightarrow> \<parallel>- p' c q'"

section {* Soundness *}
(* In the version Isabelle-10-Sep-1999: HOL: The THEN and ELSE
parts of conditional expressions (if P then x else y) are no longer
simplified.  (This allows the simplifier to unfold recursive
functional programs.)  To restore the old behaviour, we declare
@{text "lemmas [cong del] = if_weak_cong"}. *)

lemmas [cong del] = if_weak_cong

lemmas ann_hoare_induct = oghoare_ann_hoare.induct [THEN conjunct2]
lemmas oghoare_induct = oghoare_ann_hoare.induct [THEN conjunct1]

lemmas AnnBasic = oghoare_ann_hoare.AnnBasic
lemmas AnnSeq = oghoare_ann_hoare.AnnSeq
lemmas AnnCond1 = oghoare_ann_hoare.AnnCond1
lemmas AnnCond2 = oghoare_ann_hoare.AnnCond2
lemmas AnnWhile = oghoare_ann_hoare.AnnWhile
lemmas AnnAwait = oghoare_ann_hoare.AnnAwait
lemmas AnnConseq = oghoare_ann_hoare.AnnConseq

lemmas Parallel = oghoare_ann_hoare.Parallel
lemmas Basic = oghoare_ann_hoare.Basic
lemmas Seq = oghoare_ann_hoare.Seq
lemmas Cond = oghoare_ann_hoare.Cond
lemmas While = oghoare_ann_hoare.While
lemmas Conseq = oghoare_ann_hoare.Conseq

subsection {* Soundness of the System for Atomic Programs *}

lemma Basic_ntran [rule_format]:
 "(Basic f, s) -Pn\<rightarrow> (Parallel Ts, t) \<longrightarrow> All_None Ts \<longrightarrow> t = f s"
apply(induct "n")
 apply(simp (no_asm))
apply(fast dest: relpow_Suc_D2 Parallel_empty_lemma elim: transition_cases)
done

lemma SEM_fwhile: "SEM S (p \<inter> b) \<subseteq> p \<Longrightarrow> SEM (fwhile b S k) p \<subseteq> (p \<inter> -b)"
apply (induct "k")
 apply(simp (no_asm) add: L3_5v_lemma3)
apply(simp (no_asm) add: L3_5iv L3_5ii Parallel_empty)
apply(rule conjI)
 apply (blast dest: L3_5i)
apply(simp add: SEM_def sem_def id_def)
apply (blast dest: Basic_ntran rtrancl_imp_UN_relpow)
done

lemma atom_hoare_sound [rule_format]:
 " \<parallel>- p c q \<longrightarrow> atom_com(c) \<longrightarrow> \<parallel>= p c q"
apply (unfold com_validity_def)
apply(rule oghoare_induct)
apply simp_all
--{*Basic*}
    apply(simp add: SEM_def sem_def)
    apply(fast dest: rtrancl_imp_UN_relpow Basic_ntran)
--{* Seq *}
   apply(rule impI)
   apply(rule subset_trans)
    prefer 2 apply simp
   apply(simp add: L3_5ii L3_5i)
--{* Cond *}
  apply(simp add: L3_5iv)
--{* While *}
 apply (force simp add: L3_5v dest: SEM_fwhile)
--{* Conseq *}
apply(force simp add: SEM_def sem_def)
done

subsection {* Soundness of the System for Component Programs *}

inductive_cases ann_transition_cases:
    "(None,s) -1\<rightarrow> (c', s')"
    "(Some (AnnBasic r f),s) -1\<rightarrow> (c', s')"
    "(Some (AnnSeq c1 c2), s) -1\<rightarrow> (c', s')"
    "(Some (AnnCond1 r b c1 c2), s) -1\<rightarrow> (c', s')"
    "(Some (AnnCond2 r b c), s) -1\<rightarrow> (c', s')"
    "(Some (AnnWhile r b I c), s) -1\<rightarrow> (c', s')"
    "(Some (AnnAwait r b c),s) -1\<rightarrow> (c', s')"

text {* Strong Soundness for Component Programs:*}

lemma ann_hoare_case_analysis [rule_format]: "\<turnstile> C q' \<longrightarrow>
  ((\<forall>r f. C = AnnBasic r f \<longrightarrow> (\<exists>q. r \<subseteq> {s. f s \<in> q} \<and> q \<subseteq> q')) \<and>
  (\<forall>c0 c1. C = AnnSeq c0 c1 \<longrightarrow> (\<exists>q. q \<subseteq> q' \<and> \<turnstile> c0 pre c1 \<and> \<turnstile> c1 q)) \<and>
  (\<forall>r b c1 c2. C = AnnCond1 r b c1 c2 \<longrightarrow> (\<exists>q. q \<subseteq> q' \<and>
  r \<inter> b \<subseteq> pre c1 \<and> \<turnstile> c1 q \<and> r \<inter> -b \<subseteq> pre c2 \<and> \<turnstile> c2 q)) \<and>
  (\<forall>r b c. C = AnnCond2 r b c \<longrightarrow>
  (\<exists>q. q \<subseteq> q' \<and> r \<inter> b \<subseteq> pre c  \<and> \<turnstile> c q \<and> r \<inter> -b \<subseteq> q)) \<and>
  (\<forall>r i b c. C = AnnWhile r b i c \<longrightarrow>
  (\<exists>q. q \<subseteq> q' \<and> r \<subseteq> i \<and> i \<inter> b \<subseteq> pre c \<and> \<turnstile> c i \<and> i \<inter> -b \<subseteq> q)) \<and>
  (\<forall>r b c. C = AnnAwait r b c \<longrightarrow> (\<exists>q. q \<subseteq> q' \<and> \<parallel>- (r \<inter> b) c q)))"
apply(rule ann_hoare_induct)
apply simp_all
 apply(rule_tac x=q in exI,simp)+
apply(rule conjI,clarify,simp,clarify,rule_tac x=qa in exI,fast)+
apply(clarify,simp,clarify,rule_tac x=qa in exI,fast)
done

lemma Help: "(transition \<inter> {(x,y). True}) = (transition)"
apply force
done

lemma Strong_Soundness_aux_aux [rule_format]:
 "(co, s) -1\<rightarrow> (co', t) \<longrightarrow> (\<forall>c. co = Some c \<longrightarrow> s\<in> pre c \<longrightarrow>
 (\<forall>q. \<turnstile> c q \<longrightarrow> (if co' = None then t\<in>q else t \<in> pre(the co') \<and> \<turnstile> (the co') q )))"
apply(rule ann_transition_transition.induct [THEN conjunct1])
apply simp_all
--{* Basic *}
         apply clarify
         apply(frule ann_hoare_case_analysis)
         apply force
--{* Seq *}
        apply clarify
        apply(frule ann_hoare_case_analysis,simp)
        apply(fast intro: AnnConseq)
       apply clarify
       apply(frule ann_hoare_case_analysis,simp)
       apply clarify
       apply(rule conjI)
        apply force
       apply(rule AnnSeq,simp)
       apply(fast intro: AnnConseq)
--{* Cond1 *}
      apply clarify
      apply(frule ann_hoare_case_analysis,simp)
      apply(fast intro: AnnConseq)
     apply clarify
     apply(frule ann_hoare_case_analysis,simp)
     apply(fast intro: AnnConseq)
--{* Cond2 *}
    apply clarify
    apply(frule ann_hoare_case_analysis,simp)
    apply(fast intro: AnnConseq)
   apply clarify
   apply(frule ann_hoare_case_analysis,simp)
   apply(fast intro: AnnConseq)
--{* While *}
  apply clarify
  apply(frule ann_hoare_case_analysis,simp)
  apply force
 apply clarify
 apply(frule ann_hoare_case_analysis,simp)
 apply auto
 apply(rule AnnSeq)
  apply simp
 apply(rule AnnWhile)
  apply simp_all
--{* Await *}
apply(frule ann_hoare_case_analysis,simp)
apply clarify
apply(drule atom_hoare_sound)
 apply simp
apply(simp add: com_validity_def SEM_def sem_def)
apply(simp add: Help All_None_def)
apply force
done

lemma Strong_Soundness_aux: "\<lbrakk> (Some c, s) -*\<rightarrow> (co, t); s \<in> pre c; \<turnstile> c q \<rbrakk>
  \<Longrightarrow> if co = None then t \<in> q else t \<in> pre (the co) \<and> \<turnstile> (the co) q"
apply(erule rtrancl_induct2)
 apply simp
apply(case_tac "a")
 apply(fast elim: ann_transition_cases)
apply(erule Strong_Soundness_aux_aux)
 apply simp
apply simp_all
done

lemma Strong_Soundness: "\<lbrakk> (Some c, s)-*\<rightarrow>(co, t); s \<in> pre c; \<turnstile> c q \<rbrakk>
  \<Longrightarrow> if co = None then t\<in>q else t \<in> pre (the co)"
apply(force dest:Strong_Soundness_aux)
done

lemma ann_hoare_sound: "\<turnstile> c q  \<Longrightarrow> \<Turnstile> c q"
apply (unfold ann_com_validity_def ann_SEM_def ann_sem_def)
apply clarify
apply(drule Strong_Soundness)
apply simp_all
done

subsection {* Soundness of the System for Parallel Programs *}

lemma Parallel_length_post_P1: "(Parallel Ts,s) -P1\<rightarrow> (R', t) \<Longrightarrow>
  (\<exists>Rs. R' = (Parallel Rs) \<and> (length Rs) = (length Ts) \<and>
  (\<forall>i. i<length Ts \<longrightarrow> post(Rs ! i) = post(Ts ! i)))"
apply(erule transition_cases)
apply simp
apply clarify
apply(case_tac "i=ia")
apply simp+
done

lemma Parallel_length_post_PStar: "(Parallel Ts,s) -P*\<rightarrow> (R',t) \<Longrightarrow>
  (\<exists>Rs. R' = (Parallel Rs) \<and> (length Rs) = (length Ts) \<and>
  (\<forall>i. i<length Ts \<longrightarrow> post(Ts ! i) = post(Rs ! i)))"
apply(erule rtrancl_induct2)
 apply(simp_all)
apply clarify
apply simp
apply(drule Parallel_length_post_P1)
apply auto
done

lemma assertions_lemma: "pre c \<in> assertions c"
apply(rule ann_com_com.induct [THEN conjunct1])
apply auto
done

lemma interfree_aux1 [rule_format]:
  "(c,s) -1\<rightarrow> (r,t)  \<longrightarrow> (interfree_aux(c1, q1, c) \<longrightarrow> interfree_aux(c1, q1, r))"
apply (rule ann_transition_transition.induct [THEN conjunct1])
apply(safe)
prefer 13
apply (rule TrueI)
apply (simp_all add:interfree_aux_def)
apply force+
done

lemma interfree_aux2 [rule_format]:
  "(c,s) -1\<rightarrow> (r,t) \<longrightarrow> (interfree_aux(c, q, a)  \<longrightarrow> interfree_aux(r, q, a) )"
apply (rule ann_transition_transition.induct [THEN conjunct1])
apply(force simp add:interfree_aux_def)+
done

lemma interfree_lemma: "\<lbrakk> (Some c, s) -1\<rightarrow> (r, t);interfree Ts ; i<length Ts;
           Ts!i = (Some c, q) \<rbrakk> \<Longrightarrow> interfree (Ts[i:= (r, q)])"
apply(simp add: interfree_def)
apply clarify
apply(case_tac "i=j")
 apply(drule_tac t = "ia" in not_sym)
 apply simp_all
apply(force elim: interfree_aux1)
apply(force elim: interfree_aux2 simp add:nth_list_update)
done

text {* Strong Soundness Theorem for Parallel Programs:*}

lemma Parallel_Strong_Soundness_Seq_aux:
  "\<lbrakk>interfree Ts; i<length Ts; com(Ts ! i) = Some(AnnSeq c0 c1) \<rbrakk>
  \<Longrightarrow>  interfree (Ts[i:=(Some c0, pre c1)])"
apply(simp add: interfree_def)
apply clarify
apply(case_tac "i=j")
 apply(force simp add: nth_list_update interfree_aux_def)
apply(case_tac "i=ia")
 apply(erule_tac x=ia in allE)
 apply(force simp add:interfree_aux_def assertions_lemma)
apply simp
done

lemma Parallel_Strong_Soundness_Seq [rule_format (no_asm)]:
 "\<lbrakk> \<forall>i<length Ts. (if com(Ts!i) = None then b \<in> post(Ts!i)
  else b \<in> pre(the(com(Ts!i))) \<and> \<turnstile> the(com(Ts!i)) post(Ts!i));
  com(Ts ! i) = Some(AnnSeq c0 c1); i<length Ts; interfree Ts \<rbrakk> \<Longrightarrow>
 (\<forall>ia<length Ts. (if com(Ts[i:=(Some c0, pre c1)]! ia) = None
  then b \<in> post(Ts[i:=(Some c0, pre c1)]! ia)
 else b \<in> pre(the(com(Ts[i:=(Some c0, pre c1)]! ia))) \<and>
 \<turnstile> the(com(Ts[i:=(Some c0, pre c1)]! ia)) post(Ts[i:=(Some c0, pre c1)]! ia)))
  \<and> interfree (Ts[i:= (Some c0, pre c1)])"
apply(rule conjI)
 apply safe
 apply(case_tac "i=ia")
  apply simp
  apply(force dest: ann_hoare_case_analysis)
 apply simp
apply(fast elim: Parallel_Strong_Soundness_Seq_aux)
done

lemma Parallel_Strong_Soundness_aux_aux [rule_format]:
 "(Some c, b) -1\<rightarrow> (co, t) \<longrightarrow>
  (\<forall>Ts. i<length Ts \<longrightarrow> com(Ts ! i) = Some c \<longrightarrow>
  (\<forall>i<length Ts. (if com(Ts ! i) = None then b\<in>post(Ts!i)
  else b\<in>pre(the(com(Ts!i))) \<and> \<turnstile> the(com(Ts!i)) post(Ts!i))) \<longrightarrow>
 interfree Ts \<longrightarrow>
  (\<forall>j. j<length Ts \<and> i\<noteq>j \<longrightarrow> (if com(Ts!j) = None then t\<in>post(Ts!j)
  else t\<in>pre(the(com(Ts!j))) \<and> \<turnstile> the(com(Ts!j)) post(Ts!j))) )"
apply(rule ann_transition_transition.induct [THEN conjunct1])
apply safe
prefer 11
apply(rule TrueI)
apply simp_all
--{* Basic *}
   apply(erule_tac x = "i" in all_dupE, erule (1) notE impE)
   apply(erule_tac x = "j" in allE , erule (1) notE impE)
   apply(simp add: interfree_def)
   apply(erule_tac x = "j" in allE,simp)
   apply(erule_tac x = "i" in allE,simp)
   apply(drule_tac t = "i" in not_sym)
   apply(case_tac "com(Ts ! j)=None")
    apply(force intro: converse_rtrancl_into_rtrancl
          simp add: interfree_aux_def com_validity_def SEM_def sem_def All_None_def)
   apply(simp add:interfree_aux_def)
   apply clarify
   apply simp
   apply(erule_tac x="pre y" in ballE)
    apply(force intro: converse_rtrancl_into_rtrancl
          simp add: com_validity_def SEM_def sem_def All_None_def)
   apply(simp add:assertions_lemma)
--{* Seqs *}
  apply(erule_tac x = "Ts[i:=(Some c0, pre c1)]" in allE)
  apply(drule  Parallel_Strong_Soundness_Seq,simp+)
 apply(erule_tac x = "Ts[i:=(Some c0, pre c1)]" in allE)
 apply(drule  Parallel_Strong_Soundness_Seq,simp+)
--{* Await *}
apply(rule_tac x = "i" in allE , assumption , erule (1) notE impE)
apply(erule_tac x = "j" in allE , erule (1) notE impE)
apply(simp add: interfree_def)
apply(erule_tac x = "j" in allE,simp)
apply(erule_tac x = "i" in allE,simp)
apply(drule_tac t = "i" in not_sym)
apply(case_tac "com(Ts ! j)=None")
 apply(force intro: converse_rtrancl_into_rtrancl simp add: interfree_aux_def
        com_validity_def SEM_def sem_def All_None_def Help)
apply(simp add:interfree_aux_def)
apply clarify
apply simp
apply(erule_tac x="pre y" in ballE)
 apply(force intro: converse_rtrancl_into_rtrancl
       simp add: com_validity_def SEM_def sem_def All_None_def Help)
apply(simp add:assertions_lemma)
done

lemma Parallel_Strong_Soundness_aux [rule_format]:
 "\<lbrakk>(Ts',s) -P*\<rightarrow> (Rs',t);  Ts' = (Parallel Ts); interfree Ts;
 \<forall>i. i<length Ts \<longrightarrow> (\<exists>c q. (Ts ! i) = (Some c, q) \<and> s\<in>(pre c) \<and> \<turnstile> c q ) \<rbrakk> \<Longrightarrow>
  \<forall>Rs. Rs' = (Parallel Rs) \<longrightarrow> (\<forall>j. j<length Rs \<longrightarrow>
  (if com(Rs ! j) = None then t\<in>post(Ts ! j)
  else t\<in>pre(the(com(Rs ! j))) \<and> \<turnstile> the(com(Rs ! j)) post(Ts ! j))) \<and> interfree Rs"
apply(erule rtrancl_induct2)
 apply clarify
--{* Base *}
 apply force
--{* Induction step *}
apply clarify
apply(drule Parallel_length_post_PStar)
apply clarify
apply (ind_cases "(Parallel Ts, s) -P1\<rightarrow> (Parallel Rs, t)" for Ts s Rs t)
apply(rule conjI)
 apply clarify
 apply(case_tac "i=j")
  apply(simp split del:split_if)
  apply(erule Strong_Soundness_aux_aux,simp+)
   apply force
  apply force
 apply(simp split del: split_if)
 apply(erule Parallel_Strong_Soundness_aux_aux)
 apply(simp_all add: split del:split_if)
 apply force
apply(rule interfree_lemma)
apply simp_all
done

lemma Parallel_Strong_Soundness:
 "\<lbrakk>(Parallel Ts, s) -P*\<rightarrow> (Parallel Rs, t); interfree Ts; j<length Rs;
  \<forall>i. i<length Ts \<longrightarrow> (\<exists>c q. Ts ! i = (Some c, q) \<and> s\<in>pre c \<and> \<turnstile> c q) \<rbrakk> \<Longrightarrow>
  if com(Rs ! j) = None then t\<in>post(Ts ! j) else t\<in>pre (the(com(Rs ! j)))"
apply(drule  Parallel_Strong_Soundness_aux)
apply simp+
done

lemma oghoare_sound [rule_format]: "\<parallel>- p c q \<longrightarrow> \<parallel>= p c q"
apply (unfold com_validity_def)
apply(rule oghoare_induct)
apply(rule TrueI)+
--{* Parallel *}
      apply(simp add: SEM_def sem_def)
      apply(clarify, rename_tac x y i Ts')
      apply(frule Parallel_length_post_PStar)
      apply clarify
      apply(drule_tac j=i in Parallel_Strong_Soundness)
         apply clarify
        apply simp
       apply force
      apply simp
      apply(erule_tac V = "\<forall>i. ?P i" in thin_rl)
      apply(drule_tac s = "length Rs" in sym)
      apply(erule allE, erule impE, assumption)
      apply(force dest: nth_mem simp add: All_None_def)
--{* Basic *}
    apply(simp add: SEM_def sem_def)
    apply(force dest: rtrancl_imp_UN_relpow Basic_ntran)
--{* Seq *}
   apply(rule subset_trans)
    prefer 2 apply assumption
   apply(simp add: L3_5ii L3_5i)
--{* Cond *}
  apply(simp add: L3_5iv)
--{* While *}
 apply(simp add: L3_5v)
 apply (blast dest: SEM_fwhile)
--{* Conseq *}
apply(auto simp add: SEM_def sem_def)
done

end