(*  Title:      Dual_Ordered_Lattice.thy
    Authors:    Makarius; Peter Gammie; Brian Huffman; Florian Haftmann, TU Muenchen
*)

section \<open>Type of dual ordered lattices\<close>

theory Dual_Ordered_Lattice
imports MainRLT
begin

text \<open>
  The \<^emph>\<open>dual\<close> of an ordered structure is an isomorphic copy of the
  underlying type, with the \<open>\<le>\<close> relation defined as the inverse
  of the original one.

  The class of lattices is closed under formation of dual structures.
  This means that for any theorem of lattice theory, the dualized
  statement holds as well; this important fact simplifies many proofs
  of lattice theory.
\<close>

typedef 'a dual = "UNIV :: 'a set"
  morphisms undual dual ..

setup_lifting type_definition_dual

code_datatype dual

lemma dual_eqI:
  "x = y" if "undual x = undual y"
  using that by transfer assumption

lemma dual_eq_iff:
  "x = y \<longleftrightarrow> undual x = undual y"
  by transfer simp

lemma eq_dual_iff [iff]:
  "dual x = dual y \<longleftrightarrow> x = y"
  by transfer simp

lemma undual_dual [simp, code]:
  "undual (dual x) = x"
  by transfer rule

lemma dual_undual [simp]:
  "dual (undual x) = x"
  by transfer rule

lemma undual_comp_dual [simp]:
  "undual \<circ> dual = id"
  by (simp add: fun_eq_iff)

lemma dual_comp_undual [simp]:
  "dual \<circ> undual = id"
  by (simp add: fun_eq_iff)

lemma inj_dual:
  "inj dual"
  by (rule injI) simp

lemma inj_undual:
  "inj undual"
  by (rule injI) (rule dual_eqI)

lemma surj_dual:
  "surj dual"
  by (rule surjI [of _ undual]) simp

lemma surj_undual:
  "surj undual"
  by (rule surjI [of _ dual]) simp

lemma bij_dual:
  "bij dual"
  using inj_dual surj_dual by (rule bijI)

lemma bij_undual:
  "bij undual"
  using inj_undual surj_undual by (rule bijI)

instance dual :: (finite) finite
proof
  from finite have "finite (range dual :: 'a dual set)"
    by (rule finite_imageI)
  then show "finite (UNIV :: 'a dual set)"
    by (simp add: surj_dual)
qed

instantiation dual :: (equal) equal
begin

lift_definition equal_dual :: "'a dual \<Rightarrow> 'a dual \<Rightarrow> bool"
  is HOL.equal .

instance
  by (standard; transfer) (simp add: equal)

end

subsection \<open>Pointwise ordering\<close>

instantiation dual :: (ord) ord
begin

lift_definition less_eq_dual :: "'a dual \<Rightarrow> 'a dual \<Rightarrow> bool"
  is "(\<ge>)" .

lift_definition less_dual :: "'a dual \<Rightarrow> 'a dual \<Rightarrow> bool"
  is "(>)" .

instance ..

end

lemma dual_less_eqI:
  "x \<le> y" if "undual y \<le> undual x"
  using that by transfer assumption

lemma dual_less_eq_iff:
  "x \<le> y \<longleftrightarrow> undual y \<le> undual x"
  by transfer simp

lemma less_eq_dual_iff [iff]:
  "dual x \<le> dual y \<longleftrightarrow> y \<le> x"
  by transfer simp

lemma dual_lessI:
  "x < y" if "undual y < undual x"
  using that by transfer assumption

lemma dual_less_iff:
  "x < y \<longleftrightarrow> undual y < undual x"
  by transfer simp

lemma less_dual_iff [iff]:
  "dual x < dual y \<longleftrightarrow> y < x"
  by transfer simp

instance dual :: (preorder) preorder
  by (standard; transfer) (auto simp add: less_le_not_le intro: order_trans)

instance dual :: (order) order
  by (standard; transfer) simp

subsection \<open>Binary infimum and supremum\<close>

instantiation dual :: (sup) inf
begin

lift_definition inf_dual :: "'a dual \<Rightarrow> 'a dual \<Rightarrow> 'a dual"
  is sup .

instance ..

end

lemma undual_inf_eq [simp]:
  "undual (inf x y) = sup (undual x) (undual y)"
  by (fact inf_dual.rep_eq)

lemma dual_sup_eq [simp]:
  "dual (sup x y) = inf (dual x) (dual y)"
  by transfer rule

instantiation dual :: (inf) sup
begin

lift_definition sup_dual :: "'a dual \<Rightarrow> 'a dual \<Rightarrow> 'a dual"
  is inf .

instance ..

end

lemma undual_sup_eq [simp]:
  "undual (sup x y) = inf (undual x) (undual y)"
  by (fact sup_dual.rep_eq)

lemma dual_inf_eq [simp]:
  "dual (inf x y) = sup (dual x) (dual y)"
  by transfer simp

instance dual :: (semilattice_sup) semilattice_inf
  by (standard; transfer) simp_all

instance dual :: (semilattice_inf) semilattice_sup
  by (standard; transfer) simp_all

instance dual :: (lattice) lattice ..

instance dual :: (distrib_lattice) distrib_lattice
  by (standard; transfer) (fact inf_sup_distrib1)

subsection \<open>Top and bottom elements\<close>

instantiation dual :: (top) bot
begin

lift_definition bot_dual :: "'a dual"
  is top .

instance ..

end

lemma undual_bot_eq [simp]:
  "undual bot = top"
  by (fact bot_dual.rep_eq)

lemma dual_top_eq [simp]:
  "dual top = bot"
  by transfer rule

instantiation dual :: (bot) top
begin

lift_definition top_dual :: "'a dual"
  is bot .

instance ..

end

lemma undual_top_eq [simp]:
  "undual top = bot"
  by (fact top_dual.rep_eq)

lemma dual_bot_eq [simp]:
  "dual bot = top"
  by transfer rule

instance dual :: (order_top) order_bot
  by (standard; transfer) simp

instance dual :: (order_bot) order_top
  by (standard; transfer) simp

instance dual :: (bounded_lattice_top) bounded_lattice_bot ..

instance dual :: (bounded_lattice_bot) bounded_lattice_top ..

instance dual :: (bounded_lattice) bounded_lattice ..

subsection \<open>Complement\<close>

instantiation dual :: (uminus) uminus
begin

lift_definition uminus_dual :: "'a dual \<Rightarrow> 'a dual"
  is uminus .

instance ..

end

lemma undual_uminus_eq [simp]:
  "undual (- x) = - undual x"
  by (fact uminus_dual.rep_eq)

lemma dual_uminus_eq [simp]:
  "dual (- x) = - dual x"
  by transfer rule

instantiation dual :: (boolean_algebra) boolean_algebra
begin

lift_definition minus_dual :: "'a dual \<Rightarrow> 'a dual \<Rightarrow> 'a dual"
  is "\<lambda>x y. - (y - x)" .

instance
  by (standard; transfer) (simp_all add: diff_eq ac_simps)

end

lemma undual_minus_eq [simp]:
  "undual (x - y) = - (undual y - undual x)"
  by (fact minus_dual.rep_eq)

lemma dual_minus_eq [simp]:
  "dual (x - y) = - (dual y - dual x)"
  by transfer simp

subsection \<open>Complete lattice operations\<close>

text \<open>
  The class of complete lattices is closed under formation of dual
  structures.
\<close>

instantiation dual :: (Sup) Inf
begin

lift_definition Inf_dual :: "'a dual set \<Rightarrow> 'a dual"
  is Sup .

instance ..

end

lemma undual_Inf_eq [simp]:
  "undual (Inf A) = Sup (undual ` A)"
  by (fact Inf_dual.rep_eq)

lemma dual_Sup_eq [simp]:
  "dual (Sup A) = Inf (dual ` A)"
  by transfer simp

instantiation dual :: (Inf) Sup
begin

lift_definition Sup_dual :: "'a dual set \<Rightarrow> 'a dual"
  is Inf .

instance ..

end

lemma undual_Sup_eq [simp]:
  "undual (Sup A) = Inf (undual ` A)"
  by (fact Sup_dual.rep_eq)

lemma dual_Inf_eq [simp]:
  "dual (Inf A) = Sup (dual ` A)"
  by transfer simp

instance dual :: (complete_lattice) complete_lattice
  by (standard; transfer) (auto intro: Inf_lower Sup_upper Inf_greatest Sup_least)

context
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
    and g :: "'a dual \<Rightarrow> 'a dual"
  assumes "mono f"
  defines "g \<equiv> dual \<circ> f \<circ> undual"
begin

private lemma mono_dual:
  "mono g"
proof
  fix x y :: "'a dual"
  assume "x \<le> y"
  then have "undual y \<le> undual x"
    by (simp add: dual_less_eq_iff)
  with \<open>mono f\<close> have "f (undual y) \<le> f (undual x)"
    by (rule monoD)
  then have "(dual \<circ> f \<circ> undual) x \<le> (dual \<circ> f \<circ> undual) y"
    by simp
  then show "g x \<le> g y"
    by (simp add: g_def)
qed

lemma lfp_dual_gfp:
  "lfp f = undual (gfp g)" (is "?lhs = ?rhs")
proof (rule antisym)
  have "dual (undual (g (gfp g))) \<le> dual (f (undual (gfp g)))"
    by (simp add: g_def)
  with mono_dual have "f (undual (gfp g)) \<le> undual (gfp g)"
    by (simp add: gfp_unfold [where f = g, symmetric] dual_less_eq_iff)
  then show "?lhs \<le> ?rhs"
    by (rule lfp_lowerbound)
  from \<open>mono f\<close> have "dual (lfp f) \<le> dual (undual (gfp g))"
    by (simp add: lfp_fixpoint gfp_upperbound g_def)
  then show "?rhs \<le> ?lhs"
    by (simp only: less_eq_dual_iff)
qed

lemma gfp_dual_lfp:
  "gfp f = undual (lfp g)"
proof -
  have "mono (\<lambda>x. undual (undual x))"
    by (rule monoI)  (simp add: dual_less_eq_iff)
  moreover have "mono (\<lambda>a. dual (dual (f a)))"
    using \<open>mono f\<close> by (auto intro: monoI dest: monoD)
  moreover have "gfp f = gfp (\<lambda>x. undual (undual (dual (dual (f x)))))"
    by simp
  ultimately have "undual (undual (gfp (\<lambda>x. dual
    (dual (f (undual (undual x))))))) =
      gfp (\<lambda>x. undual (undual (dual (dual (f x)))))"
    by (subst gfp_rolling [where g = "\<lambda>x. undual (undual x)"]) simp_all
  then have "gfp f =
    undual
     (undual
       (gfp (\<lambda>x. dual (dual (f (undual (undual x)))))))"
    by simp
  also have "\<dots> = undual (undual (gfp (dual \<circ> g \<circ> undual)))"
    by (simp add: comp_def g_def)
  also have "\<dots> = undual (lfp g)"
    using mono_dual by (simp only: Dual_Ordered_Lattice.lfp_dual_gfp)
  finally show ?thesis .
