theory Splay_Tree_Analysis_Optimal
imports
  Splay_Tree_Analysis_Base
  Amor
  "~~/src/HOL/Library/Sum_of_Squares"
begin

section "Splay Tree Analysis (Optimal)"

text{* This analysis follows Schoenmakers~\cite{Schoenmakers-IPL93}. *}

subsection "Analysis of splay"

locale Splay_Analysis =
fixes \<alpha> :: real and \<beta> :: real
assumes a1[arith]: "\<alpha> > 1"
assumes A1: "\<lbrakk>1 \<le> x; 1 \<le> y; 1 \<le> z\<rbrakk> \<Longrightarrow>
 (x+y) * (y+z) powr \<beta> \<le> (x+y) powr \<beta> * (x+y+z)"
assumes A2: "\<lbrakk>1 \<le> l'; 1 \<le> r'; 1 \<le> lr; 1 \<le> r\<rbrakk> \<Longrightarrow>
   \<alpha> * (l'+r') * (lr+r) powr \<beta> * (lr+r'+r) powr \<beta>
    \<le> (l'+r') powr \<beta> * (l'+lr+r') powr \<beta> * (l'+lr+r'+r)"
assumes A3: "\<lbrakk>1 \<le> l'; 1 \<le> r'; 1 \<le> ll; 1 \<le> r\<rbrakk> \<Longrightarrow>
  \<alpha> * (l'+r') * (l'+ll) powr \<beta> * (r'+r) powr \<beta>
  \<le> (l'+r') powr \<beta> * (l'+ll+r') powr \<beta> * (l'+ll+r'+r)"
begin

lemma nl2: "\<lbrakk> ll \<ge> 1; lr \<ge> 1; r \<ge> 1 \<rbrakk> \<Longrightarrow>
  log \<alpha> (ll + lr) + \<beta> * log \<alpha> (lr + r)
  \<le> \<beta> * log \<alpha> (ll + lr) + log \<alpha> (ll + lr + r)"
apply(rule powr_le_cancel_iff[THEN iffD1, OF a1])
apply(simp add: powr_add mult.commute[of \<beta>] powr_powr[symmetric] A1)
done

definition \<phi> :: "'a tree \<Rightarrow> 'a tree \<Rightarrow> real" where
"\<phi> t1 t2 = \<beta> * log \<alpha> (size1 t1 + size1 t2)"

fun \<Phi> :: "'a tree \<Rightarrow> real" where
"\<Phi> Leaf = 0" |
"\<Phi> (Node l _ r) = \<Phi> l + \<Phi> r + \<phi> l r"

definition A :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> real" where
"A a t = t_splay a t + \<Phi>(splay a t) - \<Phi> t"

lemma A_simps[simp]: "A a (Node l a r) = 1"
 "a<b \<Longrightarrow> A a (Node (Node ll a lr) b r) = \<phi> lr r - \<phi> lr ll + 1"
 "b<a \<Longrightarrow> A a (Node l b (Node rl a rr)) = \<phi> rl l - \<phi> rr rl + 1"
by(auto simp add: A_def \<phi>_def algebra_simps real_of_nat_Suc)

lemma A_ub: "\<lbrakk> bst t; Node la a ra : subtrees t \<rbrakk>
  \<Longrightarrow> A a t \<le> log \<alpha> ((size1 t)/(size1 la + size1 ra)) + 1"
proof(induction a t rule: splay.induct)
  case 1 thus ?case by simp
next
  case (2 a l b r)
  let ?r = "real (size1 r)" let ?l = "real (size1 l)"
  have a: "a : insert b (set_tree l Un set_tree r)" using "2.prems"(2)
    by (metis Node_notin_subtrees_if tree.set(2))
  show ?case
  proof cases
    assume "a=b"
    thus ?thesis using "2.prems" by (auto simp: real_of_nat_Suc)
  next
    assume "a\<noteq>b"
    hence "a<b \<or> b<a" by (metis neqE)
    thus ?thesis
    proof
      assume "a<b"
      then obtain ll c lr where [simp]: "l = Node ll c lr"
        using "2.prems"(1,2)
        by (cases l) (auto, metis in_set_tree_if less_asym)
      let ?ll = "real (size1 ll)" let ?lr = "real (size1 lr)"
      have "c < b" using "2.prems"(1,2) by (auto)
      hence "c \<notin> set_tree r" using "2.prems"(1) by auto
      show ?thesis
      proof cases
        assume "a=c"
        thus ?thesis using "2.prems"(1,2) `a<b` `c \<notin> set_tree r` nl2[of ?ll ?lr ?r]
          by (auto simp: real_of_nat_Suc \<phi>_def log_divide field_simps)
      next
        assume "a\<noteq>c"
        hence "a<c \<or> c<a" by (metis neqE)
        thus ?thesis
        proof
          assume "a<c"
          hence 0: "a \<notin> set_tree lr \<and> a \<notin> set_tree r"
            using "2.prems"(1) by auto
          hence 1: "a \<in> set_tree ll" using "2.prems" `a<c` by (auto)
          then obtain l' u r' where sp: "splay a ll = Node l' u r'"
            using "2.prems"(1,2) by(cases "splay a ll") auto
          have "ll \<noteq> Leaf" using 1 by auto
          let ?l' = "real (size1 l')" let ?r' = "real (size1 r')"
          have "1 + log \<alpha> (?l' + ?r') + \<beta> * log \<alpha> (?lr + ?r) + \<beta> * log \<alpha> (?lr + ?r' + ?r) \<le>
               \<beta> * log \<alpha> (?l' + ?r') + \<beta> * log \<alpha> (?l' + ?lr + ?r') + log \<alpha> (?l' + ?lr + ?r' + ?r)" (is "?L\<le>?R")
          proof(rule powr_le_cancel_iff[THEN iffD1, OF a1])
            show "\<alpha> powr ?L \<le> \<alpha> powr ?R" using A2[of ?l' ?r' ?lr ?r]
              by(simp add: powr_add add_ac mult.commute[of \<beta>] powr_powr[symmetric])
          qed
          thus ?thesis
            using "2.IH"(1)[OF `a\<noteq>b` `a<b` `l = Node ll c lr` `a\<noteq>c`] `ll \<noteq> Leaf` `a<c` `c<b` "2.prems" 0 1 sp
            by(auto simp: A_def \<phi>_def size_if_splay algebra_simps real_of_nat_Suc log_divide)
       next
          assume "c<a"
          hence 0: "a \<notin> set_tree ll \<and> a \<notin> set_tree r"
            using "2.prems"(1) `a < b` by(auto)
          hence 1: "a \<in> set_tree lr" using "2.prems" `c<a` `a<b` by (auto)
          then obtain l' u r' where sp: "splay a lr = Node l' u r'"
            using "2.prems"(1,2) by(cases "splay a lr") auto
          have "lr \<noteq> Leaf" using 1 by auto
          let ?l' = "real (size1 l')" let ?r' = "real (size1 r')"
          have "1 + log \<alpha> (?l' + ?r') + \<beta> * log \<alpha> (?l' + ?ll) + \<beta> * log \<alpha> (?r' + ?r) \<le>
               \<beta> * log \<alpha> (?l' + ?r') + \<beta> * log \<alpha> (?l' + ?ll + ?r') + log \<alpha> (?l' + ?ll + ?r' + ?r)" (is "?L\<le>?R")
          proof(rule powr_le_cancel_iff[THEN iffD1, OF a1])
            show "\<alpha> powr ?L \<le> \<alpha> powr ?R" using A3[of ?l' ?r' ?ll ?r]
              by(simp add: powr_add mult.commute[of \<beta>] powr_powr[symmetric])
          qed
          thus ?thesis
            using "2.IH"(2)[OF `a\<noteq>b` `a<b` `l = Node ll c lr` `a\<noteq>c`] `lr \<noteq> Leaf` `c<a` `a<b` "2.prems" 0 1 sp
            by(auto simp add: A_def size_if_splay real_of_nat_Suc \<phi>_def log_divide algebra_simps)
        qed
      qed
    next
      assume "b<a"
      then obtain rl c rr where [simp]: "r = Node rl c rr"
        using "2.prems"(1,2)
        by (cases r) (auto, metis in_set_tree_if less_asym)
      let ?rl = "real (size1 rl)" let ?rr = "real (size1 rr)"
      have "b < c" using "2.prems"(1,2) by (auto)
      hence "c \<notin> set_tree l" using "2.prems"(1) by auto
      show ?thesis
      proof cases
        assume "a=c"
        thus ?thesis using "2.prems"(1,2) `b<a` `c \<notin> set_tree l` nl2[of ?rr ?rl ?l]
          by (auto simp add: real_of_nat_Suc \<phi>_def log_divide algebra_simps)
      next
        assume "a\<noteq>c"
        hence "a<c \<or> c<a" by (metis neqE)
        thus ?thesis
        proof
          assume "a<c"
          hence 0: "a \<notin> set_tree rr \<and> a \<notin> set_tree l"
            using "2.prems"(1) `b<a` by (auto)
          hence 1: "a \<in> set_tree rl" using "2.prems" `b<a` `a<c` by (auto)
          then obtain l' u r' where sp: "splay a rl = Node l' u r'"
            using "2.prems"(1,2) by(cases "splay a rl") auto
          have "rl \<noteq> Leaf" using 1 by auto
          let ?l' = "real (size1 l')" let ?r' = "real (size1 r')"
          have "1 + log \<alpha> (?l' + ?r') + \<beta> * log \<alpha> (?l' + ?l) + \<beta> * log \<alpha> (?r' + ?rr) \<le>
               \<beta> * log \<alpha> (?l' + ?r') + \<beta> * log \<alpha> (?l' + ?r' + ?rr) + log \<alpha> (?l' + ?l + ?r' + ?rr)" (is "?L\<le>?R")
          proof(rule powr_le_cancel_iff[THEN iffD1, OF a1])
            show "\<alpha> powr ?L \<le> \<alpha> powr ?R" using A3[of ?r' ?l' ?rr ?l]
              by(simp add: powr_add mult.commute[of \<beta>] powr_powr[symmetric])
                (simp add: algebra_simps)
          qed
          thus ?thesis
            using "2.IH"(3)[OF `a\<noteq>b` order_less_not_sym[OF`b<a`] `r = Node rl c rr` `a\<noteq>c`] `rl \<noteq> Leaf` `b<a` `a<c` "2.prems" 0 1 sp
            by(auto simp add: A_def size_if_splay real_of_nat_Suc \<phi>_def log_divide algebra_simps)
        next
          assume "c<a"
          hence 0: "a \<notin> set_tree rl \<and> a \<notin> set_tree l"
            using "2.prems"(1) `c<a` by(auto)
          hence 1: "a \<in> set_tree rr" using "2.prems" `c<a` `b<a` by (auto)
          then obtain l' u r' where sp: "splay a rr = Node l' u r'"
            using "2.prems"(1,2) by(cases "splay a rr") auto
          have "rr \<noteq> Leaf" using 1 by auto
          let ?l' = "real (size1 l')" let ?r' = "real (size1 r')"
          have "1 + log \<alpha> (?l' + ?r') + \<beta> * log \<alpha> (?l + ?rl) + \<beta> * log \<alpha> (?l' + ?l + ?rl) \<le>
               \<beta> * log \<alpha> (?l' + ?r') + \<beta> * log \<alpha> (?l' + ?rl + ?r') + log \<alpha> (?l' + ?rl + ?r' + ?l)" (is "?L\<le>?R")
          proof(rule powr_le_cancel_iff[THEN iffD1, OF a1])
            show "\<alpha> powr ?L \<le> \<alpha> powr ?R" using A2[of ?r' ?l' ?rl ?l]
              by(simp add: powr_add add_ac mult.commute[of \<beta>] powr_powr[symmetric])
          qed
          thus ?thesis
            using "2.IH"(4)[OF `a\<noteq>b` order_less_not_sym[OF `b<a`] `r = Node rl c rr` `a\<noteq>c`] `rr \<noteq> Leaf` `c<a` `b<a` "2.prems" 0 1 sp
            by(auto simp add: A_def size_if_splay real_of_nat_Suc \<phi>_def log_divide algebra_simps)
        qed
      qed
    qed
  qed
qed

lemma A_ub2: assumes "bst t" "a : set_tree t"
shows "A a t \<le> log \<alpha> ((size1 t)/2) + 1"
proof -
  from assms(2) obtain la ra where N: "Node la a ra : subtrees t"
    by (metis set_treeE)
  have "A a t \<le> log \<alpha> ((size1 t)/(size1 la + size1 ra)) + 1"
    by(rule A_ub[OF assms(1) N])
  also have "\<dots> \<le> log \<alpha> ((size1 t)/2) + 1" by(simp add: field_simps)
  finally show ?thesis by simp
qed

lemma A_ub3: assumes "bst t" shows "A a t \<le> log \<alpha> (size1 t) + 1"
proof cases
  assume "t = Leaf" thus ?thesis by(simp add: A_def)
next
  assume "t \<noteq> Leaf"
  from ex_in_set_tree[OF this assms] obtain a' where
    a': "a' \<in> set_tree t"  "splay a' t = splay a t"  "t_splay a' t = t_splay a t"
    by blast
  have [arith]: "log \<alpha> 2 > 0" by simp
  show ?thesis using A_ub2[OF assms a'(1)] by(simp add: A_def a' log_divide)
qed

definition Am :: "'a::linorder tree \<Rightarrow> real" where
"Am t = t_splay_max t + \<Phi>(splay_max t) - \<Phi> t"

lemma Am_simp3': "\<lbrakk> c<b; bst rr; rr \<noteq> Leaf\<rbrakk> \<Longrightarrow>
  Am (Node l c (Node rl b rr)) =
  (case splay_max rr of Node rrl _ rrr \<Rightarrow>
   Am rr + \<phi> rrl (Node l c rl) + \<phi> l rl - \<phi> rl rr - \<phi> rrl rrr + 1)"
by(auto simp: Am_def \<phi>_def size_if_splay_max algebra_simps real_of_nat_Suc neq_Leaf_iff split: tree.split)

lemma Am_ub: "\<lbrakk> bst t; t \<noteq> Leaf \<rbrakk> \<Longrightarrow> Am t \<le> log \<alpha> ((size1 t)/2) + 1"
proof(induction t rule: splay_max.induct)
  case 1 thus ?case by (simp)
next
  case 2 thus ?case by (simp add: Am_def)
next
  case (3 l b rl c rr)
  show ?case
  proof cases
    assume "rr = Leaf"
    thus ?thesis
      using nl2[of 1 "size1 rl" "size1 l"] log_le_cancel_iff[of \<alpha> 2 "2 + real(size rl)"]
      by(auto simp: real_of_nat_Suc Am_def \<phi>_def log_divide field_simps
           simp del: log_le_cancel_iff)
  next
    assume "rr \<noteq> Leaf"
    then obtain l' u r' where sp: "splay_max rr = Node l' u r'"
      using splay_max_Leaf_iff tree.exhaust by blast
    hence 1: "size rr = size l' + size r' + 1"
      using size_splay_max[of rr] by(simp)
    let ?l = "real (size1 l)" let ?rl = "real (size1 rl)"
    let ?l' = "real (size1 l')" let ?r' = "real (size1 r')"
    have "1 + log \<alpha> (?l' + ?r') + \<beta> * log \<alpha> (?l + ?rl) + \<beta> * log \<alpha> (?l' + ?l + ?rl) \<le>
      \<beta> * log \<alpha> (?l' + ?r') + \<beta> * log \<alpha> (?l' + ?rl + ?r') + log \<alpha> (?l' + ?rl + ?r' + ?l)" (is "?L\<le>?R")
    proof(rule powr_le_cancel_iff[THEN iffD1, OF a1])
      show "\<alpha> powr ?L \<le> \<alpha> powr ?R" using A2[of ?r' ?l' ?rl ?l]
        by(simp add: powr_add add.commute add.left_commute mult.commute[of \<beta>] powr_powr[symmetric])
    qed
    thus ?case using 3 sp 1 `rr \<noteq> Leaf`
      by(auto simp add: Am_simp3' real_of_nat_Suc \<phi>_def log_divide algebra_simps)
  qed
qed

lemma Am_ub3: assumes "bst t" shows "Am t \<le> log \<alpha> (size1 t) + 1"
proof cases
  assume "t = Leaf" thus ?thesis by(simp add: Am_def)
next
  assume "t \<noteq> Leaf"
  have [arith]: "log \<alpha> 2 > 0" by simp
  show ?thesis using Am_ub[OF assms `t \<noteq> Leaf`] by(simp add: Am_def log_divide)
qed

end

subsection "Optimal Interpretation"

lemma mult_root_eq_root:
  "n>0 \<Longrightarrow> y \<ge> 0 \<Longrightarrow> root n x * y = root n (x * (y ^ n))"
by(simp add: real_root_mult real_root_pos2)

lemma mult_root_eq_root2:
  "n>0 \<Longrightarrow> y \<ge> 0 \<Longrightarrow> y * root n x = root n ((y ^ n) * x)"
by(simp add: real_root_mult real_root_pos2)

lemma powr_inverse_numeral:
  "0 < x \<Longrightarrow> x powr (1 / numeral n) = root (numeral n) x"
by (simp add: root_powr_inverse)

lemmas root_simps = mult_root_eq_root mult_root_eq_root2 powr_inverse_numeral

lemma nl31: "\<lbrakk> (l'::real) \<ge> 1; r' \<ge> 1; lr \<ge> 1; r \<ge> 1 \<rbrakk> \<Longrightarrow>
  4 * (l' + r') * (lr + r) \<le> (l' + lr + r' + r)^2"
by (sos "(((A<0 * R<1) + (R<1 * (R<1 * [r + ~1*l' + lr + ~1*r']^2))))")

lemma nl32: assumes "(l'::real) \<ge> 1" "r' \<ge> 1" "lr \<ge> 1" "r \<ge> 1"
shows "4 * (l' + r') * (lr + r) * (lr + r' + r) \<le> (l' + lr + r' + r)^3"
proof -
  have 1: "lr + r' + r \<le> l' + lr + r' + r" using assms by arith
  have 2: "0 \<le> (l' + lr + r' + r)^2" by (rule zero_le_power2)
  have 3: "0 \<le> lr + r' + r" using assms by arith
  from mult_mono[OF nl31[OF assms] 1 2 3] show ?thesis
    by(simp add: ac_simps numeral_eq_Suc)
qed

lemma nl3: assumes "(l'::real) \<ge> 1" "r' \<ge> 1" "lr \<ge> 1" "r \<ge> 1"
shows "4 * (l' + r')^2 * (lr + r) * (lr + r' + r)
       \<le> (l' + lr + r') * (l' + lr + r' + r)^3"
proof-
  have 1: "l' + r' \<le> l' + lr + r'" using assms by arith
  have 2: "0 \<le> (l' + lr + r' + r)^3" using assms by simp
  have 3: "0 \<le> l' + r'" using assms by arith
  from mult_mono[OF nl32[OF assms] 1 2 3] show ?thesis
    unfolding power2_eq_square by (simp only: ac_simps)
qed

lemma nl41: assumes "(l'::real) \<ge> 1" "r' \<ge> 1" "ll \<ge> 1" "r \<ge> 1"
shows "4 * (l' + ll) * (r' + r) \<le> (l' + ll + r' + r)^2"
using assms by (sos "(((A<0 * R<1) + (R<1 * (R<1 * [r + ~1*l' + ~1*ll + r']^2))))")

lemma nl42: assumes "(l'::real) \<ge> 1" "r' \<ge> 1" "ll \<ge> 1" "r \<ge> 1"
shows "4 * (l' + r') * (l' + ll) * (r' + r) \<le> (l' + ll + r' + r)^3"
proof -
  have 1: "l' + r' \<le> l' + ll + r' + r" using assms by arith
  have 2: "0 \<le> (l' + ll + r' + r)^2" by (rule zero_le_power2)
  have 3: "0 \<le> l' + r'" using assms by arith
  from mult_mono[OF nl41[OF assms] 1 2 3] show ?thesis
    by(simp add: ac_simps numeral_eq_Suc del: distrib_right_numeral)
qed

lemma nl4: assumes "(l'::real) \<ge> 1" "r' \<ge> 1" "ll \<ge> 1" "r \<ge> 1"
shows "4 * (l' + r')^2 * (l' + ll) * (r' + r)
    \<le> (l' + ll + r') * (l' + ll + r' + r)^3"
proof-
  have 1: "l' + r' \<le> l' + ll + r'" using assms by arith
  have 2: "0 \<le> (l' + ll + r' + r)^3" using assms by simp
  have 3: "0 \<le> l' + r'" using assms by arith
  from mult_mono[OF nl42[OF assms] 1 2 3] show ?thesis
    unfolding power2_eq_square by (simp only: ac_simps)
qed

lemma cancel: "x>(0::real) \<Longrightarrow> c * x ^ 2 * y * z \<le> u * v \<Longrightarrow> c * x ^ 3 * y * z \<le> x * u * v"
by(simp add: power2_eq_square power3_eq_cube)

interpretation S34: Splay_Analysis "root 3 4" "1/3"
proof
  case goal2 thus ?case
    by(simp add: root_simps)
      (auto simp: powr_numeral numeral_eq_Suc split_mult_pos_le intro!: mult_mono)
next
  case goal3 thus ?case by(simp add: root_simps cancel nl3)
next
  case goal4 thus ?case by(simp add: root_simps cancel nl4)
qed simp

lemma log4_log2: "log 4 x = log 2 x / 2"
proof -
  have "log 4 x = log (2^2) x" by simp
  also have "\<dots> = log 2 x / 2" by(simp only: log_base_pow)
  finally show ?thesis .
qed

declare log_base_root[simp] real_of_nat_Suc[simp]

lemma A34_ub: assumes "bst t"
shows "S34.A a t \<le> (3/2) * log 2 (size1 t) + 1"
proof -
  have "S34.A a t \<le> log (root 3 4) (size1 t) + 1" by(rule S34.A_ub3[OF assms])
  also have "\<dots> = (3/2) * log 2 (size t + 1) + 1" by(simp add: log4_log2)
  finally show ?thesis by simp
qed

lemma Am34_ub: assumes "bst t"
shows "S34.Am t \<le> (3/2) * log 2 (size1 t) + 1"
proof -
  have "S34.Am t \<le> log (root 3 4) (size1 t) + 1" by(rule S34.Am_ub3[OF assms])
  also have "\<dots> = (3/2) * log 2 (size1 t) + 1" by(simp add: log4_log2)
  finally show ?thesis by simp
qed

subsection "Overall analysis"

interpretation ST: amor
where init = Leaf and nxt = nxt\<^sub>s\<^sub>t and inv = bst
and t = t\<^sub>s\<^sub>t and \<Phi> = S34.\<Phi>
and U = "\<lambda>f t. case f of
  Splay _ \<Rightarrow> (3/2) * log 2 (size1 t) + 1 |
  Insert _ \<Rightarrow> 2 * log 2 (size1 t) + 3/2 |
  Delete _ \<Rightarrow> 3 * log 2 (size1 t) + 2"
proof
  case goal1 show ?case by simp
next
  case goal2 show ?case
  proof (cases f)
    case (Splay a)
    with bst_splay[OF goal2, of a] show ?thesis by (auto split: tree.split)
  next
    case (Insert a)
    with bst_splay[OF goal2, of a] show ?thesis
      by (auto simp: splay_bstL[OF goal2] splay_bstR[OF goal2] split: tree.split)
  next
    case (Delete a)[simp]
    with goal2 show ?thesis by(simp add: bst_delete)
  qed
next
  case goal3 show ?case
    by(induction s)(simp_all add: S34.\<phi>_def)
next
  case goal4 show ?case by simp
next
  case goal5
  show ?case (is "?l \<le> ?r")
  proof(cases f)
    case (Splay a)
    thus ?thesis using S34.A_ub3[OF goal5] by(simp add: S34.A_def log4_log2)
  next
    case (Insert a)[simp]
    show ?thesis
    proof cases
      assume "s = Leaf" thus ?thesis by(simp add: S34.\<phi>_def log4_log2)
    next
      assume "s \<noteq> Leaf"
      then obtain l e r where [simp]: "splay a s = Node l e r"
        by (metis tree.exhaust splay_Leaf_iff)
      let ?t = "real(t_splay a s)"
      let ?Plr = "S34.\<Phi> l + S34.\<Phi> r"  let ?Ps = "S34.\<Phi> s"
      let ?slr = "real(size1 l) + real(size1 r)" let ?LR = "log 2 (1 + ?slr)"
      have opt: "?t + S34.\<Phi> (splay a s) - ?Ps  \<le> 3/2 * log 2 (real (size1 s)) + 1"
        using S34.A_ub3[OF goal5, simplified S34.A_def, of a]
        by (simp add: log4_log2)
      from less_linear[of e a]
      show ?thesis
      proof (elim disjE)
        assume "e=a"
        have nneg: "log 2 (1 + real (size s)) \<ge> 0" by simp
        thus ?thesis using `s \<noteq> Leaf` opt `e=a`
          apply(simp add: field_simps) using nneg by arith
      next
        let ?L = "log 2 (real(size1 l) + 1)"
        assume "e<a" hence "e \<noteq> a" by simp
        hence "?l = (?t + ?Plr - ?Ps) + ?L / 2 + ?LR / 2"
          using  `s \<noteq> Leaf` `e<a` by(simp add: S34.\<phi>_def log4_log2)
        also have "?t + ?Plr - ?Ps \<le> log 2 ?slr + 1"
          using opt size_splay[of a s,symmetric]
          by(simp add: S34.\<phi>_def log4_log2)
        also have "?L/2 \<le> log 2 ?slr / 2" by(simp)
        also have "?LR/2 \<le> log 2 ?slr / 2 + 1/2"
        proof -
          have "?LR/2 \<le> log 2 (2 * ?slr) / 2" by simp
          also have "\<dots> \<le> log 2 ?slr / 2 + 1/2"
            by (simp add: log_mult del:distrib_left_numeral)
          finally show ?thesis .
        qed
        finally show ?thesis using size_splay[of a s,symmetric] by simp
      next
        let ?R = "log 2 (2 + real(size r))"
        assume "a<e" hence "e \<noteq> a" by simp
        hence "?l = (?t + ?Plr - ?Ps) + ?R / 2 + ?LR / 2"
          using  `s \<noteq> Leaf` `a<e` by(simp add: S34.\<phi>_def log4_log2)
        also have "?t + ?Plr - ?Ps \<le> log 2 ?slr + 1"
          using opt size_splay[of a s,symmetric]
          by(simp add: S34.\<phi>_def log4_log2)
        also have "?R/2 \<le> log 2 ?slr / 2" by(simp)
        also have "?LR/2 \<le> log 2 ?slr / 2 + 1/2"
        proof -
          have "?LR/2 \<le> log 2 (2 * ?slr) / 2" by simp
          also have "\<dots> \<le> log 2 ?slr / 2 + 1/2"
            by (simp add: log_mult del:distrib_left_numeral)
          finally show ?thesis .
        qed
        finally show ?thesis using size_splay[of a s,symmetric] by simp
      qed
    qed
  next
    case (Delete a)[simp]
    show ?thesis
    proof (cases s)
      case Leaf thus ?thesis by(simp add: delete_def t_delete_def S34.\<phi>_def log4_log2)
    next
      case (Node ls x rs)[simp]
      then obtain l e r where sp[simp]: "splay a (Node ls x rs) = Node l e r"
        by (metis tree.exhaust splay_Leaf_iff)
      let ?t = "real(t_splay a s)"
      let ?Plr = "S34.\<Phi> l + S34.\<Phi> r"  let ?Ps = "S34.\<Phi> s"
      let ?slr = "real(size1 l) + real(size1 r)" let ?LR = "log 2 (1 + ?slr)"
      let ?lslr = "log 2 (2 + (real (size ls) + real (size rs)))"
      have "?lslr \<ge> 0" by simp
      have opt: "?t + S34.\<Phi> (splay a s) - ?Ps  \<le> 3/2 * log 2 (real (size1 s)) + 1"
        using S34.A_ub3[OF goal5, simplified S34.A_def, of a]
        by (simp add: log4_log2 field_simps)
      show ?thesis
      proof (cases "e=a")
        case False thus ?thesis
          using opt apply(simp add: delete_def t_delete_def field_simps)
          using `?lslr \<ge> 0` by arith
      next
        case True[simp]
        show ?thesis
        proof (cases l)
          case Leaf
          have "S34.\<phi> Leaf r \<ge> 0" by(simp add: S34.\<phi>_def)
          thus ?thesis
            using Leaf opt apply(simp add: delete_def t_delete_def field_simps)
            using `?lslr \<ge> 0` by arith
        next
          case (Node ll y lr)
          then obtain l' y' r' where [simp]:
            "splay_max (Node ll y lr) = Node l' y' r'"
            using splay_max_Leaf_iff tree.exhaust by blast
          have "bst l" using bst_splay[OF goal5, of a] by simp
          have "S34.\<Phi> r' \<ge> 0" apply (induction r') by (auto simp add: S34.\<phi>_def)
          have optm: "real(t_splay_max l) + S34.\<Phi> (splay_max l) - S34.\<Phi> l
            \<le> 3/2 * log 2 (real (size1 l)) + 1"
            using S34.Am_ub3[OF `bst l`, simplified S34.Am_def]
            by (simp add: log4_log2 field_simps Node)
          have 1: "log 4 (2+(real(size l')+real(size r))) \<le>
            log 4 (2+(real(size l)+real(size r)))"
            using size_splay_max[of l] Node by simp
          have 2: "log 4 (2 + (real (size l') + real (size r'))) \<ge> 0" by simp
          have 3: "S34.\<phi> l' r \<le> S34.\<phi> l' r' + S34.\<phi> l r"
            apply(simp add: S34.\<phi>_def) using 1 2 by arith
          have 4: "log 2 (2 + (real(size ll) + real(size lr))) \<le> ?lslr"
            using size_if_splay[OF sp] Node by simp
          show ?thesis using add_mono[OF opt optm] Node 3
            apply(simp add: delete_def t_delete_def field_simps)
            using 4 `S34.\<Phi> r' \<ge> 0` by arith
        qed
      qed
    qed
  qed
qed

end


section\<open>The binary product topology\<close>

theory Product_Topology
imports Function_Topology
begin

section \<open>Product Topology\<close>

subsection\<open>Definition\<close>

definition prod_topology :: "'a topology \<Rightarrow> 'b topology \<Rightarrow> ('a \<times> 'b) topology" where
 "prod_topology X Y \<equiv> topology (arbitrary union_of (\<lambda>U. U \<in> {S \<times> T |S T. openin X S \<and> openin Y T}))"

lemma open_product_open:
  assumes "open A"
  shows "\<exists>\<U>. \<U> \<subseteq> {S \<times> T |S T. open S \<and> open T} \<and> \<Union> \<U> = A"
proof -
  obtain f g where *: "\<And>u. u \<in> A \<Longrightarrow> open (f u) \<and> open (g u) \<and> u \<in> (f u) \<times> (g u) \<and> (f u) \<times> (g u) \<subseteq> A"
    using open_prod_def [of A] assms by metis
  let ?\<U> = "(\<lambda>u. f u \<times> g u) ` A"
  show ?thesis
    by (rule_tac x="?\<U>" in exI) (auto simp: dest: *)
qed

lemma open_product_open_eq: "(arbitrary union_of (\<lambda>U. \<exists>S T. U = S \<times> T \<and> open S \<and> open T)) = open"
  by (force simp: union_of_def arbitrary_def intro: open_product_open open_Times)

lemma openin_prod_topology:
   "openin (prod_topology X Y) = arbitrary union_of (\<lambda>U. U \<in> {S \<times> T |S T. openin X S \<and> openin Y T})"
  unfolding prod_topology_def
proof (rule topology_inverse')
  show "istopology (arbitrary union_of (\<lambda>U. U \<in> {S \<times> T |S T. openin X S \<and> openin Y T}))"
    apply (rule istopology_base, simp)
    by (metis openin_Int Times_Int_Times)
qed

lemma topspace_prod_topology [simp]:
   "topspace (prod_topology X Y) = topspace X \<times> topspace Y"
proof -
  have "topspace(prod_topology X Y) = \<Union> (Collect (openin (prod_topology X Y)))" (is "_ = ?Z")
    unfolding topspace_def ..
  also have "\<dots> = topspace X \<times> topspace Y"
  proof
    show "?Z \<subseteq> topspace X \<times> topspace Y"
      apply (auto simp: openin_prod_topology union_of_def arbitrary_def)
      using openin_subset by force+
  next
    have *: "\<exists>A B. topspace X \<times> topspace Y = A \<times> B \<and> openin X A \<and> openin Y B"
      by blast
    show "topspace X \<times> topspace Y \<subseteq> ?Z"
      apply (rule Union_upper)
      using * by (simp add: openin_prod_topology arbitrary_union_of_inc)
  qed
  finally show ?thesis .
qed

lemma subtopology_Times:
  shows "subtopology (prod_topology X Y) (S \<times> T) = prod_topology (subtopology X S) (subtopology Y T)"
proof -
  have "((\<lambda>U. \<exists>S T. U = S \<times> T \<and> openin X S \<and> openin Y T) relative_to S \<times> T) =
        (\<lambda>U. \<exists>S' T'. U = S' \<times> T' \<and> (openin X relative_to S) S' \<and> (openin Y relative_to T) T')"
    by (auto simp: relative_to_def Times_Int_Times fun_eq_iff) metis
  then show ?thesis
    by (simp add: topology_eq openin_prod_topology arbitrary_union_of_relative_to flip: openin_relative_to)
qed

lemma prod_topology_subtopology:
    "prod_topology (subtopology X S) Y = subtopology (prod_topology X Y) (S \<times> topspace Y)"
    "prod_topology X (subtopology Y T) = subtopology (prod_topology X Y) (topspace X \<times> T)"
by (auto simp: subtopology_Times)

lemma prod_topology_discrete_topology:
     "discrete_topology (S \<times> T) = prod_topology (discrete_topology S) (discrete_topology T)"
  by (auto simp: discrete_topology_unique openin_prod_topology intro: arbitrary_union_of_inc)

lemma prod_topology_euclidean [simp]: "prod_topology euclidean euclidean = euclidean"
  by (simp add: prod_topology_def open_product_open_eq)

lemma prod_topology_subtopology_eu [simp]:
  "prod_topology (subtopology euclidean S) (subtopology euclidean T) = subtopology euclidean (S \<times> T)"
  by (simp add: prod_topology_subtopology subtopology_subtopology Times_Int_Times)

lemma openin_prod_topology_alt:
     "openin (prod_topology X Y) S \<longleftrightarrow>
      (\<forall>x y. (x,y) \<in> S \<longrightarrow> (\<exists>U V. openin X U \<and> openin Y V \<and> x \<in> U \<and> y \<in> V \<and> U \<times> V \<subseteq> S))"
  apply (auto simp: openin_prod_topology arbitrary_union_of_alt, fastforce)
  by (metis mem_Sigma_iff)

lemma open_map_fst: "open_map (prod_topology X Y) X fst"
  unfolding open_map_def openin_prod_topology_alt
  by (force simp: openin_subopen [of X "fst ` _"] intro: subset_fst_imageI)

lemma open_map_snd: "open_map (prod_topology X Y) Y snd"
  unfolding open_map_def openin_prod_topology_alt
  by (force simp: openin_subopen [of Y "snd ` _"] intro: subset_snd_imageI)

lemma openin_prod_Times_iff:
     "openin (prod_topology X Y) (S \<times> T) \<longleftrightarrow> S = {} \<or> T = {} \<or> openin X S \<and> openin Y T"
proof (cases "S = {} \<or> T = {}")
  case False
  then show ?thesis
    apply (simp add: openin_prod_topology_alt openin_subopen [of X S] openin_subopen [of Y T] times_subset_iff, safe)
      apply (meson|force)+
    done
qed force

lemma closure_of_Times:
   "(prod_topology X Y) closure_of (S \<times> T) = (X closure_of S) \<times> (Y closure_of T)"  (is "?lhs = ?rhs")
proof
  show "?lhs \<subseteq> ?rhs"
    by (clarsimp simp: closure_of_def openin_prod_topology_alt) blast
  show "?rhs \<subseteq> ?lhs"
    by (clarsimp simp: closure_of_def openin_prod_topology_alt) (meson SigmaI subsetD)
qed

lemma closedin_prod_Times_iff:
   "closedin (prod_topology X Y) (S \<times> T) \<longleftrightarrow> S = {} \<or> T = {} \<or> closedin X S \<and> closedin Y T"
  by (auto simp: closure_of_Times times_eq_iff simp flip: closure_of_eq)

lemma interior_of_Times: "(prod_topology X Y) interior_of (S \<times> T) = (X interior_of S) \<times> (Y interior_of T)"
proof (rule interior_of_unique)
  show "(X interior_of S) \<times> Y interior_of T \<subseteq> S \<times> T"
    by (simp add: Sigma_mono interior_of_subset)
  show "openin (prod_topology X Y) ((X interior_of S) \<times> Y interior_of T)"
    by (simp add: openin_prod_Times_iff)
next
  show "T' \<subseteq> (X interior_of S) \<times> Y interior_of T" if "T' \<subseteq> S \<times> T" "openin (prod_topology X Y) T'" for T'
  proof (clarsimp; intro conjI)
    fix a :: "'a" and b :: "'b"
    assume "(a, b) \<in> T'"
    with that obtain U V where UV: "openin X U" "openin Y V" "a \<in> U" "b \<in> V" "U \<times> V \<subseteq> T'"
      by (metis openin_prod_topology_alt)
    then show "a \<in> X interior_of S"
      using interior_of_maximal_eq that(1) by fastforce
    show "b \<in> Y interior_of T"
      using UV interior_of_maximal_eq that(1)
      by (metis SigmaI mem_Sigma_iff subset_eq)
  qed
qed

subsection \<open>Continuity\<close>

lemma continuous_map_pairwise:
   "continuous_map Z (prod_topology X Y) f \<longleftrightarrow> continuous_map Z X (fst \<circ> f) \<and> continuous_map Z Y (snd \<circ> f)"
   (is "?lhs = ?rhs")
proof -
  let ?g = "fst \<circ> f" and ?h = "snd \<circ> f"
  have f: "f x = (?g x, ?h x)" for x
    by auto
  show ?thesis
  proof (cases "(\<forall>x \<in> topspace Z. ?g x \<in> topspace X) \<and> (\<forall>x \<in> topspace Z. ?h x \<in> topspace Y)")
    case True
    show ?thesis
    proof safe
      assume "continuous_map Z (prod_topology X Y) f"
      then have "openin Z {x \<in> topspace Z. fst (f x) \<in> U}" if "openin X U" for U
        unfolding continuous_map_def using True that
        apply clarify
        apply (drule_tac x="U \<times> topspace Y" in spec)
        by (simp add: openin_prod_Times_iff mem_Times_iff cong: conj_cong)
      with True show "continuous_map Z X (fst \<circ> f)"
        by (auto simp: continuous_map_def)
    next
      assume "continuous_map Z (prod_topology X Y) f"
      then have "openin Z {x \<in> topspace Z. snd (f x) \<in> V}" if "openin Y V" for V
        unfolding continuous_map_def using True that
        apply clarify
        apply (drule_tac x="topspace X \<times> V" in spec)
        by (simp add: openin_prod_Times_iff mem_Times_iff cong: conj_cong)
      with True show "continuous_map Z Y (snd \<circ> f)"
        by (auto simp: continuous_map_def)
    next
      assume Z: "continuous_map Z X (fst \<circ> f)" "continuous_map Z Y (snd \<circ> f)"
      have *: "openin Z {x \<in> topspace Z. f x \<in> W}"
        if "\<And>w. w \<in> W \<Longrightarrow> \<exists>U V. openin X U \<and> openin Y V \<and> w \<in> U \<times> V \<and> U \<times> V \<subseteq> W" for W
      proof (subst openin_subopen, clarify)
        fix x :: "'a"
        assume "x \<in> topspace Z" and "f x \<in> W"
        with that [OF \<open>f x \<in> W\<close>]
        obtain U V where UV: "openin X U" "openin Y V" "f x \<in> U \<times> V" "U \<times> V \<subseteq> W"
          by auto
        with Z  UV show "\<exists>T. openin Z T \<and> x \<in> T \<and> T \<subseteq> {x \<in> topspace Z. f x \<in> W}"
          apply (rule_tac x="{x \<in> topspace Z. ?g x \<in> U} \<inter> {x \<in> topspace Z. ?h x \<in> V}" in exI)
          apply (auto simp: \<open>x \<in> topspace Z\<close> continuous_map_def)
          done
      qed
      show "continuous_map Z (prod_topology X Y) f"
        using True by (simp add: continuous_map_def openin_prod_topology_alt mem_Times_iff *)
    qed
  qed (auto simp: continuous_map_def)
qed

lemma continuous_map_paired:
   "continuous_map Z (prod_topology X Y) (\<lambda>x. (f x,g x)) \<longleftrightarrow> continuous_map Z X f \<and> continuous_map Z Y g"
  by (simp add: continuous_map_pairwise o_def)

lemma continuous_map_pairedI [continuous_intros]:
   "\<lbrakk>continuous_map Z X f; continuous_map Z Y g\<rbrakk> \<Longrightarrow> continuous_map Z (prod_topology X Y) (\<lambda>x. (f x,g x))"
  by (simp add: continuous_map_pairwise o_def)

lemma continuous_map_fst [continuous_intros]: "continuous_map (prod_topology X Y) X fst"
  using continuous_map_pairwise [of "prod_topology X Y" X Y id]
  by (simp add: continuous_map_pairwise)

lemma continuous_map_snd [continuous_intros]: "continuous_map (prod_topology X Y) Y snd"
  using continuous_map_pairwise [of "prod_topology X Y" X Y id]
  by (simp add: continuous_map_pairwise)

lemma continuous_map_fst_of [continuous_intros]:
   "continuous_map Z (prod_topology X Y) f \<Longrightarrow> continuous_map Z X (fst \<circ> f)"
  by (simp add: continuous_map_pairwise)

lemma continuous_map_snd_of [continuous_intros]:
   "continuous_map Z (prod_topology X Y) f \<Longrightarrow> continuous_map Z Y (snd \<circ> f)"
  by (simp add: continuous_map_pairwise)

lemma continuous_map_prod_fst:
  "i \<in> I \<Longrightarrow> continuous_map (prod_topology (product_topology (\<lambda>i. Y) I) X) Y (\<lambda>x. fst x i)"
  using continuous_map_componentwise_UNIV continuous_map_fst by fastforce

lemma continuous_map_prod_snd:
  "i \<in> I \<Longrightarrow> continuous_map (prod_topology X (product_topology (\<lambda>i. Y) I)) Y (\<lambda>x. snd x i)"
  using continuous_map_componentwise_UNIV continuous_map_snd by fastforce

lemma continuous_map_if_iff [simp]: "continuous_map X Y (\<lambda>x. if P then f x else g x) \<longleftrightarrow> continuous_map X Y (if P then f else g)"
  by simp

lemma continuous_map_if [continuous_intros]: "\<lbrakk>P \<Longrightarrow> continuous_map X Y f; ~P \<Longrightarrow> continuous_map X Y g\<rbrakk>
      \<Longrightarrow> continuous_map X Y (\<lambda>x. if P then f x else g x)"
  by simp

lemma continuous_map_subtopology_fst [continuous_intros]: "continuous_map (subtopology (prod_topology X Y) Z) X fst"
      using continuous_map_from_subtopology continuous_map_fst by force

lemma continuous_map_subtopology_snd [continuous_intros]: "continuous_map (subtopology (prod_topology X Y) Z) Y snd"
      using continuous_map_from_subtopology continuous_map_snd by force

lemma quotient_map_fst [simp]:
   "quotient_map(prod_topology X Y) X fst \<longleftrightarrow> (topspace Y = {} \<longrightarrow> topspace X = {})"
  by (auto simp: continuous_open_quotient_map open_map_fst continuous_map_fst)

lemma quotient_map_snd [simp]:
   "quotient_map(prod_topology X Y) Y snd \<longleftrightarrow> (topspace X = {} \<longrightarrow> topspace Y = {})"
  by (auto simp: continuous_open_quotient_map open_map_snd continuous_map_snd)

lemma retraction_map_fst:
   "retraction_map (prod_topology X Y) X fst \<longleftrightarrow> (topspace Y = {} \<longrightarrow> topspace X = {})"
proof (cases "topspace Y = {}")
  case True
  then show ?thesis
    using continuous_map_image_subset_topspace
    by (fastforce simp: retraction_map_def retraction_maps_def continuous_map_fst continuous_map_on_empty)
next
  case False
  have "\<exists>g. continuous_map X (prod_topology X Y) g \<and> (\<forall>x\<in>topspace X. fst (g x) = x)"
    if y: "y \<in> topspace Y" for y
    by (rule_tac x="\<lambda>x. (x,y)" in exI) (auto simp: y continuous_map_paired)
  with False have "retraction_map (prod_topology X Y) X fst"
    by (fastforce simp: retraction_map_def retraction_maps_def continuous_map_fst)
  with False show ?thesis
    by simp
qed

lemma retraction_map_snd:
   "retraction_map (prod_topology X Y) Y snd \<longleftrightarrow> (topspace X = {} \<longrightarrow> topspace Y = {})"
proof (cases "topspace X = {}")
  case True
  then show ?thesis
    using continuous_map_image_subset_topspace
    by (fastforce simp: retraction_map_def retraction_maps_def continuous_map_fst continuous_map_on_empty)
next
  case False
  have "\<exists>g. continuous_map Y (prod_topology X Y) g \<and> (\<forall>y\<in>topspace Y. snd (g y) = y)"
    if x: "x \<in> topspace X" for x
    by (rule_tac x="\<lambda>y. (x,y)" in exI) (auto simp: x continuous_map_paired)
  with False have "retraction_map (prod_topology X Y) Y snd"
    by (fastforce simp: retraction_map_def retraction_maps_def continuous_map_snd)
  with False show ?thesis
    by simp
qed

lemma continuous_map_of_fst:
   "continuous_map (prod_topology X Y) Z (f \<circ> fst) \<longleftrightarrow> topspace Y = {} \<or> continuous_map X Z f"
proof (cases "topspace Y = {}")
  case True
  then show ?thesis
    by (simp add: continuous_map_on_empty)
next
  case False
  then show ?thesis
    by (simp add: continuous_compose_quotient_map_eq)
qed

lemma continuous_map_of_snd:
   "continuous_map (prod_topology X Y) Z (f \<circ> snd) \<longleftrightarrow> topspace X = {} \<or> continuous_map Y Z f"
proof (cases "topspace X = {}")
  case True
  then show ?thesis
    by (simp add: continuous_map_on_empty)
next
  case False
  then show ?thesis
    by (simp add: continuous_compose_quotient_map_eq)
qed

lemma continuous_map_prod_top:
   "continuous_map (prod_topology X Y) (prod_topology X' Y') (\<lambda>(x,y). (f x, g y)) \<longleftrightarrow>
    topspace (prod_topology X Y) = {} \<or> continuous_map X X' f \<and> continuous_map Y Y' g"
proof (cases "topspace (prod_topology X Y) = {}")
  case True
  then show ?thesis
    by (simp add: continuous_map_on_empty)
next
  case False
  then show ?thesis
    by (simp add: continuous_map_paired case_prod_unfold continuous_map_of_fst [unfolded o_def] continuous_map_of_snd [unfolded o_def])
qed

lemma in_prod_topology_closure_of:
  assumes  "z \<in> (prod_topology X Y) closure_of S"
  shows "fst z \<in> X closure_of (fst ` S)" "snd z \<in> Y closure_of (snd ` S)"
  using assms continuous_map_eq_image_closure_subset continuous_map_fst apply fastforce
  using assms continuous_map_eq_image_closure_subset continuous_map_snd apply fastforce
  done

proposition compact_space_prod_topology:
   "compact_space(prod_topology X Y) \<longleftrightarrow> topspace(prod_topology X Y) = {} \<or> compact_space X \<and> compact_space Y"
proof (cases "topspace(prod_topology X Y) = {}")
  case True
  then show ?thesis
    using compact_space_topspace_empty by blast
next
  case False
  then have non_mt: "topspace X \<noteq> {}" "topspace Y \<noteq> {}"
    by auto
  have "compact_space X" "compact_space Y" if "compact_space(prod_topology X Y)"
  proof -
    have "compactin X (fst ` (topspace X \<times> topspace Y))"
      by (metis compact_space_def continuous_map_fst image_compactin that topspace_prod_topology)
    moreover
    have "compactin Y (snd ` (topspace X \<times> topspace Y))"
      by (metis compact_space_def continuous_map_snd image_compactin that topspace_prod_topology)
    ultimately show "compact_space X" "compact_space Y"
      by (simp_all add: non_mt compact_space_def)
  qed
  moreover
  define \<X> where "\<X> \<equiv> (\<lambda>V. topspace X \<times> V) ` Collect (openin Y)"
  define \<Y> where "\<Y> \<equiv> (\<lambda>U. U \<times> topspace Y) ` Collect (openin X)"
  have "compact_space(prod_topology X Y)" if "compact_space X" "compact_space Y"
  proof (rule Alexander_subbase_alt)
    show toptop: "topspace X \<times> topspace Y \<subseteq> \<Union>(\<X> \<union> \<Y>)"
      unfolding \<X>_def \<Y>_def by auto
    fix \<C> :: "('a \<times> 'b) set set"
    assume \<C>: "\<C> \<subseteq> \<X> \<union> \<Y>" "topspace X \<times> topspace Y \<subseteq> \<Union>\<C>"
    then obtain \<X>' \<Y>' where XY: "\<X>' \<subseteq> \<X>" "\<Y>' \<subseteq> \<Y>" and \<C>eq: "\<C> = \<X>' \<union> \<Y>'"
      using subset_UnE by metis
    then have sub: "topspace X \<times> topspace Y \<subseteq> \<Union>(\<X>' \<union> \<Y>')"
      using \<C> by simp
    obtain \<U> \<V> where \<U>: "\<And>U. U \<in> \<U> \<Longrightarrow> openin X U" "\<Y>' = (\<lambda>U. U \<times> topspace Y) ` \<U>"
      and \<V>: "\<And>V. V \<in> \<V> \<Longrightarrow> openin Y V" "\<X>' = (\<lambda>V. topspace X \<times> V) ` \<V>"
      using XY by (clarsimp simp add: \<X>_def \<Y>_def subset_image_iff) (force simp add: subset_iff)
    have "\<exists>\<D>. finite \<D> \<and> \<D> \<subseteq> \<X>' \<union> \<Y>' \<and> topspace X \<times> topspace Y \<subseteq> \<Union> \<D>"
    proof -
      have "topspace X \<subseteq> \<Union>\<U> \<or> topspace Y \<subseteq> \<Union>\<V>"
        using \<U> \<V> \<C> \<C>eq by auto
      then have *: "\<exists>\<D>. finite \<D> \<and>
               (\<forall>x \<in> \<D>. x \<in> (\<lambda>V. topspace X \<times> V) ` \<V> \<or> x \<in> (\<lambda>U. U \<times> topspace Y) ` \<U>) \<and>
               (topspace X \<times> topspace Y \<subseteq> \<Union>\<D>)"
      proof
        assume "topspace X \<subseteq> \<Union>\<U>"
        with \<open>compact_space X\<close> \<U> obtain \<F> where "finite \<F>" "\<F> \<subseteq> \<U>" "topspace X \<subseteq> \<Union>\<F>"
          by (meson compact_space_alt)
        with that show ?thesis
          by (rule_tac x="(\<lambda>D. D \<times> topspace Y) ` \<F>" in exI) auto
      next
        assume "topspace Y \<subseteq> \<Union>\<V>"
        with \<open>compact_space Y\<close> \<V> obtain \<F> where "finite \<F>" "\<F> \<subseteq> \<V>" "topspace Y \<subseteq> \<Union>\<F>"
          by (meson compact_space_alt)
        with that show ?thesis
          by (rule_tac x="(\<lambda>C. topspace X \<times> C) ` \<F>" in exI) auto
      qed
      then show ?thesis
        using that \<U> \<V> by blast
    qed
    then show "\<exists>\<D>. finite \<D> \<and> \<D> \<subseteq> \<C> \<and> topspace X \<times> topspace Y \<subseteq> \<Union> \<D>"
      using \<C> \<C>eq by blast
  next
    have "(finite intersection_of (\<lambda>x. x \<in> \<X> \<or> x \<in> \<Y>) relative_to topspace X \<times> topspace Y)
           = (\<lambda>U. \<exists>S T. U = S \<times> T \<and> openin X S \<and> openin Y T)"
      (is "?lhs = ?rhs")
    proof -
      have "?rhs U" if "?lhs U" for U
      proof -
        have "topspace X \<times> topspace Y \<inter> \<Inter> T \<in> {A \<times> B |A B. A \<in> Collect (openin X) \<and> B \<in> Collect (openin Y)}"
          if "finite T" "T \<subseteq> \<X> \<union> \<Y>" for T
          using that
        proof induction
          case (insert B \<B>)
          then show ?case
            unfolding \<X>_def \<Y>_def
            apply (simp add: Int_ac subset_eq image_def)
            apply (metis (no_types) openin_Int openin_topspace Times_Int_Times)
            done
        qed auto
        then show ?thesis
          using that
          by (auto simp: subset_eq  elim!: relative_toE intersection_ofE)
      qed
      moreover
      have "?lhs Z" if Z: "?rhs Z" for Z
      proof -
        obtain U V where "Z = U \<times> V" "openin X U" "openin Y V"
          using Z by blast
        then have UV: "U \<times> V = (topspace X \<times> topspace Y) \<inter> (U \<times> V)"
          by (simp add: Sigma_mono inf_absorb2 openin_subset)
        moreover
        have "?lhs ((topspace X \<times> topspace Y) \<inter> (U \<times> V))"
        proof (rule relative_to_inc)
          show "(finite intersection_of (\<lambda>x. x \<in> \<X> \<or> x \<in> \<Y>)) (U \<times> V)"
            apply (simp add: intersection_of_def \<X>_def \<Y>_def)
            apply (rule_tac x="{(U \<times> topspace Y),(topspace X \<times> V)}" in exI)
            using \<open>openin X U\<close> \<open>openin Y V\<close> openin_subset UV apply (fastforce simp add:)
            done
        qed
        ultimately show ?thesis
          using \<open>Z = U \<times> V\<close> by auto
      qed
      ultimately show ?thesis
        by meson
    qed
    then show "topology (arbitrary union_of (finite intersection_of (\<lambda>x. x \<in> \<X> \<union> \<Y>)
           relative_to (topspace X \<times> topspace Y))) =
        prod_topology X Y"
      by (simp add: prod_topology_def)
  qed
  ultimately show ?thesis
    using False by blast
qed

lemma compactin_Times:
   "compactin (prod_topology X Y) (S \<times> T) \<longleftrightarrow> S = {} \<or> T = {} \<or> compactin X S \<and> compactin Y T"
  by (auto simp: compactin_subspace subtopology_Times compact_space_prod_topology)

subsection\<open>Homeomorphic maps\<close>

lemma homeomorphic_maps_prod:
   "homeomorphic_maps (prod_topology X Y) (prod_topology X' Y') (\<lambda>(x,y). (f x, g y)) (\<lambda>(x,y). (f' x, g' y)) \<longleftrightarrow>
        topspace(prod_topology X Y) = {} \<and>
        topspace(prod_topology X' Y') = {} \<or>
        homeomorphic_maps X X' f f' \<and>
        homeomorphic_maps Y Y' g g'"
  unfolding homeomorphic_maps_def continuous_map_prod_top
  by (auto simp: continuous_map_def homeomorphic_maps_def continuous_map_prod_top)

lemma homeomorphic_maps_swap:
   "homeomorphic_maps (prod_topology X Y) (prod_topology Y X)
                          (\<lambda>(x,y). (y,x)) (\<lambda>(y,x). (x,y))"
  by (auto simp: homeomorphic_maps_def case_prod_unfold continuous_map_fst continuous_map_pairedI continuous_map_snd)

lemma homeomorphic_map_swap:
   "homeomorphic_map (prod_topology X Y) (prod_topology Y X) (\<lambda>(x,y). (y,x))"
  using homeomorphic_map_maps homeomorphic_maps_swap by metis

lemma embedding_map_graph:
   "embedding_map X (prod_topology X Y) (\<lambda>x. (x, f x)) \<longleftrightarrow> continuous_map X Y f"
    (is "?lhs = ?rhs")
proof
  assume L: ?lhs
  have "snd \<circ> (\<lambda>x. (x, f x)) = f"
    by force
  moreover have "continuous_map X Y (snd \<circ> (\<lambda>x. (x, f x)))"
    using L
    unfolding embedding_map_def
    by (meson continuous_map_in_subtopology continuous_map_snd_of homeomorphic_imp_continuous_map)
  ultimately show ?rhs
    by simp
next
  assume R: ?rhs
  then show ?lhs
    unfolding homeomorphic_map_maps embedding_map_def homeomorphic_maps_def
    by (rule_tac x=fst in exI)
       (auto simp: continuous_map_in_subtopology continuous_map_paired continuous_map_from_subtopology
                   continuous_map_fst)
qed

lemma homeomorphic_space_prod_topology:
   "\<lbrakk>X homeomorphic_space X''; Y homeomorphic_space Y'\<rbrakk>
        \<Longrightarrow> prod_topology X Y homeomorphic_space prod_topology X'' Y'"
using homeomorphic_maps_prod unfolding homeomorphic_space_def by blast

lemma prod_topology_homeomorphic_space_left:
   "topspace Y = {b} \<Longrightarrow> prod_topology X Y homeomorphic_space X"
  unfolding homeomorphic_space_def
  by (rule_tac x=fst in exI) (simp add: homeomorphic_map_def inj_on_def flip: homeomorphic_map_maps)

lemma prod_topology_homeomorphic_space_right:
   "topspace X = {a} \<Longrightarrow> prod_topology X Y homeomorphic_space Y"
  unfolding homeomorphic_space_def
  by (rule_tac x=snd in exI) (simp add: homeomorphic_map_def inj_on_def flip: homeomorphic_map_maps)

lemma homeomorphic_space_prod_topology_sing1:
     "b \<in> topspace Y \<Longrightarrow> X homeomorphic_space (prod_topology X (subtopology Y {b}))"
  by (metis empty_subsetI homeomorphic_space_sym inf.absorb_iff2 insert_subset prod_topology_homeomorphic_space_left topspace_subtopology)

lemma homeomorphic_space_prod_topology_sing2:
     "a \<in> topspace X \<Longrightarrow> Y homeomorphic_space (prod_topology (subtopology X {a}) Y)"
  by (metis empty_subsetI homeomorphic_space_sym inf.absorb_iff2 insert_subset prod_topology_homeomorphic_space_right topspace_subtopology)

lemma topological_property_of_prod_component:
  assumes major: "P(prod_topology X Y)"
    and X: "\<And>x. \<lbrakk>x \<in> topspace X; P(prod_topology X Y)\<rbrakk> \<Longrightarrow> P(subtopology (prod_topology X Y) ({x} \<times> topspace Y))"
    and Y: "\<And>y. \<lbrakk>y \<in> topspace Y; P(prod_topology X Y)\<rbrakk> \<Longrightarrow> P(subtopology (prod_topology X Y) (topspace X \<times> {y}))"
    and PQ:  "\<And>X X'. X homeomorphic_space X' \<Longrightarrow> (P X \<longleftrightarrow> Q X')"
    and PR: "\<And>X X'. X homeomorphic_space X' \<Longrightarrow> (P X \<longleftrightarrow> R X')"
  shows "topspace(prod_topology X Y) = {} \<or> Q X \<and> R Y"
proof -
  have "Q X \<and> R Y" if "topspace(prod_topology X Y) \<noteq> {}"
  proof -
    from that obtain a b where a: "a \<in> topspace X" and b: "b \<in> topspace Y"
      by force
    show ?thesis
      using X [OF a major] and Y [OF b major] homeomorphic_space_prod_topology_sing1 [OF b, of X] homeomorphic_space_prod_topology_sing2 [OF a, of Y]
      by (simp add: subtopology_Times) (meson PQ PR homeomorphic_space_prod_topology_sing2 homeomorphic_space_sym)
  qed
  then show ?thesis by metis
qed

lemma limitin_pairwise:
   "limitin (prod_topology X Y) f l F \<longleftrightarrow> limitin X (fst \<circ> f) (fst l) F \<and> limitin Y (snd \<circ> f) (snd l) F"
    (is "?lhs = ?rhs")
proof
  assume ?lhs
  then obtain a b where ev: "\<And>U. \<lbrakk>(a,b) \<in> U; openin (prod_topology X Y) U\<rbrakk> \<Longrightarrow> \<forall>\<^sub>F x in F. f x \<in> U"
                        and a: "a \<in> topspace X" and b: "b \<in> topspace Y" and l: "l = (a,b)"
    by (auto simp: limitin_def)
  moreover have "\<forall>\<^sub>F x in F. fst (f x) \<in> U" if "openin X U" "a \<in> U" for U
  proof -
    have "\<forall>\<^sub>F c in F. f c \<in> U \<times> topspace Y"
      using b that ev [of "U \<times> topspace Y"] by (auto simp: openin_prod_topology_alt)
    then show ?thesis
      by (rule eventually_mono) (metis (mono_tags, lifting) SigmaE2 prod.collapse)
  qed
  moreover have "\<forall>\<^sub>F x in F. snd (f x) \<in> U" if "openin Y U" "b \<in> U" for U
  proof -
    have "\<forall>\<^sub>F c in F. f c \<in> topspace X \<times> U"
      using a that ev [of "topspace X \<times> U"] by (auto simp: openin_prod_topology_alt)
    then show ?thesis
      by (rule eventually_mono) (metis (mono_tags, lifting) SigmaE2 prod.collapse)
  qed
  ultimately show ?rhs
    by (simp add: limitin_def)
next
  have "limitin (prod_topology X Y) f (a,b) F"
    if "limitin X (fst \<circ> f) a F" "limitin Y (snd \<circ> f) b F" for a b
    using that
  proof (clarsimp simp: limitin_def)
    fix Z :: "('a \<times> 'b) set"
    assume a: "a \<in> topspace X" "\<forall>U. openin X U \<and> a \<in> U \<longrightarrow> (\<forall>\<^sub>F x in F. fst (f x) \<in> U)"
      and b: "b \<in> topspace Y" "\<forall>U. openin Y U \<and> b \<in> U \<longrightarrow> (\<forall>\<^sub>F x in F. snd (f x) \<in> U)"
      and Z: "openin (prod_topology X Y) Z" "(a, b) \<in> Z"
    then obtain U V where "openin X U" "openin Y V" "a \<in> U" "b \<in> V" "U \<times> V \<subseteq> Z"
      using Z by (force simp: openin_prod_topology_alt)
    then have "\<forall>\<^sub>F x in F. fst (f x) \<in> U" "\<forall>\<^sub>F x in F. snd (f x) \<in> V"
      by (simp_all add: a b)
    then show "\<forall>\<^sub>F x in F. f x \<in> Z"
      by (rule eventually_elim2) (use \<open>U \<times> V \<subseteq> Z\<close> subsetD in auto)
  qed
  then show "?rhs \<Longrightarrow> ?lhs"
    by (metis prod.collapse)
qed

end


theory Homework6_sol1
imports "../IMP/Big_Step"
begin

  (*
    ISSUED: Wednesday, October 25
    DUE: Wednesday, November 1, 11:59pm
    POINTS: 5
  *)

section \<open>Derivation Trees\<close>

(*
  Consider the following program, that will compute
  1+...+n, and return the result in a
*)

abbreviation (input) w where "w\<equiv>
  WHILE Less (N 0) (V ''n'') DO (
    ''a'' ::= Plus (V ''a'') (V ''n'');;
    ''n'' ::= Plus (V ''n'') (N (-1))
  )
"

abbreviation (input) "gauss \<equiv>
  ''a'' ::= N 0;;
  w
"

(*
  Do a forward derivation of a big-step execution,
  for program gauss and start state <''n'':=2>
*)

lemmas fwd_gauss = Seq[where c\<^sub>1="''a'' ::= N 0" and c\<^sub>2=w and s\<^sub>1="<''n'':=2>", OF
  (*<*)
  Assign
  WhileTrue[OF _
    Seq[OF Assign Assign]
    WhileTrue[OF _
      Seq[OF Assign Assign]
      WhileFalse]],
  (*>*)
  simplified
]

(* Test: Your lemma should solve the following goal: *)
schematic_goal "(gauss,<''n'':=2>) \<Rightarrow> ?s"
  apply (rule fwd_gauss)
  done

(* Do a backward derivation. Do not use BigSteps, nor the fwd_gauss rule,
    but apply only
      rule Seq, rule Assign, rule WhileTrue, rule WhileFalse, and simp!
*)
schematic_goal "(gauss,<''n'':=2>) \<Rightarrow> ?s"
  apply (rule Seq)
   apply (rule Assign)
  apply simp
  (*<*)
  apply (rule WhileTrue)
    apply simp
   apply (rule Seq)
    apply (rule Assign)
   apply simp
   apply (rule Assign)
  apply simp
  apply (rule WhileTrue)
    apply simp
   apply (rule Seq)
    apply (rule Assign)
   apply simp
   apply (rule Assign)
  apply simp
  apply (rule WhileFalse)
  apply simp
  (*>*)
  done

section \<open>Quotient, Rounded Down\<close>

(* Write a program that returns the quotient, rounded down, of two positive
  numbers x and y, in variable q.

  Note: Due to the limited operations available, in particular no Minus,
    finding the simplest program may require a little thought. You may need an auxiliary variable.
  Hint: You only need a single WHILE loop, and no IF.
  Hint: It might be a good idea to sketch the program in pseudocode or C first,
    before you write it down in IMP syntax.

*)

abbreviation "IMP_div \<equiv>
  ''q'' ::= N 0;;
  ''c'' ::= N 0;;
  WHILE Not (Less ((V ''x'')) (V ''c'')) DO (
    ''c'' ::= Plus (V ''c'') (V ''y'');;
    ''q'' ::= Plus (V ''q'') (N 1)
  );;
  ''q'' ::= Plus (V ''q'') (N (-1))
"

(* Test your program for different test cases! *)
schematic_goal [simplified]: "(IMP_div,<''x'' := 3, ''y'' := 2>) \<Rightarrow> ?s"
  by BigSteps

end