(* Author: Alexander Bentkamp, Universität des Saarlandes
*)
theory MPoly_Type_Univariate
  imports
    More_MPoly_Type
    "HOL-Computational_Algebra.Polynomial"
begin

text \<open>This file connects univariate MPolys to the theory of univariate polynomials from
  @{theory "HOL-Computational_Algebra.Polynomial"}.\<close>

definition poly_to_mpoly::"nat \<Rightarrow> 'a::comm_monoid_add poly \<Rightarrow> 'a mpoly"
where "poly_to_mpoly v p = MPoly (Abs_poly_mapping (\<lambda>m. (coeff p (Poly_Mapping.lookup m v)) when Poly_Mapping.keys m \<subseteq> {v}))"

lemma poly_to_mpoly_finite: "finite {m::nat \<Rightarrow>\<^sub>0 nat. (coeff p (Poly_Mapping.lookup m v) when Poly_Mapping.keys m \<subseteq> {v}) \<noteq> 0}" (is "finite ?M")
proof -
  have "?M \<subseteq> Poly_Mapping.single v ` {x. Polynomial.coeff p x \<noteq> 0}"
  proof
    fix m assume "m \<in> ?M"
    then have "\<And>v'. v'\<noteq>v \<Longrightarrow> Poly_Mapping.lookup m v' = 0" by (fastforce simp add: in_keys_iff)
    then have "m = Poly_Mapping.single v (Poly_Mapping.lookup m v)"
      using Poly_Mapping.poly_mapping_eqI by (metis (full_types) lookup_single_eq lookup_single_not_eq)
    then show "m \<in> (Poly_Mapping.single v) ` {x. Polynomial.coeff p x \<noteq> 0}" using \<open>m \<in> ?M\<close> by auto
  qed
  then show ?thesis using finite_surj[OF MOST_coeff_eq_0[unfolded eventually_cofinite]] by blast
qed

lemma coeff_poly_to_mpoly: "MPoly_Type.coeff (poly_to_mpoly v p) (Poly_Mapping.single v k) = Polynomial.coeff p k"
  unfolding poly_to_mpoly_def coeff_def MPoly_inverse[OF Set.UNIV_I] lookup_Abs_poly_mapping[OF poly_to_mpoly_finite]
  using empty_subsetI keys_single lookup_single order_refl when_simps(1) by simp

definition mpoly_to_poly::"nat \<Rightarrow> 'a::comm_monoid_add mpoly \<Rightarrow> 'a poly"
where "mpoly_to_poly v p = Abs_poly (\<lambda>k. MPoly_Type.coeff p (Poly_Mapping.single v k))"

lemma coeff_mpoly_to_poly[simp]: "Polynomial.coeff (mpoly_to_poly v p) k = MPoly_Type.coeff p (Poly_Mapping.single v k)"
proof -
  have 0:"Poly_Mapping.single v ` {x. Poly_Mapping.lookup (mapping_of p) (Poly_Mapping.single v x) \<noteq> 0}
          \<subseteq> {k. Poly_Mapping.lookup (mapping_of p) k \<noteq> 0}"
    by auto
  have "\<forall>\<^sub>\<infinity> k. MPoly_Type.coeff p (Poly_Mapping.single v k) = 0" unfolding coeff_def eventually_cofinite
    using  finite_imageD[OF finite_subset[OF 0 Poly_Mapping.finite_lookup]] inj_single by (metis inj_eq inj_onI)
  then show ?thesis
    unfolding mpoly_to_poly_def by (simp add: Abs_poly_inverse)
qed

lemma mpoly_to_poly_inverse:
assumes "vars p \<subseteq> {v}"
shows "poly_to_mpoly v (mpoly_to_poly v p) = p"
proof -
  define f where "f = (\<lambda>m. Polynomial.coeff (mpoly_to_poly v p) (Poly_Mapping.lookup m v) when Poly_Mapping.keys m \<subseteq> {v})"
  have "finite {m. f m \<noteq> 0}" unfolding f_def using poly_to_mpoly_finite by blast
  have "Abs_poly_mapping f = mapping_of p"
  proof (rule "Poly_Mapping.poly_mapping_eqI")
    fix m
    show "Poly_Mapping.lookup (Abs_poly_mapping f) m = Poly_Mapping.lookup (mapping_of p) m"
    proof (cases "Poly_Mapping.keys m \<subseteq> {v}")
      assume "Poly_Mapping.keys m \<subseteq> {v}"
      then show ?thesis unfolding "Poly_Mapping.lookup_Abs_poly_mapping"[OF \<open>finite {m. f m \<noteq> 0}\<close>] unfolding f_def
        unfolding coeff_mpoly_to_poly coeff_def using when_simps(1) apply simp
        using keys_single lookup_not_eq_zero_eq_in_keys lookup_single_eq
        lookup_single_not_eq poly_mapping_eqI subset_singletonD
        by (metis (no_types, lifting) aux lookup_eq_zero_in_keys_contradict)
    next
      assume "\<not>Poly_Mapping.keys m \<subseteq> {v}"
      then show ?thesis unfolding "Poly_Mapping.lookup_Abs_poly_mapping"[OF \<open>finite {m. f m \<noteq> 0}\<close>] unfolding f_def
        using \<open>vars p \<subseteq> {v}\<close> unfolding vars_def by (metis (no_types, lifting) UN_I lookup_not_eq_zero_eq_in_keys subsetCE subsetI when_def)
    qed
  qed
  then show ?thesis
    unfolding poly_to_mpoly_def f_def  by (simp add: mapping_of_inverse)
qed

lemma poly_to_mpoly_inverse: "mpoly_to_poly v (poly_to_mpoly v p) = p"
  unfolding mpoly_to_poly_def coeff_poly_to_mpoly by (simp add: coeff_inverse)

lemma poly_to_mpoly0: "poly_to_mpoly v 0 = 0"
proof -
  have "\<And>m. (Polynomial.coeff 0 (Poly_Mapping.lookup m v) when Poly_Mapping.keys m \<subseteq> {v}) = 0" by simp
  have "Abs_poly_mapping (\<lambda>m. Polynomial.coeff 0 (Poly_Mapping.lookup m v) when Poly_Mapping.keys m \<subseteq> {v}) = 0"
    apply (rule Poly_Mapping.poly_mapping_eqI) unfolding lookup_Abs_poly_mapping[OF poly_to_mpoly_finite] by auto
  then show ?thesis using poly_to_mpoly_def zero_mpoly.abs_eq by (metis (no_types))
qed

lemma mpoly_to_poly_add: "mpoly_to_poly v (p1 + p2) = mpoly_to_poly v p1 + mpoly_to_poly v p2"
  unfolding  Polynomial.plus_poly.abs_eq More_MPoly_Type.coeff_add coeff_mpoly_to_poly
  using mpoly_to_poly_def by auto

lemma poly_eq_insertion:
assumes "vars p \<subseteq> {v}"
shows "poly (mpoly_to_poly v p) x = insertion (\<lambda>v. x) p"
using assms proof (induction p rule:mpoly_induct)
  case (monom m a)
  then show ?case
  proof (cases "a=0")
    case True
    then show ?thesis
      by (metis MPoly_Type.monom.abs_eq insertion_zero monom_zero poly_0 poly_to_mpoly0 poly_to_mpoly_inverse single_zero)
  next
    case False
    then have "Poly_Mapping.keys m \<subseteq> {v}" using monom unfolding vars_def MPoly_Type.mapping_of_monom keys_single by simp
    then have "\<And>v'. v'\<noteq>v \<Longrightarrow> Poly_Mapping.lookup m v' = 0" unfolding vars_def by (auto simp: in_keys_iff)
    then have "m = Poly_Mapping.single v (Poly_Mapping.lookup m v)"
      by (metis lookup_single_eq lookup_single_not_eq poly_mapping_eqI)
    then have 0:"insertion (\<lambda>v. x) (MPoly_Type.monom m a) = a * x ^ (Poly_Mapping.lookup m v)"
      using insertion_single by metis
    have "\<And>k. Poly_Mapping.single v k = m \<longleftrightarrow> Poly_Mapping.lookup m v = k"
      using \<open>m = Poly_Mapping.single v (Poly_Mapping.lookup m v)\<close> by auto
    then have "monom a (Poly_Mapping.lookup m v) = (Abs_poly (\<lambda>k. if Poly_Mapping.single v k = m then a else 0))"
      by (simp add: Polynomial.monom.abs_eq)
    then show ?thesis unfolding mpoly_to_poly_def More_MPoly_Type.coeff_monom 0 when_def by (metis poly_monom)
  qed
next
  case (sum p1 p2 m a)
  then have "poly (mpoly_to_poly v p1) x = insertion (\<lambda>v. x) p1"
            "poly (mpoly_to_poly v p2) x = insertion (\<lambda>v. x) p2"
    by (simp_all add: vars_add_monom)
  then show ?case unfolding insertion_add mpoly_to_poly_add by simp
qed

text \<open>Using the new connection between MPoly and univariate polynomials, we can transfer:\<close>

lemma univariate_mpoly_roots_finite:
fixes p::"'a::idom mpoly"
assumes "vars p \<subseteq> {v}" "p \<noteq> 0"
shows "finite {x. insertion (\<lambda>v. x) p = 0}"
using poly_roots_finite[of "mpoly_to_poly v p", unfolded poly_eq_insertion[OF \<open>vars p \<subseteq> {v}\<close>]]
using assms(1) assms(2) mpoly_to_poly_inverse poly_to_mpoly0 by fastforce

end


(* Author: Tobias Nipkow *)

section "Join-Based Implementation of Sets via RBTs"

theory Set2_Join_RBT
imports
  Set2_Join
  RBT_Set
begin

subsection "Code"

text \<open>
Function \<open>joinL\<close> joins two trees (and an element).
Precondition: \<^prop>\<open>bheight l \<le> bheight r\<close>.
Method:
Descend along the left spine of \<open>r\<close>
until you find a subtree with the same \<open>bheight\<close> as \<open>l\<close>,
then combine them into a new red node.
\<close>
fun joinL :: "'a rbt \<Rightarrow> 'a \<Rightarrow> 'a rbt \<Rightarrow> 'a rbt" where
"joinL l x r =
  (if bheight l \<ge> bheight r then R l x r
   else case r of
     B l' x' r' \<Rightarrow> baliL (joinL l x l') x' r' |
     R l' x' r' \<Rightarrow> R (joinL l x l') x' r')"

fun joinR :: "'a rbt \<Rightarrow> 'a \<Rightarrow> 'a rbt \<Rightarrow> 'a rbt" where
"joinR l x r =
  (if bheight l \<le> bheight r then R l x r
   else case l of
     B l' x' r' \<Rightarrow> baliR l' x' (joinR r' x r) |
     R l' x' r' \<Rightarrow> R l' x' (joinR r' x r))"

definition join :: "'a rbt \<Rightarrow> 'a \<Rightarrow> 'a rbt \<Rightarrow> 'a rbt" where
"join l x r =
  (if bheight l > bheight r
   then paint Black (joinR l x r)
   else if bheight l < bheight r
   then paint Black (joinL l x r)
   else B l x r)"

declare joinL.simps[simp del]
declare joinR.simps[simp del]

subsection "Properties"

subsubsection "Color and height invariants"

lemma invc2_joinL:
 "\<lbrakk> invc l; invc r; bheight l \<le> bheight r \<rbrakk> \<Longrightarrow>
  invc2 (joinL l x r)
  \<and> (bheight l \<noteq> bheight r \<and> color r = Black \<longrightarrow> invc(joinL l x r))"
proof (induct l x r rule: joinL.induct)
  case (1 l x r) thus ?case
    by(auto simp: invc_baliL invc2I joinL.simps[of l x r] split!: tree.splits if_splits)
qed

lemma invc2_joinR:
  "\<lbrakk> invc l; invh l; invc r; invh r; bheight l \<ge> bheight r \<rbrakk> \<Longrightarrow>
  invc2 (joinR l x r)
  \<and> (bheight l \<noteq> bheight r \<and> color l = Black \<longrightarrow> invc(joinR l x r))"
proof (induct l x r rule: joinR.induct)
  case (1 l x r) thus ?case
    by(fastforce simp: invc_baliR invc2I joinR.simps[of l x r] split!: tree.splits if_splits)
qed

lemma bheight_joinL:
  "\<lbrakk> invh l; invh r; bheight l \<le> bheight r \<rbrakk> \<Longrightarrow> bheight (joinL l x r) = bheight r"
proof (induct l x r rule: joinL.induct)
  case (1 l x r) thus ?case
    by(auto simp: bheight_baliL joinL.simps[of l x r] split!: tree.split)
qed

lemma invh_joinL:
  "\<lbrakk> invh l;  invh r;  bheight l \<le> bheight r \<rbrakk> \<Longrightarrow> invh (joinL l x r)"
proof (induct l x r rule: joinL.induct)
  case (1 l x r) thus ?case
    by(auto simp: invh_baliL bheight_joinL joinL.simps[of l x r] split!: tree.split color.split)
qed

lemma bheight_joinR:
  "\<lbrakk> invh l;  invh r;  bheight l \<ge> bheight r \<rbrakk> \<Longrightarrow> bheight (joinR l x r) = bheight l"
proof (induct l x r rule: joinR.induct)
  case (1 l x r) thus ?case
    by(fastforce simp: bheight_baliR joinR.simps[of l x r] split!: tree.split)
qed

lemma invh_joinR:
  "\<lbrakk> invh l; invh r; bheight l \<ge> bheight r \<rbrakk> \<Longrightarrow> invh (joinR l x r)"
proof (induct l x r rule: joinR.induct)
  case (1 l x r) thus ?case
    by(fastforce simp: invh_baliR bheight_joinR joinR.simps[of l x r]
        split!: tree.split color.split)
qed

text \<open>All invariants in one:\<close>

lemma inv_joinL: "\<lbrakk> invc l; invc r; invh l; invh r; bheight l \<le> bheight r \<rbrakk>
 \<Longrightarrow> invc2 (joinL l x r) \<and> (bheight l \<noteq> bheight r \<and> color r = Black \<longrightarrow>  invc (joinL l x r))
     \<and> invh (joinL l x r) \<and> bheight (joinL l x r) = bheight r"
proof (induct l x r rule: joinL.induct)
  case (1 l x r) thus ?case
    by(auto simp: inv_baliL invc2I joinL.simps[of l x r] split!: tree.splits if_splits)
qed

lemma inv_joinR: "\<lbrakk> invc l; invc r; invh l; invh r; bheight l \<ge> bheight r \<rbrakk>
 \<Longrightarrow> invc2 (joinR l x r) \<and> (bheight l \<noteq> bheight r \<and> color l = Black \<longrightarrow>  invc (joinR l x r))
     \<and> invh (joinR l x r) \<and> bheight (joinR l x r) = bheight l"
proof (induct l x r rule: joinR.induct)
  case (1 l x r) thus ?case
    by(auto simp: inv_baliR invc2I joinR.simps[of l x r] split!: tree.splits if_splits)
qed

(* unused *)
lemma rbt_join: "\<lbrakk> invc l; invh l; invc r; invh r \<rbrakk> \<Longrightarrow> rbt(join l x r)"
by(simp add: inv_joinL inv_joinR invh_paint rbt_def color_paint_Black join_def)

text \<open>To make sure the the black height is not increased unnecessarily:\<close>