qed

end

text \<open>Finally\<close>

lifting_update dual.lifting
lifting_forget dual.lifting

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   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.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_28
  imports "../../Test_Base"
begin

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 rev :: "'a list => 'a list" where
  "rev (nil2) = nil2"
| "rev (cons2 z xs) = x (rev xs) (cons2 z (nil2))"

fun revflat :: "('a list) list => 'a list" where
  "revflat (nil2) = nil2"
| "revflat (cons2 xs xss) = x (revflat xss) (rev xs)"

fun qrevflat :: "('a list) list => 'a list => 'a list" where
  "qrevflat (nil2) z = z"
| "qrevflat (cons2 xs xss) z = qrevflat xss (x (rev xs) z)"
lemma app_nil: "x y nil2 = y" by (induction y, auto)
lemma app_assoc: "x (x y z) w = x y (x z w)" by (induction y, auto)
lemma revflat_qrevflat:  "(qrevflat y z) = x (revflat y) z"
  apply(induction y arbitrary: z, auto)
  apply(simp add: app_assoc)
  done
theorem property0 :
  "((revflat y) = (qrevflat y (nil2)))"
  apply(induction y, auto)
  apply(simp add: app_nil revflat_qrevflat)
  done

end


(*
  File:     Legendre_Symbol.thy
  Authors:  Daniel Stüwe

  Some more facts about the Legendre symbol that are missing from HOL-Number_Theory
*)
section \<open>Additional Facts about the Legendre Symbol\<close>
theory Legendre_Symbol
imports
  "HOL-Number_Theory.Number_Theory"
begin

lemma basic_cong[simp]:
  fixes p :: int
  assumes "2 < p"
  shows   "[-1 \<noteq>  1] (mod p)"
          "[ 1 \<noteq> -1] (mod p)"
          "[ 0 \<noteq>  1] (mod p)"
          "[ 1 \<noteq>  0] (mod p)"
          "[ 0 \<noteq> -1] (mod p)"
          "[-1 \<noteq>  0] (mod p)"
  using assms by (simp_all add: cong_iff_dvd_diff zdvd_not_zless)

lemma Legendre_in_cong_eq:
  fixes p :: int
  assumes "p > 2" and "b \<in> {-1,0,1}"
  shows   "[Legendre a m = b] (mod p) \<longleftrightarrow> Legendre a m = b"
  using assms unfolding Legendre_def by auto

lemma Legendre_p_eq_2[simp]: "Legendre a 2 = a mod 2"
  by (clarsimp simp: Legendre_def QuadRes_def cong_iff_dvd_diff) presburger

lemma Legendre_p_eq_1[simp]: "Legendre a 1 = 0" by (simp add: Legendre_def)

lemma euler_criterion_int:
  assumes "prime p" and "2 < p"
  shows "[Legendre a p = a^((nat p-1) div 2)] (mod p)"
  using euler_criterion assms prime_int_nat_transfer
  by (metis int_nat_eq nat_numeral prime_gt_0_int zless_nat_conj)

lemma QuadRes_neg[simp]: "QuadRes (-p) a = QuadRes p a" unfolding QuadRes_def by auto

lemma Legendre_neg[simp]: "Legendre a (-p) = Legendre a p" unfolding Legendre_def by auto

lemma Legendre_mult[simp]:
  assumes "prime p"
  shows "Legendre (a*b) p = Legendre a p * Legendre b p"
proof -
  consider "p = 2" | "p > 2"
    using assms order_le_less prime_ge_2_int by auto

  thus ?thesis proof (cases)
  case 1
    then show ?thesis
      by (metis Legendre_p_eq_2 mod_mult_eq mod_self mult_cancel_right2
                mult_eq_0_iff not_mod_2_eq_1_eq_0 one_mod_two_eq_one)
  next
  case 2
    hence "[Legendre (a*b) p = (a*b)^((nat p-1) div 2)] (mod p)"
      using euler_criterion_int assms by blast

    also have "[(a*b)^((nat p-1) div 2) = a^((nat p-1) div 2) * b^((nat p-1) div 2)] (mod p)"
      by (simp add: field_simps)

    also have "[a^((nat p-1) div 2) * b^((nat p-1) div 2) = Legendre a p * Legendre b p] (mod p)"
      using cong_sym[OF euler_criterion_int] assms 2 cong_mult by blast

    finally show ?thesis using Legendre_in_cong_eq[OF 2] by (simp add: Legendre_def)
  qed
qed

lemma QuadRes_mod[simp]: "p dvd n \<Longrightarrow> QuadRes p (a mod n) = QuadRes p a"
  by (simp add: mod_mod_cancel QuadRes_def cong_def)

lemma Legendre_mod[simp]: "p dvd n \<Longrightarrow> Legendre (a mod n) p = Legendre a p"
  by (simp add: mod_mod_cancel Legendre_def cong_def)

lemma two_cong_0_iff: "[2 = 0] (mod p) \<longleftrightarrow> p = 1 \<or> p = 2" for p :: nat
  unfolding cong_altdef_nat[of 0 2 p, simplified]
  using dvd_refl prime_nat_iff two_is_prime_nat by blast

lemma two_cong_0_iff_nat: "[2 = 0] (mod int p) \<longleftrightarrow> p = 1 \<or> p = 2"
  unfolding cong_iff_dvd_diff
  using two_is_prime_nat prime_nat_iff int_dvd_int_iff[of p 2]
  by auto

lemma QuadRes_2_2 [simp, intro]: "QuadRes 2 2"
  unfolding QuadRes_def
  unfolding cong_def
  by presburger

lemma Suc_mod_eq[simp]: "[Suc a = Suc b] (mod 2) = [a = b] (mod 2)"
  using Suc_eq_plus1_left cong_add_lcancel_nat by presburger

lemma div_cancel_aux: "c dvd a \<Longrightarrow> (d + a * b) div c = (d div c) + a div c * b" for a b c :: nat
  by (metis div_plus_div_distrib_dvd_right dvd_div_mult dvd_trans dvd_triv_left)

corollary div_cancel_Suc: "c dvd a \<Longrightarrow> 1 < c \<Longrightarrow> Suc (a * b) div c = a div c * b"
  using div_cancel_aux[where d = 1] by fastforce

lemma cong_aux_eq_1: "odd p \<Longrightarrow> [(p - 1) div 2 - p div 4 = (p^2 - 1) div 8] (mod 2)" for p :: nat
proof (induction p rule: nat_less_induct)
  case (1 n)

  consider "n = 1" | "n > 1" using odd_pos[OF \<open>odd n\<close>] by linarith

  then show ?case proof (cases)
    assume "n > 1"

    then obtain m where m: "m = n - 2" and m': "odd m" "m < n" using \<open>odd n\<close> by simp
    then obtain b where b: "m = 2 * b + 1" using oddE by blast

    have IH: "[(m - 1) div 2 - m div 4 = (m^2 - 1) div 8] (mod 2)" using "1.IH" m' by simp

    have [simp]: "n = 2 * b + 1 + 2" using m \<open>n > 1\<close> b by auto

    have *: "(n\<^sup>2 - 1) div 8 = ((n - 2)\<^sup>2 - 1) div 8 + (n - 1) div 2"
      unfolding  power2_sum power2_eq_square by simp

    have "[(n - 1) div 2 - n div 4 = (n - 2 - 1) div 2 - (n - 2) div 4 + (n - 1) div 2] (mod 2)"
      by (rule cong_sym, cases "even b") (auto simp: cong_altdef_nat div_cancel_Suc elim: oddE)
    also have "[(n - 2 - 1) div 2 - (n - 2) div 4 + (n - 1) div 2 = (n\<^sup>2 - 1) div 8] (mod 2)"
        using IH cong_add_rcancel_nat unfolding * m by presburger
    finally show ?thesis .

  qed simp
qed

lemma cong_2_pow[intro]: "(-1 :: int)^a = (-1)^b" if "[a = b] (mod 2)" for a b :: nat
proof -
  have "even a = even b"
    by (simp add: cong_dvd_iff that)
  then show ?thesis by auto
qed

lemma card_Int: "card (A \<inter> B) = card A - card (A - B)" if "finite A"
  by (metis Diff_Diff_Int Diff_subset card_Diff_subset finite_Diff that)

text \<open>Proofs are inspired by \cite{Quadratic_Reciprocity}.\<close>

theorem supplement2_Legendre:
  fixes p :: int
  assumes "p > 2" "prime p"
  shows "Legendre 2 p = (-1) ^ (((nat p)^2 - 1) div 8)"
proof -
  interpret GAUSS "nat p" 2
    using assms
    unfolding GAUSS_def prime_int_nat_transfer
    by (simp add: two_cong_0_iff_int)

  have "card E = card ((\<lambda>x. x * 2 mod p) `
          {0<..(p - 1) div 2} \<inter> {(p - 1) div 2<..})" (is "_ = card ?A")
    unfolding E_def C_def B_def A_def image_image using assms by simp
  also have "(\<lambda>x. x * 2 mod p) ` {0<..(p - 1) div 2} = ((*) 2) ` {0<..(p - 1) div 2}"
    by (intro image_cong) auto
  also have "card (\<dots> \<inter> {(p - 1) div 2<..}) =
               nat ((p - 1) div 2) - card ((*) 2 ` {0<..(p - 1) div 2} - {(p - 1) div 2<..})"
    using assms by (subst card_Int) (auto simp: card_image inj_onI)
  also have "card (((*) 2) ` {0<..(p - 1) div 2} - {(p - 1) div 2<..}) = card {0 <.. (p div 4)}"
    by (rule sym, intro bij_betw_same_card[of "(*) 2"] bij_betw_imageI inj_onI)
       (insert assms prime_odd_int[of p], auto simp: image_def elim!: oddE)
  also have "\<dots> = nat p div 4" using assms by simp
  also have "nat ((p - 1) div 2) - nat p div 4 =  nat ((p - 1) div 2 - p div 4)"
    using assms by (simp add: nat_diff_distrib nat_div_distrib)
  finally have "card E = \<dots>" .

  then have "Legendre 2 p = (-1) ^ nat ((p - 1) div 2 - p div 4)"
    using gauss_lemma assms by simp
  also have "nat ((p - 1) div 2 - p div 4) = (nat p - 1) div 2 - nat p div 4"
    using assms by (simp add: nat_div_distrib nat_diff_distrib)
  also have "(-1) ^ \<dots> = ((-1) ^ (((nat p)^2 - 1) div 8) :: int)"
    using cong_aux_eq_1[of "nat p"] odd_p by blast
  finally show ?thesis .
qed

theorem supplement1_Legendre:
  "prime p \<Longrightarrow> 2 < p \<Longrightarrow> Legendre (-1) p = (-1)^((p-1) div 2)"
  using euler_criterion[of p "-1"] Legendre_in_cong_eq[symmetric, of p]
  by (simp add: minus_one_power_iff)

lemma QuadRes_1_right [intro, simp]: "QuadRes p 1"
  by (metis QuadRes_def cong_def power_one)

lemma Legendre_1_left [simp]: "prime p \<Longrightarrow> Legendre 1 p = 1"
  by (auto simp add: Legendre_def cong_iff_dvd_diff not_prime_unit)

lemma cong_eq_0_not_coprime: "prime p \<Longrightarrow> [a = 0] (mod p) \<Longrightarrow> \<not>coprime a p" for a p :: int
  unfolding cong_iff_dvd_diff prime_int_iff
  by auto

lemma not_coprime_cong_eq_0: "prime p \<Longrightarrow> \<not>coprime a p \<Longrightarrow> [a = 0] (mod p)" for a p :: int
  unfolding cong_iff_dvd_diff
  using prime_imp_coprime[of p a]
  by (auto simp: coprime_commute)

lemma prime_cong_eq_0_iff: "prime p \<Longrightarrow> [a = 0] (mod p) \<longleftrightarrow> \<not>coprime a p" for a p :: int
  using not_coprime_cong_eq_0[of p a] cong_eq_0_not_coprime[of p a]
  by auto

lemma Legendre_eq_0_iff [simp]: "prime p \<Longrightarrow> Legendre a p = 0 \<longleftrightarrow> \<not>coprime a p"
  unfolding Legendre_def by (auto simp: prime_cong_eq_0_iff)

lemma Legendre_prod_mset [simp]: "prime p \<Longrightarrow> Legendre (prod_mset M) p = (\<Prod>q\<in>#M. Legendre q p)"
  by (induction M) simp_all

lemma Legendre_0_eq_0[simp]: "Legendre 0 p = 0" unfolding Legendre_def by auto

lemma Legendre_values: "Legendre p q \<in> {1, - 1, 0}"
  unfolding Legendre_def by auto

end


(*<*)
theory Optimized_Join
  imports "Generic_Join.Generic_Join_Correctness"
begin
(*>*)

section \<open>Optimized relational join\<close>

subsection \<open>Binary join\<close>

definition join_mask :: "nat \<Rightarrow> nat set \<Rightarrow> bool list" where
  "join_mask n X = map (\<lambda>i. i \<in> X) [0..<n]"

fun proj_tuple :: "bool list \<Rightarrow> 'a tuple \<Rightarrow> 'a tuple" where
  "proj_tuple [] [] = []"
| "proj_tuple (True # bs) (a # as) = a # proj_tuple bs as"
| "proj_tuple (False # bs) (a # as) = None # proj_tuple bs as"
| "proj_tuple (b # bs) [] = []"
| "proj_tuple [] (a # as) = []"

lemma proj_tuple_replicate: "(\<And>i. i \<in> set bs \<Longrightarrow> \<not>i) \<Longrightarrow> length bs = length as \<Longrightarrow>
  proj_tuple bs as = replicate (length bs) None"
  by (induction bs as rule: proj_tuple.induct) fastforce+

lemma proj_tuple_join_mask_empty: "length as = n \<Longrightarrow>
  proj_tuple (join_mask n {}) as = replicate n None"
  using proj_tuple_replicate[of "join_mask n {}"] by (auto simp add: join_mask_def)

lemma proj_tuple_alt: "proj_tuple bs as = map2 (\<lambda>b a. if b then a else None) bs as"
  by (induction bs as rule: proj_tuple.induct) auto

lemma map2_map: "map2 f (map g [0..<length as]) as = map (\<lambda>i. f (g i) (as ! i)) [0..<length as]"
  by (rule nth_equalityI) auto

lemma proj_tuple_join_mask_restrict: "length as = n \<Longrightarrow>
  proj_tuple (join_mask n X) as = restrict X as"
  by (auto simp add: restrict_def proj_tuple_alt join_mask_def map2_map)

lemma wf_tuple_proj_idle:
  assumes wf: "wf_tuple n X as"
  shows "proj_tuple (join_mask n X) as = as"
  using proj_tuple_join_mask_restrict[of as n X, unfolded restrict_idle[OF wf]] wf
  by (auto simp add: wf_tuple_def)

lemma wf_tuple_change_base:
  assumes wf: "wf_tuple n X as"
  and mask: "join_mask n X = join_mask n Y"
  shows "wf_tuple n Y as"
  using wf mask by (auto simp add: wf_tuple_def join_mask_def)

definition proj_tuple_in_join :: "bool \<Rightarrow> bool list \<Rightarrow> 'a tuple \<Rightarrow> 'a table \<Rightarrow> bool" where
  "proj_tuple_in_join pos bs as t = (if pos then proj_tuple bs as \<in> t else proj_tuple bs as \<notin> t)"

abbreviation "join_cond pos t \<equiv> (\<lambda>as. if pos then as \<in> t else as \<notin> t)"

abbreviation "join_filter_cond pos t \<equiv> (\<lambda>as _. join_cond pos t as)"

lemma proj_tuple_in_join_mask_idle:
  assumes wf: "wf_tuple n X as"
  shows "proj_tuple_in_join pos (join_mask n X) as t \<longleftrightarrow> join_cond pos t as"
  using wf_tuple_proj_idle[OF wf] by (auto simp add: proj_tuple_in_join_def)

lemma join_sub:
  assumes "L \<subseteq> R" "table n L t1" "table n R t2"
  shows "join t2 pos t1 = {as \<in> t2. proj_tuple_in_join pos (join_mask n L) as t1}"
  using assms proj_tuple_join_mask_restrict[of _ n L] join_restrict[of t2 n R t1 L pos]
    wf_tuple_length restrict_idle
  by (auto simp add: table_def proj_tuple_in_join_def sup.absorb1) fastforce+

lemma join_sub':
  assumes "R \<subseteq> L" "table n L t1" "table n R t2"
  shows "join t2 True t1 = {as \<in> t1. proj_tuple_in_join True (join_mask n R) as t2}"
  using assms proj_tuple_join_mask_restrict[of _ n R] join_restrict[of t2 n R t1 L True]
    wf_tuple_length restrict_idle
  by (auto simp add: table_def proj_tuple_in_join_def sup.absorb1 Un_absorb1) fastforce+

lemma join_eq:
  assumes tab: "table n R t1" "table n R t2"
  shows "join t2 pos t1 = (if pos then t2 \<inter> t1 else t2 - t1)"
  using join_sub[OF _ tab, of pos] tab(2) proj_tuple_in_join_mask_idle[of n R _ pos t1]
  by (auto simp add: table_def)

lemma join_no_cols:
  assumes tab: "table n {} t1" "table n R t2"
  shows "join t2 pos t1 = (if (pos \<longleftrightarrow> replicate n None \<in> t1) then t2 else {})"
  using join_sub[OF _ tab, of pos] tab(2)
  by (auto simp add: table_def proj_tuple_in_join_def wf_tuple_length proj_tuple_join_mask_empty)

lemma join_empty_left: "join {} pos t = {}"
  by (auto simp add: join_def)

lemma join_empty_right: "join t pos {} = (if pos then {} else t)"
  by (auto simp add: join_def)

fun bin_join :: "nat \<Rightarrow> nat set \<Rightarrow> 'a table \<Rightarrow> bool \<Rightarrow> nat set \<Rightarrow> 'a table \<Rightarrow> 'a table" where
  "bin_join n A t pos A' t' =
    (if t = {} then {}
    else if t' = {} then (if pos then {} else t)
    else if A' = {} then (if (pos \<longleftrightarrow> replicate n None \<in> t') then t else {})
    else if A' = A then (if pos then t \<inter> t' else t - t')
    else if A' \<subseteq> A then {as \<in> t. proj_tuple_in_join pos (join_mask n A') as t'}
    else if A \<subseteq> A' \<and> pos then {as \<in> t'. proj_tuple_in_join pos (join_mask n A) as t}
    else join t pos t')"

lemma bin_join_table:
  assumes tab: "table n A t" "table n A' t'"
  shows "bin_join n A t pos A' t' = join t pos t'"
  using assms join_empty_left[of pos t'] join_empty_right[of t pos]
    join_no_cols[OF _ assms(1), of t' pos] join_eq[of n A t' t pos] join_sub[OF _ assms(2,1)]
    join_sub'[OF _ assms(2,1)]
  by auto+

subsection \<open>Multi-way join\<close>

fun mmulti_join' :: "(nat set list \<Rightarrow> nat set list \<Rightarrow> 'a table list \<Rightarrow> 'a table)" where
  "mmulti_join' A_pos A_neg L = (
    let Q = set (zip A_pos L) in
    let Q_neg = set (zip A_neg (drop (length A_pos) L)) in
    New_max_getIJ_wrapperGenericJoin Q Q_neg)"

lemma mmulti_join'_correct:
  assumes "A_pos \<noteq> []"
      and "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A) (A_pos @ A_neg) L"
  shows "z \<in> mmulti_join' A_pos A_neg L \<longleftrightarrow> wf_tuple n (\<Union>A\<in>set A_pos. A) z \<and>
    list_all2 (\<lambda>A X. restrict A z \<in> X) A_pos (take (length A_pos) L) \<and>
    list_all2 (\<lambda>A X. restrict A z \<notin> X) A_neg (drop (length A_pos) L)"