lemma bheight_paint_Black: "bheight(paint Black t) \<le> bheight t + 1"
by(cases t) auto

lemma "\<lbrakk> rbt l; rbt r \<rbrakk> \<Longrightarrow> bheight(join l x r) \<le> max (bheight l) (bheight r) + 1"
using bheight_paint_Black[of "joinL l x r"] bheight_paint_Black[of "joinR l x r"]
  bheight_joinL[of l r x] bheight_joinR[of l r x]
by(auto simp: max_def rbt_def join_def)

subsubsection "Inorder properties"

text "Currently unused. Instead \<^const>\<open>set_tree\<close> and \<^const>\<open>bst\<close> properties are proved directly."

lemma inorder_joinL: "bheight l \<le> bheight r \<Longrightarrow> inorder(joinL l x r) = inorder l @ x # inorder r"
proof(induction l x r rule: joinL.induct)
  case (1 l x r)
  thus ?case by(auto simp: inorder_baliL joinL.simps[of l x r] split!: tree.splits color.splits)
qed

lemma inorder_joinR:
  "inorder(joinR l x r) = inorder l @ x # inorder r"
proof(induction l x r rule: joinR.induct)
  case (1 l x r)
  thus ?case by (force simp: inorder_baliR joinR.simps[of l x r] split!: tree.splits color.splits)
qed

lemma "inorder(join l x r) = inorder l @ x # inorder r"
by(auto simp: inorder_joinL inorder_joinR inorder_paint join_def
      split!: tree.splits color.splits if_splits
      dest!: arg_cong[where f = inorder])

subsubsection "Set and bst properties"

lemma set_baliL:
  "set_tree(baliL l a r) = set_tree l \<union> {a} \<union> set_tree r"
by(cases "(l,a,r)" rule: baliL.cases) (auto)

lemma set_joinL:
  "bheight l \<le> bheight r \<Longrightarrow> set_tree (joinL l x r) = set_tree l \<union> {x} \<union> set_tree r"
proof(induction l x r rule: joinL.induct)
  case (1 l x r)
  thus ?case by(auto simp: set_baliL joinL.simps[of l x r] split!: tree.splits color.splits)
qed

lemma set_baliR:
  "set_tree(baliR l a r) = set_tree l \<union> {a} \<union> set_tree r"
by(cases "(l,a,r)" rule: baliR.cases) (auto)

lemma set_joinR:
  "set_tree (joinR l x r) = set_tree l \<union> {x} \<union> set_tree r"
proof(induction l x r rule: joinR.induct)
  case (1 l x r)
  thus ?case by(force simp: set_baliR joinR.simps[of l x r] split!: tree.splits color.splits)
qed

lemma set_paint: "set_tree (paint c t) = set_tree t"
by (cases t) auto

lemma set_join: "set_tree (join l x r) = set_tree l \<union> {x} \<union> set_tree r"
by(simp add: set_joinL set_joinR set_paint join_def)

lemma bst_baliL:
  "\<lbrakk>bst l; bst r; \<forall>x\<in>set_tree l. x < a; \<forall>x\<in>set_tree r. a < x\<rbrakk>
   \<Longrightarrow> bst (baliL l a r)"
by(cases "(l,a,r)" rule: baliL.cases) (auto simp: ball_Un)

lemma bst_baliR:
  "\<lbrakk>bst l; bst r; \<forall>x\<in>set_tree l. x < a; \<forall>x\<in>set_tree r. a < x\<rbrakk>
   \<Longrightarrow> bst (baliR l a r)"
by(cases "(l,a,r)" rule: baliR.cases) (auto simp: ball_Un)

lemma bst_joinL:
  "\<lbrakk>bst (Node l (a, n) r); bheight l \<le> bheight r\<rbrakk>
  \<Longrightarrow> bst (joinL l a r)"
proof(induction l a r rule: joinL.induct)
  case (1 l a r)
  thus ?case
    by(auto simp: set_baliL joinL.simps[of l a r] set_joinL ball_Un intro!: bst_baliL
        split!: tree.splits color.splits)
qed

lemma bst_joinR:
  "\<lbrakk>bst l; bst r; \<forall>x\<in>set_tree l. x < a; \<forall>y\<in>set_tree r. a < y \<rbrakk>
  \<Longrightarrow> bst (joinR l a r)"
proof(induction l a r rule: joinR.induct)
  case (1 l a r)
  thus ?case
    by(auto simp: set_baliR joinR.simps[of l a r] set_joinR ball_Un intro!: bst_baliR
        split!: tree.splits color.splits)
qed

lemma bst_paint: "bst (paint c t) = bst t"
by(cases t) auto

lemma bst_join:
  "bst (Node l (a, n) r) \<Longrightarrow> bst (join l a r)"
by(auto simp: bst_paint bst_joinL bst_joinR join_def)

lemma inv_join: "\<lbrakk> invc l; invh l; invc r; invh r \<rbrakk> \<Longrightarrow> invc(join l x r) \<and> invh(join l x r)"
by (simp add: inv_joinL inv_joinR invh_paint join_def)

subsubsection "Interpretation of \<^locale>\<open>Set2_Join\<close> with Red-Black Tree"

global_interpretation RBT: Set2_Join
where join = join and inv = "\<lambda>t. invc t \<and> invh t"
defines insert_rbt = RBT.insert and delete_rbt = RBT.delete and split_rbt = RBT.split
and join2_rbt = RBT.join2 and split_min_rbt = RBT.split_min
proof (standard, goal_cases)
  case 1 show ?case by (rule set_join)
next
  case 2 thus ?case by (simp add: bst_join)
next
  case 3 show ?case by simp
next
  case 4 thus ?case by (simp add: inv_join)
next
  case 5 thus ?case by simp
qed

text \<open>The invariant does not guarantee that the root node is black. This is not required
to guarantee that the height is logarithmic in the size --- Exercise.\<close>

end


(* Author: Tobias Nipkow, based on work by Daniel Somogyi *)

section \<open>Optimal BSTs: The `Quadratic' Algorithm\label{sec:quadratic}\<close>

theory Optimal_BST2
imports
  Optimal_BST
  Quadrilateral_Inequality
begin

text \<open>Knuth presented an optimization of the previously known cubic dynamic programming algorithm
to a quadratic one. A simplified proof of this optimization was found by Yao~\cite{Yao80}.
Mehlhorn follows Yao closely. The core of the optimization argument is given abstractly
in theory @{theory Optimal_BST.Quadrilateral_Inequality}. In addition we first need to establish some more
properties of @{const argmin}.\<close>

text\<open>An index-based specification of @{const argmin}
expressing that the last minimal list-element is picked:\<close>

lemma argmin_takes_last: "xs \<noteq> [] \<Longrightarrow>
  argmin f xs = xs ! Max {i. i < length xs \<and> (\<forall>x \<in> set xs. f(xs!i) \<le> f x)}"
  (is "_ \<Longrightarrow> _ = _ ! Max (?M xs)")
proof(induction xs)
  case (Cons x xs)
  show ?case
  proof cases
    assume "xs = []" thus ?thesis by(simp cong: conj_cong)
  next
    assume 0: "xs \<noteq> []"
    show ?thesis
    proof cases
      assume 1: "\<forall>u \<in> set xs. f x < f u"
      hence 2: "?M (x#xs) = {0}"
        by (fastforce simp: not_less[symmetric] less_Suc_eq_0_disj)
      have "f x < f (argmin f xs)" using 0 1 argmin_Min[of xs f] by auto
      with 1 Cons.prems show ?case by(subst 2) (auto simp: Let_def)
    next
      assume 1: "\<not>(\<forall>u \<in> set xs. f x < f u)"
      have 2: "\<not> f x < f (argmin f xs)" using 1 argmin_Min[of xs f] 0 by auto
      have "argmin f xs : {u \<in> set xs. \<forall>x\<in>set xs. f u \<le> f x}"
        using 0 argmin_Min[of xs f] by (simp add: argmin_in)
      hence "{u \<in> set xs. \<forall>x\<in>set xs. f u \<le> f x} \<noteq> {}" by blast
      hence ne: "?M xs \<noteq> {}" by(auto simp: in_set_conv_nth)
      have "Max (?M (x#xs)) = Max (?M xs) + 1"
      proof (cases "\<exists>u \<in> set xs. f u < f x")
        case True
        hence "?M (x#xs) = (+) 1 ` ?M xs"
          by (auto simp: nth_Cons' image_def less_Suc_eq_0_disj)
        thus ?thesis
          using mono_Max_commute[of "(+) 1" "?M xs"] ne by (auto simp: mono_def)
      next
        case False
        hence *: "?M (x#xs) = insert 0 ((+) 1 ` ?M xs)"
          using 1 by (auto simp: nth_Cons' image_def less_Suc_eq_0_disj)
        hence "Max (?M (x#xs)) = Max ((+) 1 ` ?M xs)" using Max_insert ne by simp
        thus ?thesis using mono_Max_commute[of "(+) 1" "?M xs"] ne by (auto simp: mono_def)
      qed
      with Cons 2 0 show ?case by auto
    qed
  qed
qed simp

lemma Min_ex: "\<lbrakk> finite F; F \<noteq> {} \<rbrakk> \<Longrightarrow> \<exists>m \<in> F. \<forall>n \<in> F. m \<le> (n::_::linorder)"
using eq_Min_iff[of F "Min F"] by (fastforce)

text \<open>A consequence of @{thm [source] argmin_takes_last}:\<close>

lemma argmin_Max_Args_min_on: assumes [arith]: "i \<le> j"
shows "argmin f [i..j] = Max (Args_min_on f {i..j})"
proof -
  let ?min = "\<lambda>k. \<forall>n \<in> {i..j}. f([i..j]!k) \<le> f n"
  let ?M = "{k. k < nat(j-i+1) \<and> ?min k}"
  let ?Max = "Max ?M"
  have "?M \<noteq> {}" using Min_ex[of "f ` {i..j}"]
    apply(auto simp add: nth_upto)
    apply(rule_tac x="nat (m-i)" in exI)
    by simp
  hence "?Max < nat(j-i+1)" by(simp add: nth_upto)
  hence 1: "i + int ?Max \<le> j" by linarith
  have "argmin f [i..j] = [i..j] ! ?Max"
    using argmin_takes_last[of "[i..j]" f] by simp
  also have "\<dots> = i + int ?Max" using 1 by(simp add: nth_upto)
  also have "\<dots> = i + Max(int ` {k. k < nat(j-i+1) \<and> ?min k})"
    using \<open>?M \<noteq> {}\<close> by (simp add: monoI mono_Max_commute)
  also have "\<dots> = Max ((\<lambda>x. i + x) ` (int ` {k. k < nat(j-i+1) \<and> ?min k}))"
    using \<open>?M \<noteq> {}\<close> by (simp add: monoI mono_Max_commute)
  also have "(\<lambda>x. i + x) ` (int ` {k. k < nat(j-i+1) \<and> ?min k}) =
   {k. is_arg_min_on f {i..j} k}"
    apply(auto simp: is_arg_min_on_def Ball_def nth_upto image_def cong: conj_cong)
    apply(rule_tac x = "x-i" in exI)
    apply auto
    apply(rule_tac x = "nat(x-i)" in exI)
    by auto
   finally show ?thesis by(simp add: Args_min_simps)
qed

text \<open>As a consequence of @{thm [source] argmin_Max_Args_min_on} the following lemma
allows us to justify the restriction of the index range of @{const argmin}
used below in the optimized (quadratic) algorithm.\<close>

lemma argmin_red_ivl:
assumes "i \<le> i'" "argmin f [i..j] \<in> {i'..j'}" "j' \<le> j"
shows "argmin f [i'..j'] = argmin f [i..j]"
proof -
  have ij[arith]: "i \<le> j" using assms by simp
  have ij'[arith]: "i' \<le> j'" using assms by simp
  from Min_ex[of "f ` {i..j}"] have m: "\<exists>m \<in> {i..j}. \<forall>n \<in> {i..j}. f m \<le> f n" by auto
  note * = argmin_Max_Args_min_on[OF ij, of f]
  note ** = argmin_Max_Args_min_on[OF ij', of f]
  let ?M = "Args_min_on f {i..j}"
  let ?M' = "Args_min_on f {i'..j'}"
  have M: "finite ?M" "?M \<noteq> {}"
    using m by (fastforce simp: Args_min_simps simp del: atLeastAtMost_iff)+
  have "Max ?M \<in> ?M" by (simp add: M)
  have "Max ?M \<in> ?M'" using Max_in[OF M] assms * by(auto simp: Args_min_simps)
  have "?M' \<subseteq> ?M" using \<open>Max ?M \<in> ?M\<close> \<open>Max ?M \<in> ?M'\<close> assms(1,3)
    by(force simp add: Args_min_simps Ball_def)
  have "finite ?M'" using M(1) \<open>?M' \<subseteq> ?M\<close> infinite_super by blast
  hence "Max ?M \<le> Max ?M'" by (simp add: \<open>Max ?M \<in> ?M'\<close>)
  have "Max ?M' \<le> Max ?M" using Max.subset_imp[OF \<open>?M' \<subseteq> ?M\<close> _ M(1)] \<open>Max ?M \<in> ?M'\<close> by auto
  thus ?thesis using * ** \<open>Max ?M \<le> Max ?M'\<close> by force
qed

fun root:: "'a tree \<Rightarrow> 'a" where
"root \<langle>_,r,_\<rangle> = r"

text \<open>Now we can formulate and verify the improved algorithm. This requires two
assumptions on the weight function \<open>w\<close>.\<close>

locale Optimal_BST2 = Optimal_BST +
assumes monotone_w: "\<lbrakk>i \<le> i'; i' \<le> j; j \<le> j'\<rbrakk> \<Longrightarrow> w i' j \<le> w i j'"
assumes QI_w: "\<lbrakk>i \<le> i'; i' \<le> j; j \<le> j'\<rbrakk>\<Longrightarrow> w i j + w i' j'\<le> w i' j + w i j'"
begin

text\<open>When finding an optimal tree for @{term "[i..j]"} the optimization consists in reducing
the search for the root from @{term "[i..j]"} to
@{term "[root (opt_bst2 i (j-1)) .. root (opt_bst2 (i+1) j)]"}:\<close>

function opt_bst2 :: "int \<Rightarrow> int \<Rightarrow> int tree" where
"opt_bst2 i j =
  (if i > j then Leaf else
   if i = j then Node Leaf i Leaf else
   let left = root (opt_bst2 i (j-1)) in
   let right= root (opt_bst2 (i+1) j) in
     argmin (wpl i j) [\<langle>opt_bst2 i (k-1), k, opt_bst2 (k+1) j\<rangle>. k \<leftarrow> [left..right]])"
by auto

text \<open>The termination of @{const opt_bst2} is not completely obvious.
We first need to establish some functional properties of the terminating computations.
We start by showing that the root of the returned tree is always between \<open>left\<close> and \<open>right\<close>.
This is essentially equivalent to proving that \<open>left \<le> right\<close>
because otherwise @{const argmin} is applied to \<open>[]\<close>, which is undefined.\<close>

lemma left_le_right:
 "opt_bst2_dom(i,j) \<Longrightarrow>
  (i=j \<longrightarrow> root(opt_bst2 i j) = i) \<and>
  (i<j \<longrightarrow> root(opt_bst2 i j) \<in> {root(opt_bst2 i (j-1)) .. root(opt_bst2 (i+1) j)})"
proof (induction rule: opt_bst2.pinduct)
  case (1 i j)
  let ?left = "root (opt_bst2 i (j-1))"
  let ?right = "root (opt_bst2 (i+1) j)"
  let ?f ="(\<lambda>k. \<langle>opt_bst2 i (k - 1), k, opt_bst2 (k + 1) j\<rangle>)"
  show ?case
  proof cases
    assume "i > j" thus ?thesis by auto
  next
    assume [arith]: "\<not> i > j"
    show ?thesis
    proof cases
      assume "i = j" thus ?thesis using opt_bst2.psimps[OF "1.hyps"] by simp
    next
      assume [arith]: "i \<noteq> j"
      have left_le_right: "?left \<le> ?right"
      proof cases
        assume [arith]: "i = j-1"
        have l: "root (opt_bst2 i (j - 1)) = i" using "1.IH"(1) by auto
        have r: "root (opt_bst2 (i+1) j) = j" using "1.IH"(2) by auto
        show ?thesis using l r by auto
      next
        assume "\<not> i = j-1"
        hence[arith]: "i < j-1" by arith
        have "?left \<le> root (opt_bst2 (i + 1) (j - 1))" using "1.IH"(1) by auto
        also have "... \<le> root (opt_bst2 (i+1) j)" using "1.IH"(2) by auto
        finally have "?left \<le> ?right" .
        thus ?thesis by auto
      qed

      let ?lambda = "\<lambda>t. root t \<in> {?left .. ?right}"
      show ?thesis
        using argmin_forall[of \<open>map ?f [?left..?right]\<close> \<open>?lambda\<close> \<open>wpl i j\<close>] left_le_right
        by (fastforce simp add: opt_bst2.psimps[OF "1.hyps"])
    qed
  qed
qed

text \<open>Now we can bound the result of @{const opt_bst2} easily:\<close>

lemma root_opt_bst2_bound:
  "opt_bst2_dom (i,j) \<Longrightarrow> i \<le> j \<Longrightarrow> root (opt_bst2 i j) \<in> {i..j}"
proof(induction i j rule:opt_bst2.pinduct)
  case (1 i j)
  show ?case using  "1.prems" "1.IH"(1,2) left_le_right[OF "1.hyps"] by force
qed

text \<open>Now termination follows easily:\<close>

lemma opt_bst2_dom: "\<forall>args. opt_bst2_dom args"
proof (relation "measure (\<lambda>(i,j). nat (j-i+1))")
  let ?R = "measure (\<lambda>(i,j). nat (j-i+1))"
  show "wf ?R" ..

  fix i j::int
  assume [arith]: "\<not>j < i" "i \<noteq> j"
  thus "((i, j - 1), (i, j)) \<in> ?R" by auto

  fix left
  assume left: "left = root (opt_bst2 i (j - 1))" "opt_bst2_dom (i, j - 1)"
  thus "((i + 1, j), (i, j)) \<in> ?R" by(auto)

  fix right k
  assume right: "right = root (opt_bst2 (i + 1) j)" "k \<in> set[left..right]"
    "opt_bst2_dom (i+1, j)"

  thus "((i, k - 1), (i, j)) \<in> ?R"
    using root_opt_bst2_bound[of "i+1" j] by(auto)

  show "((k + 1, j), (i, j)) \<in> ?R"
    using left right root_opt_bst2_bound[of i "j-1"] by(auto)
qed

termination by(rule opt_bst2_dom)

declare opt_bst2.simps[simp del]

abbreviation "min_wpl3 i j k \<equiv> min_wpl i (k-1) + min_wpl (k+1) j + w i j"

text\<open>The correctness proof \cite{Yao} is based on a general theory of `quatrilateral inequalities'
developed in locale QI that we now instantiate:\<close>

interpretation QI
  where
    c = "\<lambda>i j. min_wpl (i+1) j"
    and c_k = "\<lambda>i j. min_wpl3 (i+1) j"
    and w = "\<lambda>i j. w (i+1) j"
proof (standard, goal_cases)
  case (1 i i' j j')
  thus ?case using QI_w by simp
next
  case (2 i i' j j')
  thus ?case using monotone_w by simp
next
  case (3 i j)
  thus ?case by simp
next
  case (4 i j k)
  show ?case by simp
qed

lemma K_argmin: "i < j \<Longrightarrow> K i j = argmin (min_wpl3 (i+1) j) [i+1..j]"
by(simp add: K_def argmin_Max_Args_min_on Args_min_on_def)

theorem opt_bst2_opt_bst: "opt_bst2 i j = opt_bst i j"
proof (induction i j rule: opt_bst2.induct)
  case (1 i j)
  show ?case
  proof cases
    assume "i \<ge> j" thus ?thesis by(cases "i=j") (auto simp: opt_bst2.simps)
  next
    assume [arith]: "\<not> i \<ge> j"
    let ?c = "\<lambda>k. min_wpl i (k-1) + min_wpl (k+1) j + w i j"
    let ?opt = "\<lambda>k. \<langle>opt_bst i (k-1), k, opt_bst (k+1) j\<rangle>"
    have 1: "i \<le> K (i-1) (j-1)"
      using argmin_in[of "[i..j-1]"] by(auto simp add: K_argmin)
    have 2: "argmin ?c [i..j] \<in> {K (i-1) (j-1)..K i j}"
      using lemma_3[of "i-1" "j-1"] by(simp add: K_argmin)
    have 3: "K i j \<le> j" using argmin_in[of "[i+1..j]"] by(auto simp: K_argmin)
    have *: "argmin ?c [K (i-1) (j-1)..K i j] = argmin ?c [i..j]"
      by(rule argmin_red_ivl[OF 1 2 3])
    have "opt_bst2 i j =
     argmin (wpl i j) (map ?opt [root(opt_bst2 i (j-1))..root(opt_bst2 (i+1) j)])"
      using [[simp_depth_limit=3]]
      by(simp add: "1.IH"(3,4)[OF _ _ refl refl] opt_bst2.simps[of i j] cong: list.map_cong_simp)
    also have "\<dots> = argmin (wpl i j) (map ?opt [root(opt_bst i (j-1))..root(opt_bst (i+1) j)])"
      by (simp add: "1.IH"(1,2))
    also have "root(opt_bst i (j-1)) = K (i-1) (j-1)"
      by(simp add: argmin_map wpl_opt_bst comp_def K_argmin)
    also have "root(opt_bst (i+1) j) = K i j"
      by(simp add: argmin_map wpl_opt_bst comp_def K_argmin)
    also have "argmin (wpl i j) (map ?opt [K (i - 1) (j - 1)..K i j])
       = ?opt (argmin (wpl i j o ?opt) [K (i-1) (j-1)..K i j])"
      using lemma_3[of "i-1" "j-1"] by(simp add: argmin_map)
    also have "\<dots> = ?opt (argmin ?c [K (i-1) (j-1)..K i j])"
      by(simp add: comp_def wpl_opt_bst)
    also have "\<dots> = ?opt(argmin ?c [i..j])"
      by (simp add: "*")
    also have "\<dots> = ?opt(argmin (wpl i j o ?opt) [i..j])"
      by(simp add: comp_def wpl_opt_bst)
    also have "\<dots> = argmin (wpl i j) (map ?opt [i..j])"
      by(simp add: argmin_map)
    also have "\<dots> = opt_bst i j"
      by simp
    finally show ?thesis .
  qed
qed

corollary opt_bst2_is_optimal: "wpl i j (opt_bst2 i j) = min_wpl i j"
by (simp add: opt_bst2_opt_bst wpl_opt_bst)

function opt_bst_wpl2 :: "int \<Rightarrow> int \<Rightarrow> int tree \<times> nat" where
"opt_bst_wpl2 i j =
  (if i > j then (Leaf,0) else
   if i = j then (Node Leaf i Leaf, w i i) else
   let l = root(fst(opt_bst_wpl2 i (j-1)));
      r = root(fst(opt_bst_wpl2 (i+1) j)) in
     argmin snd
       [let (tl,wl) = opt_bst_wpl2 i (k-1); (tr,wr) = opt_bst_wpl2 (k+1) j
        in (\<langle>tl, k, tr\<rangle>, wl + wr + w i j) . k \<leftarrow> [l..r]])"
by auto

lemma left_le_right2:
 "opt_bst_wpl2_dom(i,j) \<Longrightarrow>
  (i=j \<longrightarrow> root(fst(opt_bst_wpl2 i j)) = i) \<and>
  (i<j \<longrightarrow> root(fst(opt_bst_wpl2 i j)) \<in>
    {root(fst(opt_bst_wpl2 i (j-1))) .. root(fst(opt_bst_wpl2 (i+1) j))})"
proof (induction rule: opt_bst_wpl2.pinduct)
  case (1 i j)
  let ?l = "root (fst(opt_bst_wpl2 i (j-1)))"
  let ?r = "root (fst(opt_bst_wpl2 (i+1) j))"
  let ?f ="\<lambda>k. let (tl,wl) = opt_bst_wpl2 i (k-1); (tr,wr) = opt_bst_wpl2 (k+1) j
               in (\<langle>tl, k, tr\<rangle>, wl + wr + w i j)"
  show ?case
  proof cases
    assume "i > j" thus ?thesis by auto
  next
    assume [arith]: "\<not> i > j"
    show ?thesis
    proof cases
      assume "i = j" thus ?thesis using opt_bst_wpl2.psimps[OF "1.hyps"] by simp
    next
      assume [arith]: "i \<noteq> j"
      have left_le_right: "?l \<le> ?r"
      proof cases
        assume [arith]: "i = j-1"
        have l: "root (fst(opt_bst_wpl2 i (j-1))) = i" using "1.IH"(1) by auto
        have r: "root (fst(opt_bst_wpl2 (i+1) j)) = j" using \<open>i = j-1\<close> "1.IH"(2)
          by auto
        show ?thesis using l r by auto
      next
        assume "\<not> i = j-1"
        hence[arith]: "i < j-1" by arith
        have "?l \<le> root (fst(opt_bst_wpl2 (i+1) (j-1)))" using "1.IH"(1) by auto
        also have "... \<le> root (fst(opt_bst_wpl2 (i+1) j))" using "1.IH"(2) by auto
        finally have "?l \<le> ?r" .
        thus ?thesis by auto
      qed

      let ?P = "\<lambda>t. root (fst t) \<in> {?l .. ?r}"
      show ?thesis
        using argmin_forall[of \<open>map ?f [?l..?r]\<close> ?P snd] left_le_right
        by (fastforce simp add: opt_bst_wpl2.psimps[OF "1.hyps"] split: prod.splits)
    qed
  qed
qed

text \<open>Now we can bound the result of @{const opt_bst_wpl2}:\<close>

lemma root_opt_bst_wpl2_bound:
  "opt_bst_wpl2_dom (i,j) \<Longrightarrow> i \<le> j \<Longrightarrow> root (fst(opt_bst_wpl2 i j)) \<in> {i..j}"
proof(induction i j rule:opt_bst_wpl2.pinduct)
  case (1 i j)
  show ?case using  "1.prems" "1.IH"(1)  "1.IH"(2)[OF _ _ refl] left_le_right2[OF "1.hyps"]
    by fastforce
qed

text \<open>Now termination follows easily:\<close>

lemma opt_bst_wpl2_dom: "\<forall>args. opt_bst_wpl2_dom args"
proof (relation "measure (\<lambda>(i,j). nat (j-i+1))")
  let ?R = "measure (\<lambda>(i,j). nat (j-i+1))"
  show "wf ?R" ..

  fix i j::int
  assume [arith]: "\<not>j < i" "i \<noteq> j"
  thus "((i, j - 1), (i, j)) \<in> ?R" by auto

  fix left
  assume left: "left = root (fst(opt_bst_wpl2 i (j-1)))" "opt_bst_wpl2_dom (i, j-1)"
  thus "((i+1, j), (i, j)) \<in> ?R" by(auto)

  fix right k
  assume right: "right = root (fst(opt_bst_wpl2 (i+1) j))" "k \<in> set[left..right]"
    "opt_bst_wpl2_dom (i+1, j)"

  thus "((i, k-1), (i, j)) \<in> ?R"
    using root_opt_bst_wpl2_bound[of "i+1" j] by(auto)

  show "((k+1, j), (i, j)) \<in> ?R"
    using left right root_opt_bst_wpl2_bound[of i "j-1"] by(auto)
qed

termination by(rule opt_bst_wpl2_dom)

declare opt_bst_wpl2.simps[simp del]

lemma opt_bst_wpl2_eq_pair:
  "opt_bst_wpl2 i j = (opt_bst2 i j, wpl i j (opt_bst2 i j))"
proof(induction i j rule: opt_bst_wpl2.induct)
  case (1 i j)
  note [simp] = opt_bst2.simps[of i j] opt_bst_wpl2.simps[of i j] (*opt_bst2_opt_bst*)
  show ?case
  proof cases
    assume "i > j" thus ?thesis using "1.prems" by (simp)
  next
    assume [arith]: "\<not> i > j"
    show ?case
    proof cases
      assume [arith]: "i = j"
      show ?thesis by(simp) (simp add: \<open>i = j\<close>)
    next
      assume [arith]: "i \<noteq> j"
      let ?l = "root (opt_bst2 i (j-1))" let ?r = "root (opt_bst2 (i+1) j)"
      have *: "?l \<le> ?r"
        using left_le_right[of i j] by (fastforce simp: opt_bst2_opt_bst opt_bst2_dom)
      let ?f = "\<lambda>k. case opt_bst_wpl2 i (k-1) of
             (l,wl) \<Rightarrow> case opt_bst_wpl2 (k+1) j of
                         (r,wr) \<Rightarrow> (\<langle>l,k,r\<rangle>, wl + wr + w i j)"
      let ?g = "\<lambda>k. (\<langle>opt_bst2 i (k-1), k, opt_bst2 (k+1) j\<rangle>,
                    wpl i (k-1) (opt_bst2 i (k-1)) + wpl (k+1) j (opt_bst2 (k+1) j) + w i j)"
      have fg: "?f k = ?g k" if k: "k \<in> {?l..?r}" for k
      proof -
        have 1: "opt_bst_wpl2 i (k-1) = (opt_bst2 i (k-1), wpl i (k-1) (opt_bst2 i (k-1)))"
          using k "1.IH"(3) by(simp add: "1.IH"(1,2))
        have 2: "opt_bst_wpl2 (k+1) j = (opt_bst2 (k+1) j, wpl (k+1) j (opt_bst2 (k+1) j))"
          using 1 k "1.IH"(4) by(simp add: "1.IH"(1,2))
        show ?thesis using 1 2 by(simp)
      qed
      have "opt_bst_wpl2 i j =
        argmin snd (map ?f [root(fst(opt_bst_wpl2 i (j-1)))..root(fst(opt_bst_wpl2 (i+1) j))])"
        by(simp)
      also have "\<dots> = argmin snd (map ?f [?l..?r])"
        by(simp add: "1.IH"(1,2))
      also have "\<dots> = argmin snd (map ?g [?l..?r])"
        using fg by (simp cong: list.map_cong_simp)
      also have "\<dots> = (opt_bst2 i j, wpl i j (opt_bst2 i j))" using *
        by(simp add: argmin_pairs comp_def)
      finally show ?thesis .
    qed
  qed
qed

corollary opt_bst_wpl2_eq_pair': "opt_bst_wpl2 i j = (opt_bst i j, min_wpl i j)"
by (simp add: opt_bst_wpl2_eq_pair opt_bst2_opt_bst wpl_opt_bst)

end (* locale Optimal_BST2 *)

end


theory Sorting_Log2
imports Sorting_Setup
begin

section \<open>Count Leading Zeroes and Log2\<close>
(* TODO: Define semantics of llvm.ctlz intrinsic! *)

subsection \<open>Explicit Implementation by Loop\<close>

definition word_clz' :: "'a::len word \<Rightarrow> nat" where
  "word_clz' x \<equiv> if x=0 then 0 else word_clz x"

lemma word_clz'_eq: "x\<noteq>0 \<Longrightarrow> word_clz' x = word_clz x"
  by (simp add: word_clz'_def)

lemma of_bl_eqZ:
  "\<lbrakk> length xs = LENGTH ('a::len0) \<rbrakk> \<Longrightarrow> (of_bl xs :: 'a word) = 0 \<longleftrightarrow> (xs = replicate LENGTH('a) False)"
  apply auto
  by (metis to_bl_0 to_bl_use_of_bl word_bl_Rep')

lemma word_clz'_rec: "word_clz' x = (if x <=s 0 then 0 else 1 + word_clz' (x << 1))"
  (* TODO: Clean up this mess! *)
  apply (clarsimp simp: word_clz'_def word_clz_def)
  apply (cases "to_bl x")
  apply auto
  apply (simp add: word_msb_alt word_sle_msb_le)
  apply (simp add: word_msb_alt word_sle_msb_le)
  apply (simp add: word_msb_alt word_sle_msb_le shiftl_bl)
  apply (subst (asm) of_bl_eqZ)
  apply (auto) []
  apply (metis length_Cons word_bl_Rep')
  apply (metis length_append_singleton length_replicate replicate_Suc replicate_append_same rotate1_rl' to_bl_0 word_bl.Rep_eqD)
  apply (simp add: word_msb_alt word_sle_msb_le)
  apply (simp add: bl_shiftl shiftl_bl)
  apply (subst (asm) of_bl_eqZ)
  apply auto
  apply (metis length_Cons word_bl_Rep')
  apply (subst word_bl.Abs_inverse)
  apply auto
  apply (metis length_Cons word_bl_Rep')
  apply (subgoal_tac "True\<in>set list")
  apply simp
  by (simp add: eq_zero_set_bl)

lemma word_clz'_rec2: "word_clz' x = (if 0 <s x then 1 + word_clz' (x << 1) else 0)"
  by (meson signed.not_le word_clz'_rec)

lemma word_clz'_simps2:
  "0 <s x \<Longrightarrow> word_clz' x = 1 + word_clz' (x << 1)"
  "\<not>(0 <s x) \<Longrightarrow> word_clz' x = 0"
  using word_clz'_rec2 by metis+

definition word_clz2 :: "'a::len2 word \<Rightarrow> nat nres"
  where "word_clz2 x \<equiv> do {
    (c,_) \<leftarrow> WHILET (\<lambda>(c,x). 0 <s x) (\<lambda>(c,x). do {
      ASSERT (c + 1 < max_snat LENGTH('a));
      RETURN (c+1,x << 1)
    }) (0,x);
    RETURN c
  }"

lemma word_clz'_fits_snat: "word_clz' (x::'a::len2 word) < max_snat LENGTH('a)"
  unfolding word_clz'_def using word_clz_nonzero_max[of x]
  apply (auto simp: word_size max_snat_def)
  by (meson le_def n_less_equal_power_2 nat_le_Suc_less_imp order_trans)

lemma word_clz2_refine: "word_clz2 x\<^sub>0 \<le> RETURN (word_clz' x\<^sub>0)"
  unfolding word_clz2_def
  supply [refine_vcg] = WHILET_rule[
    where I="\<lambda>(c,x). word_clz' x\<^sub>0 = c + word_clz' x"
      and R="measure (word_clz' o snd)"
  ]
  apply refine_vcg
  using word_clz'_fits_snat[of x\<^sub>0]
  apply (auto simp: word_clz'_simps2)
  done

lemma word_clz2_refine': "(word_clz2, RETURN o word_clz') \<in> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
  by (auto intro!: nres_relI simp: word_clz2_refine)

sepref_def word_clz'_impl is word_clz2 :: "(word_assn' TYPE('a::len2))\<^sup>k \<rightarrow>\<^sub>a snat_assn' TYPE('a)"
  unfolding word_clz2_def
  apply (rewrite at "(_ + \<hole>,_)" snat_const_fold[where 'a='a])
  apply (rewrite at "(_ << \<hole>)" snat_const_fold[where 'a='a])
  apply (rewrite at "(\<hole>,_)" snat_const_fold[where 'a='a])
  by sepref

export_llvm "word_clz'_impl :: 64 word \<Rightarrow> 64 word llM"

sepref_register word_clz word_clz'
lemmas [sepref_fr_rules] = word_clz'_impl.refine[FCOMP word_clz2_refine']

lemma word_clz_alt: "word_clz x = (if x=0 then size x else word_clz' x)"
  unfolding word_clz'_def by (auto simp: word_size)

sepref_def word_clz_impl
  is "RETURN o word_clz" :: "[\<lambda>_. LENGTH('a)>2]\<^sub>a (word_assn' TYPE('a::len2))\<^sup>k \<rightarrow> snat_assn' TYPE('a)"
  unfolding word_clz_alt
  by sepref

export_llvm "word_clz_impl :: 64 word \<Rightarrow> _"

lemma word_clz_nonzero_max': "x\<noteq>0 \<Longrightarrow> word_clz (x::'a::len2 word) \<le> LENGTH('a) - Suc 0"
  using word_clz_nonzero_max[of x] unfolding word_size
  by simp

sepref_def word_log2_impl is
  "RETURN o word_log2" :: "[\<lambda>x. x>0 \<and> LENGTH('a)>2]\<^sub>a (word_assn' TYPE('a::len2))\<^sup>k \<rightarrow> snat_assn' TYPE('a)"
  unfolding word_log2_def word_size
  apply (annot_snat_const "TYPE('a)")
  supply [simp] = word_clz_nonzero_max'
  by sepref

export_llvm "word_log2_impl :: 64 word \<Rightarrow> _"

subsection \<open>Connection with \<^const>\<open>Discrete.log\<close>\<close>

lemma discrete_log_ltI: (* TODO: Check how precise this bound is! *)
  assumes "n\<noteq>0" "N\<noteq>0" "n<2^N"
  shows "Discrete.log n < N"
  using assms
  by (metis Discrete.log_le_iff leD linorder_neqE_nat log_exp log_exp2_le order_less_le zero_order(3))

lemma unat_x_div_2_conv:
  fixes x y :: "'a::len2 word"
  shows "unat x div 2 = unat y \<longleftrightarrow> y = x div 2"
proof -
  have A: "2 = unat (2::'a word)"
    by (metis le_less_trans len2_simps(2) n_less_equal_power_2 of_nat_numeral unat_of_nat_len)

  have B: "unat x div 2 = unat (x div 2)"
    unfolding A
    by (simp add: unat_div)

  show ?thesis
    by (auto simp: B dest: word_unat.Rep_eqD)

qed

lemma take_size_m1_to_bl:
  fixes x :: "'a::len word"
  shows "take (size x - Suc 0) (to_bl x) = butlast (to_bl x)"
  by (simp add: butlast_conv_take word_size_bl)

lemma takeWhile_butlast_eqI: "\<lbrakk>x\<in>set xs; \<not>P x\<rbrakk> \<Longrightarrow> takeWhile P (butlast xs) = takeWhile P xs"
  by (metis append_Nil2 butlast.simps(2) butlast_append list.simps(3) split_list_last takeWhile_tail)

lemma takeWhile_butlast_eqI': "\<lbrakk>\<exists>x\<in>set xs. \<not>P x\<rbrakk> \<Longrightarrow> takeWhile P (butlast xs) = takeWhile P xs"
  by (metis append_Nil2 butlast.simps(2) butlast_append list.simps(3) split_list_last takeWhile_tail)

lemma ex_True_in_set_conv: "(\<exists>x\<in>S. x) \<longleftrightarrow> True\<in>S" by auto

lemma word_clz_rec:
  fixes x :: "'a::len2 word"
  shows "2\<le>x \<Longrightarrow> word_clz (x div 2) = word_clz x + 1"
  unfolding word_clz_def shiftr1_is_div_2[symmetric]
  apply (auto simp: bl_shiftr word_size)
  apply (subst bl_shiftr)
  apply (simp add: word_size Suc_leI)
  apply (auto simp: take_size_m1_to_bl)
  apply (subst takeWhile_butlast_eqI')
  apply (simp_all add: ex_True_in_set_conv)
  apply (rule ccontr)
  apply (simp only: eq_zero_set_bl[symmetric])
  by (metis le_unat_uoi len2_simps(2) n_less_equal_power_2 of_nat_numeral unat_0 unat_of_nat_len word_le_0_iff zero_neq_numeral)

lemma word_clz_ge2_max: "2\<le>(x::'a::len2 word) \<Longrightarrow> word_clz x + 1 < size x"
  apply (simp only: word_clz_rec[symmetric] word_size)
  apply (rule word_clz_nonzero_max[of "x div 2", unfolded word_size])
  by (smt One_nat_def Suc_pred add.left_neutral add.right_neutral add_diff_cancel_left' add_diff_cancel_right' add_left_cancel diff_Suc_Suc div_less div_of_0_id div_self lessI less_eq_Suc_le less_one linorder_neqE_nat linorder_not_le mult.right_neutral not_numeral_le_zero numeral_2_eq_2 numeral_One numeral_le_one_iff order_less_le overflow_safe_hbound_check pos2 power.simps(1) power.simps(2) semiring_norm(69) unat_0 unat_div unat_eq_zero unat_gt_0 unat_x_div_2_conv word_clz_rec word_gt_0_no word_le_nat_alt zero_less_one zero_neq_one)

lemma word_log2_rec:
  fixes x :: "'a::len2 word" shows "2\<le>x \<Longrightarrow> word_log2 x = Suc (word_log2 (x div 2))"
  apply (auto simp: word_log2_def word_size word_clz_rec)
  using word_clz_ge2_max[unfolded word_size, of x]
  by auto

lemma word_log2_is_discrete_log:
  fixes x :: "'a::len2 word"
  shows "word_log2 x = Discrete.log (unat x)"
  apply (cases "x=0")
  apply simp
  subgoal proof -
    assume "x \<noteq> 0"
    hence "unat x > 0" by (simp add: unat_gt_0)
    then show ?thesis
    proof (induction "unat x" arbitrary: x rule: log_induct)
      case one
      hence "x=1" using word_unat_Rep_inject1 by auto
      then show ?case
        unfolding word_log2_def
        by (auto simp: word_size)

    next
      case double

      from double.hyps(2) have "Discrete.log (unat x div 2) = word_log2 (x div 2)"
        by (metis unat_x_div_2_conv)

      then show ?case
        apply (subst log_rec, simp add: \<open>2 \<le> unat x\<close>)
        apply simp
        apply (subst word_log2_rec)
        apply auto
        using double.hyps(1) le_unat_uoi word_le_nat_alt by fastforce

    qed
  qed
  done

lemma word_log2_refine_unat: "(word_log2, Discrete.log) \<in> unat_rel' TYPE('a::len2) \<rightarrow> nat_rel"
  using word_log2_is_discrete_log
  by (fastforce simp: unat_rel_def unat.rel_def in_br_conv)

lemma word_log2_refine_snat: "(word_log2, Discrete.log) \<in> snat_rel' TYPE('a::len2) \<rightarrow> nat_rel"
  using word_log2_is_discrete_log
  by (fastforce simp: snat_rel_def snat.rel_def in_br_conv snat_eq_unat)

sepref_register Discrete.log

lemmas discrete_log_unat_hnr[sepref_fr_rules] = word_log2_impl.refine[FCOMP word_log2_refine_unat]
lemmas discrete_log_snat_hnr[sepref_fr_rules] = word_log2_impl.refine[FCOMP word_log2_refine_snat]

end


theory Proj3
imports "HOL-Analysis.Cross3" "Instantiate_Existentials" "Tarskis_Geometry.Linear_Algebra2"
begin

text "Some basic setup to pretty print calculation results."

fun of_vector3 :: "('a, 3) vec \<Rightarrow> 'a list" where
 "of_vector3 a = [a$1, a$2, a$3]"

definition [code_unfold]: "example \<equiv> vector [1,2,3]::real^3"
definition "example2 \<equiv> vec_lambda (\<lambda>x. if x \<in> {1,2,3} then 1 else 0)::real^3"
lemma [code_unfold]: "example2 = vector [1, 1, 1]"
  unfolding vector_def example2_def by auto

declare vec_lambda_beta[code_unfold]

lemma [code_unfold]:
  "\<lbrakk>a = vector [a1,a2,a3]; b = (vector [b1,b2,b3])\<rbrakk> \<Longrightarrow>
    cross3 a b =
            vector [a2 * b3 - a3 * b2,
            a3 * b1 - a1 * b3,
            a1 * b2 - a2 * b1]"
  unfolding cross3_def vector_def
  by auto

declare vector_3[code_unfold]
lemma [code_unfold]: "\<lbrakk>a = vector [a1, a2, a3] \<rbrakk> \<Longrightarrow> of_vector3 a = [a1,a2,a3]"
  by auto

value "vector [1::real,2,3] $ (2::3)"
value "of_vector3 (cross3 example example2)"

text "The quotient type"

definition scalar_multiple:: "(real,'b::finite) vec \<Rightarrow> (real,'b::finite) vec \<Rightarrow> bool" where
  "scalar_multiple u v \<equiv> \<exists>c::real. c \<noteq> 0 \<and> u = c *\<^sub>R v"

definition parallel:: "(real,'b::finite) vec \<Rightarrow> (real,'b) vec \<Rightarrow> bool" where
  "parallel \<equiv> scalar_multiple"

definition "non_zero = {x. x \<noteq> 0}"

(*
typedef (overloaded) ('a::zero_neq_one, 'b::finite) nzvec = "non_zero :: (('a, 'b) vec) set"
  morphisms vec_of nzvec_of
proof
  show "(\<chi> i::'b. (1::'a)) \<in> non_zero"
    by (metis mem_Collect_eq non_zero_def one_index one_vec_def zero_index zero_neq_one)
qed

declare [[coercion vec_of]] *)

quotient_type homogz = "(real,3) vec" / scalar_multiple
  morphisms vec_of_homogz homogz_of_vec
  apply(rule equivpI)
    apply (auto simp add: reflp_def symp_def transp_def scalar_multiple_def)
   apply (metis divide_inverse_commute divide_self_if inverse_eq_divide scaleR_one zero_eq_1_divide_iff)
  by (metis mult_eq_0_iff)

declare [[coercion vec_of_homogz]]

instantiation homogz :: zero
begin

lift_definition zero_homogz :: homogz is "(0 :: (real,3) vec)" .

instance ..
end

lift_definition one_homogz :: homogz is "(\<chi> i. 1)" .

lemma homogz_mult_eq_abs:
  assumes "c \<noteq> 0"
  shows  "homogz_of_vec (c *\<^sub>R v) = homogz_of_vec v"
  by (meson Quotient3_homogz Quotient3_rel assms scalar_multiple_def)

lemma homogz_mult_eq:
  assumes "c \<noteq> 0"
  shows  "homogz_of_vec (c *\<^sub>R vec_of_homogz v) = v"
  by (metis Quotient3_abs_rep Quotient3_homogz assms homogz_mult_eq_abs)

typedef homog = "non_zero :: homogz set"
  morphisms homogz_of_homog homog_of_homogz
proof
  show "one_homogz \<in> non_zero"
    by (smt (verit, del_insts) Quotient3_homogz Quotient3_rel mem_Collect_eq non_zero_def one_homogz_def one_vec_def scalar_multiple_def scale_eq_0_iff zero_homogz_def zero_neq_one)
qed

abbreviation "homog_of_vec \<equiv> (\<lambda>x. homog_of_homogz (homogz_of_vec x))"
abbreviation "vec_of_homog \<equiv> (\<lambda>x. vec_of_homogz (homogz_of_homog x))"

lemma homog_mult_eq_abs:
  assumes "c \<noteq> 0"
  shows  "homog_of_vec (c *\<^sub>R v) = homog_of_vec v"
  by (simp add: assms homogz_mult_eq_abs)

lemma homog_mult_eq:
  assumes "c \<noteq> 0"
  shows  "homog_of_vec (c *\<^sub>R  vec_of_homog v) = v"
  by (simp add: assms homogz_mult_eq homogz_of_homog_inverse)

lemma homog_non_zero:
  "homogz_of_homog v \<noteq> 0"
  "vec_of_homog v \<noteq> 0"
  by (metis (full_types) Quotient3_abs_rep Quotient3_homogz homogz_of_homog mem_Collect_eq non_zero_def zero_homogz.abs_eq)+

declare [[coercion homogz_of_homog]]

lift_definition incidz :: "homogz \<Rightarrow> homogz \<Rightarrow> bool" is "\<lambda>u v. inner u v = 0"
  unfolding scalar_multiple_def
  by auto

definition incid :: "homog \<Rightarrow> homog \<Rightarrow> bool" where "incid = incidz"

lemma incidz_commute: "incidz p l = incidz l p"
  by (simp add: incidz.rep_eq inner_commute)+

lemma incid_commute: "incid p l = incid l p"
  by (simp add: incid_def incidz_commute)+

lift_definition joinz :: "homogz \<Rightarrow> homogz \<Rightarrow> homogz" is "\<lambda>u v.
   cross3 u v"
  unfolding scalar_multiple_def
proof (safe, goal_cases)
  case (1 v1 v2 v3 v4 a b)
  then show ?case
    apply(inst_existentials "a*b")
    by (auto simp add: cross_mult_left cross_mult_right)
qed

definition join :: "homog \<Rightarrow> homog \<Rightarrow> homog" where
  "u \<noteq> v \<Longrightarrow> join u v = homog_of_homogz (joinz u v)"

definition [simp]: "meetz \<equiv> joinz"

definition [simp]: "meet \<equiv> join"

lemma joinz_commute: "joinz p q = joinz q p"
  apply(transfer)
proof -
  fix p q
  have "cross3 p q = - cross3 q p"
    using cross_skew by blast
  moreover have "(-1::real) \<noteq> 0"
    by simp
  ultimately show "scalar_multiple (cross3 p q) (cross3 q p)"
    unfolding scalar_multiple_def
    by (metis scaleR_minus1_left)
qed

lemma join_commute: "join p q = join q p"
  by (metis join_def joinz_commute)

lemma incidz_joinz:
  "incidz p (joinz p q)"
  "incidz q (joinz p q)"
  by (transfer; simp add: dot_cross_self)+

lemma incidz_meetz:
  "incidz (joinz p q) p"
  "incidz (joinz p q) q"
  by (simp_all add: incidz_commute incidz_joinz)

lemma homogz_homog_eq: "p \<noteq> 0 \<Longrightarrow> homogz_of_homog (homog_of_homogz p) = p"
  by (simp add: non_zero_def homog_of_homogz_inverse)

lemma cross3_scalar_multiple: "cross3 x y = 0 \<longleftrightarrow> (scalar_multiple x y \<or> x = 0 \<or> y = 0)"
  unfolding scalar_multiple_def
  unfolding cross_eq_0 collinear_lemma
  by (metis homogz.abs_eq_iff scalar_multiple_def scale_zero_left)

lemma cross3_scalar_non0: "\<lbrakk>x \<noteq> 0; y \<noteq> 0\<rbrakk> \<Longrightarrow> cross3 x y = 0 \<longleftrightarrow> scalar_multiple x y"
  by (simp add: cross3_scalar_multiple)

lemma scalar_multiple_coll: "\<lbrakk>a \<noteq> 0; b \<noteq> 0\<rbrakk> \<Longrightarrow> (scalar_multiple a b) = (collinear {0, a, b})"
  by (metis (no_types, lifting) collinear_lemma insert_commute scalar_multiple_def scale_eq_0_iff)

lemma incid_joinz:
  assumes "p \<noteq> q"
  shows "incid p (join p q)"
  and "incid q (join p q)"
proof -
  from assms have "cross3 p q \<noteq> 0"
    by (metis (full_types) Quotient3_abs_rep Quotient3_homogz Quotient3_rel_rep cross3_scalar_multiple homogz_of_homog homogz_of_homog_inject mem_Collect_eq non_zero_def zero_homogz.abs_eq)
  then have "joinz p q \<noteq> 0"
    by (smt (verit, del_insts) Quotient3_abs_rep Quotient3_homogz incidz.abs_eq incidz.transfer inner_eq_zero_iff joinz.abs_eq rel_fun_def zero_homogz.transfer)
  moreover have "join p q = homog_of_homogz (joinz p q)"
    by (simp add: \<open>p \<noteq> q\<close> homogz_of_homog_inverse join_def)
  ultimately show
    "incid p (join p q)"
    "incid q (join p q)"
    by (simp_all add: homogz_of_homog_inverse incid_def homogz_homog_eq incidz_joinz incidz_meetz)
qed

definition mat_of_vec3 :: "(real,3) vec \<Rightarrow> (real,3) vec \<Rightarrow> (real,3) vec \<Rightarrow> ((real,3) vec, 3) vec" where
  "mat_of_vec3 a b c = vector [a,b,c]"

definition mat_scalar_multiple:: "((real,3) vec, 3) vec \<Rightarrow> ((real,3) vec, 3) vec \<Rightarrow> bool" where
  "mat_scalar_multiple u v \<equiv> \<exists>c d e::real. c \<noteq> 0 \<and> d \<noteq> 0 \<and> e \<noteq> 0 \<and> u$1 = c *\<^sub>R v$1 \<and> u$2 = d *\<^sub>R v$2 \<and> u$3 = e *\<^sub>R v$3"

quotient_type mat_homogz = "((real,3) vec, 3) vec" / mat_scalar_multiple
  apply(rule equivpI)
    apply (auto simp add: reflp_def symp_def transp_def mat_scalar_multiple_def)
    apply fastforce
   apply (metis divide_inverse_commute divide_self_if inverse_eq_divide scaleR_one zero_eq_1_divide_iff)
  by (metis mult_eq_0_iff)

lift_definition mat_of_homogz :: "homogz \<Rightarrow> homogz \<Rightarrow> homogz \<Rightarrow> mat_homogz" is mat_of_vec3
  unfolding mat_of_vec3_def scalar_multiple_def mat_scalar_multiple_def
  by auto

instantiation mat_homogz :: zero begin

lift_definition zero_mat_homogz :: mat_homogz is 0 .

instance ..

end

definition mat_of_homog :: "homog \<Rightarrow> homog \<Rightarrow> homog \<Rightarrow> mat_homogz"
  where "mat_of_homog \<equiv> mat_of_homogz"

quotient_type real_homogz = real / "\<lambda>x y. \<exists>c. x = c * y \<and> c \<noteq> 0"
  apply(rule equivpI)
    apply (auto simp add: reflp_def symp_def transp_def)
  by (metis divide_inverse_commute divide_self_if inverse_eq_divide zero_eq_1_divide_iff)

find_theorems det

text "It turns out (due to irrelevance of scalar multiples)
we only care about whether the determinant of the representatives
is zero or not. We express this by identity with respect to scalar
multiples in the one dimensional case."

lift_definition det_homogz :: "mat_homogz \<Rightarrow> real_homogz" is det
  unfolding mat_scalar_multiple_def
proof (safe; goal_cases)
  case (1 vec1 vec2 c d e)
  let ?c = "(((\<lambda>_. 0)(1 := c))(2 := d))(3 := e)  :: 3 \<Rightarrow> real"
  from 1 have "vec1 = (\<chi> i. ?c i *s (vec2 $ i))"
    apply (auto simp add: vec_eq_iff)
    by (metis exhaust_3)
  thm det_rows_mul
  then have "det vec1 = prod ?c UNIV * det vec2"
    by (simp add: det_rows_mul)
  moreover have "prod ?c UNIV \<noteq> 0"
    using 1 apply(auto)
    by (metis exhaust_3)
  ultimately show ?case
    by blast
qed

definition "det_homog \<equiv> det_homogz"

instantiation real_homogz :: zero begin

lift_definition zero_real_homogz :: real_homogz is 0 .

instance ..

end

lemma inner_real_vec_def: "inner (p:: (real, 'a::finite) vec) q = (\<Sum>j\<in>UNIV. p $ j * q $ j)"
  by (metis (mono_tags, lifting) inner_real_def inner_vec_def sum.cong)

lemma vector_mul_is_scalar: "(vector [p, q, r::((real, 3) vec)]::(_,3) vec) *v l = vector [inner p l, inner q l, inner r l]"
  apply (auto simp add: matrix_vector_mult_def inner_real_vec_def vec_eq_iff)
  apply(subst UNIV_3)+
  apply simp
  subgoal for i
    apply(cases i)
    apply (auto)
    by (smt (z3) exhaust_3 vector_3)
  done

definition colz where "colz p q r = (\<exists>l. l \<noteq> 0 \<and> incidz p l \<and> incidz q l \<and> incidz r l)"

definition col where "col p q r = (\<exists>l. incid p l \<and> incid q l \<and> incid r l)"

lemma colz_det_0:
  "colz p q r \<Longrightarrow> det_homogz (mat_of_homogz p q r) = 0"
  unfolding colz_def
  apply transfer
  apply safe
   apply (auto simp add: incidz_def mat_of_vec3_def scalar_multiple_def)
proof (goal_cases)
  case (1 p q r l)
  thm dot_cross_det
  find_theorems cross3
  find_theorems dependent
  find_theorems "vec.dependent"
  then have "vector [p, q, r] *v l = (vector [inner p l, inner q l, inner r l]::(_,3) vec)"
    by (simp add: vector_mul_is_scalar)
  also have "\<dots> = 0"
    using 1
    by (metis inner_zero_right vec.zero vector_mul_is_scalar)
  finally have "(vector [p, q, r]::(_,3) vec) *v l = 0" .
  then show ?case
    by (metis (no_types, lifting) 1 cross_matrix_mult cross_zero_right dot_cross_det norm_and_cross_eq_0 scale_eq_0_iff vec.zero)
qed
(* TODO other direction *)
(* TODO transfer to homog *)

lemma col_det_0:
  "col p q r \<Longrightarrow> det_homog (mat_of_homog p q r) = 0"
  by (metis (mono_tags, hide_lams) col_def colz_def det_homog_def homog_non_zero(1) incid_def colz_det_0 mat_of_homog_def)

(* Taken from Tarski_Geometry *)

lemma dependent_proj2_abs:
  assumes "p \<noteq> 0" and "q \<noteq> 0" and "i \<noteq> 0 \<or> j \<noteq> 0" and "i *\<^sub>R p + j *\<^sub>R q = 0"
  shows "homogz_of_vec p = homogz_of_vec q" "homog_of_vec p = homog_of_vec q"
proof -
  have "i \<noteq> 0"
  proof
    assume "i = 0"
    with \<open>i \<noteq> 0 \<or> j \<noteq> 0\<close> have "j \<noteq> 0" by simp
    with \<open>i *\<^sub>R p + j *\<^sub>R q = 0\<close> and \<open>q \<noteq> 0\<close> have "i *\<^sub>R p \<noteq> 0" by auto
    with \<open>i = 0\<close> show False by simp
  qed
  with \<open>p \<noteq> 0\<close> and \<open>i *\<^sub>R p + j *\<^sub>R q = 0\<close> have "j \<noteq> 0" by auto

  from \<open>i \<noteq> 0\<close>
  have "homogz_of_vec p = homogz_of_vec (i *\<^sub>R p)"
    by (simp add: homogz_mult_eq_abs)
  also from \<open>i *\<^sub>R p + j *\<^sub>R q = 0\<close> and homogz_mult_eq_abs [of "-1" "j *\<^sub>R q"]
  have "\<dots> = homogz_of_vec (j *\<^sub>R q)" by (simp add: algebra_simps [symmetric])
  also from \<open>j \<noteq> 0\<close> have "\<dots> = homogz_of_vec q" by (rule homogz_mult_eq_abs)
  finally show "homogz_of_vec p = homogz_of_vec q" .
  then show "homog_of_vec p = homog_of_vec q"
    by simp
qed

lemma proj2_rep_dependent:
  assumes "i *\<^sub>R vec_of_homog v + j *\<^sub>R vec_of_homog w = 0"
  (is "i *\<^sub>R ?p + j *\<^sub>R ?q = 0")
  and "i \<noteq> 0 \<or> j \<noteq> 0"
  shows "v = w"
proof -
  have "?p \<noteq> 0" and "?q \<noteq> 0" by (rule homog_non_zero)+
  with \<open>i \<noteq> 0 \<or> j \<noteq> 0\<close> and \<open>i *\<^sub>R ?p + j *\<^sub>R ?q = 0\<close>
  have "homog_of_vec ?p = homog_of_vec ?q" by (simp add: dependent_proj2_abs)
  thus "v = w"
    by (metis Quotient3_abs_rep Quotient3_homogz \<open>vec_of_homog v \<noteq> 0\<close> \<open>vec_of_homog w \<noteq> 0\<close> assms(1) assms(2) dependent_proj2_abs(1) homogz_of_homog_inject)
qed

lemma proj2_rep_independent:
  assumes "p \<noteq> q"
  shows "independent {vec_of_homog p, vec_of_homog q}"
proof
  let ?p' = "vec_of_homog p"
  let ?q' = "vec_of_homog q"
  let ?S = "{?p', ?q'}"
  assume "dependent ?S"
  from  \<open>p \<noteq> q\<close> have "?p' \<noteq> ?q'"
    using \<open>dependent ?S\<close> homog_non_zero(2) by fastforce
  with dependent_explicit_2 [of ?p' ?q'] and \<open>dependent ?S\<close>
  obtain i and j where "i *\<^sub>R ?p' + j *\<^sub>R ?q' = 0" and "i \<noteq> 0 \<or> j \<noteq> 0"
    by (simp add: scalar_equiv) auto
  with proj2_rep_dependent have "p = q" by simp
  with \<open>p \<noteq> q\<close> show False ..
qed

lemma colz_permute:
  assumes "colz a b c"
  shows "colz a c b"
  and "colz b a c"
  using assms colz_def by auto

lemma colz_coincide:
  shows "colz a a c"
  unfolding colz_def
  apply(transfer)
  by (metis (no_types, hide_lams) scalar_multiple_def add.inverse_inverse axis_eq_0_iff cross_basis(2) cross_skew cross_triple dot_cross_self(1) dot_cross_self(2) inner_commute inner_zero_left pth_4(2) zero_neq_one)

lemma col_permute:
  assumes "col a b c"
  shows "col a c b"
  and "col b a c"
  using assms col_def by auto

lemma col_coincide:
  shows "col a a c"
  unfolding col_def incid_def
  by (metis colz_coincide colz_def homogz_homog_eq)

lemma colz_det_0:
  "det_homogz (mat_of_homogz p q r) = 0 \<Longrightarrow> colz p q r"
  unfolding colz_def
  apply transfer
  apply safe
proof(goal_cases)
  case (1 p q r c)
  then have "det (mat_of_vec3 p q r) = 0"
    by simp
  then have "dependent {p, q, r}"
    oops

lemma proj2_points_define_linez:
  shows "\<exists>l\<noteq>0. incidz p l \<and> incidz q l"
proof -
  let ?p' = "vec_of_homogz p"
  let ?q' = "vec_of_homogz q"
  let ?B = "{?p', ?q'}"
  from card_suc_ge_insert [of ?p' "{?q'}"] have "card ?B \<le> 2" by simp
  with dim_le_card' [of ?B] have "dim ?B < 3" by simp
  with lowdim_subset_hyperplane [of ?B]
  obtain l' where "l' \<noteq> 0" and "span ?B \<subseteq> {x. l' \<bullet> x = 0}" by auto
  let ?l = "homogz_of_vec l'"
  let ?l'' = "vec_of_homogz ?l"
  from  \<open>l' \<noteq> 0\<close>
  obtain k where "?l'' = k *\<^sub>R l'"
    using homogz.abs_eq_iff homogz_mult_eq scalar_multiple_def by fastforce

  have "?p' \<in> ?B" and "?q' \<in> ?B" by simp_all
  with span_superset [of ?B] and \<open>span ?B \<subseteq> {x. l' \<bullet> x = 0}\<close>
  have "l' \<bullet> ?p' = 0" and "l' \<bullet> ?q' = 0" by auto
  hence "?p' \<bullet> l' = 0" and "?q' \<bullet> l' = 0" by (simp_all add: inner_commute)
  with dot_scaleR_mult(2) [of _ k l'] and \<open>?l'' = k *\<^sub>R l'\<close>
  have "incidz p ?l \<and> incidz q ?l"
    unfolding incidz_def
    by simp
  moreover have "homogz_of_vec l' \<noteq> 0"
    by (simp add: \<open>l' \<noteq> 0\<close> homogz.abs_eq_iff scalar_multiple_def zero_homogz_def)
  ultimately show "\<exists> l. l \<noteq> 0 \<and> incidz p l \<and> incidz q l"
    by blast
qed

lemma proj2_points_define_line:
  shows "\<exists> l. incid p l \<and> incid q l"
  unfolding incid_def
  using proj2_points_define_linez homog_non_zero homogz_homog_eq
  by metis

definition line_through :: "homog \<Rightarrow> homog \<Rightarrow> homog" where
  "line_through p q \<equiv> \<some> l. incid p l \<and> incid q l"

lemma line_through_incident:
  shows "incid p (line_through p q)"
  and "incid q (line_through p q)"
  unfolding line_through_def
  using proj2_points_define_line
    and someI_ex [of "\<lambda> l. incid p l \<and> incid q l"]
  by simp_all

lemma line_through_unique:
  assumes "p \<noteq> q" and "incid p l" and "incid q l"
  shows "l = line_through p q"
proof -
  let ?l' = "vec_of_homog l"
  let ?m = "line_through p q"
  let ?m' = "vec_of_homog ?m"
  let ?p' = "vec_of_homog p"
  let ?q' = "vec_of_homog q"
  let ?A = "{?p', ?q'}"
  let ?B = "insert ?m' ?A"
  from line_through_incident
  have "incid p ?m" and "incid q ?m" by simp_all
  with \<open>incid p l\<close> and \<open>incid q l\<close>
  have ortho: "\<And>w. w\<in>?A \<Longrightarrow> orthogonal ?m' w" "\<And>w. w\<in>?A \<Longrightarrow> orthogonal ?l' w"
    unfolding incid_def and orthogonal_def
    by (metis empty_iff incidz.rep_eq inner_commute insert_iff)+
  from proj2_rep_independent and \<open>p \<noteq> q\<close> have "independent ?A" by simp
  from homog_non_zero have "?m' \<noteq> 0" by simp
  with orthogonal_independent \<open>independent ?A\<close> ortho
  have "independent ?B" by auto

  from \<open>p \<noteq> q\<close> have "?p' \<noteq> ?q'"
    by (metis Quotient3_abs_rep Quotient3_homogz homogz_of_homog_inject)
  hence "card ?A = 2" by simp
  moreover have "?m' \<notin> ?A"
    using ortho(1) orthogonal_self homog_non_zero by auto
  ultimately have "card ?B = 3" by simp
  with independent_is_basis [of ?B] and \<open>independent ?B\<close>
  have "is_basis ?B" by simp
  with basis_expand obtain c where "?l' = (\<Sum> v\<in>?B. c v *\<^sub>R v)" by auto
  let ?l'' = "?l' - c ?m' *\<^sub>R ?m'"
  from \<open>?l' = (\<Sum> v\<in>?B. c v *\<^sub>R v)\<close> and \<open>?m' \<notin> ?A\<close>
  have "?l'' = (\<Sum> v\<in>?A. c v *\<^sub>R v)" by simp
  with orthogonal_sum [of ?A] ortho
  have "orthogonal ?l' ?l''" and "orthogonal ?m' ?l''"
    by (simp_all add: scalar_equiv)
  from \<open>orthogonal ?m' ?l''\<close>
  have "orthogonal (c ?m' *\<^sub>R ?m') ?l''" by (simp add: orthogonal_clauses)
  with \<open>orthogonal ?l' ?l''\<close>
  have "orthogonal ?l'' ?l''" by (simp add: orthogonal_clauses)
  with orthogonal_self_eq_0 [of ?l''] have "?l'' = 0" by simp
  with proj2_rep_dependent [of 1 l "- c ?m'" ?m] show "l = ?m" by simp
qed

lemma incid_unique:
  assumes "incid p l"
  and "incid q l"
  and "incid p m"
  and "incid q m"
  shows "p = q \<or> l = m"
proof cases
  assume "p = q"
  thus "p = q \<or> l = m" ..
next
  assume "p \<noteq> q"
  with \<open>incid p l\<close> and \<open>incid q l\<close>
    and line_through_unique
  have "l = line_through p q" by simp
  moreover from \<open>p \<noteq> q\<close> and \<open>incid p m\<close> and \<open>incid q m\<close>
  have "m = line_through p q" by (rule line_through_unique)
  ultimately show "p = q \<or> l = m" by simp
qed

lemma proj2_lines_define_point: "\<exists> p. incid p l \<and> incid p m"
proof -
  let ?l' = "l"
  let ?m' = "m"
  from proj2_points_define_line [of ?l' ?m']
  obtain p' where "incid ?l' p' \<and> incid ?m' p'" by auto
  hence "incid p' l \<and> incid p' m"
    unfolding incid_def
    by (simp add: incidz.rep_eq inner_commute)
  thus "\<exists> p. incid p l \<and> incid p m" by auto
qed

definition intersection :: "homog \<Rightarrow> homog \<Rightarrow> homog" where
  "intersection \<equiv> line_through"

declare intersection_def [simp]

lemma intersection_incident:
  shows "incid (intersection l m) l"
  and "incid (intersection l m) m"
  using line_through_incident(1) [of "l" "m"]
    and line_through_incident(2) [of "m" "l"]
  unfolding intersection_def
  by (simp_all add: incid_commute)

lemma intersection_unique:
  assumes "l \<noteq> m" and "incid p l" and "incid p m"
  shows "p = intersection l m"
proof -
  from \<open>incid p l\<close> and \<open>incid p m\<close>
    and incid_commute
  have "incid l p" and "incid m p"
    by simp_all
  with \<open>l \<noteq> m\<close> and line_through_unique
  have "p = line_through l m" by simp
  thus "p = intersection l m"
    unfolding intersection_def
    by (simp)
qed

lemma proj2_not_self_incident:
  "\<not> (incid p p)"
  unfolding incid_def
  using homog_non_zero and inner_eq_zero_iff [of "vec_of_homog p"]
  by (simp add: incidz.rep_eq)

lemma proj2_another_point_on_line:
  "\<exists> q. q \<noteq> p \<and> incid q l"
proof -
  let ?m = "p"
  let ?q = "intersection l ?m"
  from intersection_incident
  have "incid ?q l" and "incid ?q ?m" by simp_all
  from \<open>incid ?q ?m\<close> and proj2_not_self_incident have "?q \<noteq> p" by auto
  with \<open>incid ?q l\<close> show "\<exists> q. q \<noteq> p \<and> incid q l" by auto
qed

lemma proj2_another_line_through_point:
  "\<exists> m. m \<noteq> l \<and> incid p m"
proof -
  from proj2_another_point_on_line
  obtain q where "q \<noteq> l \<and> incid q p" by auto
  with incid_commute
  have "q \<noteq> l \<and> incid p q" by auto
  thus "\<exists> m. m \<noteq> l \<and> incid p m" ..
qed

lemma incid_abs:
  assumes "v \<noteq> 0" and "w \<noteq> 0"
  shows "incid (homog_of_vec v) (homog_of_vec w) \<longleftrightarrow> v \<bullet> w = 0"
  by (metis assms(1) assms(2) homogz_homog_eq incid_def incidz.abs_eq inner_eq_zero_iff zero_homogz_def)

lemma incid_left_abs:
  assumes "v \<noteq> 0"
  shows "incid (homog_of_vec v) l \<longleftrightarrow> v \<bullet> (vec_of_homog l) = 0"
proof -
  have "vec_of_homog l \<noteq> 0"
    by (simp add: homog_non_zero)
  with \<open>v \<noteq> 0\<close> and incid_abs [of v "vec_of_homog l"]
  show "incid (homog_of_vec v) l \<longleftrightarrow> v \<bullet> (vec_of_homog l) = 0"
    by (metis Quotient3_abs_rep Quotient3_homogz homogz_of_homog_inverse)
qed

lemma incid_right_abs:
  assumes "v \<noteq> 0"
  shows "incid p (homog_of_vec v) \<longleftrightarrow> (vec_of_homog p) \<bullet> v = 0"
proof -
  have "vec_of_homog p \<noteq> 0" by (simp add: homog_non_zero)
  with \<open>v \<noteq> 0\<close> and incid_abs [of "vec_of_homog p" v]
  show "incid p (homog_of_vec v) \<longleftrightarrow> (vec_of_homog p) \<bullet> v = 0"
    by (metis Quotient3_abs_rep Quotient3_homogz homogz_of_homog_inverse)
qed

lemma "p \<noteq> q \<Longrightarrow> join p q = line_through p q"
  by (simp add: incid_joinz line_through_unique)

end


(*<*)
(*
   Title:  Theory  stream.thy (FOCUS streams)
   Author: Maria Spichkova <maria.spichkova at rmit.edu.au>, 2013
*)
(*>*)

header "FOCUS streams: operators and lemmas"

theory stream
  imports ListExtras ArithExtras
begin

subsection {* Definition of the FOCUS stream types *}

-- "Finite timed FOCUS stream"
type_synonym 'a fstream = "'a list list"

-- "Infinite timed FOCUS stream"
type_synonym 'a istream = "nat \<Rightarrow> 'a list"

-- "Infinite untimed FOCUS stream"
type_synonym 'a iustream = "nat \<Rightarrow> 'a"

-- "FOCUS stream (general)"
datatype 'a stream =
          FinT "'a fstream" -- "finite timed streams"
        | FinU "'a list" -- "finite untimed streams"
        | InfT "'a istream" -- "infinite timed streams"
        | InfU "'a iustream" -- "infinite untimed streams"

subsection {* Definitions of operators *}

-- "domain of an infinite untimed stream"
definition
   infU_dom :: "natInf set"
 where
  "infU_dom \<equiv> {x. \<exists> i. x = (Fin i)} \<union> {\<infinity>}"

-- "domain of a finite untimed stream (using natural numbers enriched by Infinity)"
definition
   finU_dom_natInf :: "'a list \<Rightarrow> natInf set"
   where
  "finU_dom_natInf s \<equiv> {x. \<exists> i. x = (Fin i) \<and> i < (length s)}"

-- "domain of a finite untimed stream"
primrec
finU_dom :: "'a list \<Rightarrow> nat set"
where
  "finU_dom [] = {}" |
  "finU_dom (x#xs) = {length xs} \<union> (finU_dom xs)"

-- "range of a finite timed stream"
primrec
  finT_range :: "'a fstream \<Rightarrow> 'a set"
where
  "finT_range [] = {}" |
  "finT_range (x#xs) = (set x) \<union> finT_range xs"

-- "range of a finite untimed stream"
definition
   finU_range :: "'a list \<Rightarrow> 'a set"
where
  "finU_range x \<equiv> set x"

-- "range of an infinite timed stream"
definition
   infT_range :: "'a istream \<Rightarrow> 'a set"
where
  "infT_range s \<equiv> {y. \<exists> i::nat. y mem (s i)}"

-- "range of a finite untimed stream"
definition
   infU_range :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a set"
where
  "infU_range s \<equiv> { y. \<exists> i::nat. y = (s i) }"

-- "range of a (general) stream"
definition
   stream_range :: "'a stream \<Rightarrow> 'a set"
where
 "stream_range s \<equiv> case s of
       FinT x \<Rightarrow> finT_range x
     | FinU x \<Rightarrow> finU_range x
     | InfT x \<Rightarrow> infT_range x
     | InfU x \<Rightarrow> infU_range x"

-- "finite timed stream that consists of n empty time intervals"
primrec
   nticks :: "nat \<Rightarrow> 'a fstream"
where
  "nticks 0 = []" |
  "nticks (Suc i) = [] # (nticks i)"

-- "removing the first element from an infinite stream"
-- "in the case of an untimed stream: removing the first data element"
-- "in the case of a timed stream: removing the first time interval"
definition
   inf_tl :: "(nat \<Rightarrow> 'a) \<Rightarrow> (nat \<Rightarrow> 'a)"
where
  "inf_tl s \<equiv> (\<lambda> i. s (Suc i))"

-- "removing i first elements from an infinite stream s"
-- "in the case of an untimed stream: removing i first data elements"
-- "in the case of a timed stream: removing i first time intervals"
definition
   inf_drop :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> (nat \<Rightarrow> 'a)"
where
  "inf_drop i s \<equiv>  \<lambda> j. s (i+j)"

-- "finding the first nonempty time interval in a finite timed stream"
primrec
 fin_find1nonemp :: "'a fstream \<Rightarrow> 'a list"
where
 "fin_find1nonemp [] = []" |
 "fin_find1nonemp (x#xs) =
    ( if x = []
      then fin_find1nonemp xs
      else x )"

-- "finding the first nonempty time interval in an infinite timed stream"
definition
  inf_find1nonemp :: "'a istream \<Rightarrow> 'a list"
where
 "inf_find1nonemp s
  \<equiv>
  ( if (\<exists> i. s i \<noteq> [])
    then s (LEAST i. s i \<noteq> [])
    else [] )"

-- "finding the index of the first nonempty time interval in a finite timed stream"
primrec
 fin_find1nonemp_index :: "'a fstream \<Rightarrow> nat"
where
 "fin_find1nonemp_index [] = 0" |
 "fin_find1nonemp_index (x#xs) =
    ( if x = []
      then Suc (fin_find1nonemp_index xs)
      else 0 )"

-- "finding the index of the first nonempty time interval in an infinite timed stream"
definition
  inf_find1nonemp_index :: "'a istream \<Rightarrow> nat"
where
 "inf_find1nonemp_index s
  \<equiv>
  ( if (\<exists> i. s i \<noteq> [])
    then (LEAST i. s i \<noteq> [])
    else 0 )"

-- "length of a finite timed stream: number of data elements in this stream"
primrec
  fin_length :: "'a fstream \<Rightarrow> nat"
where
  "fin_length [] = 0" |
  "fin_length (x#xs) = (length x) + (fin_length xs)"

-- "length of a (general) stream"
definition
   stream_length :: "'a stream \<Rightarrow> natInf"
where
  "stream_length s \<equiv>
      case s of
                (FinT x) \<Rightarrow> Fin (fin_length x)
              | (FinU x) \<Rightarrow> Fin (length x)
              | (InfT x) \<Rightarrow> \<infinity>
              | (InfU x) \<Rightarrow> \<infinity>"

-- "removing the first k elements from a finite (nonempty) timed stream"
axiomatization
  fin_nth :: "'a fstream \<Rightarrow> nat \<Rightarrow> 'a"
where
   fin_nth_Cons:
  "fin_nth (hds # tls) k =
      ( if hds = []
        then fin_nth tls k
        else ( if (k < (length hds))
               then nth hds k
               else fin_nth tls (k - length hds) ))"

-- "removing i first data elements from an infinite timed stream s"
primrec
  inf_nth :: "'a istream \<Rightarrow> nat \<Rightarrow> 'a"
where
 "inf_nth s 0 =  hd (s (LEAST i.(s i) \<noteq> []))"  |
 "inf_nth s (Suc k) =
      ( if ((Suc k) < (length (s 0)))
        then (nth (s 0) (Suc k))
        else ( if (s 0) = []
               then (inf_nth (inf_tl (inf_drop
                     (LEAST i. (s i) \<noteq> []) s)) k )
               else inf_nth (inf_tl s) k ))"

-- "removing the first k data elements from a (general) stream"
definition
    stream_nth :: "'a stream \<Rightarrow> nat \<Rightarrow> 'a"
where
   "stream_nth s k \<equiv>
         case s of (FinT x) \<Rightarrow> fin_nth x k
                 | (FinU x) \<Rightarrow> nth x k
                 | (InfT x) \<Rightarrow> inf_nth x k
                 | (InfU x) \<Rightarrow> x k"

-- "prefix of an infinite stream"
primrec
  inf_prefix :: "'a list \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> bool"
where
  "inf_prefix [] s k = True" |
  "inf_prefix (x#xs) s k = ( (x = (s k)) \<and> (inf_prefix xs s (Suc k)) )"

-- "prefix of a finite stream"
primrec
  fin_prefix :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "fin_prefix [] s = True" |
  "fin_prefix (x#xs) s =
     (if (s = [])
      then False
      else (x = (hd s)) \<and> (fin_prefix xs s) )"

-- "prefix of a (general) stream"
definition
   stream_prefix :: "'a stream \<Rightarrow> 'a stream \<Rightarrow> bool"
where
  "stream_prefix p s \<equiv>
   (case p of
        (FinT x) \<Rightarrow>
        (case s of (FinT y) \<Rightarrow>  (fin_prefix x y)
                 | (FinU y) \<Rightarrow> False
                 | (InfT y) \<Rightarrow> inf_prefix x y 0
                 | (InfU y) \<Rightarrow> False )
      | (FinU x) \<Rightarrow>
        (case s of (FinT y) \<Rightarrow> False
                 | (FinU y) \<Rightarrow>  (fin_prefix x y)
                 | (InfT y) \<Rightarrow> False
                 | (InfU y) \<Rightarrow>  inf_prefix x y 0 )
      | (InfT x) \<Rightarrow>
        (case s of (FinT y) \<Rightarrow> False
                 | (FinU y) \<Rightarrow> False
                 | (InfT y) \<Rightarrow> (\<forall> i. x i = y i)
                 | (InfU y) \<Rightarrow> False )
      | (InfU x) \<Rightarrow>
        (case s of (FinT y) \<Rightarrow> False
                 | (FinU y) \<Rightarrow> False
                 | (InfT y) \<Rightarrow> False
                 | (InfU y) \<Rightarrow> (\<forall> i. x i = y i) )  )"

-- "truncating a finite stream after the n-th element"
primrec
fin_truncate :: "'a list \<Rightarrow> nat \<Rightarrow> 'a list"
where
  "fin_truncate [] n = []" |
  "fin_truncate (x#xs) i =
      (case i of 0 \<Rightarrow> []
         | (Suc n) \<Rightarrow> x # (fin_truncate xs n))"

-- "truncating a finite stream after the n-th element"
-- "n is of type of natural numbers enriched by Infinity"
definition
  fin_truncate_plus :: "'a list \<Rightarrow> natInf \<Rightarrow> 'a list"
 where
 "fin_truncate_plus s n
  \<equiv>
  case n of (Fin i) \<Rightarrow> fin_truncate s i
           |  \<infinity>     \<Rightarrow> s "

-- "truncating an infinite stream after the n-th element"
primrec
  inf_truncate :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a list"
where
   "inf_truncate s 0 = [ s 0 ]" |
   "inf_truncate s (Suc k) = (inf_truncate s k) @ [s (Suc k)]"

-- "truncating an infinite stream after the n-th element"
-- "n is of type of natural numbers enriched by Infinity"
definition
  inf_truncate_plus :: "'a istream \<Rightarrow> natInf \<Rightarrow> 'a stream"
 where
 "inf_truncate_plus s n
  \<equiv>
  case n of (Fin i) \<Rightarrow> FinT (inf_truncate s i)
           | \<infinity>     \<Rightarrow> InfT s"

-- "concatanation of a finite and an infinite stream"
definition
    fin_inf_append ::
        "'a list \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> (nat \<Rightarrow> 'a)"
where
"fin_inf_append us s \<equiv>
 (\<lambda> i. ( if (i < (length us))
         then (nth us i)
         else s (i - (length us)) ))"

-- "insuring that the infinite timed stream is time-synchronous"
definition
   ts :: "'a istream \<Rightarrow> bool"
where
"ts s \<equiv>  \<forall> i. (length (s i) = 1)"

-- "insuring that each time interval of an infinite timed stream contains at most n data elements"
definition
  msg :: "nat \<Rightarrow> 'a istream \<Rightarrow> bool"
where
 "msg n s \<equiv>  \<forall> t. length (s t) \<le> n"

-- "insuring that each time interval of a finite timed stream contains at most n data elements"
primrec
  fin_msg :: "nat \<Rightarrow> 'a list list \<Rightarrow> bool"
where
 "fin_msg n [] = True" |
 "fin_msg n (x#xs) = (((length x) \<le> n) \<and> (fin_msg n xs))"

-- "making a finite timed stream to a finite untimed stream"
definition
   fin_make_untimed :: "'a fstream  \<Rightarrow> 'a list"
where
  "fin_make_untimed x \<equiv>  concat x"

-- "making an infinite timed stream to an infinite untimed stream"
-- "(auxiliary function)"
primrec
  inf_make_untimed1 :: "'a istream \<Rightarrow> nat \<Rightarrow> 'a "
where
inf_make_untimed1_0:
  "inf_make_untimed1 s 0 =  hd (s (LEAST i.(s i) \<noteq> []))"  |
inf_make_untimed1_Suc:
  "inf_make_untimed1 s (Suc k) =
    ( if ((Suc k) < length (s 0))
      then nth (s 0) (Suc k)
      else ( if (s 0) = []
             then (inf_make_untimed1 (inf_tl (inf_drop
                          (LEAST i. \<forall> j. j < i \<longrightarrow> (s j) = [])
                           s)) k )
             else inf_make_untimed1 (inf_tl s) k ))"

-- "making an infinite timed stream to an infinite untimed stream"
-- "(main function)"
definition
   inf_make_untimed :: "'a istream \<Rightarrow> (nat \<Rightarrow> 'a) "
where
  "inf_make_untimed s
   \<equiv>
   \<lambda> i. inf_make_untimed1 s i"

-- "making a (general) stream untimed"
definition
    make_untimed :: "'a stream  \<Rightarrow> 'a stream"
where
   "make_untimed s \<equiv>
      case s of (FinT x) \<Rightarrow> FinU (fin_make_untimed x)
              | (FinU x) \<Rightarrow> FinU x
              | (InfT x) \<Rightarrow>
                (if (\<exists> i.\<forall> j. i < j \<longrightarrow> (x j) = [])
                 then FinU (fin_make_untimed (inf_truncate x
                             (LEAST i.\<forall> j. i < j \<longrightarrow> (x j) = [])))
                 else InfU (inf_make_untimed x))
              | (InfU x) \<Rightarrow> InfU x"

-- "finding the index of the time interval that contains the k-th data element"
-- "defined over a finite timed stream"
primrec
  fin_tm :: "'a fstream \<Rightarrow> nat \<Rightarrow> nat"
where
  "fin_tm [] k = k" |
  "fin_tm (x#xs) k =
    (if k = 0
     then 0
     else (if (k \<le> length x)
           then (Suc 0)
           else Suc(fin_tm xs (k - length x))))"

-- "auxiliary lemma for the definition of the truncate operator"
lemma inf_tm_hint1:
  assumes "i2 = Suc i - length a"
      and "\<not> Suc i \<le> length a"
      and "a \<noteq> []"
  shows "i2 < Suc i"
using assms
by auto

-- "filtering a finite timed stream"
definition
   finT_filter :: "'a set => 'a fstream => 'a fstream"
where
  "finT_filter m s \<equiv>  map (\<lambda> s. filter (\<lambda> y. y \<in> m) s) s"

-- "filtering an infinite timed stream"
definition
   infT_filter :: "'a set => 'a istream => 'a istream"
where
  "infT_filter m s \<equiv>  (\<lambda>i.( filter (\<lambda> x. x \<in> m) (s i)))"

-- "removing duplications from a finite timed stream"
definition
   finT_remdups :: "'a fstream => 'a fstream"
where
  "finT_remdups s \<equiv>  map (\<lambda> s. remdups s) s"

-- "removing duplications from an infinite timed stream"
definition
   infT_remdups :: "'a istream => 'a istream"
where
  "infT_remdups s \<equiv>  (\<lambda>i.( remdups (s i)))"

-- "removing duplications from a time interval of a stream"
primrec
   fst_remdups :: "'a list \<Rightarrow> 'a list"
where
 "fst_remdups [] = []" |
 "fst_remdups (x#xs) =
    (if xs = []
     then [x]
     else (if x = (hd xs)
           then fst_remdups xs
           else (x#xs)))"

-- "time interval operator"
definition
  ti :: "'a fstream \<Rightarrow> nat \<Rightarrow> 'a list"
where
 "ti s i \<equiv>
    (if s = []
     then []
     else (nth s i))"

-- "insuring that a sheaf of channels is correctly defined"
definition
   CorrectSheaf :: "nat \<Rightarrow> bool"
where
  "CorrectSheaf n \<equiv> 0 < n"

-- "insuring that all channels in a sheaf are disjunct"
-- "indices in the sheaf are represented using an extra specified set"
definition
   inf_disjS :: "'b set \<Rightarrow> ('b \<Rightarrow> 'a istream) \<Rightarrow> bool"
where
  "inf_disjS IdSet nS
   \<equiv>
   \<forall> (t::nat) i j. (i:IdSet) \<and> (j:IdSet) \<and>
   ((nS i) t) \<noteq> []  \<longrightarrow> ((nS j) t) = []"

-- "insuring that all channels in a sheaf are disjunct"
-- "indices in the sheaf are represented using natural numbers"
definition
   inf_disj :: "nat \<Rightarrow> (nat \<Rightarrow> 'a istream) \<Rightarrow> bool"
where
  "inf_disj n nS
   \<equiv>
   \<forall> (t::nat) (i::nat) (j::nat).
   i < n  \<and>  j < n \<and> i \<noteq> j \<and> ((nS i) t) \<noteq> []  \<longrightarrow>
   ((nS j) t) = []"

-- "taking the prefix of n data elements from a finite timed stream"
-- "(defined over natural numbers)"
fun fin_get_prefix  :: "('a fstream \<times> nat) \<Rightarrow> 'a fstream"
where
  "fin_get_prefix([], n) = []" |
  "fin_get_prefix(x#xs, i) =
     ( if (length x) < i
       then x # fin_get_prefix(xs, (i - (length x)))
       else [take i x] ) "

-- "taking the prefix of n data elements from a finite timed stream"
-- "(defined over natural numbers enriched by Infinity)"
definition
  fin_get_prefix_plus :: "'a fstream \<Rightarrow> natInf \<Rightarrow> 'a fstream"
where
 "fin_get_prefix_plus s n
  \<equiv>
  case n of (Fin i) \<Rightarrow> fin_get_prefix(s, i)
           | \<infinity>      \<Rightarrow> s "

-- "auxiliary lemmas "
lemma length_inf_drop_hint1:
  assumes "s k \<noteq> []"
  shows    "length (inf_drop k s 0) \<noteq> 0"
using assms
by (auto simp: inf_drop_def)

-- "taking the prefix of n data elements from an infinite timed stream"
-- "(defined over natural numbers)"
fun infT_get_prefix  :: "('a istream \<times> nat) \<Rightarrow> 'a fstream"
where
  "infT_get_prefix(s, 0) = []"
|
  "infT_get_prefix(s, Suc i) =
    ( if (s 0) = []
      then ( if (\<forall> i. s i = [])
             then []
             else (let
                     k = (LEAST k. s k \<noteq> [] \<and> (\<forall>i. i < k \<longrightarrow> s i = []));
                     s2 = inf_drop (k+1) s
                   in (if (length (s k)=0)
                       then []
                       else (if (length (s k) < (Suc i))
                             then s k # infT_get_prefix (s2,Suc i - length (s k))
                             else [take (Suc i) (s k)] )))
           )
      else
        (if ((length (s 0)) < (Suc i))
         then (s 0) # infT_get_prefix( inf_drop 1 s, (Suc i) - (length (s 0)))
         else [take (Suc i) (s 0)]
         )
     )"

-- "taking the prefix of n data elements from an infinite untimed stream"
-- "(defined over natural numbers)"
primrec
  infU_get_prefix  :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a list"
where
  "infU_get_prefix s 0 = []" |
  "infU_get_prefix s (Suc i)
         = (infU_get_prefix s i) @ [s i]"

-- "taking the prefix of n data elements from an infinite timed stream"
-- "(defined over natural numbers enriched by Infinity)"
definition
  infT_get_prefix_plus :: "'a istream \<Rightarrow> natInf \<Rightarrow> 'a stream"
where
"infT_get_prefix_plus s n
  \<equiv>
  case n of (Fin i) \<Rightarrow> FinT (infT_get_prefix(s, i))
           | \<infinity>     \<Rightarrow> InfT s"

-- "taking the prefix of n data elements from an infinite untimed stream"
-- "(defined over natural numbers enriched by Infinity)"
definition
  infU_get_prefix_plus :: "(nat \<Rightarrow> 'a) \<Rightarrow> natInf \<Rightarrow> 'a stream"
where
 "infU_get_prefix_plus s n
  \<equiv>
  case n of (Fin i) \<Rightarrow> FinU (infU_get_prefix s i)
           | \<infinity>     \<Rightarrow> InfU s"

-- "taking the prefix of n data elements from an infinite stream"
-- "(defined over natural numbers enriched by Infinity)"
definition
  take_plus :: "natInf \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
 "take_plus n s
  \<equiv>
  case n of (Fin i) \<Rightarrow> (take i s)
           | \<infinity>      \<Rightarrow> s"

-- "taking the prefix of n data elements from a (general) stream"
-- "(defined over natural numbers enriched by Infinity)"
definition
   get_prefix :: "'a stream \<Rightarrow> natInf \<Rightarrow> 'a stream"
where
   "get_prefix s k \<equiv>
        case s of  (FinT x) \<Rightarrow> FinT (fin_get_prefix_plus x k)
                 | (FinU x) \<Rightarrow> FinU (take_plus k x)
                 | (InfT x) \<Rightarrow> infT_get_prefix_plus x k
                 | (InfU x) \<Rightarrow> infU_get_prefix_plus x k"

-- "merging time intervals of two finite timed streams"
primrec
   fin_merge_ti :: "'a fstream \<Rightarrow> 'a fstream \<Rightarrow> 'a fstream"
where
 "fin_merge_ti [] y = y" |
 "fin_merge_ti (x#xs) y =
    ( case y of [] \<Rightarrow> (x#xs)
         | (z#zs) \<Rightarrow> (x@z) # (fin_merge_ti xs zs))"

-- "merging time intervals of two infinite timed streams"
definition
 inf_merge_ti :: "'a istream \<Rightarrow> 'a istream \<Rightarrow> 'a istream"
where
 "inf_merge_ti x y
  \<equiv>
  \<lambda> i. (x i)@(y i)"

-- "the last time interval of a finite timed stream"
primrec
  fin_last_ti :: "('a list) list \<Rightarrow> nat \<Rightarrow> 'a list"
where
 "fin_last_ti s 0 = hd s" |
 "fin_last_ti s (Suc i) =
     ( if s!(Suc i) \<noteq> []
       then s!(Suc i)
       else fin_last_ti s i)"

-- "the last nonempty time interval of a finite timed stream"
-- "(can be applied to the streams which time intervals are empty from some moment)"
primrec
  inf_last_ti :: "'a istream \<Rightarrow> nat \<Rightarrow> 'a list"
where
 "inf_last_ti s 0 = s 0" |
 "inf_last_ti s (Suc i) =
     ( if s (Suc i) \<noteq> []
       then s (Suc i)
       else inf_last_ti s i)"

subsection {* Properties of operators *}

lemma inf_last_ti_nonempty_k:
  assumes "inf_last_ti dt t \<noteq> []"
  shows    "inf_last_ti dt (t + k) \<noteq> []"
using assms
by (induct k, auto)

lemma inf_last_ti_nonempty:
  assumes "s t \<noteq> []"
  shows    "inf_last_ti s (t + k) \<noteq> []"
using assms
by (induct k, auto, induct t, auto)

lemma arith_sum_t2k:
"t + 2 + k = (Suc t) + (Suc k)"
by arith

lemma inf_last_ti_Suc2:
  assumes "dt (Suc t) \<noteq> [] \<or> dt (Suc (Suc t)) \<noteq> []"
  shows    "inf_last_ti dt (t + 2 + k) \<noteq> []"
proof (cases "dt (Suc t) \<noteq> []")
  assume a1:"dt (Suc t) \<noteq> []"
  from a1 have sg2:"inf_last_ti dt ((Suc t) + (Suc k)) \<noteq> []"
    by (rule inf_last_ti_nonempty)
  from sg2 show ?thesis by (simp add: arith_sum_t2k)
next
  assume a2:"\<not> dt (Suc t) \<noteq> []"
  from a2 and assms have sg1:"dt (Suc (Suc t)) \<noteq> []" by simp
  from sg1 have sg2:"inf_last_ti dt (Suc (Suc t) + k) \<noteq> []"
    by (rule inf_last_ti_nonempty)
  from sg2 show ?thesis by auto
qed

subsubsection {* Lemmas for concatenation operator *}

lemma fin_length_append:
  "fin_length (x@y) = (fin_length x) + (fin_length y)"
by (induct x, auto)

lemma fin_append_Nil:  "fin_inf_append [] z = z"
by (simp add: fin_inf_append_def)

lemma correct_fin_inf_append1:
  assumes "s1 = fin_inf_append [x] s"
  shows    "s1 (Suc i) = s i"
using assms
by (simp add: fin_inf_append_def)

lemma correct_fin_inf_append2:
  "fin_inf_append [x] s (Suc i) = s i"
by (simp add: fin_inf_append_def)

lemma fin_append_com_Nil1:
  "fin_inf_append [] (fin_inf_append y z)
   = fin_inf_append ([] @ y) z"
by (simp add: fin_append_Nil)

lemma fin_append_com_Nil2:
  "fin_inf_append x (fin_inf_append [] z)
  = fin_inf_append (x @ []) z"
by (simp add: fin_append_Nil)

lemma fin_append_com_i:
  "fin_inf_append x (fin_inf_append y z) i = fin_inf_append (x @ y) z i "
proof (cases x)
  assume Nil:"x = []"
  thus ?thesis by (simp add: fin_append_com_Nil1)
next
  fix a l assume Cons:"x = a # l"
  thus ?thesis
  proof (cases y)
    assume "y = []"
    thus ?thesis by (simp add: fin_append_com_Nil2)
  next
    fix aa la assume Cons2:"y = aa # la"
    show ?thesis
    apply (simp add: fin_inf_append_def, auto, simp add: list_nth_append0)
    by (simp add: nth_append)
  qed
qed

subsubsection {* Lemmas for operators $ts$ and $msg$ *}

lemma ts_msg1:
  assumes "ts p"
  shows    "msg 1 p"
using assms
by (simp add: ts_def msg_def)

lemma ts_inf_tl:
  assumes "ts x"
  shows    "ts (inf_tl x)"
using assms
by (simp add: ts_def inf_tl_def)

lemma ts_length_hint1:
 assumes "ts x"
 shows    "x i \<noteq> []"
proof -
  from assms have sg1:"length (x i) = Suc 0"  by (simp add: ts_def)
  thus ?thesis by auto
qed

lemma ts_length_hint2:
 assumes "ts x"
 shows    "length (x i) = Suc (0::nat)"
using assms
by (simp add: ts_def)

lemma ts_Least_0:
  assumes "ts x"
  shows    "(LEAST i. (x i) \<noteq> [] ) = (0::nat)"
proof -
  from assms have sg1:"x 0 \<noteq> []" by (rule ts_length_hint1)
  thus ?thesis
  apply (simp add: Least_def)
  by auto
qed

lemma inf_tl_Suc: "inf_tl x i = x (Suc i)"
by (simp add: inf_tl_def)

lemma ts_Least_Suc0:
  assumes "ts x"
  shows    "(LEAST i. x (Suc i) \<noteq> []) = 0"
proof -
  from assms have "x (Suc 0) \<noteq> []" by (simp add: ts_length_hint1)
  thus ?thesis by (simp add: Least_def, auto)
qed

lemma ts_inf_make_untimed_inf_tl:
  assumes "ts x"
  shows     "inf_make_untimed (inf_tl x) i = inf_make_untimed x (Suc i)"
using assms
apply (simp add: inf_make_untimed_def)
by (metis Suc_less_eq gr_implies_not0 ts_length_hint1 ts_length_hint2)

lemma ts_inf_make_untimed1_inf_tl:
  assumes "ts x"
  shows    "inf_make_untimed1 (inf_tl x) i = inf_make_untimed1 x (Suc i)"
using assms
by (metis inf_make_untimed_def ts_inf_make_untimed_inf_tl)

lemma msg_nonempty1:
  assumes h1:"msg (Suc 0) a"
         and h2:"a t = aa # l"
  shows "l = []"
proof -
  from h1 have "length (a t) \<le> Suc 0" by (simp add: msg_def)
  from h2 and this show ?thesis by auto
qed

lemma msg_nonempty2:
  assumes h1:"msg (Suc 0) a"
         and h2:"a t  \<noteq> []"
  shows "length (a t) = (Suc 0)"
proof -
  from h1 have sg1:"length (a t) \<le> Suc 0" by (simp add: msg_def)
  from h2 have sg2:"length (a t) \<noteq> 0" by auto
  from sg1 and sg2 show ?thesis by arith
qed

subsubsection {* Lemmas for $inf\_truncate$ *}

lemma inf_truncate_nonempty:
  assumes "z i \<noteq> []"
  shows    "inf_truncate z i \<noteq> []"
proof (induct i)
    case 0
    from assms  show ?case by auto
  next
    case (Suc i)
     from assms show ?case by auto
qed

lemma concat_inf_truncate_nonempty:
  assumes  "z i \<noteq> []"
  shows      "concat (inf_truncate z i) \<noteq> []"
using assms
proof (induct i)
    case 0
    thus ?case by auto
  next
    case (Suc i)
    thus ?case by auto
qed

lemma concat_inf_truncate_nonempty_a:
  assumes "z i = [a]"
  shows    "concat (inf_truncate z i) \<noteq> []"
using assms
by (metis concat_inf_truncate_nonempty list.distinct(1))

lemma concat_inf_truncate_nonempty_el:
  assumes "z i \<noteq> []"
  shows    "concat (inf_truncate z i) \<noteq> []"
using assms
by (metis concat_inf_truncate_nonempty)

lemma inf_truncate_append:
  "(inf_truncate z i @ [z (Suc i)]) = inf_truncate z (Suc i)"
using assms
by (metis inf_truncate.simps(2))

subsubsection {* Lemmas for $fin\_make\_untimed$ *}

lemma fin_make_untimed_append:
  assumes "fin_make_untimed x \<noteq> []"
  shows    "fin_make_untimed (x @ y) \<noteq> []"
using assms by (simp add: fin_make_untimed_def)

lemma fin_make_untimed_inf_truncate_Nonempty:
  assumes "z k \<noteq> []"
         and "k \<le> i"
  shows "fin_make_untimed (inf_truncate z i) \<noteq> []"
using assms
  apply (simp add: fin_make_untimed_def)
  proof (induct i)
    case 0
    thus ?case  by auto
  next
    case (Suc i)
    thus ?case
    proof cases
      assume "k \<le> i"
      from Suc and this show "\<exists>xs\<in>set (inf_truncate z (Suc i)). xs \<noteq> []"
        by auto
    next
      assume "\<not> k \<le> i"
      from Suc and this have "k = Suc i" by arith
      from Suc and this show "\<exists>xs\<in>set (inf_truncate z (Suc i)). xs \<noteq> []"
        by auto
     qed
qed

lemma last_fin_make_untimed_inf_truncate:
  assumes "z i = [a]"
  shows    "last (fin_make_untimed (inf_truncate z i)) = a"
using assms
proof (induction i)
   case 0  thus ?case by (simp add: fin_make_untimed_def)
next
   case (Suc i)  thus ?case by (simp add: fin_make_untimed_def)
qed

lemma fin_make_untimed_append_empty:
  "fin_make_untimed (z @ [[]]) = fin_make_untimed z"
by (simp add: fin_make_untimed_def)

lemma fin_make_untimed_inf_truncate_append_a:
  "fin_make_untimed (inf_truncate z i @ [[a]]) !
  (length (fin_make_untimed (inf_truncate z i @ [[a]])) - Suc 0) = a"
by (simp add: fin_make_untimed_def)

lemma fin_make_untimed_inf_truncate_Nonempty_all:
  assumes "z k \<noteq> []"
  shows    "\<forall> i. k \<le> i \<longrightarrow> fin_make_untimed (inf_truncate z i) \<noteq> []"
using assms by (simp add:  fin_make_untimed_inf_truncate_Nonempty)

lemma fin_make_untimed_inf_truncate_Nonempty_all0:
  assumes "z 0 \<noteq> []"
  shows    "\<forall> i. fin_make_untimed (inf_truncate z i) \<noteq> []"
using assms by (simp add: fin_make_untimed_inf_truncate_Nonempty)

lemma fin_make_untimed_inf_truncate_Nonempty_all0a:
  assumes "z 0 = [a]"
  shows    "\<forall> i. fin_make_untimed (inf_truncate z i) \<noteq> []"
using assms by (simp add: fin_make_untimed_inf_truncate_Nonempty_all0)

lemma fin_make_untimed_inf_truncate_Nonempty_all_app:
  assumes "z 0 = [a]"
  shows    "\<forall> i. fin_make_untimed (inf_truncate z i @ [z (Suc i)]) \<noteq> []"
proof
  fix i
  from assms have "fin_make_untimed (inf_truncate z i) \<noteq> []"
    by (simp add: fin_make_untimed_inf_truncate_Nonempty_all0a)
  from assms and this show
    "fin_make_untimed (inf_truncate z i @ [z (Suc i)]) \<noteq> []"
    by (simp add: fin_make_untimed_append)
qed

lemma fin_make_untimed_nth_length:
  assumes "z i = [a]"
  shows
  "fin_make_untimed (inf_truncate z i) !
     (length (fin_make_untimed (inf_truncate z i)) - Suc 0)
    = a"
proof -
from assms have sg1:"last (fin_make_untimed (inf_truncate z i)) = a"
  by (simp add: last_fin_make_untimed_inf_truncate)
from assms have sg2:"concat (inf_truncate z i) \<noteq> []"
  by (rule concat_inf_truncate_nonempty_a)
from assms and sg1 and sg2 show ?thesis
  by (simp add: fin_make_untimed_def last_nth_length)
qed

subsubsection {* Lemmas for $inf\_disj$ and $inf\_disjS$ *}

lemma inf_disj_index:
  assumes h1:"inf_disj n nS"
         and "nS k t \<noteq> []"
         and "k < n"
  shows  "(SOME i. i < n \<and>  nS i t \<noteq> []) = k"
proof -
  from h1 have "\<forall> j. k < n \<and> j < n \<and> k \<noteq> j \<and> nS k t \<noteq> [] \<longrightarrow> nS j t = []"
    by (simp add: inf_disj_def, auto)
  from this and assms show ?thesis by auto
qed

lemma inf_disjS_index:
  assumes h1:"inf_disjS IdSet nS"
      and "k:IdSet"
      and "nS k t \<noteq> []"
  shows "(SOME i. (i:IdSet) \<and> nSend i t \<noteq> []) = k"
proof -
  from h1 have "\<forall> j. k \<in> IdSet \<and> j \<in> IdSet \<and> nS k t \<noteq> [] \<longrightarrow> nS j t = []"
    by (simp add: inf_disjS_def, auto)
  from this and assms show ?thesis by auto
qed

end