proof -
  define Q where "Q = set (zip A_pos L)"
  have Q_alt: "Q = set (zip A_pos (take (length A_pos) L))"
    unfolding Q_def by (fastforce simp: in_set_zip)
  define Q_neg where "Q_neg = set (zip A_neg (drop (length A_pos) L))"
  let ?r = "mmulti_join' A_pos A_neg L"
  have "?r = New_max_getIJ_wrapperGenericJoin Q Q_neg"
    unfolding Q_def Q_neg_def by (simp del: New_max.wrapperGenericJoin.simps)
  moreover have "card Q \<ge> 1"
    unfolding Q_def using assms(1,2)
    by (auto simp: Suc_le_eq card_gt_0_iff zip_eq_Nil_iff)
  moreover have "\<forall>(A, X)\<in>(Q \<union> Q_neg). table n A X \<and> wf_set n A"
    unfolding Q_alt Q_neg_def using assms(2) by (simp add: zip_append1 list_all2_iff)
  ultimately have "z \<in> ?r \<longleftrightarrow> wf_tuple n (\<Union>(A, X)\<in>Q. A) z \<and>
      (\<forall>(A, X)\<in>Q. restrict A z \<in> X) \<and> (\<forall>(A, X)\<in>Q_neg. restrict A z \<notin> X)"
    using New_max.wrapper_correctness case_prod_beta' by blast
  moreover have "(\<Union>A\<in>set A_pos. A) = (\<Union>(A, X)\<in>Q. A)" proof -
    from assms(2) have "length A_pos \<le> length L" by (auto dest!: list_all2_lengthD)
    then show ?thesis
      unfolding Q_alt
      by (auto elim: in_set_impl_in_set_zip1[rotated, where ys="take (length A_pos) L"]
          dest: set_zip_leftD)
  qed
  moreover have "\<And>z. (\<forall>(A, X)\<in>Q. restrict A z \<in> X) \<longleftrightarrow>
    list_all2 (\<lambda>A X. restrict A z \<in> X) A_pos (take (length A_pos) L)"
    unfolding Q_alt using assms(2) by (auto simp add: list_all2_iff)
  moreover have "\<And>z. (\<forall>(A, X)\<in>Q_neg. restrict A z \<notin> X) \<longleftrightarrow>
    list_all2 (\<lambda>A X. restrict A z \<notin> X) A_neg (drop (length A_pos) L)"
    unfolding Q_neg_def using assms(2) by (auto simp add: list_all2_iff)
  ultimately show ?thesis
    unfolding Q_def Q_neg_def using assms(2) by simp
qed

lemmas restrict_nested = New_max.restrict_nested

lemma list_all2_opt_True:
  assumes "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A) ((A_zs @ A_x # A_xs @ A_y # A_ys) @ A_neg)
    ((zs @ x # xs @ y # ys) @ L_neg)"
    "length A_xs = length xs" "length A_ys = length ys" "length A_zs = length zs"
  shows "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A)
    ((A_zs @ (A_x \<union> A_y) # A_xs @ A_ys) @ A_neg) ((zs @ join x True y # xs @ ys) @ L_neg)"
proof -
  have assms_dest: "table n A_x x" "table n A_y y" "wf_set n A_x" "wf_set n A_y"
    using assms
    by (auto simp del: mmulti_join'.simps simp add: list_all2_append1 dest: list_all2_lengthD)
  then have tabs: "table n (A_x \<union> A_y) (join x True y)" "wf_set n (A_x \<union> A_y)"
    using join_table[of n A_x x A_y y True "A_x \<union> A_y", OF assms_dest(1,2)] assms_dest(3,4)
    by (auto simp add: wf_set_def)
  then show "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A)
    ((A_zs @ (A_x \<union> A_y) # A_xs @ A_ys) @ A_neg) ((zs @ join x True y # xs @ ys) @ L_neg)"
    using assms
    by (auto simp del: mmulti_join'.simps simp add: list_all2_append1 list_all2_append2
        list_all2_Cons1 list_all2_Cons2 dest: list_all2_lengthD) fastforce
qed

lemma mmulti_join'_opt_True:
  assumes "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A) ((A_zs @ A_x # A_xs @ A_y # A_ys) @ A_neg)
    ((zs @ x # xs @ y # ys) @ L_neg)"
    "length A_xs = length xs" "length A_ys = length ys" "length A_zs = length zs"
  shows "mmulti_join' (A_zs @ A_x # A_xs @ A_y # A_ys) A_neg ((zs @ x # xs @ y # ys) @ L_neg) =
    mmulti_join' (A_zs @ (A_x \<union> A_y) # A_xs @ A_ys) A_neg
    ((zs @ join x True y # xs @ ys) @ L_neg)"
proof -
  have assms_dest: "table n A_x x" "table n A_y y" "wf_set n A_x" "wf_set n A_y"
    using assms
    by (auto simp del: mmulti_join'.simps simp add: list_all2_append1 dest: list_all2_lengthD)
  then have tabs: "table n (A_x \<union> A_y) (join x True y)" "wf_set n (A_x \<union> A_y)"
    using join_table[of n A_x x A_y y True "A_x \<union> A_y", OF assms_dest(1,2)] assms_dest(3,4)
    by (auto simp add: wf_set_def)
  then have list_all2': "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A)
    ((A_zs @ (A_x \<union> A_y) # A_xs @ A_ys) @ A_neg) ((zs @ join x True y # xs @ ys) @ L_neg)"
    using assms
    by (auto simp del: mmulti_join'.simps simp add: list_all2_append1 list_all2_append2
        list_all2_Cons1 list_all2_Cons2 dest: list_all2_lengthD) fastforce
  have res: "\<And>z Z. wf_tuple n Z z \<Longrightarrow> A_x \<union> A_y \<subseteq> Z \<Longrightarrow>
    restrict (A_x \<union> A_y) z \<in> join x True y \<longleftrightarrow> restrict A_x z \<in> x \<and> restrict A_y z \<in> y"
    using join_restrict[of x n A_x y A_y True] wf_tuple_restrict_simple[of n _ _ "A_x \<union> A_y"]
      assms_dest(1,2)
    by (auto simp add: table_def restrict_nested Int_absorb2)
  show ?thesis
  proof (rule set_eqI, rule iffI)
    fix z
    assume "z \<in> mmulti_join' (A_zs @ A_x # A_xs @ A_y # A_ys) A_neg
      ((zs @ x # xs @ y # ys) @ L_neg)"
    then have z_in_dest: "wf_tuple n (\<Union>(set (A_zs @ A_x # A_xs @ A_y # A_ys))) z"
      "list_all2 (\<lambda>A. (\<in>) (restrict A z)) A_zs zs"
      "restrict A_x z \<in> x"
      "list_all2 (\<lambda>A. (\<in>) (restrict A z)) A_ys ys"
      "restrict A_y z \<in> y"
      "list_all2 (\<lambda>A. (\<in>) (restrict A z)) A_xs xs"
      "list_all2 (\<lambda>A. (\<notin>) (restrict A z)) A_neg L_neg"
      using mmulti_join'_correct[OF _ assms(1), of z]
      by (auto simp del: mmulti_join'.simps simp add: assms list_all2_append1
          dest: list_all2_lengthD)
    then show "z \<in> mmulti_join' (A_zs @ (A_x \<union> A_y) # A_xs @ A_ys) A_neg
      ((zs @ join x True y # xs @ ys) @ L_neg)"
      using mmulti_join'_correct[OF _ list_all2', of z] res[OF z_in_dest(1)]
      by (auto simp add: assms list_all2_appendI le_supI2 Un_assoc simp del: mmulti_join'.simps
          dest: list_all2_lengthD)
  next
    fix z
    assume "z \<in> mmulti_join' (A_zs @ (A_x \<union> A_y) # A_xs @ A_ys) A_neg
      ((zs @ join x True y # xs @ ys) @ L_neg)"
    then have z_in_dest: "wf_tuple n (\<Union>(set (A_zs @ A_x # A_xs @ A_y # A_ys))) z"
      "list_all2 (\<lambda>A. (\<in>) (restrict A z)) A_zs zs"
      "restrict (A_x \<union> A_y) z \<in> join x True y"
      "list_all2 (\<lambda>A. (\<in>) (restrict A z)) A_ys ys"
      "list_all2 (\<lambda>A. (\<in>) (restrict A z)) A_xs xs"
      "list_all2 (\<lambda>A. (\<notin>) (restrict A z)) A_neg L_neg"
      using mmulti_join'_correct[OF _ list_all2', of z]
      by (auto simp del: mmulti_join'.simps simp add: assms list_all2_append Un_assoc
          dest: list_all2_lengthD)
    then show "z \<in> mmulti_join' (A_zs @ A_x # A_xs @ A_y # A_ys) A_neg
      ((zs @ x # xs @ y # ys) @ L_neg)"
      using mmulti_join'_correct[OF _ assms(1), of z] res[OF z_in_dest(1)]
      by (auto simp add: assms list_all2_appendI le_supI2 Un_assoc simp del: mmulti_join'.simps
          dest: list_all2_lengthD)
  qed
qed

lemma list_all2_opt_False:
  assumes "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A)
    ((A_zs @ A_x # A_xs) @ (A_ws @ A_y # A_ys)) ((zs @ x # xs) @ (ws @ y # ys))"
    "length A_ws = length ws" "length A_xs = length xs"
    "length A_ys = length ys" "length A_zs = length zs"
    "A_y \<subseteq> A_x"
  shows "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A)
    ((A_zs @ A_x # A_xs) @ (A_ws @ A_ys)) ((zs @ join x False y # xs) @ (ws @ ys))"
proof -
  have assms_dest: "table n A_x x" "table n A_y y" "wf_set n A_x" "wf_set n A_y"
    using assms
    by (auto simp del: mmulti_join'.simps simp add: list_all2_append dest: list_all2_lengthD)
  have tabs: "table n A_x (join x False y)"
    using join_table[of n A_x x A_y y False A_x, OF assms_dest(1,2) assms(6)] assms(6) by auto
  then show "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A)
    ((A_zs @ A_x # A_xs) @ (A_ws @ A_ys)) ((zs @ join x False y # xs) @ (ws @ ys))"
    using assms assms_dest(3)
    by (auto simp del: mmulti_join'.simps simp add: list_all2_append1 list_all2_append2
        list_all2_Cons1 list_all2_Cons2 dest: list_all2_lengthD) fastforce
qed

lemma mmulti_join'_opt_False:
  assumes "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A)
    ((A_zs @ A_x # A_xs) @ (A_ws @ A_y # A_ys)) ((zs @ x # xs) @ (ws @ y # ys))"
    "length A_ws = length ws" "length A_xs = length xs"
    "length A_ys = length ys" "length A_zs = length zs"
    "A_y \<subseteq> A_x"
  shows "mmulti_join' (A_zs @ A_x # A_xs) (A_ws @ A_y # A_ys) ((zs @ x # xs) @ (ws @ y # ys)) =
    mmulti_join' (A_zs @ A_x # A_xs) (A_ws @ A_ys) ((zs @ join x False y # xs) @ (ws @ ys))"
proof -
  have assms_dest: "table n A_x x" "table n A_y y" "wf_set n A_x" "wf_set n A_y"
    using assms
    by (auto simp del: mmulti_join'.simps simp add: list_all2_append dest: list_all2_lengthD)
  have tabs: "table n A_x (join x False y)"
    using join_table[of n A_x x A_y y False A_x, OF assms_dest(1,2) assms(6)] assms(6) by auto
  then have list_all2': "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A)
    ((A_zs @ A_x # A_xs) @ (A_ws @ A_ys)) ((zs @ join x False y # xs) @ (ws @ ys))"
    using assms assms_dest(3)
    by (auto simp del: mmulti_join'.simps simp add: list_all2_append1 list_all2_append2
        list_all2_Cons1 list_all2_Cons2 dest: list_all2_lengthD) fastforce
  have res: "\<And>z. restrict A_x z \<in> join x False y \<longleftrightarrow> restrict A_x z \<in> x \<and> restrict A_y z \<notin> y"
    using join_restrict[of x n A_x y A_y False, OF _ _ assms(6)] assms_dest(1,2) assms(6)
    by (auto simp add: table_def restrict_nested Int_absorb2 Un_absorb2)
  show ?thesis
  proof (rule set_eqI, rule iffI)
    fix z
    assume "z \<in> mmulti_join' (A_zs @ A_x # A_xs) (A_ws @ A_y # A_ys)
      ((zs @ x # xs) @ ws @ y # ys)"
    then have z_in_dest: "wf_tuple n (\<Union>(set (A_zs @ A_x # A_xs))) z"
      "list_all2 (\<lambda>A. (\<in>) (restrict A z)) A_zs zs"
      "restrict A_x z \<in> x"
      "list_all2 (\<lambda>A. (\<in>) (restrict A z)) A_xs xs"
      "list_all2 (\<lambda>A. (\<notin>) (restrict A z)) A_ws ws"
      "restrict A_y z \<notin> y"
      "list_all2 (\<lambda>A. (\<notin>) (restrict A z)) A_ys ys"
      using mmulti_join'_correct[OF _ assms(1), of z]
      by (auto simp del: mmulti_join'.simps simp add: assms list_all2_append1
          dest: list_all2_lengthD)
    then show "z \<in> mmulti_join' (A_zs @ A_x # A_xs) (A_ws @ A_ys)
      ((zs @ join x False y # xs) @ ws @ ys)"
      using mmulti_join'_correct[OF _ list_all2', of z] res
      by (auto simp add: assms list_all2_appendI Un_assoc simp del: mmulti_join'.simps
          dest: list_all2_lengthD)
  next
    fix z
    assume "z \<in> mmulti_join' (A_zs @ A_x # A_xs) (A_ws @ A_ys)
      ((zs @ join x False y # xs) @ ws @ ys)"
    then have z_in_dest: "wf_tuple n (\<Union>(set (A_zs @ A_x # A_xs))) z"
      "list_all2 (\<lambda>A. (\<in>) (restrict A z)) A_zs zs"
      "restrict A_x z \<in> join x False y"
      "list_all2 (\<lambda>A. (\<in>) (restrict A z)) A_xs xs"
      "list_all2 (\<lambda>A. (\<notin>) (restrict A z)) A_ws ws"
      "list_all2 (\<lambda>A. (\<notin>) (restrict A z)) A_ys ys"
      using mmulti_join'_correct[OF _ list_all2', of z]
      by (auto simp del: mmulti_join'.simps simp add: assms list_all2_append1
          dest: list_all2_lengthD)
    then show "z \<in> mmulti_join' (A_zs @ A_x # A_xs) (A_ws @ A_y # A_ys)
      ((zs @ x # xs) @ ws @ y # ys)"
      using mmulti_join'_correct[OF _ assms(1), of z] res
      by (auto simp add: assms list_all2_appendI Un_assoc simp del: mmulti_join'.simps
          dest: list_all2_lengthD)
  qed
qed

fun find_sub_in :: "'a set \<Rightarrow> 'a set list \<Rightarrow> bool \<Rightarrow>
  ('a set list \<times> 'a set \<times> 'a set list) option" where
  "find_sub_in X [] b = None"
| "find_sub_in X (x # xs) b = (if (x \<subseteq> X \<or> (b \<and> X \<subseteq> x)) then Some ([], x, xs)
    else (case find_sub_in X xs b of None \<Rightarrow> None | Some (ys, z, zs) \<Rightarrow> Some (x # ys, z, zs)))"

lemma find_sub_in_sound: "find_sub_in X xs b = Some (ys, z, zs) \<Longrightarrow>
  xs = ys @ z # zs \<and> (z \<subseteq> X \<or> (b \<and> X \<subseteq> z))"
  by (induction X xs b arbitrary: ys z zs rule: find_sub_in.induct)
     (fastforce split: if_splits option.splits)+

fun find_sub_True :: "'a set list \<Rightarrow>
  ('a set list \<times> 'a set \<times> 'a set list \<times> 'a set \<times> 'a set list) option" where
  "find_sub_True [] = None"
| "find_sub_True (x # xs) = (case find_sub_in x xs True of None \<Rightarrow>
    (case find_sub_True xs of None \<Rightarrow> None
    | Some (ys, w, ws, z, zs) \<Rightarrow> Some (x # ys, w, ws, z, zs))
  | Some (ys, z, zs) \<Rightarrow> Some ([], x, ys, z, zs))"

lemma find_sub_True_sound: "find_sub_True xs = Some (ys, w, ws, z, zs) \<Longrightarrow>
  xs = ys @ w # ws @ z # zs \<and> (z \<subseteq> w \<or> w \<subseteq> z)"
  using find_sub_in_sound
  by (induction xs arbitrary: ys w ws z zs rule: find_sub_True.induct)
     (fastforce split: option.splits)+

fun find_sub_False :: "'a set list \<Rightarrow> 'a set list \<Rightarrow>
  (('a set list \<times> 'a set \<times> 'a set list) \<times> ('a set list \<times> 'a set \<times> 'a set list)) option" where
  "find_sub_False [] ns = None"
| "find_sub_False (x # xs) ns = (case find_sub_in x ns False of None \<Rightarrow>
    (case find_sub_False xs ns of None \<Rightarrow> None
    | Some ((rs, w, ws), (ys, z, zs)) \<Rightarrow> Some ((x # rs, w, ws), (ys, z, zs)))
  | Some (ys, z, zs) \<Rightarrow> Some (([], x, xs), (ys, z, zs)))"

lemma find_sub_False_sound: "find_sub_False xs ns = Some ((rs, w, ws), (ys, z, zs)) \<Longrightarrow>
  xs = rs @ w # ws \<and> ns = ys @ z # zs \<and> (z \<subseteq> w)"
  using find_sub_in_sound
  by (induction xs ns arbitrary: rs w ws ys z zs rule: find_sub_False.induct)
     (fastforce split: option.splits)+

fun proj_list_3 :: "'a list \<Rightarrow> ('b list \<times> 'b \<times> 'b list) \<Rightarrow> ('a list \<times> 'a \<times> 'a list)" where
  "proj_list_3 xs (ys, z, zs) = (take (length ys) xs, xs ! (length ys),
    take (length zs) (drop (length ys + 1) xs))"

lemma proj_list_3_same:
  assumes "proj_list_3 xs (ys, z, zs) = (ys', z', zs')"
    "length xs = length ys + 1 + length zs"
  shows "xs = ys' @ z' # zs'"
  using assms by (auto simp add: id_take_nth_drop)

lemma proj_list_3_length:
  assumes "proj_list_3 xs (ys, z, zs) = (ys', z', zs')"
    "length xs = length ys + 1 + length zs"
  shows "length ys = length ys'" "length zs = length zs'"
  using assms by auto

fun proj_list_5 :: "'a list \<Rightarrow>
  ('b list \<times> 'b \<times> 'b list \<times> 'b \<times> 'b list) \<Rightarrow>
  ('a list \<times> 'a \<times> 'a list \<times> 'a \<times> 'a list)" where
  "proj_list_5 xs (ys, w, ws, z, zs) = (take (length ys) xs, xs ! (length ys),
    take (length ws) (drop (length ys + 1) xs), xs ! (length ys + 1 + length ws),
    drop (length ys + 1 + length ws + 1) xs)"

lemma proj_list_5_same:
  assumes "proj_list_5 xs (ys, w, ws, z, zs) = (ys', w', ws', z', zs')"
    "length xs = length ys + 1 + length ws + 1 + length zs"
  shows "xs = ys' @ w' # ws' @ z' # zs'"
proof -
  have "xs ! length ys # take (length ws) (drop (Suc (length ys)) xs) = take (Suc (length ws)) (drop (length ys) xs)"
    using assms(2) by (simp add: list_eq_iff_nth_eq nth_Cons split: nat.split)
  moreover have "take (Suc (length ws)) (drop (length ys) xs) @ drop (Suc (length ys + length ws)) xs =
      drop (length ys) xs"
    unfolding Suc_eq_plus1 add.assoc[of _ _ 1] add.commute[of _ "length ws + 1"]
      drop_drop[symmetric, of "length ws + 1"] append_take_drop_id ..
  ultimately show ?thesis
    using assms by (auto simp: Cons_nth_drop_Suc append_Cons[symmetric])
qed

lemma proj_list_5_length:
  assumes "proj_list_5 xs (ys, w, ws, z, zs) = (ys', w', ws', z', zs')"
    "length xs = length ys + 1 + length ws + 1 + length zs"
  shows "length ys = length ys'" "length ws = length ws'"
    "length zs = length zs'"
  using assms by auto

fun dominate_True :: "nat set list \<Rightarrow> 'a table list \<Rightarrow>
  ((nat set list \<times> nat set \<times> nat set list \<times> nat set \<times> nat set list) \<times>
  ('a table list \<times> 'a table \<times> 'a table list \<times> 'a table \<times> 'a table list)) option" where
  "dominate_True A_pos L_pos = (case find_sub_True A_pos of None \<Rightarrow> None
  | Some split \<Rightarrow> Some (split, proj_list_5 L_pos split))"

lemma find_sub_True_proj_list_5_same:
  assumes "find_sub_True xs = Some (ys, w, ws, z, zs)" "length xs = length xs'"
    "proj_list_5 xs' (ys, w, ws, z, zs) = (ys', w', ws', z', zs')"
  shows "xs' = ys' @ w' # ws' @ z' # zs'"
proof -
  have len: "length xs' = length ys + 1 + length ws + 1 + length zs"
    using find_sub_True_sound[OF assms(1)] by (auto simp add: assms(2)[symmetric])
  show ?thesis
    using proj_list_5_same[OF assms(3) len] .
qed

lemma dominate_True_sound:
  assumes "dominate_True A_pos L_pos = Some ((A_zs, A_x, A_xs, A_y, A_ys), (zs, x, xs, y, ys))"
    "length A_pos = length L_pos"
  shows "A_pos = A_zs @ A_x # A_xs @ A_y # A_ys" "L_pos = zs @ x # xs @ y # ys"
    "length A_xs = length xs" "length A_ys = length ys" "length A_zs = length zs"
  using assms find_sub_True_sound find_sub_True_proj_list_5_same find_sub_True_proj_list_5_length
  by (auto simp del: proj_list_5.simps split: option.splits) fast+

fun dominate_False :: "nat set list \<Rightarrow> 'a table list \<Rightarrow> nat set list \<Rightarrow> 'a table list \<Rightarrow>
  (((nat set list \<times> nat set \<times> nat set list) \<times> nat set list \<times> nat set \<times> nat set list) \<times>
  (('a table list \<times> 'a table \<times> 'a table list) \<times>
  'a table list \<times> 'a table \<times> 'a table list)) option" where
  "dominate_False A_pos L_pos A_neg L_neg = (case find_sub_False A_pos A_neg of None \<Rightarrow> None
  | Some (pos_split, neg_split) \<Rightarrow>
    Some ((pos_split, neg_split), (proj_list_3 L_pos pos_split, proj_list_3 L_neg neg_split)))"

lemma find_sub_False_proj_list_3_same_left:
  assumes "find_sub_False xs ns = Some ((rs, w, ws), (ys, z, zs))"
    "length xs = length xs'" "proj_list_3 xs' (rs, w, ws) = (rs', w', ws')"
  shows "xs' = rs' @ w' # ws'"
proof -
  have len: "length xs' = length rs + 1 + length ws"
    using find_sub_False_sound[OF assms(1)] by (auto simp add: assms(2)[symmetric])
  show ?thesis
    using proj_list_3_same[OF assms(3) len] .
qed

lemma find_sub_False_proj_list_3_length_left:
  assumes "find_sub_False xs ns = Some ((rs, w, ws), (ys, z, zs))"
    "length xs = length xs'" "proj_list_3 xs' (rs, w, ws) = (rs', w', ws')"
  shows "length rs = length rs'" "length ws = length ws'"
  using find_sub_False_sound[OF assms(1)] proj_list_3_length[OF assms(3)] assms(2) by auto

lemma find_sub_False_proj_list_3_same_right:
  assumes "find_sub_False xs ns = Some ((rs, w, ws), (ys, z, zs))"
    "length ns = length ns'" "proj_list_3 ns' (ys, z, zs) = (ys', z', zs')"
  shows "ns' = ys' @ z' # zs'"
proof -
  have len: "length ns' = length ys + 1 + length zs"
    using find_sub_False_sound[OF assms(1)] by (auto simp add: assms(2)[symmetric])
  show ?thesis
    using proj_list_3_same[OF assms(3) len] .
qed

lemma find_sub_False_proj_list_3_length_right:
  assumes "find_sub_False xs ns = Some ((rs, w, ws), (ys, z, zs))"
    "length ns = length ns'" "proj_list_3 ns' (ys, z, zs) = (ys', z', zs')"
  shows "length ys = length ys'" "length zs = length zs'"
  using find_sub_False_sound[OF assms(1)] proj_list_3_length[OF assms(3)] assms(2) by auto

lemma dominate_False_sound:
  assumes "dominate_False A_pos L_pos A_neg L_neg =
    Some (((A_zs, A_x, A_xs), A_ws, A_y, A_ys), ((zs, x, xs), ws, y, ys))"
    "length A_pos = length L_pos" "length A_neg = length L_neg"
  shows "A_pos = (A_zs @ A_x # A_xs)" "A_neg = A_ws @ A_y # A_ys"
    "L_pos = (zs @ x # xs)" "L_neg = ws @ y # ys"
    "length A_ws = length ws" "length A_xs = length xs"
    "length A_ys = length ys" "length A_zs = length zs"
    "A_y \<subseteq> A_x"
  using assms find_sub_False_proj_list_3_same_left find_sub_False_proj_list_3_same_right
    find_sub_False_proj_list_3_length_left find_sub_False_proj_list_3_length_right
    find_sub_False_sound
  by (auto simp del: proj_list_3.simps split: option.splits) fast+

function mmulti_join :: "(nat \<Rightarrow> nat set list \<Rightarrow> nat set list \<Rightarrow> 'a table list \<Rightarrow> 'a table)" where
  "mmulti_join n A_pos A_neg L = (if length A_pos + length A_neg \<noteq> length L then {} else
    let L_pos = take (length A_pos) L; L_neg = drop (length A_pos) L in
    (case dominate_True A_pos L_pos of None \<Rightarrow>
      (case dominate_False A_pos L_pos A_neg L_neg of None \<Rightarrow> mmulti_join' A_pos A_neg L
      | Some (((A_zs, A_x, A_xs), A_ws, A_y, A_ys), ((zs, x, xs), ws, y, ys)) \<Rightarrow>
        mmulti_join n (A_zs @ A_x # A_xs) (A_ws @ A_ys)
        ((zs @ bin_join n A_x x False A_y y # xs) @ (ws @ ys)))
    | Some ((A_zs, A_x, A_xs, A_y, A_ys), (zs, x, xs, y, ys)) \<Rightarrow>
      mmulti_join n (A_zs @ (A_x \<union> A_y) # A_xs @ A_ys) A_neg
      ((zs @ bin_join n A_x x True A_y y # xs @ ys) @ L_neg)))"
  by pat_completeness auto
termination
  by (relation "measure (\<lambda>(n, A_pos, A_neg, L). length A_pos + length A_neg)")
    (use find_sub_True_sound find_sub_False_sound in \<open>fastforce split: option.splits\<close>)+

lemma mmulti_join_link:
  assumes "A_pos \<noteq> []"
      and "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A) (A_pos @ A_neg) L"
    shows "mmulti_join n A_pos A_neg L = mmulti_join' A_pos A_neg L"
  using assms
proof (induction A_pos A_neg L rule: mmulti_join.induct)
  case (1 n A_pos A_neg L)
  define L_pos where "L_pos = take (length A_pos) L"
  define L_neg where "L_neg = drop (length A_pos) L"
  have L_def: "L = L_pos @ L_neg"
    using L_pos_def L_neg_def by auto
  have lens_match: "length A_pos = length L_pos" "length A_neg = length L_neg"
    using L_pos_def L_neg_def 1(4)[unfolded L_def] by (auto dest: list_all2_lengthD)
  then have lens_sum: "length A_pos + length A_neg = length L"
    by (auto simp add: L_def)
  show ?case
  proof (cases "dominate_True A_pos L_pos")
    case None
    note dom_True = None
    show ?thesis
    proof (cases "dominate_False A_pos L_pos A_neg L_neg")
      case None
      show ?thesis
        by (subst mmulti_join.simps)
           (simp del: dominate_True.simps dominate_False.simps mmulti_join.simps
            mmulti_join'.simps add: Let_def dom_True L_pos_def[symmetric] None
            L_neg_def[symmetric] lens_sum split: option.splits)
    next
      case (Some a)
      then obtain A_zs A_x A_xs A_ws A_y A_ys zs x xs ws y ys where
        dom_False: "dominate_False A_pos L_pos A_neg L_neg =
        Some (((A_zs, A_x, A_xs), A_ws, A_y, A_ys), ((zs, x, xs), ws, y, ys))"
        by (cases a) auto
      note list_all2 = 1(4)[unfolded L_def dominate_False_sound[OF dom_False lens_match]]
      have lens: "length A_ws = length ws" "length A_xs = length xs"
        "length A_ys = length ys" "length A_zs = length zs"
        using dominate_False_sound[OF dom_False lens_match] by auto
      have sub: "A_y \<subseteq> A_x"
        using dominate_False_sound[OF dom_False lens_match] by auto
      have list_all2': "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A)
        ((A_zs @ A_x # A_xs) @ (A_ws @ A_ys)) ((zs @ join x False y # xs) @ (ws @ ys))"
        using list_all2_opt_False[OF list_all2 lens sub] .
      have tabs: "table n A_x x" "table n A_y y"
        using list_all2 by (auto simp add: lens list_all2_append)
      have bin_join_conv: "join x False y = bin_join n A_x x False A_y y"
        using bin_join_table[OF tabs, symmetric] .
      have mmulti: "mmulti_join n A_pos A_neg L = mmulti_join n (A_zs @ A_x # A_xs) (A_ws @ A_ys)
        ((zs @ bin_join n A_x x False A_y y # xs) @ (ws @ ys))"
        by (subst mmulti_join.simps)
           (simp del: dominate_True.simps dominate_False.simps mmulti_join.simps
            add: Let_def dom_True L_pos_def[symmetric] L_neg_def[symmetric] dom_False lens_sum)
      show ?thesis
        unfolding mmulti
        unfolding L_def dominate_False_sound[OF dom_False lens_match]
        by (rule 1(1)[OF _ L_pos_def L_neg_def dom_True dom_False,
            OF _ _ _ _ _ _ _ _ _ _ _ _ _ list_all2'[unfolded bin_join_conv],
            unfolded mmulti_join'_opt_False[OF list_all2 lens sub, symmetric,
            unfolded bin_join_conv]])
           (auto simp add: lens_sum)
    qed
  next
    case (Some a)
    then obtain A_zs A_x A_xs A_y A_ys zs x xs y ys where dom_True: "dominate_True A_pos L_pos =
      Some ((A_zs, A_x, A_xs, A_y, A_ys), (zs, x, xs, y, ys))"
      by (cases a) auto
    note list_all2 = 1(4)[unfolded L_def dominate_True_sound[OF dom_True lens_match(1)]]
    have lens: "length A_xs = length xs" "length A_ys = length ys" "length A_zs = length zs"
      using dominate_True_sound[OF dom_True lens_match(1)] by auto
    have list_all2': "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A)
      ((A_zs @ (A_x \<union> A_y) # A_xs @ A_ys) @ A_neg) ((zs @ join x True y # xs @ ys) @ L_neg)"
      using list_all2_opt_True[OF list_all2 lens] .
    have tabs: "table n A_x x" "table n A_y y"
        using list_all2 by (auto simp add: lens list_all2_append)
    have bin_join_conv: "join x True y = bin_join n A_x x True A_y y"
      using bin_join_table[OF tabs, symmetric] .
    have mmulti: "mmulti_join n A_pos A_neg L = mmulti_join n (A_zs @ (A_x \<union> A_y) # A_xs @ A_ys)
      A_neg ((zs @ bin_join n A_x x True A_y y # xs @ ys) @ L_neg)"
      by (subst mmulti_join.simps)
         (simp del: dominate_True.simps dominate_False.simps mmulti_join.simps
          add: Let_def dom_True L_pos_def[symmetric] L_neg_def lens_sum)
    show ?thesis
      unfolding mmulti
      unfolding L_def dominate_True_sound[OF dom_True lens_match(1)]
      by (rule 1(2)[OF _ L_pos_def L_neg_def dom_True,
          OF _ _ _ _ _ _ _ _ _ _ _ list_all2'[unfolded bin_join_conv],
          unfolded mmulti_join'_opt_True[OF list_all2 lens, symmetric,
          unfolded bin_join_conv]])
         (auto simp add: lens_sum)
  qed
qed

lemma mmulti_join_correct:
  assumes "A_pos \<noteq> []"
      and "list_all2 (\<lambda>A X. table n A X \<and> wf_set n A) (A_pos @ A_neg) L"
  shows "z \<in> mmulti_join n A_pos A_neg L \<longleftrightarrow> wf_tuple n (\<Union>A\<in>set A_pos. A) z \<and>
    list_all2 (\<lambda>A X. restrict A z \<in> X) A_pos (take (length A_pos) L) \<and>
    list_all2 (\<lambda>A X. restrict A z \<notin> X) A_neg (drop (length A_pos) L)"
  unfolding mmulti_join_link[OF assms] using mmulti_join'_correct[OF assms] .

end


(*  Title:       Category theory using Isar and Locales
    Author:      Greg O'Keefe, June, July, August 2003
    License: LGPL

Define natural transformation, prove that the identity arrow function is one.
*)

header {* Natural Transformations *}

theory NatTrans
imports Functors
begin

(* guess the third axiom is implied by the fifth *)
locale natural_transformation = two_cats +
  fixes F and G and u
  assumes "Functor F : AA \<longrightarrow> BB"
  and "Functor G : AA \<longrightarrow> BB"
  and "u : ob AA \<rightarrow> ar BB"
  and "u \<in> extensional (ob AA)"
  and "\<forall>A\<in>Ob. u A \<in> Hom\<^bsub>BB\<^esub> (F\<^bsub>\<o>\<^esub> A) (G\<^bsub>\<o>\<^esub> A)"
  and "\<forall>A\<in>Ob. \<forall>B\<in>Ob. \<forall>f\<in>Hom A B. (G\<^bsub>\<a>\<^esub> f) \<bullet>\<^bsub>BB\<^esub> (u A) = (u B) \<bullet>\<^bsub>BB\<^esub> (F\<^bsub>\<a>\<^esub> f)"

abbreviation
  nt_syn  ("_ : _ \<Rightarrow> _ in Func '(_ , _ ')" [81]) where
  "u : F \<Rightarrow> G in Func(AA, BB) \<equiv> natural_transformation AA BB F G u"

(* is this doing what I think its doing? *)
locale endoNT = natural_transformation + one_cat

theorem (in endoNT) id_restrict_natural:
  "(\<lambda>A\<in>Ob. Id A) : (id_func AA) \<Rightarrow> (id_func AA) in Func(AA,AA)"
proof (intro natural_transformation.intro natural_transformation_axioms.intro
    two_cats.intro ballI)
  show "(\<lambda>A\<in>Ob. Id A) : Ob \<rightarrow> Ar"
    by (rule funcsetI) auto
  show "(\<lambda>A\<in>Ob. Id A) \<in> extensional (Ob)"
    by (rule restrict_extensional)
  fix A
  assume A: "A \<in> Ob"
  hence "Id A \<in> Hom A A" ..
  thus "(\<lambda>X\<in>Ob. Id X) A \<in> Hom ((id_func AA)\<^bsub>\<o>\<^esub> A)  ((id_func AA)\<^bsub>\<o>\<^esub> A)"
    using A by (simp add: id_func_def)
  fix B and f
  assume B: "B \<in> Ob"
    and "f \<in> Hom A B"
  hence "f \<in> Ar" and "A = Dom f" and "B = Cod f" and "Dom f \<in> Ob" and "Cod f \<in> Ob"
    using A by (simp_all add: hom_def)
  thus "(id_func AA)\<^bsub>\<a>\<^esub> f \<bullet> (\<lambda>A\<in>Ob. Id A) A
      = (\<lambda>A\<in>Ob. Id A) B \<bullet> (id_func AA)\<^bsub>\<a>\<^esub> f"
    by (simp add:  id_func_def)
qed (auto intro: id_func_functor, unfold_locales, unfold_locales)

end


theory Trees imports "HOL-Library.Linear_Temporal_Logic_on_Streams" begin

(* TODO: find a shorter naming convention for selectors? *)

(* TODO: maybe the property should go last in alwt etc. "alwt tab P" *)

(* TODO: would it be nicer to use fsets than lists for the subs? *)

codatatype (labels: 'a) tree = Node (getLabel: 'a) (getSubs: \<open>'a tree list\<close>)
  for map: tmap

lemmas tmap_simps[simp] = tree.map_sel
lemmas getLabel_labels = tree.set_sel(1)
lemmas getSubs_labels = tree.set_sel(2)

section \<open>Trees over fixed sets of labels\<close>

coinductive_set
  trees :: "'a set \<Rightarrow> 'a tree set"
  for A :: "'a set"
where
  Tree[intro, simp, no_atp]: \<open>\<lbrakk>l \<in> A; \<forall>s \<in> set subs. s \<in> trees A\<rbrakk> \<Longrightarrow> Node l subs \<in> trees A\<close>

lemma in_trees: \<open>\<forall>s \<in> set (getSubs t). s \<in> trees A \<Longrightarrow> getLabel t \<in> A \<Longrightarrow> t \<in> trees A\<close>
  by (cases t) simp_all

lemma treesE: \<open>t \<in> trees A \<Longrightarrow> (getLabel t \<in> A \<Longrightarrow> \<forall>s \<in> set (getSubs t). s \<in> trees A \<Longrightarrow> P) \<Longrightarrow> P\<close>
  by (auto elim: trees.cases)

lemma Trees_image: \<open>Node x y \<in> (Node x') ` Y \<longleftrightarrow> x = x' \<and> y \<in> Y\<close>
  by auto

lemma trees_Trees: \<open>Node l subs \<in> trees A \<longleftrightarrow> l \<in> A \<and> (\<forall>s \<in> set subs. s \<in> trees A)\<close>
  by (auto elim: trees.cases)

lemma labels_trees:
  assumes \<open>labels t \<subseteq> A\<close>
  shows \<open>t \<in> trees A\<close>
  using assms
proof (coinduction arbitrary: t)
  case trees then show ?case by (cases t) auto
qed

lemma trees_labels:
  assumes \<open>t \<in> trees A\<close>
  shows \<open>labels t \<subseteq> A\<close>
proof
  fix l
  assume \<open>l \<in> labels t\<close>
  then show \<open>l \<in> A\<close>
    using \<open>t \<in> trees A\<close> by (induct t) (auto elim: treesE)
qed

lemma trees_iff_labels: \<open>t \<in> trees A \<longleftrightarrow> labels t \<subseteq> A\<close>
  by (metis labels_trees trees_labels)

lemma trees_mono: \<open>t \<in> trees A \<Longrightarrow> A \<subseteq> B \<Longrightarrow> t \<in> trees B\<close>
  unfolding trees_iff_labels by auto

lemma trees_mono2: \<open>S \<subseteq> T \<Longrightarrow> trees S \<subseteq> trees T\<close>
  by (auto intro: trees_mono)

lemma tmap_trees: \<open>t \<in> trees A \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> f x \<in> B) \<Longrightarrow> tmap f t \<in> trees B\<close>
  unfolding trees_iff_labels tree.set_map by fast

lemma streams_empty: \<open>trees {} = {}\<close>
  by (auto elim: trees.cases)

lemma streams_UNIV[simp]: \<open>trees UNIV = UNIV\<close>
  by (auto simp: trees_iff_labels)

section \<open>Finite trees and infinite paths\<close>

inductive fin :: \<open>'a tree \<Rightarrow> bool\<close> where
  Fin: \<open>\<forall>s \<in> set subs. fin s \<Longrightarrow> fin (Node l subs)\<close>

abbreviation infin :: \<open>'a tree \<Rightarrow> bool\<close> where
  \<open>infin x \<equiv> \<not> fin x\<close>

coinductive ipath :: \<open>'a tree \<Rightarrow> 'a stream \<Rightarrow> bool\<close> where
  IPath: \<open>s \<in> set subs \<Longrightarrow> ipath s tail \<Longrightarrow> ipath (Node l subs) (l ## tail)\<close>

lemma fin_no_ipath: \<open>fin tab \<Longrightarrow> \<not> ipath tab path\<close>
  by (induct tab arbitrary: path rule: fin.induct) (auto elim: ipath.cases)

lemma infin_sub: \<open>infin tab \<Longrightarrow> \<exists>s \<in> set (getSubs tab). infin s\<close>
  using Fin by (metis tree.exhaust_sel)

primcorec get_ipath :: \<open>'a tree \<Rightarrow> 'a stream\<close> where
  \<open>shd (get_ipath t) = getLabel t\<close>
| \<open>stl (get_ipath t) = get_ipath (SOME s. s \<in> set (getSubs t) \<and> infin s)\<close>

lemma ipath: \<open>infin tab \<Longrightarrow> ipath tab (get_ipath tab)\<close>
  by (coinduction arbitrary: tab)
    (metis (no_types, lifting) get_ipath.code infin_sub someI_ex tree.exhaust_sel)

corollary \<open>\<nexists>path. ipath tab path \<Longrightarrow> fin tab\<close>
  using ipath by blast

section \<open>Properties Inherited by Paths\<close>

datatype 'a rel
  = Here \<open>'a \<Rightarrow> bool\<close>
  | Next \<open>'a rel\<close>
  | Also \<open>'a rel\<close> \<open>'a rel\<close>
  | Impl \<open>'a \<Rightarrow> bool\<close> \<open>'a rel\<close>

primrec relt :: \<open>'a rel \<Rightarrow> 'a tree \<Rightarrow> bool\<close> where
  \<open>relt (Here P) t = P (getLabel t)\<close>
| \<open>relt (Next r) t = (\<forall>s \<in> set (getSubs t). relt r s)\<close>
| \<open>relt (Also r r') = relt r aand relt r'\<close>
| \<open>relt (Impl P r) = (P o getLabel) impl relt r\<close>

primrec rels :: \<open>'a rel \<Rightarrow> 'a stream \<Rightarrow> bool\<close> where
  \<open>rels (Here P) = holds P\<close>
| \<open>rels (Next r) = nxt (rels r)\<close>
| \<open>rels (Also r r') = rels r aand rels r'\<close>
| \<open>rels (Impl P r) = holds P impl rels r\<close>

lemma relt_ipath:
  assumes \<open>relt r t\<close> \<open>ipath t s\<close>
  shows \<open>rels r s\<close>
  using assms
  by (induct r arbitrary: t s) (fastforce elim: ipath.cases)+

section \<open>Trees where every subtree satisfies a property.\<close>

coinductive alwt :: \<open>('a tree \<Rightarrow> bool) \<Rightarrow> 'a tree \<Rightarrow> bool\<close> where
  AlwT: \<open>P t \<Longrightarrow> \<forall>s \<in> set (getSubs t). alwt P s \<Longrightarrow> alwt P t\<close>

abbreviation holdst :: \<open>('a \<Rightarrow> bool) \<Rightarrow> 'a tree \<Rightarrow> bool\<close> where
  \<open>holdst P t \<equiv> P (getLabel t)\<close>

lemma alwt_holdst_trees: \<open>alwt (holdst P) t \<Longrightarrow> t \<in> trees (Collect P)\<close>
  by (coinduction arbitrary: t) (metis mem_Collect_eq alwt.cases tree.collapse)

lemma trees_alwt: \<open>t \<in> trees (Collect P) \<Longrightarrow> alwt (holdst P) t\<close>
  by (coinduction arbitrary: t) (auto elim: trees.cases)

lemma alwt_holdst_labels: \<open>alwt (holdst P) t \<Longrightarrow> l \<in> labels t \<Longrightarrow> P l\<close>
  using alwt_holdst_trees trees_labels by blast

lemma labels_alwt_holdst: \<open>\<forall>l \<in> labels t. P l \<Longrightarrow> alwt (holdst P) t\<close>
  by (simp add: trees_alwt Ball_Collect labels_trees)

corollary labels_alwt': \<open>alwt (holdst (\<lambda>n. n \<in> labels t)) t\<close>
  using labels_alwt_holdst by fast

lemma alwt_True: \<open>alwt (\<lambda>_. True) t\<close>
  by (coinduction arbitrary: t) simp_all

subsection \<open>Paths\<close>

lemma alw_sset: \<open>alw (holds P) stream \<Longrightarrow> s \<in> sset stream \<Longrightarrow> P s\<close>
  by (metis alw_iff_sdrop holds.simps imageE sdrop_simps(1) sset_range)

lemma sset_alw: \<open>\<forall>x \<in> sset s. P x \<Longrightarrow> alw (holds P) s\<close>
  by (simp add: alw_iff_sdrop)

lemma alw_in_sset: \<open>alw (holds (\<lambda>n. n \<in> sset s)) s\<close>
  by (simp add: sset_alw)

lemma alw_snth: \<open>alw (holds P) s \<Longrightarrow> P (s !! n)\<close>
  by (simp add: alw_iff_sdrop)

lemma alwt_ipath: \<open>alwt (holdst P) tab \<Longrightarrow> ipath tab path \<Longrightarrow> alw (holds P) path\<close>
proof (coinduction arbitrary: tab path)
  case alw
  then show ?case
    by cases (force elim: ipath.cases)
qed

lemma alw_streams: \<open>alw (holds P) s \<Longrightarrow> s \<in> streams (Collect P)\<close>
  by (meson Ball_Collect alw_sset sset_streams)

lemma trees_streams:
  assumes \<open>ipath t s\<close> \<open>t \<in> trees (Collect P)\<close>
  shows \<open>s \<in> streams (Collect P)\<close>
  using assms by (coinduction arbitrary: s)
    (meson alw_streams streams.cases alwt_ipath trees_alwt)

section \<open>Trees where every sub-tree eventually satisfies a property\<close>

inductive evt :: \<open>('a tree \<Rightarrow> bool) \<Rightarrow> 'a tree \<Rightarrow> bool\<close> where
  Here: \<open>P t \<Longrightarrow> evt P t\<close>
| There: \<open>\<forall>s \<in> set subs. evt P s \<Longrightarrow> evt P (Node l subs)\<close>

lemma alwt_evt: \<open>alwt P t \<Longrightarrow> evt P t\<close>
  by (auto elim: alwt.cases intro: evt.intros)

lemma evt_ev_holds:
  assumes \<open>evt (holdst P) t\<close> \<open>ipath t s\<close>
  shows \<open>ev (holds P) s\<close>
  using assms by (induct \<open>holdst P\<close> t arbitrary: P s)
    (fastforce simp: ev.intros elim: ipath.cases)+

section \<open>Next\<close>

abbreviation nxtt :: \<open>('a tree \<Rightarrow> bool) \<Rightarrow> 'a tree \<Rightarrow> bool\<close> where
  \<open>nxtt P t \<equiv> \<forall>s \<in> set (getSubs t). P s\<close>

lemma alwt_impl_nxtt: \<open>alwt (P impl nxtt P) t \<Longrightarrow> P t \<Longrightarrow> alwt P t\<close>
  by (coinduction arbitrary: t) (auto elim: alwt.cases)

(* TODO: is this useful? *)
lemma lift_alwt:
  assumes \<open>\<And>t. P t\<close>
  shows \<open>alwt P t\<close>
  using assms by (coinduction arbitrary: t) blast

(*
  introduces_lasting says:
  introduces _ = Some (ps, a) impl nxtt \<exists>p \<in> ps. p at a in _)

  And then preservation says it stays there.
*)

lemma alwt_holds_alw:
  assumes \<open>alwt (holdst P impl holdst Q) t\<close> \<open>ipath t s\<close>
  shows \<open>alw (holds P impl holds Q) s\<close>
  using assms
proof (coinduction arbitrary: t s)
  case alw
  then show ?case
  proof cases
    case AlwT
    with alw(2) show ?thesis
    proof cases
      case (IPath s subs tail l)
      then show ?thesis
        using AlwT by auto
    qed
  qed
qed

lemma alwt_nxt_holds_alw:
  assumes \<open>alwt (holdst P impl nxtt (holdst Q)) t\<close> \<open>ipath t s\<close>
  shows \<open>alw (holds P impl nxt (holds Q)) s\<close>
  using assms
proof (coinduction arbitrary: t s)
  case alw
  then show ?case
  proof cases
    case AlwT
    with alw(2) show ?thesis
    proof cases
      case (IPath s' subs tail l)
      moreover from this have \<open>holds P s \<longrightarrow> nxt (holds Q) s\<close>
        using AlwT by (fastforce elim: ipath.cases)
      ultimately show ?thesis
        using AlwT by auto
    qed
  qed
qed

lemma alwt_ipath_lt:
  assumes
    \<open>alwt (holdst P impl nxtt (holdst Q)) t\<close> \<open>alwt (holdst Q impl nxtt (holdst Q)) t\<close>
    \<open>ipath t s\<close> \<open>n < k\<close> \<open>P (s !! n)\<close>
  shows \<open>Q (s !! k)\<close>
proof -
  have \<open>alw (holds P impl nxt (holds Q)) s\<close>
    using assms(1, 3) alwt_nxt_holds_alw by blast
  then have \<open>alw (holds P impl nxt (holds Q)) (sdrop n s)\<close>
    using alw_sdrop by blast
  then have \<open>holds Q (sdrop (Suc n) s)\<close>
    using assms(5) by auto
  moreover have \<open>alw (holds Q impl nxt (holds Q)) s\<close>
    using assms(2-3) alwt_nxt_holds_alw by blast
  then have \<open>alw (holds Q impl nxt (holds Q)) (sdrop (Suc n) s)\<close>
    using alw_sdrop by blast
  ultimately have \<open>alw (holds Q) (sdrop (Suc n) s)\<close>
    using alw_invar by blast
  then have \<open>alw (holds Q) (sdrop k s)\<close>
    using assms(4) by (metis alw_sdrop less_iff_Suc_add sdrop.simps(2) sdrop_add)
  then show ?thesis
    by auto
qed

section \<open>Paths\<close>

lemma sset_sdrop: \<open>s \<in> sset steps \<Longrightarrow> \<exists>n. s = shd (sdrop n steps)\<close>
  by (metis imageE sdrop_simps(1) sset_range)

lemma stake_subset: \<open>n < k \<Longrightarrow> set (stake n steps) \<subseteq> set (stake k steps)\<close>
  using length_stake stake_cycle_le take_stake
  by (metis less_le set_take_subset stake_invert_Nil zero_order(2))

lemma snth_stake: \<open>steps !! n = s \<Longrightarrow> n < k \<Longrightarrow> s \<in> set (stake k steps)\<close>
  using stake_subset by (metis Suc_lessI in_set_conv_decomp stake_Suc subsetD)

lemma stake_finite:
  assumes \<open>S \<subseteq> sset steps\<close> \<open>finite S\<close>
  shows \<open>\<exists>n. S \<subseteq> set (stake n steps)\<close>
proof -
  obtain N where N: \<open>finite N\<close> \<open>\<forall>s \<in> S. \<exists>n \<in> N. steps !! n = s\<close>
    using assms by (metis (no_types, opaque_lifting) finite_subset_image imageE sset_range)
  then have \<open>\<forall>s \<in> S. s \<in> set (stake (Suc (Max N)) steps)\<close>
    using snth_stake by (metis Max_less_iff empty_iff lessI)
  then show ?thesis
    by blast
qed

lemma stake_finite':
  assumes \<open>S \<subseteq> f ` sset steps\<close> \<open>finite S\<close>
  shows \<open>\<exists>n. S \<subseteq> f ` set (stake n steps)\<close>
proof -
  obtain N where N: \<open>finite N\<close> \<open>\<forall>s \<in> S. \<exists>n \<in> N. f (steps !! n) = s\<close>
    using assms by (smt sset_range finite_subset_image image_iff) (* TODO: smt *)
  then have \<open>\<forall>s \<in> S. s \<in> f ` set (stake (Suc (Max N)) steps)\<close>
    using snth_stake by (metis Max_less_iff empty_iff image_iff lessI)
  then show ?thesis
    by blast
qed

lemma stake_snth:
  assumes \<open>s \<in> set (stake n steps)\<close>
  shows \<open>\<exists>m \<le> n. steps !! m = s\<close>
  using assms
proof (induct n)
  case 0
  then show ?case
    by simp
next
  case (Suc n)
  then consider (here) \<open>steps !! n = s\<close> | (there) \<open>s \<in> set (stake n steps)\<close>
    by (metis UnE list.set(1) list.set(2) set_append singletonD stake_Suc)
  then show ?case
    using Suc le_SucI by cases blast+
qed

end