(*  Title:       BIT is 1.75 competitive on lists of length 2
    Author:      Max Haslbeck
*)
section "BIT is 1.75 competitive on lists of length 2"

theory BIT_2comp_on2
imports BIT Phase_Partitioning
begin

subsection "auxliary lemmas"

subsubsection "\<open>E_bernoulli3\<close>"

lemma E_bernoulli3: assumes "0<p"
    and "p<1"
    and "finite (set_pmf (bind_pmf (bernoulli_pmf p) f))"
    shows "E (bind_pmf (bernoulli_pmf p) f) = E(f True)*p + E(f False)*(1-p)" (is "?L = ?R")
proof -

  have T: "(\<Sum>a\<in>(\<Union>x. set_pmf (f x)). (a * pmf (f True) a))
            = E(f True)"
    unfolding E_def
    apply(subst integral_measure_pmf[of "bind_pmf (bernoulli_pmf p) f"])
      using assms apply(simp)
      using assms apply(simp add: set_pmf_bernoulli) apply blast
      using assms by(simp add: set_pmf_bernoulli mult_ac)
  have F: "(\<Sum>a\<in>(\<Union>x. set_pmf (f x)). (a * pmf (f False) a))
            = E(f False)"
    unfolding E_def
    apply(subst integral_measure_pmf[of "bind_pmf (bernoulli_pmf p) f"])
      using assms apply(simp)
      using assms apply(simp add: set_pmf_bernoulli) apply blast
      using assms by(simp add: set_pmf_bernoulli mult_ac)

  have "?L = (\<Sum>a\<in>(\<Union>x. set_pmf (f x)).
       a *
       (pmf (f True) a * p +
        pmf (f False) a * (1 - p)))"
  unfolding E_def
  apply(subst integral_measure_pmf[of "bind_pmf (bernoulli_pmf p) f"])
    using assms apply(simp)
    apply(simp)
    using assms apply(simp add: set_pmf_bernoulli )
    by(simp add: pmf_bind mult_ac)
  also have "\<dots> = (\<Sum>a\<in>(\<Union>x. set_pmf (f x)). (a * pmf (f True) a * p)
                                    + (a * pmf (f False) a * (1 - p)))"
    apply(rule sum.cong) apply(simp) by algebra
  also have "\<dots> = (\<Sum>a\<in>(\<Union>x. set_pmf (f x)). (a * pmf (f True) a * p))
                  + (\<Sum>a\<in>(\<Union>x. set_pmf (f x)). (a * pmf (f False) a * (1 - p)))"
    by (simp add: sum.distrib)
  also have "\<dots> = (\<Sum>a\<in>(\<Union>x. set_pmf (f x)). (a * pmf (f True) a)) * p
                  + (\<Sum>a\<in>(\<Union>x. set_pmf (f x)). (a * pmf (f False) a )) * (1 - p)"
    by (simp add: sum_distrib_right)
  also have "\<dots> = ?R" unfolding T F by simp
  finally show ?thesis .
qed

subsubsection "types of configurations"

definition "type0 init x y = do {
                  (a::bool) \<leftarrow> (bernoulli_pmf 0.5);
                  (b::bool) \<leftarrow> (bernoulli_pmf 0.5);
                  return_pmf  ([x,y], ([a,b],init))
                }"

definition "type1 init x y = do {
                  (a::bool) \<leftarrow> (bernoulli_pmf 0.5);
                  (b::bool) \<leftarrow> (bernoulli_pmf 0.5);
                  return_pmf ( if ~[a,b]!(index init x)\<and>[a,b]!(index init y) then ([y,x], ([a,b],init))
                         else ([x,y], ([a,b],init)))
                }"

definition "type3 init x y = do {
                  (a::bool) \<leftarrow> (bernoulli_pmf 0.5);
                  (b::bool) \<leftarrow> (bernoulli_pmf 0.5);
                  return_pmf ( if [a,b]!(index init x)\<and>~[a,b]!(index init y) then ([x,y], ([a,b],init))
                         else ([y,x], ([a,b],init)))
                }"

definition "type4 init x y = do {
                  (a::bool) \<leftarrow> (bernoulli_pmf 0.5);
                  (b::bool) \<leftarrow> (bernoulli_pmf 0.5);
                  return_pmf ( if ~[a,b]!(index init y) then ([x,y], ([a,b],init))
                         else ([y,x], ([a,b],init)))
                }"

definition "BIT_inv s x i == (s = (type0 i x (hd (filter (\<lambda>y. y\<noteq>x) i) )))"

lemma BIT_inv2: "x\<noteq>y \<Longrightarrow> z\<in>{x,y} \<Longrightarrow> BIT_inv s z [x,y] = (s= type0 [x,y] z (other z x y))"
  unfolding BIT_inv_def by(auto simp add: other_def)

subsubsection "cost of BIT"

lemma costBIT_0x:
    assumes "x\<noteq>y" "x : {x0,y0}" "y\<in>{x0,y0}"
    shows
  "E (type0 [x0, y0] x y \<bind>
       (\<lambda>s. BIT_step s x \<bind>
            (\<lambda>(a, is'). return_pmf (real (t\<^sub>p (fst s) x a))))) = 0"
using assms apply(auto)
  apply(simp_all add: type0_def BIT_step_def bind_assoc_pmf bind_return_pmf )
  apply(simp_all add: E_bernoulli3 t\<^sub>p_def)
  done

lemma costBIT_1x:
    assumes "x\<noteq>y" "x : {x0,y0}" "y\<in>{x0,y0}"
    shows
  "E (type1 [x0, y0] x y \<bind>
       (\<lambda>s. BIT_step s x \<bind>
            (\<lambda>(a, is'). return_pmf (real (t\<^sub>p (fst s) x a))))) = 1/4"
using assms apply(auto)
  apply(simp_all add: type1_def BIT_step_def bind_assoc_pmf bind_return_pmf )
  apply(simp_all add: E_bernoulli3 t\<^sub>p_def)
  done

lemma costBIT_1y:
    assumes "x\<noteq>y" "x : {x0,y0}" "y\<in>{x0,y0}"
    shows
  "E (type1 [x0, y0] x y \<bind>
       (\<lambda>s. BIT_step s y \<bind>
            (\<lambda>(a, is'). return_pmf (real (t\<^sub>p (fst s) y a))))) = 3/4"
using assms apply(auto)
  apply(simp_all add: type1_def BIT_step_def bind_assoc_pmf bind_return_pmf )
  apply(simp_all add: E_bernoulli3 t\<^sub>p_def)
  done

lemma costBIT_3x:
    assumes "x\<noteq>y" "x : {x0,y0}" "y\<in>{x0,y0}"
    shows
  "E (type3 [x0, y0] x y \<bind>
       (\<lambda>s. BIT_step s x \<bind>
            (\<lambda>(a, is'). return_pmf (real (t\<^sub>p (fst s) x a))))) = 3/4"
using assms apply(auto)
  apply(simp_all add: type3_def BIT_step_def bind_assoc_pmf bind_return_pmf )
  apply(simp_all add: E_bernoulli3 t\<^sub>p_def)
  done

lemma costBIT_3y:
    assumes "x\<noteq>y" "x : {x0,y0}" "y\<in>{x0,y0}"
    shows
  "E (type3 [x0, y0] x y \<bind>
       (\<lambda>s. BIT_step s y \<bind>
            (\<lambda>(a, is'). return_pmf (real (t\<^sub>p (fst s) y a))))) = 1/4"
using assms apply(auto)
  apply(simp_all add: type3_def BIT_step_def bind_assoc_pmf bind_return_pmf )
  apply(simp_all add: E_bernoulli3 t\<^sub>p_def)
  done

lemma costBIT_4x:
    assumes "x\<noteq>y" "x : {x0,y0}" "y\<in>{x0,y0}"
    shows
  "E (type4 [x0, y0] x y \<bind>
       (\<lambda>s. BIT_step s x \<bind>
            (\<lambda>(a, is'). return_pmf (real (t\<^sub>p (fst s) x a))))) = 0.5"
using assms apply(auto)
  apply(simp_all add: type4_def BIT_step_def bind_assoc_pmf bind_return_pmf )
  apply(simp_all add: E_bernoulli3 t\<^sub>p_def)
  done

lemma costBIT_4y:
    assumes "x\<noteq>y" "x : {x0,y0}" "y\<in>{x0,y0}"
    shows
  "E (type4 [x0, y0] x y \<bind>
       (\<lambda>s. BIT_step s y \<bind>
            (\<lambda>(a, is'). return_pmf (real (t\<^sub>p (fst s) y a))))) = 0.5"
using assms apply(auto)
  apply(simp_all add: type4_def BIT_step_def bind_assoc_pmf bind_return_pmf )
  apply(simp_all add: E_bernoulli3 t\<^sub>p_def)
  done

lemmas costBIT = costBIT_0x costBIT_0y costBIT_1x costBIT_1y costBIT_3x costBIT_3y costBIT_4x costBIT_4y

subsubsection "state transformation of BIT"

abbreviation "BIT_Step s x == (s \<bind> (\<lambda>s. BIT_step s x \<bind> (\<lambda>(a, is'). return_pmf (step (fst s) x a, is'))))"

lemma oneBIT_step0x:
    assumes "x\<noteq>y" "x : {x0,y0}" "y\<in>{x0,y0}"
    shows "BIT_Step (type0 [x0, y0] x y) x = type0 [x0, y0] x y"
  using assms
  apply(simp add: type0_def BIT_step_def bind_assoc_pmf bind_return_pmf step_def mtf2_def)
  apply(safe)
    apply(rule pmf_eqI) apply(simp add: pmf_bind swap_def type0_def)
    apply(rule pmf_eqI) apply(simp add: add.commute pmf_bind swap_def type0_def)
    done

lemma oneBIT_step0y:
    assumes "x\<noteq>y" "x : {x0,y0}" "y\<in>{x0,y0}"
    shows "BIT_Step (type0 [x0, y0] x y) y = type4 [x0, y0] x y"
  using assms
  apply(simp add: type0_def BIT_step_def bind_assoc_pmf bind_return_pmf step_def mtf2_def)
  apply(safe)
    apply(rule pmf_eqI) apply(simp add: add.commute pmf_bind swap_def type4_def)
    apply(rule pmf_eqI) apply(simp add: pmf_bind swap_def type4_def)
    done

lemma oneBIT_step1x:
    assumes "x\<noteq>y" "x : {x0,y0}" "y\<in>{x0,y0}"
    shows "BIT_Step (type1 [x0, y0] x y) x = type0 [x0, y0] x y"
  using assms
  apply(simp add: type1_def BIT_step_def bind_assoc_pmf bind_return_pmf step_def mtf2_def)
  apply(safe)
    apply(rule pmf_eqI) apply(simp add: pmf_bind swap_def type0_def)
    apply(rule pmf_eqI) apply(simp add: add.commute pmf_bind swap_def type0_def)
    done

lemma oneBIT_step1y:
    assumes "x\<noteq>y" "x : {x0,y0}" "y\<in>{x0,y0}"
    shows "BIT_Step (type1 [x0, y0] x y) y = type3 [x0, y0] x y"
  using assms
  apply(simp add: type1_def BIT_step_def bind_assoc_pmf bind_return_pmf step_def mtf2_def)
  apply(safe)
    apply(rule pmf_eqI) apply(simp add: add.commute pmf_bind swap_def type3_def)
    apply(rule pmf_eqI) apply(simp add: pmf_bind swap_def type3_def)
    done

lemma oneBIT_step3x:
    assumes "x\<noteq>y" "x:{x0,y0}" "y:{x0,y0}"
    shows "BIT_Step (type3 [x0, y0] x y) x = type1 [x0, y0] x y"
  using assms
  apply(simp add: type3_def BIT_step_def bind_assoc_pmf bind_return_pmf step_def mtf2_def)
  apply(safe)
    apply(rule pmf_eqI) apply(simp add: pmf_bind swap_def type1_def)
    apply(rule pmf_eqI) apply(simp add: add.commute pmf_bind swap_def type1_def)
    done

lemma oneBIT_step3y:
    assumes "x\<noteq>y" "x : {x0,y0}" "y\<in>{x0,y0}"
    shows "BIT_Step (type3 [x0, y0] x y) y = type0 [x0, y0] y x"
  using assms
  apply(simp add: type3_def BIT_step_def bind_assoc_pmf bind_return_pmf step_def mtf2_def)
  apply(safe)
    apply(rule pmf_eqI) apply(simp add: add.commute pmf_bind swap_def type0_def)
    apply(rule pmf_eqI) apply(simp add: pmf_bind swap_def type0_def)
    done

lemma oneBIT_step4x:
    assumes "x\<noteq>y" "x : {x0,y0}" "y\<in>{x0,y0}"
    shows "BIT_Step (type4 [x0, y0] x y) x =  type1 [x0, y0] x y"
  using assms
  apply(simp add: type4_def BIT_step_def bind_assoc_pmf bind_return_pmf step_def mtf2_def)
  apply(safe)
    apply(rule pmf_eqI) apply(simp add: pmf_bind swap_def type1_def)
    apply(rule pmf_eqI) apply(simp add: add.commute pmf_bind swap_def type1_def)
    done

subsubsection "yx"

lemma bit_yx: assumes "x \<noteq> y"
      and kas: "init \<in> {[x,y],[y,x]}"
      and "qs \<in> lang (Star(Times (Atom y) (Atom x))) "
   shows "T\<^sub>p_on_rand' BIT (type1 init x y) (qs@r) = 0.75 * length qs + T\<^sub>p_on_rand' BIT (type1 init x y) r
    \<and> config'_rand BIT (type1 init x y) qs  = (type1 init x y)"
proof -
  from assms have "qs \<in> star ({[y]} @@ {[x]})" by (simp)
  from this assms show ?thesis
  proof (induct qs rule: star_induct)
    case (append u v)
    then have uyx: "u = [y,x]" by auto

    have yy: "T\<^sub>p_on_rand' BIT (type1 init x y)  (v @ r)  = 0.75*length v + T\<^sub>p_on_rand' BIT (type1 init x y) r
            \<and> config'_rand BIT  (type1 init x y) v = (type1 init x y)"
        apply(rule append(3))
          apply(fact)+
          using append(2,6) by(simp_all)

    have s2: "config'_rand BIT  (type1 init x y) [y,x] = (type1 init x y)"
      using kas assms(1) by (auto simp add: oneBIT_step )

    have ta: "T\<^sub>p_on_rand' BIT (type1 init x y) u = 1.5"
      using kas assms(1)
        by(auto simp add: uyx oneBIT_step costBIT_1y costBIT_3x)

    have config: "config'_rand BIT  (type1 init x y) (u @ v)
          = type1 init x y" by (simp only: config'_rand_append s2 uyx yy)

    have "T\<^sub>p_on_rand' BIT (type1 init x y) (u @ (v @ r))
        = T\<^sub>p_on_rand' BIT (type1 init x y) u  + T\<^sub>p_on_rand' BIT ( config'_rand BIT (type1 init x y)  u) (v@r) "
          by (simp only: T_on_rand'_append)
    also have "\<dots> =  T\<^sub>p_on_rand' BIT  (type1 init x y) u + T\<^sub>p_on_rand' BIT (type1 init x y) (v@r) "
      unfolding uyx by(simp only: s2)
    also have "\<dots> = T\<^sub>p_on_rand' BIT (type1 init x y) u  + 0.75*length v + T\<^sub>p_on_rand' BIT (type1 init x y) r "
        by(simp only: yy)
    also have "\<dots> = 2*0.75 + 0.75*length v + T\<^sub>p_on_rand' BIT (type1 init x y) r " by(simp add: ta)
    also have "\<dots> = 0.75 * (2+length v) + T\<^sub>p_on_rand' BIT (type1 init x y) r"
      by (simp add: ring_distribs del: add_2_eq_Suc' add_2_eq_Suc)
    also have "\<dots> = 0.75 * length (u @ v) + T\<^sub>p_on_rand' BIT (type1 init x y) r"
      using uyx by simp
    finally show ?case using config by simp
  qed simp
qed

subsubsection "(yx)*yx"

lemma bit_yxyx: assumes "x \<noteq> y" and kas: "init \<in> {[x,y],[y,x]}" and
      "qs \<in> lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])"
   shows "T\<^sub>p_on_rand' BIT (type0 init x y) (qs@r) = 0.75 * length qs + T\<^sub>p_on_rand' BIT (type1 init x y) r
    \<and> config'_rand BIT (type0 init x y) qs  = (type1 init x y)"
proof -
  obtain u v where uu: "u \<in> lang (Times (Atom y) (Atom x))"
              and vv: "v \<in> lang (seq[ Star(Times (Atom y) (Atom x))])"
              and qsuv: "qs = u @ v"
  using assms(3) by (auto simp: conc_def)

  from uu have uyx: "u = [y,x]" by(auto)

  from qsuv uyx have vqs: "length v = length qs - 2" by auto
  from qsuv uyx  have vqs2: "length v + 2 = length qs" by auto

  have s2: "config'_rand BIT  (type0 init x y) [y,x] = (type1 init x y)"
     using kas assms(1) by(auto simp add: oneBIT_step)

  have ta: "T\<^sub>p_on_rand' BIT (type0 init x y) u = 1.5"
    using kas assms(1) by (auto simp add: uyx oneBIT_step costBIT)

  have tat: "T\<^sub>p_on_rand' BIT (type1 init x y) (v @ r) =   0.75*length v + T\<^sub>p_on_rand' BIT (type1 init x y) r
            \<and> config'_rand BIT (type1 init x y) v = (type1 init x y)"
        apply(rule bit_yx)
      apply(fact)+
      using vv by(simp_all)

  have config: "config'_rand BIT (type0 init x y) (u @ v) = type1 init x y"
    by(simp only: config'_rand_append s2 uyx tat)

  have "T\<^sub>p_on_rand' BIT (type0 init x y) (u @ (v @ r))
        = T\<^sub>p_on_rand' BIT (type0 init x y) u + T\<^sub>p_on_rand' BIT (config'_rand BIT (type0 init x y) u) (v@r)" by (simp only: T_on_rand'_append)
also
  have "\<dots> =  T\<^sub>p_on_rand' BIT (type0 init x y) u + T\<^sub>p_on_rand' BIT (type1 init x y) (v@r)" by(simp only: uyx s2)
also
  have "\<dots> = T\<^sub>p_on_rand' BIT (type0 init x y) u + 0.75*length v + T\<^sub>p_on_rand' BIT (type1 init x y) r" by(simp only: tat)
also
  have "\<dots> = 2*0.75 + 0.75*length v + T\<^sub>p_on_rand' BIT (type1 init x y) r" by(simp add: ta)
also
  have "\<dots> = 0.75 * (2+length v) + T\<^sub>p_on_rand' BIT (type1 init x y) r" by (simp add: ring_distribs del: add_2_eq_Suc' add_2_eq_Suc)
also
  have "\<dots> = 0.75 * length (u @ v) + T\<^sub>p_on_rand' BIT (type1 init x y) r" using uyx by simp
finally
  show ?thesis using qsuv config by simp
qed

subsubsection \<open>\<open>x^+..\<close>\<close>

lemma BIT_x: assumes "x\<noteq>y"
       "init \<in> {[x,y],[y,x]}" "qs \<in> lang (Plus (Atom x) One)"
 shows "T\<^sub>p_on_rand' BIT (type0 init x y) (qs@r) = T\<^sub>p_on_rand' BIT (type0 init x y) r
    \<and> config'_rand BIT  (type0 init x y) qs = (type0 init x y)"
proof -
  have s: "config'_rand BIT (type0 init x y) qs = type0 init x y"
    using assms by (auto simp add: oneBIT_step)

  have t: "T\<^sub>p_on_rand' BIT (type0 init x y) qs = 0"
    using assms by (auto simp add: costBIT)

  show ?thesis using s t by(simp add: T_on_rand'_append)
qed

subsubsection "Phase Form A"

lemma BIT_a: assumes "x \<noteq> y"
    " init \<in> {[x,y],[y,x]}"
   "qs \<in> lang (seq [Plus (Atom x) One, Atom y, Atom y])"
  shows "config'_rand BIT (type0 init x y) qs = (type0 init y x)" (is ?C)
    and b: "T\<^sub>p_on_rand' BIT (type0 init x y) qs = 1.5" (is ?T)
proof -
  from assms(3) have alt: "qs = [x,y,y] \<or> qs = [y,y]" apply(simp) by fastforce
  show ?C
    using assms(1,2) alt by (auto simp add: oneBIT_step)
  show ?T
    using assms(1,2) alt by(auto simp add: oneBIT_step costBIT)
qed

lemma bit_a: assumes
    "x \<noteq> y" "{x, y} = {x0, y0}" "BIT_inv s x [x0, y0]"
    "set qs \<subseteq> {x, y}" "qs \<in> lang (seq [Plus (Atom x) One, Atom y, Atom y])"
 shows
    "T\<^sub>p_on_rand' BIT s qs  \<le> 1.75 * T\<^sub>p [x,y] qs (OPT2 qs [x,y])
      \<and>  BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0]
      \<and> T\<^sub>p_on_rand' BIT s qs = 1.5"
proof -
  from assms have f: "x0\<noteq>y0" by auto
  from assms(1,3) assms(2)[symmetric] have s: "s = type0 [x0,y0] x y"
    apply(simp add: BIT_inv2[OF f] other_def) by fast

  from assms(1,2) have kas: "[x,y] = [x0,y0] \<or> [x,y] = [y0,x0]" by auto

  from assms have lqs: "last qs = y" by fastforce
  from assms(1,2) kas have p: "T\<^sub>p_on_rand' BIT s qs = 1.5"
    unfolding s
    apply(safe)
      apply(rule BIT_a)
        apply(simp) apply(simp) using assms(5) apply(simp)
      apply(rule BIT_a)
        apply(simp) apply(simp) using assms(5) apply(simp)
  done
  with OPT2_A[OF assms(1,5)] have BIT: "T\<^sub>p_on_rand' BIT s qs \<le> 1.75 * T\<^sub>p [x, y] qs (OPT2 qs [x, y])" by auto

  from assms(1,2) kas have "config'_rand BIT s qs = type0 [x0, y0] y x"
    unfolding s
    apply(safe)
      apply(rule BIT_a)
        apply(simp) apply(simp) using assms(5) apply(simp)
      apply(rule BIT_a)
        apply(simp) apply(simp) using assms(5) apply(simp)
  done

  then have "BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0]"
    apply(simp)
    using assms(1) kas f lqs by(auto simp add: BIT_inv2 other_def)

  then show ?thesis using BIT s p by simp
qed

lemma bit_a'': " a \<noteq> b \<Longrightarrow>
         {a, b} = {x, y} \<Longrightarrow>
         BIT_inv s a [x, y] \<Longrightarrow>
         set qs \<subseteq> {a, b} \<Longrightarrow>
         qs \<in> lang (seq [question (Atom a), Atom b, Atom b]) \<Longrightarrow>
         BIT_inv (Partial_Cost_Model.config'_rand BIT s qs) (last qs) [x, y] \<and> T\<^sub>p_on_rand' BIT s qs = 1.5"
using bit_a[of a b x y] by blast

subsubsection "Phase Form B"

lemma BIT_b: assumes A: "x \<noteq> y"
       "init \<in> {[x,y],[y,x]}"
    "v \<in> lang (seq [Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
    shows "T\<^sub>p_on_rand' BIT (type0 init x y) v = 0.75 * length v - 0.5" (is ?T)
     and "config'_rand BIT  (type0 init x y) v = (type0 init y x)" (is ?C)
proof -
  have lenvmod: "length v mod 2 = 0"
  proof -
    from assms(3) have "v \<in> ({[y]} @@ {[x]}) @@ star({[y]} @@ {[x]}) @@ {[y]} @@ {[y]}" by(simp add: conc_assoc)
    then obtain p q r where pqr: "v=p@q@r" and "p\<in>({[y]} @@ {[x]})"
              and q: "q \<in> star ({[y]} @@ {[x]})" and "r \<in>{[y]} @@ {[y]}" by (metis concE)
    then have "p = [y,x]" "r=[y,y]" by auto
    with pqr have a: "length v = 4+length q" by auto

    from q have b: "length q mod 2 = 0"
    apply(induct q rule: star_induct) by (auto)
    from a b show "length v mod 2 = 0" by auto
  qed

  from assms(3) have "v \<in> lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])
                          @@ lang (seq[Atom y, Atom y])" by (auto simp: conc_def)
  then obtain a b where aa: "a \<in> lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])"
                      and "b \<in> lang (seq[Atom y, Atom y])"
                      and vab: "v = a @ b"
                      by(erule concE)
  then have bb: "b=[y,y]" by auto
  from vab bb have lenv: "length v = length a + 2" by auto

  from bit_yxyx[OF assms(1,2) aa] have stars: "T\<^sub>p_on_rand' BIT (type0 init x y) (a @ b)  = 0.75 * length a + T\<^sub>p_on_rand' BIT (type1 init x y) b"
                             and s2: "config'_rand BIT (type0 init x y) a = type1 init x y"  by fast+

  have t: "T\<^sub>p_on_rand' BIT (type1 init x y) b = 1"
    using assms(1,2) by (auto simp add: oneBIT_step  costBIT bb)

  have s: "config'_rand BIT  (type1 init x y) [y, y] = type0 init y x"
    using assms(1,2) by (auto simp add: oneBIT_step)

  have config: "config'_rand BIT (type0 init x y) (a @ b) = type0 init y x"
    by (simp only: config'_rand_append s2 vab bb s)

  have calc: "3 * Suc (Suc (length a)) / 4 - 1 / 2 = 3 * (2+length a) / 4 - 1 / 2" by simp

  from t stars have "T\<^sub>p_on_rand' BIT (type0 init x y) (a @ b) = 0.75 * length a + 1" by auto
  then show "T\<^sub>p_on_rand' BIT  (type0 init x y) v = 0.75 * length v - 0.5"
    unfolding lenv by(simp add: vab ring_distribs del: add_2_eq_Suc')
  from config vab show ?C by simp
qed

lemma bit_b''1: assumes
    "x \<noteq> y" "{x, y} = {x0, y0}" "BIT_inv s x [x0, y0]"
    "set qs \<subseteq> {x, y}"
    "qs \<in> lang (seq[Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom y, Atom y])"
 shows "BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0] \<and>
          T\<^sub>p_on_rand' BIT s qs  = 0.75 * length qs - 0.5"
proof -
  from assms have f: "x0\<noteq>y0" by auto
  from assms(1,3) assms(2)[symmetric] have s: "s = type0 [x0,y0] x y"
    apply(simp add: BIT_inv2[OF f] other_def) by fast

  from assms(1,2) have kas: "[x,y] = [x0,y0] \<or> [x,y] = [y0,x0]" by auto

  from assms(5) have lqs: "last qs = y" by fastforce
  from assms(1,2) kas have BIT: "T\<^sub>p_on_rand' BIT s qs = 0.75 * length qs - 0.5"
    unfolding s
    apply(safe)
      apply(rule BIT_b)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
      apply(rule BIT_b)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
  done

  from assms(1,2) kas have "config'_rand BIT s qs = type0 [x0, y0] y x"
    unfolding s
    apply(safe)
      apply(rule BIT_b)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
      apply(rule BIT_b)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
  done

  then have config: "BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0]"
    apply(simp)
    using assms(1) kas lqs by(auto simp add: BIT_inv2 other_def)

  show ?thesis using BIT config by simp
qed

lemma BIT_b2: assumes A: "x \<noteq> y"
       "init \<in> {[x,y],[y,x]}"
    "v \<in> lang (seq [Atom x, Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
    shows "T\<^sub>p_on_rand' BIT (type0 init x y) v = 0.75 * (length v - 1) - 0.5" (is ?T)
     and "config'_rand BIT  (type0 init x y) v = (type0 init y x)" (is ?C)
proof -
  from assms(3) obtain w where  vw: "v = [x]@w" and
          w: "w \<in> lang (seq [Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
          by(auto)
  have c1: "config'_rand BIT (type0 init x y) [x] = type0 init x y"
      using assms by(auto simp add: oneBIT_step)
  have t1: "T\<^sub>p_on_rand' BIT (type0 init x y) [x] = 0"
      using assms by(auto simp add: costBIT)
  show "T\<^sub>p_on_rand' BIT (type0 init x y) v
      = 0.75 * (length v - 1) - 0.5"
      unfolding vw apply(simp only: T_on_rand'_append c1 BIT_b[OF assms(1,2) w] t1)
        by (simp)
  show "config'_rand BIT (type0 init x y) v = (type0 init y x)"
    unfolding vw by(simp only: config'_rand_append c1 BIT_b[OF assms(1,2) w])
qed

lemma bit_b''2: assumes
    "x \<noteq> y" "{x, y} = {x0, y0}" "BIT_inv s x [x0, y0]"
    "set qs \<subseteq> {x, y}"
    "qs \<in> lang (seq[Atom x, Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom y, Atom y])"
 shows "BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0] \<and>
          T\<^sub>p_on_rand' BIT s qs  = 0.75 * (length qs - 1) - 0.5"
proof -
  from assms have f: "x0\<noteq>y0" by auto
  from assms(1,3) assms(2)[symmetric] have s: "s = type0 [x0,y0] x y"
    apply(simp add: BIT_inv2[OF f] other_def) by fast

  from assms(1,2) have kas: "[x,y] = [x0,y0] \<or> [x,y] = [y0,x0]" by auto

  from assms(5) have lqs: "last qs = y" by fastforce
  from assms(1,2) kas have BIT: "T\<^sub>p_on_rand' BIT s qs = 0.75 * (length qs-1) - 0.5"
    unfolding s
    apply(safe)
      apply(rule BIT_b2)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
      apply(rule BIT_b2)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
  done

  from assms(1,2) kas have "config'_rand BIT s qs = type0 [x0, y0] y x"
    unfolding s
    apply(safe)
      apply(rule BIT_b2)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
      apply(rule BIT_b2)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
  done

  then have config: "BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0]"
    apply(simp)
    using assms(1) kas lqs by(auto simp add: BIT_inv2 other_def)

  show ?thesis using BIT config by simp
qed

lemma bit_b: assumes "x \<noteq> y"
      "init \<in> {[x,y],[y,x]}"
   "qs \<in> lang (seq[Plus (Atom x) One, Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom y, Atom y])"
 shows  "T\<^sub>p_on_rand' BIT (type0 init x y) qs \<le> 1.75 * T\<^sub>p [x,y] qs (OPT2 qs [x,y])"
  and "config'_rand BIT (type0 init x y) qs = type0 init y x"
proof -
  obtain u v where uu: "u \<in> lang (Plus (Atom x) One)"
        and vv: "v \<in> lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
        and qsuv: "qs = u @ v"
        using assms
        by (auto simp: conc_def)
  have lenv: "length v mod 2 = 0 \<and> last v = y \<and> v\<noteq>[]"
  proof -
    from vv have "v \<in> ({[y]} @@ {[x]}) @@ star({[y]} @@ {[x]}) @@ {[y]} @@ {[y]}" by simp
    then obtain p q r where pqr: "v=p@q@r" and "p\<in>({[y]} @@ {[x]})"
              and q: "q \<in> star ({[y]} @@ {[x]})" and "r \<in>{[y]} @@ {[y]}" by (metis concE)
    then have rr: "p = [y,x]" "r=[y,y]" by auto
    with pqr have a: "length v = 4+length q" by auto

    have "last v = last r" using pqr rr by auto
    then have c: "last v = y" using rr by auto

    from q have b: "length q mod 2 = 0"
    apply(induct q rule: star_induct) by (auto)
    from a b c show ?thesis by auto
  qed

  from vv have "v \<in> lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])
                          @@ lang (seq[Atom y, Atom y])" by (auto simp: conc_def)
  then obtain a b where aa: "a \<in> lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])"
                    and "b \<in> lang (seq[Atom y, Atom y])"
                    and vab: "v = a @ b"
                      by(erule concE)

  from BIT_x[OF assms(1,2) uu] have u_t: "T\<^sub>p_on_rand' BIT (type0 init x y) (u @ v)  = T\<^sub>p_on_rand' BIT (type0 init x y) v"
      and u_c: "config'_rand BIT (type0 init x y) u = type0 init x y" by auto
  from BIT_b[OF assms(1,2) vv] have b_t: "T\<^sub>p_on_rand' BIT (type0 init x y) v  = 0.75 * length v - 0.5"
      and  b_c: "config'_rand BIT (type0 init x y) v = (type0 init y x)" by auto

  have BIT: "T\<^sub>p_on_rand' BIT (type0 init x y) qs  = 0.75 * length v - 0.5"
    by(simp add: qsuv u_t b_t)

  (* OPT *)

  from uu have uuu: "u=[] \<or> u=[x]" by auto
  have OPT: "T\<^sub>p [x,y] qs (OPT2 qs [x,y]) = (length v) div 2" apply(rule OPT2_B) by(fact)+

  from lenv have "v \<noteq> []"  "last v = y" by auto
  then have 1:  "last qs = y" using last_appendR qsuv by simp
  then have 2: "other (last qs) x y = x" unfolding other_def by simp

  show "T\<^sub>p_on_rand' BIT (type0 init x y) qs \<le> 1.75 * T\<^sub>p [x,y] qs (OPT2 qs [x,y])"
    using BIT OPT lenv by auto

  (* config *)

  show "config'_rand BIT (type0 init x y) qs = type0 init y x"
    by (auto simp add: config'_rand_append qsuv u_c b_c)
qed

lemma bit_b'': assumes
    "x \<noteq> y" "{x, y} = {x0, y0}" "BIT_inv s x [x0, y0]"
    "set qs \<subseteq> {x, y}"
    "qs \<in> lang (seq[Plus (Atom x) One, Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom y, Atom y])"
 shows
    "T\<^sub>p_on_rand' BIT s qs  \<le> 1.75 * T\<^sub>p [x,y] qs (OPT2 qs [x,y])
      \<and>  BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0]"
proof -
  from assms have f: "x0\<noteq>y0" by auto
  from assms(1,3) assms(2)[symmetric] have s: "s = type0 [x0,y0] x y"
    apply(simp add: BIT_inv2[OF f] other_def) by fast

  from assms(1,2) have kas: "[x,y] = [x0,y0] \<or> [x,y] = [y0,x0]" by auto

  from assms(5) have lqs: "last qs = y" by fastforce
  from assms(1,2) kas have BIT: "T\<^sub>p_on_rand' BIT s qs \<le> 1.75 * T\<^sub>p [x, y] qs (OPT2 qs [x, y])"
    unfolding s
    apply(safe)
      apply(rule bit_b)
        apply(simp) apply(simp) using assms(5) apply(simp)
      apply(rule bit_b)
        apply(simp) apply(simp) using assms(5) apply(simp)
  done

  from assms(1,2) kas have "config'_rand BIT s qs = type0 [x0, y0] y x"
    unfolding s
    apply(safe)
      apply(rule bit_b)
        apply(simp) apply(simp) using assms(5) apply(simp)
      apply(rule bit_b)
        apply(simp) apply(simp) using assms(5) apply(simp)
  done

  then have "BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0]"
    apply(simp)
    using assms(1) kas lqs by(auto simp add: BIT_inv2 other_def)

  then show ?thesis using BIT s by simp
qed

lemma bit_b''': " a \<noteq> b \<Longrightarrow>
         {a, b} = {x, y} \<Longrightarrow>
         BIT_inv s a [x, y] \<Longrightarrow>
         set qs \<subseteq> {a, b} \<Longrightarrow>
         qs \<in> lang (seq[Plus (Atom x) One, Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom y, Atom y]) \<Longrightarrow>
         BIT_inv (Partial_Cost_Model.config'_rand BIT s qs) (last qs) [x, y] \<and> T\<^sub>p_on_rand' BIT s qs = 1.5"
using bit_a[of a b x y] oops

subsubsection "Phase Form C"

lemma BIT_c: assumes "x \<noteq> y"
       "init \<in> {[x,y],[y,x]}"
    "v \<in> lang (seq [Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
    shows "T\<^sub>p_on_rand' BIT (type0 init x y) v = 0.75 * length v - 0.5"
      and "config'_rand BIT  (type0 init x y) v = (type0 init x y)" (is ?C)
proof -
  have A: "x\<noteq>y"  using assms by auto

  from assms(3) have "v \<in> lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])
                          @@ lang (seq[Atom x])" by (auto simp: conc_def)
  then obtain a b where aa: "a \<in> lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])"
                      and "b \<in> lang (seq[Atom x])"
                      and vab: "v = a @ b"
                      by(erule concE)
  then have bb: "b=[x]" by auto
  from aa have lena: "length a > 0" by auto
  from vab bb have lenv: "length v = length a + 1" by auto

  from bit_yxyx assms(1,2) aa have stars: "T\<^sub>p_on_rand' BIT (type0 init x y) (a @ b)  = 0.75 * length a + T\<^sub>p_on_rand' BIT (type1 init x y) b"
                             and s2: "config'_rand BIT (type0 init x y) a = type1 init x y"  by fast+

  have t: "T\<^sub>p_on_rand' BIT (type1 init x y) b = 1/4"
    using assms(1,2) by (auto simp add: bb costBIT)

  have s: "config'_rand BIT  (type1 init x y) b = type0 init x y"
    using assms(1,2) by (auto simp add: bb oneBIT_step1x )

  have config: "config'_rand BIT  (type0 init x y) (a @ b) = type0 init x y"
    by (simp only: config'_rand_append s2 vab s)

  have calc: "3 * Suc (Suc (length a)) / 4 - 1 / 2 = 3 * (2+length a) / 4 - 1 / 2" by simp

  from t stars have "T\<^sub>p_on_rand' BIT (type0 init x y) (a @ b) = 0.75 * length a + 1/4" by auto
  then show "T\<^sub>p_on_rand' BIT  (type0 init x y) v = 0.75 * length v - 0.5" unfolding lenv
    by(simp add: vab ring_distribs del: add_2_eq_Suc')
  from config vab show ?C by simp
qed

lemma bit_c''1: assumes
    "x \<noteq> y" "{x, y} = {x0, y0}" "BIT_inv s x [x0, y0]"
    "set qs \<subseteq> {x, y}"
    "qs \<in> lang (seq[Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom x])"
 shows "BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0] \<and>
          T\<^sub>p_on_rand' BIT s qs  = 0.75 * length qs - 0.5"
proof -
  from assms have f: "x0\<noteq>y0" by auto
  from assms(1,3) assms(2)[symmetric] have s: "s = type0 [x0,y0] x y"
    apply(simp add: BIT_inv2[OF f] other_def) by fast

  from assms(1,2) have kas: "[x,y] = [x0,y0] \<or> [x,y] = [y0,x0]" by auto

  from assms(5) have lqs: "last qs = x" by fastforce
  from assms(1,2) kas have BIT: "T\<^sub>p_on_rand' BIT s qs = 0.75 * length qs - 0.5"
    unfolding s
    apply(safe)
      apply(rule BIT_c)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
      apply(rule BIT_c)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
  done

  from assms(1,2) kas have "config'_rand BIT s qs = type0 [x0, y0] x y"
    unfolding s
    apply(safe)
      apply(rule BIT_c)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
      apply(rule BIT_c)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
  done

  then have config: "BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0]"
    apply(simp)
    using assms(1) kas lqs by(auto simp add: BIT_inv2 other_def)

  show ?thesis using BIT config by simp
qed

lemma bit_c: assumes "x \<noteq> y"
      "init \<in> {[x,y],[y,x]}"
   "qs \<in> lang (seq[Plus (Atom x) One, Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom x])"
 shows  "T\<^sub>p_on_rand' BIT (type0 init x y) qs \<le> 1.75 * T\<^sub>p [x,y] qs (OPT2 qs [x,y])"
  and "config'_rand BIT (type0 init x y) qs = type0 init x y"
proof -
  obtain u v where uu: "u \<in> lang (Plus (Atom x) One)"
        and vv: "v \<in> lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
        and qsuv: "qs = u @ v"
        using assms
        by (auto simp: conc_def)
  have lenv: "length v mod 2 = 1 \<and> length v \<ge> 3 \<and> last v = x"
  proof -
    from vv have "v \<in> ({[y]} @@ {[x]}) @@ star({[y]} @@ {[x]}) @@ {[x]}" by auto
    then obtain p q r where pqr: "v=p@q@r" and "p\<in>({[y]} @@ {[x]})"
              and q: "q \<in> star ({[y]} @@ {[x]})" and "r \<in> {[x]}" by (metis concE)
    then have rr: "p = [y,x]"  "r=[x]" by auto
    with pqr have a: "length v = 3+length q" by auto

    have "last v = last r" using pqr rr by auto
    then have c: "last v = x" using rr by auto

    from q have b: "length q mod 2 = 0"
    apply(induct q rule: star_induct) by (auto)
    from a b c show "length v mod 2 = 1 \<and> length v \<ge> 3 \<and> last v = x" by auto
  qed

  from vv have "v \<in> lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])
                          @@ lang (seq[Atom x])" by (auto simp: conc_def)
  then obtain a b where aa: "a \<in> lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])"
                      and "b \<in> lang (seq[Atom x])"
                      and vab: "v = a @ b"
                      by(erule concE)

  from BIT_x[OF assms(1,2) uu] have u_t: "T\<^sub>p_on_rand' BIT (type0 init x y)  (u @ v)  = T\<^sub>p_on_rand' BIT (type0 init x y) v"
      and u_c: "config'_rand BIT (type0 init x y) u = type0 init x y" by auto
  from BIT_c[OF assms(1,2) vv] have b_t: "T\<^sub>p_on_rand' BIT (type0 init x y) v  = 0.75 * length v - 0.5"
      and  b_c: "config'_rand BIT (type0 init x y) v = (type0 init x y)" by auto

  have BIT: "T\<^sub>p_on_rand' BIT (type0 init x y) qs  = 0.75 * length v - 0.5"
    by(simp add: qsuv u_t b_t)

  (* OPT *)

  from uu have uuu: "u=[] \<or> u=[x]" by auto
  from vv have vvv: "v \<in> lang (seq
          [Atom y, Atom x,
           Star (Times (Atom y) (Atom x)),
           Atom x])" by(auto simp: conc_def)
  have OPT: "T\<^sub>p [x,y] qs (OPT2 qs [x,y]) = (length v) div 2" apply(rule OPT2_C) by(fact)+

  from lenv have "v \<noteq> []"  "last v = x" by auto
  then have 1:  "last qs = x" using last_appendR qsuv by simp
  then have 2: "other (last qs) x y = y" unfolding other_def by simp

  have vgt3: "length v \<ge> 3" using lenv by simp
  have "T\<^sub>p_on_rand' BIT (type0 init x y) qs  = 0.75 * length v - 0.5" using BIT by simp
also
  have "\<dots> \<le> 1.75 * (length v - 1)/2"
  proof -
    have "10 + 6 * length v \<le> 7 * Suc (length v)
        \<longleftrightarrow> 10 + 6 * length v \<le> 7 * length v + 7" by auto
    also have "\<dots> \<longleftrightarrow> 3 \<le> length v" by auto
    also have "\<dots> \<longleftrightarrow> True" using vgt3 by auto
    finally have A: " 6 * length v - 4 \<le> 7 * (length v - 1)" by simp
    show ?thesis apply(simp) using A by linarith
  qed
also
  have "\<dots> = 1.75 * (length v div 2)"
  proof -
    from div_mult_mod_eq have "length v = length v div 2 * 2 + length v mod 2" by auto
    with lenv have "length v = length v div 2 * 2 + 1" by auto
    then have "(length v - 1) / 2 = length v div 2" by simp
    then show ?thesis by simp
  qed
also
  have "\<dots> = 1.75 * T\<^sub>p [x, y] qs (OPT2 qs [x, y])" using OPT by auto
finally
  show "T\<^sub>p_on_rand' BIT (type0 init x y) qs \<le> 1.75 * T\<^sub>p [x,y] qs (OPT2 qs [x,y])"
    using BIT OPT lenv   1 2  by auto

  (* config *)

  show "config'_rand BIT  (type0 init x y) qs  = type0 init x y"
    by (auto simp add: config'_rand_append qsuv u_c b_c)
qed

lemma bit_c'': assumes
    "x \<noteq> y" "{x, y} = {x0, y0}" "BIT_inv s x [x0, y0]"
    "set qs \<subseteq> {x, y}"
    "qs \<in> lang (seq[Plus (Atom x) One, Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom x])"
 shows
    "T\<^sub>p_on_rand' BIT s qs  \<le> 1.75 * T\<^sub>p [x,y] qs (OPT2 qs [x,y])
      \<and>  BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0]"
proof -
  from assms have f: "x0\<noteq>y0" by auto
  from assms(1,3) assms(2)[symmetric] have s: "s = type0 [x0,y0] x y"
    apply(simp add: BIT_inv2[OF f] other_def) by fast

  from assms(1,2) have kas: "[x,y] = [x0,y0] \<or> [x,y] = [y0,x0]" by auto

  from assms have lqs: "last qs = x" by fastforce
  from assms(1,2) kas have BIT: "T\<^sub>p_on_rand' BIT s qs \<le> 1.75 * T\<^sub>p [x, y] qs (OPT2 qs [x, y])"
    unfolding s
    apply(safe)
      apply(rule bit_c )
        apply(simp) apply(simp) using assms(5) apply(simp)
      apply(rule bit_c)
        apply(simp) apply(simp) using assms(5) apply(simp)
  done

  from assms(1,2) kas have "config'_rand BIT s qs = type0 [x0, y0] x y"
    unfolding s
    apply(safe)
      apply(rule bit_c)
        apply(simp) apply(simp) using assms(5) apply(simp)
      apply(rule bit_c)
        apply(simp) apply(simp) using assms(5) apply(simp)
  done

  then have "BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0]"
    apply(simp)
    using assms(1) kas f lqs by(auto simp add: BIT_inv2 other_def)

  then show ?thesis using BIT s by simp
qed

lemma BIT_c2: assumes A: "x \<noteq> y"
       "init \<in> {[x,y],[y,x]}"
    "v \<in> lang (seq [Atom x, Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
    shows "T\<^sub>p_on_rand' BIT (type0 init x y) v = 0.75 * (length v - 1) - 0.5" (is ?T)
     and "config'_rand BIT  (type0 init x y) v = (type0 init x y)" (is ?C)
proof -
  from assms(3) obtain w where  vw: "v = [x]@w" and
          w: "w \<in> lang (seq [Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
          by(auto)
  have c1: "config'_rand BIT (type0 init x y) [x] = type0 init x y"
      using assms by(auto simp add: oneBIT_step)
  have t1: "T\<^sub>p_on_rand' BIT (type0 init x y) [x] = 0"
      using assms by(auto simp add: costBIT)
  show "T\<^sub>p_on_rand' BIT (type0 init x y) v
      = 0.75 * (length v - 1) - 0.5"
      unfolding vw apply(simp only: T_on_rand'_append c1 BIT_c[OF assms(1,2) w] t1)
        by (simp)
  show "config'_rand BIT (type0 init x y) v = (type0 init x y)"
    unfolding vw by(simp only: config'_rand_append c1 BIT_c[OF assms(1,2) w])
qed

lemma bit_c''2: assumes
    "x \<noteq> y" "{x, y} = {x0, y0}" "BIT_inv s x [x0, y0]"
    "set qs \<subseteq> {x, y}"
    "qs \<in> lang (seq[Atom x, Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom x])"
 shows "BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0] \<and>
          T\<^sub>p_on_rand' BIT s qs  = 0.75 * (length qs - 1) - 0.5"
proof -
  from assms have f: "x0\<noteq>y0" by auto
  from assms(1,3) assms(2)[symmetric] have s: "s = type0 [x0,y0] x y"
    apply(simp add: BIT_inv2[OF f] other_def) by fast

  from assms(1,2) have kas: "[x,y] = [x0,y0] \<or> [x,y] = [y0,x0]" by auto

  from assms(5) have lqs: "last qs = x" by fastforce
  from assms(1,2) kas have BIT: "T\<^sub>p_on_rand' BIT s qs = 0.75 * (length qs-1) - 0.5"
    unfolding s
    apply(safe)
      apply(rule BIT_c2)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
      apply(rule BIT_c2)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
  done

  from assms(1,2) kas have "config'_rand BIT s qs = type0 [x0, y0] x y"
    unfolding s
    apply(safe)
      apply(rule BIT_c2)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
      apply(rule BIT_c2)
        apply(simp) apply(simp) using assms(5) apply(simp add: conc_assoc)
  done

  then have config: "BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0]"
    apply(simp)
    using assms(1) kas lqs by(auto simp add: BIT_inv2 other_def)

  show ?thesis using BIT config by simp
qed

subsubsection "Phase Form D"

lemma bit_d: assumes
    "x \<noteq> y" "{x, y} = {x0, y0}" "BIT_inv s x [x0, y0]"
    "set qs \<subseteq> {x, y}" "qs \<in> lang (seq [Atom x, Atom x])"
  shows "T\<^sub>p_on_rand' BIT s qs \<le> 175 / 10\<^sup>2 * real (T\<^sub>p [x, y] qs (OPT2 qs [x, y])) \<and>
    BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0] \<and>
     T\<^sub>p_on_rand' BIT s qs = 0"
proof -
  from assms have qs: "qs = [x,x]" by auto
  then have OPT: "T\<^sub>p [x, y] qs (OPT2 qs [x, y]) = 0" by (simp add: t\<^sub>p_def step_def)

  from assms have f: "x0\<noteq>y0" by auto
  from assms(1,3) assms(2)[symmetric] have s: "s = type0 [x0,y0] x y"
    apply(simp add: BIT_inv2[OF f] other_def) by fast

  from assms(1,2) have kas: "[x,y] = [x0,y0] \<or> [x,y] = [y0,x0]" by auto

  have BIT: "T\<^sub>p_on_rand' BIT (type0 [x0,y0] x y) qs = 0"
    using kas assms(1,2) by (auto simp add: qs oneBIT_step costBIT)

  have lqs: "last qs = x" "last qs \<in> {x0,y0}" using assms(2,4) qs by auto

  have inv: "config'_rand BIT s qs = type0 [x0, y0] x y"
    using kas assms(1,2) by (auto simp add: qs s  oneBIT_step0x)

  then have "BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0]"
    apply(simp)
    using assms(1) kas f lqs by(auto simp add: BIT_inv2 other_def)

  then show ?thesis using BIT s by(auto)
qed

lemma bit_d': assumes
    "x \<noteq> y" "{x, y} = {x0, y0}" "BIT_inv s x [x0, y0]"
    "set qs \<subseteq> {x, y}" "qs \<in> lang (seq [Atom x, Atom x])"
  shows "BIT_inv (config'_rand BIT s qs) (last qs) [x0, y0] \<and>
     T\<^sub>p_on_rand' BIT s qs = 0"
using bit_d[OF assms] by blast

subsection "Phase Partitioning"

lemma BIT_inv_initial: assumes "(x::nat) \<noteq> y"
    shows "BIT_inv (map_pmf (Pair [x, y]) (fst BIT [x, y])) x [x, y]"
using assms(1) apply(simp add: BIT_inv2 BIT_init_def type0_def)
      apply(simp add: map_pmf_def other_def bind_return_pmf bind_assoc_pmf)
      using bind_commute_pmf by fast

lemma D'': assumes "qs \<in> Lxx a b"
    "a \<noteq> b" "{a, b} = {x, y}" "BIT_inv s a [x, y]"
    "set qs \<subseteq> {a, b}"
 shows "T\<^sub>p_on_rand' BIT s qs \<le> 175 / 10\<^sup>2 * real (T\<^sub>p [a, b] qs (OPT2 qs [a, b])) \<and>
    BIT_inv (Partial_Cost_Model.config'_rand BIT s qs) (last qs) [x, y]"
 apply(rule LxxE[OF assms(1)])
  using bit_d[OF assms(2-5)] apply(simp)
  apply(rule bit_b''[OF assms(2-5)]) apply(simp)
  apply(rule bit_c''[OF assms(2-5)]) apply(simp)
  using bit_a[OF assms(2-5)] apply(simp)
  done

theorem BIT_175comp_on_2:
    assumes "(x::nat) \<noteq> y" "set \<sigma> \<subseteq> {x,y}"
     shows "T\<^sub>p_on_rand BIT [x,y] \<sigma>  \<le> 1.75 * real (T\<^sub>p_opt [x,y] \<sigma>) + 1.75"
proof (rule Phase_partitioning_general[where P=BIT_inv], goal_cases)
  case 4
  show "BIT_inv (map_pmf (Pair [x, y]) (fst BIT [x, y])) x [x, y]"
   by (rule BIT_inv_initial[OF assms(1)])
next
  case (5 a b qs s)
  then show ?case by(rule D'')
qed (simp_all add: assms)

end


theory LangCompFunOrd
imports LangCompSimple MergeableFun
begin

definition scross :: "('a \<Rightarrow> 'b) set \<Rightarrow> 'a set \<Rightarrow> 'b set" where
"scross Fs Xs =
  { x . \<exists> f y . f \<in> Fs \<and> y \<in> Xs \<and> x = f y }"

lemma scross_inI :
  assumes Hf : "f \<in> Fs"
  assumes Hx : "x \<in> Xs"
  assumes Heq : "res = f x"
  shows "res \<in> scross Fs Xs" using assms
  unfolding scross_def
  by blast

lemma scross_inD  :
  assumes "res \<in> scross Fs Xs"
  shows "\<exists> f y . f \<in> Fs \<and> y \<in> Xs \<and> res = f y" using assms
  unfolding scross_def
  by blast

definition sups_pres ::
  "('a \<Rightarrow> ('b :: Mergeableb) \<Rightarrow> 'b) set \<Rightarrow> bool"
  where
"sups_pres Fs =
  (\<forall> x sup syn Xs .
    x \<in> Xs \<longrightarrow>
    finite Xs \<longrightarrow>
    is_sup Xs sup \<longrightarrow>
    (\<exists> fsup . is_sup Fs fsup \<and> is_sup (scross ((\<lambda> f . f syn) ` Fs) Xs) (fsup syn sup)))"

lemma sups_presI [intro] :
  assumes "\<And> x sup syn Xs  .
           x \<in> Xs \<Longrightarrow>
           finite Xs \<Longrightarrow>
           is_sup Xs sup \<Longrightarrow>
          (\<exists> fsup . is_sup Fs fsup \<and> is_sup (scross ((\<lambda> f . f syn) ` Fs) Xs) (fsup syn sup))"
  shows "sups_pres Fs"
  using assms unfolding sups_pres_def by blast

lemma sups_presD :
  assumes "sups_pres Fs"
  assumes "x \<in> Xs"
  assumes "finite Xs"
  assumes "is_sup Xs sp"
  shows "(\<exists> fsup . is_sup Fs fsup \<and> is_sup (scross ((\<lambda> f . f syn) ` Fs) Xs) (fsup syn sp))" using assms
  unfolding sups_pres_def
  by blast

lemma scross_subset :
  assumes HF : "Fs1 \<subseteq> Fs2"
  assumes HX : "Xs1 \<subseteq> Xs2"
  shows "scross Fs1 Xs1 \<subseteq> scross Fs2 Xs2"
proof
  fix res
  assume Hres : "res \<in> scross Fs1 Xs1"

  obtain f x where
    F : "f \<in> Fs1" and
    X : "x \<in> Xs1" and
    Res : "res = f x" using scross_inD[OF Hres] by blast

  show "res \<in> scross Fs2 Xs2"
  proof(rule scross_inI)
    show "f \<in> Fs2"
      using F HF by blast
    show "x \<in> Xs2"
      using X HX by blast
    show "res = f x" using Res by auto
  qed
qed

definition scross_alt :: "('a \<Rightarrow> 'b) set \<Rightarrow> 'a set \<Rightarrow> 'b set" where
"scross_alt Fs Xs =
  (\<lambda> fx . (case fx of (f, x) \<Rightarrow> f x)) ` (Fs \<times> Xs)"

lemma scross_alt_eq :
  "scross_alt Fs Xs = scross Fs Xs"
  unfolding scross_def scross_alt_def
  by(auto)

lemma scross_finite :
  assumes HF : "finite Fs"
  assumes HX : "finite Xs"
  shows "finite (scross Fs Xs)"
  unfolding sym[OF scross_alt_eq] scross_alt_def
  using finite_cartesian_product[OF HF HX]
  by blast

lemma sups_pres_subset :
  fixes Fs :: "('a \<Rightarrow> ('b :: Mergeableb) \<Rightarrow> 'b) set"
  assumes H : "sups_pres Fs"
  assumes Hfin : "finite Fs"
  assumes Hsub : "Fs' \<subseteq> Fs"
  assumes Hnemp : "f \<in> Fs'"
  shows "sups_pres Fs'"
proof(rule sups_presI)
  fix el :: "'b"
  fix sup1 :: "'b"
  fix syn
  fix Xs :: "'b set"
  fix Fs_sub :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) set"

  assume Hfin_Xs : "finite Xs"
  assume H' : "is_sup Xs sup1"
  assume Hnemp_Xs : "el \<in> Xs"

  obtain Rest where Rest : "Fs' \<union> Rest = Fs" using Hsub by blast
  have Rfin : "finite Rest" using Rest Hfin by auto

  obtain supr where Supr1 :
    "is_sup Fs supr" and
    Supr2 :
    "is_sup (scross ((\<lambda>f. f syn) ` Fs) Xs) (supr syn sup1)"
    unfolding Rest
    using sups_presD[OF H Hnemp_Xs Hfin_Xs H']
    unfolding has_sup_def
    by(auto)

  have Subset' : "(\<lambda>f. f syn) ` Fs' \<subseteq> (\<lambda>f. f syn) ` Fs"
    unfolding sym[OF Rest] by blast

  have Subset : "(scross ((\<lambda>f. f syn) ` (Fs')) Xs)  \<subseteq> (scross ((\<lambda>f. f syn) ` (Fs' \<union> Rest)) Xs)"
    using scross_subset[OF Subset', of Xs Xs]
    unfolding Rest
    by blast

  have Subset2: "(\<lambda>f. f syn sup1) ` Fs' \<subseteq> (\<lambda>f. f syn sup1) ` (Fs' \<union> Rest)"
    by blast

  have Nemp : "(f syn el) \<in> scross ((\<lambda>f. f syn) ` Fs') Xs"
    using Hnemp Hnemp_Xs
    unfolding scross_def by auto

  have Nemp2 : "f syn sup1 \<in> (\<lambda>f. f syn sup1) ` Fs'"
    using Hnemp by auto

  have Hfin_full' : "finite ((\<lambda>f. f syn) ` (Fs))"
    using Hfin by blast

  have Fin_full : "finite (scross ((\<lambda>f. f syn) ` (Fs)) Xs)"
    using scross_finite[OF Hfin_full' Hfin_Xs]
    by auto

  have Fin_full2 : "finite ((\<lambda>f. f syn sup1) ` ((Fs' \<union> Rest)))"
    using Hfin
    sorry

  obtain fsup where Fsup : "is_sup Fs' fsup"
    using has_sup_subset[OF Hfin Supr1 Hsub Hnemp]
    unfolding has_sup_def by auto

  have "is_sup (scross ((\<lambda>f. f syn) ` Fs') Xs) (fsup syn sup1)"
  proof(rule is_sup_intro)
    fix xy
    assume Xy : "xy \<in> scross ((\<lambda>f. f syn) ` Fs') Xs"

    obtain fxy xxy
      where Fxy' : "fxy \<in> (\<lambda>f. f syn) ` Fs'" and Xxy' : "xxy \<in> Xs" and Xy_eq : "xy = fxy xxy"
      using scross_inD[OF Xy]
      by auto

    obtain fxy2 where Fxy2 : "fxy2 \<in> Fs'" and
      Fxy2_eq : "fxy = fxy2 syn"
      using Fxy'
      by(blast)

    show "xy <[ fsup syn sup1"
      using is_sup_unfold1[OF Fsup Fxy2]
      unfolding Xy_eq Fxy2_eq fun_pleq
      apply(step) apply(step)

(* same problem? we can derive a sup for Fs', but we don't actually know anything about what
happens to cross product when we remove some functions...

new sup <[ overall sup (obvious).

*)

  show "\<exists> fsup .
    is_sup Fs' fsup \<and> is_sup (scross ((\<lambda>f. f syn) ` Fs') Xs) (fsup syn sup1)"

  obtain sup2 where Sup2 : "is_sup (scross ((\<lambda>f. f syn) ` Fs') Xs) sup2"
    using has_sup_subset[OF _ Supr1 Subset ] Fin_full unfolding Rest has_sup_def
    by auto

  obtain sup2' where Sup2' : "is_sup ((\<lambda>f. f syn sup1) ` (Fs')) sup2'"
    using has_sup_subset[OF Fin_full2 Supr2 Subset2 Nemp2]  unfolding Rest has_sup_def
    by auto

  show "\<exists>sup'. is_sup ((\<lambda>f. f syn sup1) ` Fs') sup' \<and> is_sup (scross ((\<lambda>f. f syn) ` Fs') Xs) sup'"
    using has_sup_subset[OF _ Supr Subset Nemp] Fin_full unfolding Rest
    by auto

end


(***********************************************************************
* HiVe theory files
*
* Copyright (C) 2015 Commonwealth of Australia as represented by Defence Science and Technology
* Group (DST Group)
*
* All rights reserved.
*
* The HiVe theory files are free software: released for redistribution and use, and/or modification,
* under the BSD License, details of which can be found in the LICENSE file included in the
* distribution.
************************************************************************)

theory
  Order_Locale

imports
  Z_Rel
  Z_Fun

begin

text {*

In considering the theory of ordered sets, we are faced with a modelling
choice as to whether to use a graph or operator model of the order
relation. The most convenient from algebraic considerations would be
the graph model, but the @{text "order"} class already makes use of the
operator model. Since the primary purpose of developing the theory is
to support instance reasoning on the @{text "order"} class, we are
forced to adopt the operator model, leading occasionally to inelegant
type coercions.

Note: at some stage it might be worthwhile to re-implement relational
theory using operators.

Our development primarily follows Back and von Wright \cite{Back:Text},
with contributons from Davey and Priestley \cite{Davey:Lattice}.

*}

section {* Partially ordered sets *}

text {*

Let @{text X} be a non-empty set and @{text "r"} a relation on
@{text X}.

*}

locale carrier_sig =
  fixes
    X :: "'a set"

locale carrier = carrier_sig +
  assumes
    non_empty: "X \<noteq> \<emptyset>"

notation (zed)
  carrier ("\<^carrier>{:_:}")

lemma (in carrier) carrier:
  "\<^carrier>{:X:}"
  by (simp add: carrier_def non_empty)

lemmas carrier_def' = carrier_def
lemmas carrier_intros = carrier_def' [THEN meta_eq_to_obj_eq, THEN iffD2, simplified, rule_format]

type_synonym
  'a orderT = "['a, 'a] \<rightarrow> \<bool>"

text {*

We include the carrier set in setrel_sig so as to provide a context for
defining operators on relations
over carrier sets without bringing in the setrel conditions.
This approach allows the use of these operators in the various order contexts,
without explicit reference to the context parameters.

*}

locale setrel_sig =
  fixes
    X :: "'a set" and
    r :: "'a orderT"

begin

notation
  r (infixl "\<hookrightarrow>" 50)

end

locale setrel =
  carrier +
  setrel_sig +
assumes
  rel: "\<^oprel>{:(op \<hookrightarrow>):} \<in> X \<zrel> X"

begin

lemmas setrel_carrier = carrier

end

notation (zed)
  setrel ("\<^setrel>{:_:}{:_:}")

lemma (in setrel) setrel:
    "\<^setrel>{:X:}{:(op \<hookrightarrow>):}"
  by unfold_locales

lemmas setrel_def' = setrel_def [simplified setrel_axioms_def carrier_def' conj_ac']
lemmas setrel_intros = setrel_def' [THEN meta_eq_to_obj_eq, THEN iffD2, simplified, rule_format]

lemma (in setrel) relD1:
    "x \<hookrightarrow> y \<turnstile> x \<in> X"
  apply (rule rel_dom_mem [OF rel])
  apply (simp add: op2rel_def)
  done

lemma (in setrel) relD2:
    "x \<hookrightarrow> y \<turnstile> y \<in> X"
  apply (rule rel_ran_mem [OF rel])
  apply (simp add: op2rel_def)
  done

lemma (in setrel) eq_trans1 [trans]:
    "\<lbrakk> x = y; y \<hookrightarrow> z \<rbrakk> \<turnstile> x \<hookrightarrow> z"
  by (simp)

lemma (in setrel) eq_trans2 [trans]:
    "\<lbrakk> x \<hookrightarrow> y; y = z \<rbrakk> \<turnstile> x \<hookrightarrow> z"
  by (simp)

text {*

We define the notions of relexive, transitive, symmetric and antisymmetric
relations as follows.

*}

locale reflexive = setrel +
  assumes
    refl: "(\<forall> x | x \<in> X \<bullet> x \<hookrightarrow> x)"

begin

lemmas reflexive_setrel = setrel

end

notation (zed)
  reflexive ("\<^reflexive>{:_:}{:_:}")

lemma (in reflexive) reflexive:
  "\<^reflexive>{:X:}{:r:}"
  by (unfold_locales)

lemmas reflexive_def' = reflexive_def [simplified reflexive_axioms_def setrel_def' conj_ac']
lemmas reflexive_intros = reflexive_def' [THEN meta_eq_to_obj_eq, THEN iffD2, simplified, rule_format]

lemma (in reflexive) reflD:
  "x \<in> X \<turnstile> x \<hookrightarrow> x"
  apply (rule refl [rule_format])
  apply (auto)
  done

lemma (in reflexive) total_rel:
  "\<zdom> (\<^oprel>{:r:}) = X" and "\<zran> (\<^oprel>{:r:}) = X"
proof -
  from rel refl
  show "\<zdom> (\<^oprel>{:r:}) = X" and "\<zran> (\<^oprel>{:r:}) = X"
    by (auto simp add: rel_def Domain_def Range_def op2rel_def subset_def)
qed

locale transitive =
  setrel +

assumes
    trans: "\<forall> x y z | \<lch> x, y, z \<chIn> X \<rch> \<bullet> x \<hookrightarrow> y \<and> y \<hookrightarrow> z \<Rightarrow> x \<hookrightarrow> z"

begin

lemmas transitive_setrel = setrel

end

notation (zed)
  transitive ("\<^transitive>{:_:}{:_:}")

lemma (in transitive) transitive:
  "\<^transitive>{:X:}{:r:}"
  by (unfold_locales)

lemmas transitive_def' = transitive_def [simplified setrel_def' transitive_axioms_def conj_ac']
lemmas transitive_intros = transitive_def' [THEN meta_eq_to_obj_eq, THEN iffD2, simplified, rule_format]

lemma (in transitive) transD [trans]:
  "\<lbrakk> x \<hookrightarrow> y; y \<hookrightarrow> z \<rbrakk> \<turnstile> x \<hookrightarrow> z"
  apply (rule trans [rule_format])
  apply (auto simp add: relD1 relD2)
  done

locale symmetric = setrel +
  assumes
    sym: "\<forall> x y | \<lch> x, y \<chIn> X \<rch> \<bullet> x \<hookrightarrow> y \<Rightarrow> y \<hookrightarrow> x"

begin

lemmas symmetric_setrel = setrel

end

notation (zed)
  symmetric ("\<^symmetric>{:_:}{:_:}")

lemma (in symmetric) symmetric:
  "\<^symmetric>{:X:}{:r:}"
  by (unfold_locales)

lemmas symmetric_def' = symmetric_def [simplified setrel_def' symmetric_axioms_def conj_ac']
lemmas symmetric_intros = symmetric_def' [THEN meta_eq_to_obj_eq, THEN iffD2, simplified, rule_format]

lemma (in symmetric) symD:
  "x \<hookrightarrow> y \<turnstile> y \<hookrightarrow> x"
  apply (rule sym [rule_format])
  apply (auto simp add: relD1 relD2)
  done

locale antisymmetric =
  setrel +

assumes
  antisym: "\<forall> x y | \<lch> x, y \<chIn> X \<rch> \<bullet> x \<hookrightarrow> y \<and> y \<hookrightarrow> x \<Rightarrow> x = y"

begin

lemmas antisymmetric_setrel = setrel

end

notation (zed)
  antisymmetric ("\<^antisymmetric>{:_:}{:_:}")

lemma (in antisymmetric) antisymmetric:
  "\<^antisymmetric>{:X:}{:r:}"
  by (unfold_locales)

lemmas antisymmetric_def' = antisymmetric_def [simplified setrel_def' antisymmetric_axioms_def conj_ac']
lemmas antisymmetric_intros = antisymmetric_def' [THEN meta_eq_to_obj_eq, THEN iffD2, simplified, rule_format]

lemma (in antisymmetric) antisymD [trans]:
  "\<lbrakk> x \<hookrightarrow> y;  y \<hookrightarrow> x \<rbrakk> \<turnstile> x = y"
  apply (rule antisym [rule_format])
  apply (auto simp add: relD1 relD2)
  done

text {*

A relation is a preorder if it is reflexive and transitive.

*}

locale preorder =
  reflexive +
  transitive

begin

lemmas preorder_reflexive = reflexive

lemmas preorder_transitive = transitive

end

notation (zed)
  preorder ("\<^preorder>{:_:}{:_:}")

lemma (in preorder) preorder:
  "\<^preorder>{:X:}{:r:}"
  by (simp add: preorder_def reflexive_axioms transitive_axioms setrel_axioms carrier)

lemmas preorder_def' = preorder_def [simplified reflexive_def' transitive_def' conj_ac']
lemmas preorder_intros = preorder_def' [THEN meta_eq_to_obj_eq, THEN iffD2, simplified, rule_format]

text {*

A preorder is an equivalence if it is also symmetric.

*}

locale equivalence =
    preorder X BS_sim +
    symmetric X BS_sim

for
  X::"'a set" and
  BS_sim::"'a orderT"

begin

notation
  BS_sim (infixl "\<sim>" 50)

lemmas equivalence_preorder = preorder

lemmas equivalence_symmetric = symmetric

lemmas equivalence_reflexive = reflexive

lemmas equivalence_transitive = transitive

lemmas equivalence_setrel = setrel

end

notation (zed)
  equivalence ("\<^equivalence>{:_:}{:_:}")

lemma (in equivalence) equivalence:
  "\<^equivalence>{:X:}{:(op \<sim>):}"
  by (unfold_locales)

lemmas equivalence_def' = equivalence_def [simplified preorder_def' symmetric_def' conj_ac']
lemmas equivalence_intros = equivalence_def' [THEN meta_eq_to_obj_eq, THEN iffD2, simplified, rule_format]

lemma equivalence_conv:
  "\<^equivalence>{:X:}{:BS_sim:} \<Leftrightarrow>  \<^reflexive>{:X:}{:BS_sim:} \<and> \<^transitive>{:X:}{:BS_sim:} \<and> \<^symmetric>{:X:}{:BS_sim:}"
  by (simp add: equivalence_def preorder_def)

text {*

A preorder is a partial order if it is also anti-symmetric.

*}

locale partial_order =
  preorder +
  antisymmetric

begin

notation
  r (infixl "\<preceq>" 50)

lemmas partial_order_preorder = preorder

lemmas partial_order_antisymmetric = antisymmetric

lemmas partial_order_reflexive = reflexive

lemmas partial_order_transitive = transitive

lemmas partial_order_setrel = setrel

end

notation (zed)
  partial_order ("\<^poset>{:_:}{:_:}")

lemma (in partial_order) partial_order:
  "\<^poset>{:X:}{:(op \<preceq>):}"
  by (unfold_locales)

lemmas partial_order_def' =
  partial_order_def [simplified preorder_def' antisymmetric_def' conj_ac']
lemmas partial_order_intros =
  partial_order_def' [THEN meta_eq_to_obj_eq, THEN iffD2, simplified, rule_format]

lemma partial_order_conv:
  "\<^poset>{:X:}{:BS_leq:} \<Leftrightarrow> \<^reflexive>{:X:}{:BS_leq:} \<and> \<^transitive>{:X:}{:BS_leq:} \<and> \<^antisymmetric>{:X:}{:BS_leq:}"
  by (auto simp add: partial_order_def preorder_def)

text {*

If every pair of elements are related, the relation is a linear order,
or simply order.

*}

locale linear =
  setrel +

assumes
  lin: "\<forall> x y | \<lch> x, y \<chIn> X \<rch> \<bullet> x \<hookrightarrow> y \<or> y \<hookrightarrow> x"

begin

lemmas linear_setrel = setrel

end

notation (zed)
  linear ("\<^linear>{:_:}{:_:}")

lemma (in linear) linear:
  "\<^linear>{:X:}{:(op \<hookrightarrow>):}"
  by (unfold_locales)

lemmas linear_def' = linear_def [simplified linear_axioms_def setrel_def' conj_ac']
lemmas linear_intros = linear_def' [THEN meta_eq_to_obj_eq, THEN iffD2, simplified, rule_format]

lemma (in linear) linD:
  "\<lbrakk> x \<in> X; y \<in> X \<rbrakk> \<turnstile> x \<hookrightarrow> y \<or> y \<hookrightarrow> x"
  apply (rule lin [rule_format])
  apply (auto simp add: relD1)
  done

locale order =
  partial_order +
  linear

begin

lemmas order_partial_order = partial_order

lemmas order_linear = linear

lemmas order_antisymmetric = antisymmetric

lemmas order_reflexive = reflexive

lemmas order_transitive = transitive

lemmas order_setrel = setrel

end

notation (zed)
  order ("\<^order>{:_:}{:_:}")

lemma (in order) order:
  "\<^order>{:X:}{:op \<preceq>:}"
  by (unfold_locales)

lemmas order_def' =
  order_def [simplified partial_order_def' linear_def' conj_ac']
lemmas order_intros =
  order_def' [THEN meta_eq_to_obj_eq, THEN iffD2, simplified, rule_format]

lemma order_conv:
  "\<^order>{:X:}{:BS_leq:} \<Leftrightarrow> \<^reflexive>{:X:}{:BS_leq:} \<and> \<^transitive>{:X:}{:BS_leq:} \<and> \<^antisymmetric>{:X:}{:BS_leq:} \<and> \<^linear>{:X:}{:BS_leq:}"
  by (auto simp add: order_def partial_order_def preorder_def)

lemma order_conva:
  "\<^order>{:X:}{:BS_leq:} \<Leftrightarrow> \<^poset>{:X:}{:BS_leq:} \<and> (\<forall> x y | \<lch> x, y \<chIn> X \<rch> \<bullet> \<^infop>{:x:}{:BS_leq:}{:y:} \<or> \<^infop>{:y:}{:BS_leq:}{:x:})"
  by (auto simp add: order_def partial_order_def preorder_def linear_def' reflexive_def')

lemmas partial_orderI = partial_order_intros

lemmas orderI = order_intros

lemma (in partial_order) orderIa:
  "(\<And> x y \<bullet> \<lbrakk> x \<in> X; y \<in> X \<rbrakk> \<turnstile> x \<preceq> y \<or> y \<preceq> x) \<turnstile> \<^order>{:X:}{:op \<preceq>:}"
  apply (unfold_locales)
  apply (auto)
  done

section {* The converse order *}

text {*

The converse order is generated by the converse of the order relation.

*}

definition
  converse_rel :: "('a orderT) \<rightarrow> ('a orderT)"
where
  converse_rel_def: "converse_rel \<defs> (\<olambda> r x y \<bullet> \<^infopa>{:y:}{:r:}{:x:})"

notation (zed)
  converse_rel ("\<^convord>{:_:}")

context setrel_sig

begin

abbreviation
  converse_rel :: "'a orderT" (infixl "\<hookleftarrow>" 50)
where
  "(op \<hookleftarrow>) \<defs> \<^convord>{:(op \<hookrightarrow>):}"

end

context partial_order

begin

notation
  converse_rel (infixl "\<succeq>" 50)

lemma converse_poI:
    "\<^poset>{:X:}{:(op \<succeq>):}"
  apply (simp add: converse_rel_def)
  apply (rule partial_orderI)
  apply (rule non_empty)
  apply (insert rel)
  apply (simp add: op2rel_def rel_def subset_def)
  apply (rule reflD)
  apply (assumption)
  apply (rule antisymD)
  apply (assumption+)
  apply (rule transD)
  apply (assumption+)
  done

end

lemma (in order) converse_orderI:
  "\<^order>{:X:}{:op \<succeq>:}"
  apply (simp add: order_conva)
  apply (mauto(inference) mintro: converse_poI)
  apply (simp add: linear_def linear_axioms_def converse_rel_def)
  apply (rule linD)
  apply (assumption+)
  done

section {* On the relation between classes and locales *}

text {*

We demonstrate the useful connection between posets and the
@{text order} axclass, namely that you can demonstrate that a type
is an order, by showing that its universal set is a poset under the
standard order.

*}

definition
  derefl :: "('a orderT) \<rightarrow> ('a orderT)"
where
  derefl_def [simp]: "derefl \<defs> (\<olambda> r x y \<bullet> \<^infopa>{:x:}{:r:}{:y:} \<and> x \<noteq> y)"

notation (zed)
  derefl ("\<derefl>")

theorem order_classI:
  "\<lbrakk> \<^poset>{:\<univ>-[('a::ord)]:}{:(op \<le>):};
    ((op <)::('a::ord) orderT) = \<derefl> (op \<le>) \<rbrakk>
  \<turnstile> OFCLASS('a, order_class)"
proof -
  assume po: "\<^poset>{:\<univ>-['a]:}{:(op \<le>):}" and
    lt: "((op <)::'a orderT) = \<derefl> (op \<le>)"
  show "OFCLASS('a, order_class)"
  proof (intro_classes)
    fix x::'a
    from po show "x \<le> x"
      apply (intro reflexive.reflD [of "\<univ>-['a]" "(op \<le>)" x])
      apply (auto simp add: partial_order_conv)
      done
  next
    fix x::'a and y::'a and z::'a
    assume a1: "x \<le> y" and a2: "y \<le> z"
    from po show "x \<le> z"
       apply (intro transitive.transD [of "\<univ>-['a]" "(op \<le>)", OF _ a1 a2])
       apply (simp add: partial_order_conv)
       done
  next
    fix x::'a and y::'a
    assume a1: "x \<le> y" and a2: "y \<le> x"
    from po show "x = y"
      apply (intro antisymmetric.antisymD [of "\<univ>-['a]" "(op \<le>)", OF _ a1 a2])
      apply (simp add: partial_order_conv)
      done
  next
    fix x::'a and y::'a
    from po show "x < y \<Leftrightarrow> x \<le> y \<and> \<not> (y \<le> x)"
      apply (simp add: lt derefl_def)
      apply (msafe(inference))
      apply (rule contrapos_nn, assumption)
      apply (intro antisymmetric.antisymD [of "\<univ>-['a]" "(op \<le>)"])
      apply (simp_all add: partial_order_conv)
      apply (rule contrapos_nn, assumption,simp)
    done
  qed
qed

lemma order_classD: "\<^poset>{:\<univ>-[('a::order)]:}{:(op \<le>):}"
  apply (rule partial_orderI)
  apply (auto intro: order_antisym order_trans simp add: op2rel_def rel_def)
  done

interpretation order_class: partial_order "\<univ>-[('a::order)]" "(op \<le>)"
  by (rule order_classD)

theorem linorder_classI:
  "\<lbrakk> \<^order>{:\<univ>-[('a::ord)]:}{:(op \<le>):};
    ((op <)::('a::ord) orderT) = \<derefl> (op \<le>) \<rbrakk>
  \<turnstile> OFCLASS('a, linorder_class)"
proof -
  assume
    ord: "\<^order>{:\<univ>-['a]:}{:(op \<le>):}" and
    lt: "((op <)::'a orderT) = \<derefl> (op \<le>)"
  show "OFCLASS('a, linorder_class)"
  proof (intro_classes)
    fix x::'a
    from ord show "x \<le> x"
      apply (intro reflexive.reflD [of "\<univ>-['a]" "(op \<le>)" x])
      apply (auto simp add: order_conv)
      done
  next
    fix x::'a and y::'a and z::'a
    assume a1: "x \<le> y" and a2: "y \<le> z"
    from ord show "x \<le> z"
       apply (intro transitive.transD [of "\<univ>-['a]" "(op \<le>)", OF _ a1 a2])
       apply (simp add: order_conv)
       done
  next
    fix x::'a and y::'a
    assume a1: "x \<le> y" and a2: "y \<le> x"
    from ord show "x = y"
      apply (intro antisymmetric.antisymD [of "\<univ>-['a]" "(op \<le>)", OF _ a1 a2])
      apply (simp add: order_conv)
      done
  next
    fix x::'a and y::'a
    from ord show "x \<le> y \<or> y \<le> x"
      apply (intro linear.linD [of "\<univ>-['a]" "(op \<le>)"])
      apply (auto simp add: order_conv)
      done
  next
    fix x::'a and y::'a
    from ord show "x < y \<Leftrightarrow> x \<le> y \<and> \<not> (y \<le> x)"
      apply (simp add: lt derefl_def)
      apply (msafe(inference))
      apply (rule contrapos_nn, assumption)
      apply (intro antisymmetric.antisymD [of "\<univ>-['a]" "(op \<le>)"])
      apply (simp_all add: order_conv)
      apply (rule contrapos_nn, assumption,simp)
    done
  qed
qed

lemma linorder_classI2:
  "\<^linear>{:\<univ>-[('a::order)]:}{:(op \<le>):}
  \<turnstile> OFCLASS('a::order, linorder_class)"
proof -
  assume lin: "\<^linear>{:\<univ>-['a]:}{:(op \<le>):}"
  show "OFCLASS('a, linorder_class)"
  proof (intro_classes)
    fix x::'a and y::'a
    from lin linear.linD [of "\<univ>-['a]" "(op \<le>)"]
    show "x \<le> y \<or> y \<le> x"
      by (auto)
  qed
qed

lemma linorder_classD: "\<^order>{:\<univ>-[('a::linorder)]:}{:(op \<le>):}"
  apply (rule partial_order.orderIa)
  apply (rule order_classD)
  apply (rule linorder_linear)
  done

interpretation linorder_class: order "\<univ>-[('a::linorder)]" "(op \<le>)"
  by (rule linorder_classD)

text {*

Of course, we are now left with the question of what has been gained
by converting the problem to the poset formalism. The answer to this
is that in the poset formalism we are better able to treat algebraic
concepts such as sub-orders, quotient orders, and order-morphisms and
that such notions are often critical to efficient demonstration of
poset instances.

*}

section {* Two orders *}

text {*

There are a number of occasions in which it is necessary to consider two orders
at once. To facilitate this we develop distinguished copies of the order hierachy.

*}

locale X_carrier =
  X: carrier X
for
  X::"'a set"

locale Y_carrier =
  Y: carrier Y
for
  Y::"'a set"

locale X_setrel =
  X: setrel X r
for
  X::"'a set" and
  r::"'a orderT"

begin

notation
  r (infixl "\<hookrightarrow>\<^sub>X" 50) and
  converse_rel (infixl "\<hookleftarrow>\<^sub>X" 50)

end

sublocale X_setrel \<subseteq> X_carrier
  by (unfold_locales)

locale Y_setrel =
  Y: setrel Y s
for
  Y::"'a set" and
  s::"'a orderT"

begin

notation
  s (infixl "\<hookrightarrow>\<^sub>Y" 50) and
  converse_rel (infixl "\<hookleftarrow>\<^sub>Y" 50)

end

sublocale Y_setrel \<subseteq> Y_carrier
  by (unfold_locales)

locale X_partial_order =
  X: partial_order X r
for
  X::"'a set" and
  r::"'a orderT"

begin

notation
  r (infixl "\<preceq>\<^sub>X" 50)

end

sublocale X_partial_order \<subseteq> X_setrel
  by (unfold_locales)

locale Y_partial_order =
  Y: partial_order Y s
for
  Y::"'a set" and
  s::"'a orderT"

begin

notation
  s (infixl "\<preceq>\<^sub>Y" 50)

end

sublocale Y_partial_order \<subseteq> Y_setrel
  by (unfold_locales)

locale X_order =
  X: order X r
for
  X::"'a set" and
  r::"'a orderT"

sublocale X_order \<subseteq> X_partial_order
  by (unfold_locales)

locale Y_order =
  Y: order Y s
for
  Y::"'a set" and
  s::"'a orderT"

sublocale Y_order \<subseteq> Y_partial_order
  by (unfold_locales)

section {* Sub-orders *}

text {*

We begin by considering the concept of sub-order. A sub-order is
just an order relation restricted to a sub-space. A sub-order
is also an order.

*}

definition
  subset_order :: "['a orderT, 'a set] \<rightarrow> 'a orderT"
where
  subset_order_def: "subset_order \<defs> (\<olambda> r Y \<bullet> \<^relop>{:(\<^oprel>{:r:} \<inter> (Y \<times> Y)):})"

notation (xsymbols output)
  subset_order ("_|\<^bsub>_\<^esub>")

notation (zed)
  subset_order ("\<^subord>{:_:}{:_:}")

lemma subset_order_conv:
  "\<^infopa>{:x:}{:\<^subord>{:BS_leq:}{:Y:}:}{:y:} \<Leftrightarrow> x \<in> Y \<and> y \<in> Y \<and> \<^infopa>{:x:}{:BS_leq:}{:y:}"
  by (auto simp add: subset_order_def op2rel_def rel2op_def)

locale sub_setrel =
  X_setrel +
  Y_carrier +
assumes
  subset_Y: "Y \<subseteq> X"

begin

abbreviation
  Y_subset_order :: "'a orderT" (infixl "\<hookrightarrow>\<^sub>Y"50)
where
  "Y_subset_order \<defs> subset_order (op \<hookrightarrow>) Y"

end

sublocale sub_setrel \<subseteq> Y_setrel Y Y_subset_order
proof (unfold_locales)
  show
      "\<^oprel>{:Y_subset_order:} \<in> Y \<zrel> Y"
    by (auto simp add: rel_def subset_order_def op2rel_def rel2op_def)
qed

context sub_setrel

begin

lemmas X_setrel = X.setrel

lemmas Y_setrel = Y.setrel

end

text {*

Here we show that all of the order attributes are preserved by sub-orders.
There is the option of introducing subset relation variants for each of the
order attribute locales or of simply assuming the attribute in a
@{text "sub_setrel"} theorem. The balance seems with the latter option, unless
the subset locale is likely to get significant use. Thus we develop subset locales
only for @{text "partial_order"} and @{text "order"}.

*}

lemma (in sub_setrel) sub_reflI:
  assumes
    a1: "\<^reflexive>{:X:}{:(op \<hookrightarrow>):}"
  shows
      "\<^reflexive>{:Y:}{:(op \<hookrightarrow>\<^sub>Y):}"
  apply (rule reflexive.intro)
  apply (rule Y_setrel)
  apply (auto simp add: reflexive_axioms_def)
proof -
  fix x
  assume
    "x \<in> Y"
  with reflexive.reflD [OF a1] subset_Y show
      "x \<hookrightarrow>\<^sub>Y x"
    by (auto simp add: subset_order_def op2rel_def rel2op_def)
qed

lemma (in sub_setrel) sub_transI:
  assumes
    a1: "\<^transitive>{:X:}{:(op \<hookrightarrow>):}"
  shows
      "\<^transitive>{:Y:}{:(op \<hookrightarrow>\<^sub>Y):}"
  apply (rule transitive.intro)
  apply (rule Y_setrel)
  apply (auto intro: transitive.transD [OF a1] simp add: transitive_axioms_def subset_order_def op2rel_def rel2op_def)
  done

lemma (in sub_setrel) sub_antisymI:
  assumes
    a1: "\<^antisymmetric>{:X:}{:(op \<hookrightarrow>):}"
  shows
    "\<^antisymmetric>{:Y:}{:(op \<hookrightarrow>\<^sub>Y):}"
  apply (rule antisymmetric.intro)
  apply (rule Y_setrel)
  apply (auto intro: antisymmetric.antisymD [OF a1] simp add: antisymmetric_axioms_def subset_order_def op2rel_def rel2op_def)
  done

lemma (in sub_setrel) sub_linI:
  assumes
    a1: "\<^linear>{:X:}{:(op \<hookrightarrow>):}"
  shows
      "\<^linear>{:Y:}{:(op \<hookrightarrow>\<^sub>Y):}"
  apply (rule linear.intro)
  apply (rule Y_setrel)
  apply (simp add: linear_axioms_def subset_order_def op2rel_def rel2op_def)
  apply (msafe(inference))
  apply (rule linear.linD [OF a1])
  apply (auto intro: subset_Y [THEN subsetD])
  done

lemma (in sub_setrel) sub_preorderI:
  assumes
    a1: "\<^preorder>{:X:}{:(op \<hookrightarrow>):}"
  shows
      "\<^preorder>{:Y:}{:(op \<hookrightarrow>\<^sub>Y):}"
  using a1
  by (auto intro!: sub_reflI sub_transI simp add: preorder_def)

locale sub_partial_order =
  X_partial_order +
  sub_setrel

sublocale sub_partial_order \<subseteq> Y_partial_order Y Y_subset_order
  using
    sub_transI [OF X.transitive]
    sub_reflI [OF X.reflexive]
    sub_antisymI [OF X.antisymmetric]
  by (auto intro: Y_partial_order.intro partial_order.intro preorder.intro)

context sub_partial_order

begin

notation
  Y_subset_order (infixl "\<preceq>\<^sub>Y" 50)

lemmas X_reflI = X.reflexive

lemmas Y_reflI = Y.reflexive

lemmas X_transI = X.transitive

lemmas Y_transI = Y.transitive

lemmas X_antisymI = X.antisymmetric

lemmas Y_antisymI = Y.antisymmetric

lemmas X_poI = X.partial_order

lemmas Y_poI = Y.partial_order

end (* sub_partial_order *)

locale sub_order =
  X_order +
  sub_partial_order

sublocale sub_order \<subseteq> Y_order Y Y_subset_order
  apply (unfold_locales)
  using
    linear.linD [OF sub_linI [OF X.linear]]
  apply (auto)
  done

context sub_order

begin

lemmas X_linI = X.linear

lemmas Y_linI = Y.linear

lemmas X_poI = X.partial_order

lemmas Y_poI = Y.partial_order

lemmas X_orderI = X.order

lemmas Y_orderI = Y.order

end (* sub_order *)

text {*

The sub-order construction can be used to determine a default ordering on
any subset of an ordered type.

*}

definition
  default_order :: "('a::ord) set \<rightarrow> 'a orderT"
where
  default_order_def: "default_order Y \<defs> \<^subord>{:(op \<le>):}{:Y:}"

lemma default_order_conv:
    "default_order Y x y \<Leftrightarrow> x \<in> Y \<and> y \<in> Y \<and> x \<le> y"
  by (auto simp add: default_order_def subset_order_conv)

lemma default_po:
  fixes
    Y::"('a::order) set"
  assumes
    a1: "Y \<noteq> \<emptyset>"
  shows
    "\<^poset>{:Y:}{:(default_order Y):}"
proof -
  interpret
    b1: sub_partial_order "\<univ>" "(op \<le>)" "Y"
    apply (unfold_locales)
    apply (auto simp add: a1)
    done
  from b1.Y_poI show
      ?thesis
    by (auto simp add: default_order_def)
qed

locale po_carrier =
  carrier X
for
  X::"('a::order) set"

sublocale po_carrier \<subseteq> carrier
  by (unfold_locales)

sublocale po_carrier \<subseteq> partial_order X "(default_order X)"
  apply (rule default_po)
  apply (rule non_empty)
  done

text {*

The default order on any subset of a linearly ordered type is
a linear order.

*}

lemma default_order:
  fixes
    Y::"('a::linorder) set"
  assumes
    a1: "Y \<noteq> \<emptyset>"
  shows
    "\<^order>{:Y:}{:(default_order Y):}"
proof -
  interpret
    b1: sub_order "\<univ>" "(op \<le>)" "Y"
    apply (unfold_locales)
    apply (auto simp add: a1)
    done
  from b1.Y_orderI show
      ?thesis
    by (auto simp add: default_order_def)
qed

locale order_carrier =
  carrier X
for
  X::"('a::linorder) set"

sublocale order_carrier \<subseteq> carrier
  by (unfold_locales)

sublocale order_carrier \<subseteq> order X "(default_order X)"
  apply (rule default_order)
  apply (rule non_empty)
  done

section {* Chains *}

text {*

The term chain is synonym for ordered set, but the term tends to be used
when applying the properties of ordered sets in other areas of mathematics,
rather than when investigating ordered sets. As such we feel entitled to
co-opt the term to name a collection of objects that are well-ordered
under the type-ordering.

*}

definition
  chain :: "('a::order) set \<rightarrow> \<bool> "
where
  chain_def: "chain X \<defs> order X (default_order X)"

lemma chain_conv:
    "chain X \<Leftrightarrow> X \<noteq> \<emptyset> \<and> (\<forall> x y | x \<in> X \<and> y \<in> X \<bullet> x \<le> y \<or> y \<le> x)"
proof -
  have
      "chain X
      \<Leftrightarrow> \<^poset>{:X:}{:(default_order X):} \<and> (\<forall> x y | x \<in> X \<and> y \<in> X \<bullet> x \<le> y \<or> y \<le> x)"
    by (auto simp add: chain_def order_conv partial_order_conv
      linear_def linear_axioms_def subset_order_def default_order_def
      reflexive_def op2rel_def rel2op_def)
  also have "\<dots>
      \<Leftrightarrow> X \<noteq> \<emptyset> \<and> (\<forall> x y | x \<in> X \<and> y \<in> X \<bullet> x \<le> y \<or> y \<le> x)"
  proof (mauto(wind))
    show
        "\<^poset>{:X:}{:(default_order X):} \<Leftrightarrow> X \<noteq> \<emptyset>"
      apply (msafe(inference))
      apply (rule carrier.non_empty [of X])
      apply (simp add: partial_order_conv reflexive_def' carrier_def')
      apply (simp add: default_po)
      done
  qed
  finally show
      ?thesis
    by this
qed

lemma chainI:
    "\<lbrakk> X \<noteq> \<emptyset>; (\<And> x y \<bullet> \<lbrakk> x \<in> X; y \<in> X \<rbrakk> \<turnstile> x \<le> y \<or> y \<le> x) \<rbrakk>
    \<turnstile> chain X "
  by (auto simp add: chain_conv)

lemma chainE:
    "\<lbrakk> chain X; x \<in> X; y \<in> X; x \<le> y \<turnstile> R; y \<le> x \<turnstile> R \<rbrakk> \<turnstile> R"
  by (auto simp add: chain_conv)

section {* Bounds *}

text {*

Suppose that @{text "X\<^bsub>BS_leq\<^esub>)"} is a poset and that @{text "Y \<subseteq> X"}.

A lower (upper) bound for @{text Y} is an lower (upper) bound for every
element of @{text Y}.

*}

definition
  is_lb  :: "['a set, 'a orderT, 'a set, 'a] \<rightarrow> \<bool>"
where
  is_lb_def: "is_lb \<defs> (\<olambda> X r Y a \<bullet> a \<in> X \<and> (\<forall> x | x \<in> Y \<bullet> \<^infopa>{:a:}{:r:}{:x:}))"

definition
  is_ub  :: "['a set, 'a orderT, 'a set, 'a] \<rightarrow> \<bool>"
where
  is_ub_def: "is_ub \<defs> (\<olambda> X r Y a \<bullet> a \<in> X \<and> (\<forall> x | x \<in> Y \<bullet> \<^infopa>{:x:}{:r:}{:a:}))"

notation (zed)
  is_lb ("\<^lbp>{:_:}{:_:}") and
  is_ub ("\<^ubp>{:_:}{:_:}")

text {*

A lower (upper) bound of @{text Y} that is in @{text Y} is called the
least (greatest) element of @{text Y}.

*}

definition
  is_least :: "['a set, 'a orderT, 'a set, 'a] \<rightarrow> \<bool>"
where
  is_least_def: "is_least \<defs> (\<olambda> X r Y a \<bullet> a \<in> X \<inter> Y \<and> (\<forall> x | x \<in> Y \<bullet> \<^infopa>{:a:}{:r:}{:x:}))"

definition
  is_greatest :: "['a set, 'a orderT, 'a set, 'a] \<rightarrow> \<bool>"
where
  is_greatest_def: "is_greatest \<defs> (\<olambda> X r Y a \<bullet> a \<in> X \<inter> Y \<and> (\<forall> x | x \<in> Y \<bullet> \<^infopa>{:x:}{:r:}{:a:}))"

notation (zed)
  is_least ("\<^lp>{:_:}{:_:}") and
  is_greatest ("\<^gp>{:_:}{:_:}")

text {*

The greatest (least) lower (upper) bound for @{text Y} is the greatest
(least) of the lower (upper) bounds of @{text Y}.

*}

definition
  is_glb :: "['a set, 'a orderT, 'a set, 'a] \<rightarrow> \<bool>"
where
  is_glb_def: "is_glb \<defs> (\<olambda> X r Y a \<bullet> is_greatest X r {b | is_lb X r Y b} a)"

definition
  is_lub :: "['a set, 'a orderT, 'a set, 'a] \<rightarrow> \<bool>"
where
  is_lub_def: "is_lub \<defs> (\<olambda> X r Y a \<bullet> is_least X r {b | is_ub X r Y b} a)"

notation (zed)
  is_glb ("\<^glbp>{:_:}{:_:}") and
  is_lub ("\<^lubp>{:_:}{:_:}")

text {*

Bounds and extremals only exist for subsets of the poset.

*}

context setrel_sig

begin

abbreviation
  is_lb :: "['a set, 'a] \<rightarrow> \<bool>"
where
  "is_lb \<defs> \<^lbp>{:X:}{:(op \<hookrightarrow>):}"

abbreviation
  is_ub :: "['a set, 'a] \<rightarrow> \<bool>"
where
  "is_ub \<defs> \<^ubp>{:X:}{:(op \<hookrightarrow>):}"

abbreviation
  is_least :: "['a set, 'a] \<rightarrow> \<bool>"
where
  "is_least \<defs> \<^lp>{:X:}{:(op \<hookrightarrow>):}"

abbreviation
  is_greatest :: "['a set, 'a] \<rightarrow> \<bool>"
where
  "is_greatest \<defs> \<^gp>{:X:}{:(op \<hookrightarrow>):}"

abbreviation
  is_glb :: "['a set, 'a] \<rightarrow> \<bool>"
where
  "is_glb \<defs> \<^glbp>{:X:}{:(op \<hookrightarrow>):}"

abbreviation
  is_lub :: "['a set, 'a] \<rightarrow> \<bool>"
where
  "is_lub \<defs> \<^lubp>{:X:}{:(op \<hookrightarrow>):}"

end

context X_setrel

begin

notation
  X.is_glb ("is'_glb\<^sub>X") and
  X.is_lub ("is'_lub\<^sub>X")

end

context Y_setrel

begin

notation
  Y.is_glb ("is'_glb\<^sub>Y") and
  Y.is_lub ("is'_lub\<^sub>Y")

end

context setrel

begin

lemma lb_sub:
    "is_lb Y a \<turnstile> Y \<subseteq> X"
  by (auto intro: relD2 simp add: is_lb_def)

lemma ub_sub:
    "is_ub Y a \<turnstile> Y \<subseteq> X"
  by (auto intro: relD1 simp add: is_ub_def)

lemma least_sub:
    "is_least Y a \<turnstile> Y \<subseteq> X"
  by (auto intro: relD2 simp add: is_least_def)

lemma greatest_sub:
    "is_greatest Y a \<turnstile> Y \<subseteq> X"
  by (auto intro: relD1 simp add: is_greatest_def)

lemma glb_sub:
    "is_glb Y a \<turnstile> Y \<subseteq> X"
  by (auto intro: relD2 simp add: is_glb_def is_greatest_def is_lb_def)

lemma lub_sub:
    "is_lub Y a \<turnstile> Y \<subseteq> X"
  by (auto intro: relD1 simp add: is_lub_def is_least_def is_ub_def)

end

text {*

A bound or extremal must by in the poset.

*}

context setrel_sig

begin

lemma lb_elt:
    "is_lb Y a \<turnstile> a \<in> X"
  by (auto simp add: is_lb_def)

lemma ub_elt:
    "is_ub Y a \<turnstile> a \<in> X"
  by (auto simp add: is_ub_def)

end

context setrel

begin

lemma least_elt:
    "is_least Y a \<turnstile> a \<in> X"
  by (auto intro: relD1 simp add: is_least_def)

lemma greatest_elt:
    "is_greatest Y a \<turnstile> a \<in> X"
  by (auto intro: relD1 simp add: is_greatest_def)

lemma glb_elt:
    "is_glb Y a \<turnstile> a \<in> X"
  by (auto intro: relD1 simp add: is_glb_def is_greatest_def is_lb_def)

lemma lub_elt:
    "is_lub Y a \<turnstile> a \<in> X"
  by (auto intro: relD1 simp add: is_lub_def is_least_def is_ub_def)

end

text {*

If a least (greatest) element exists then it is unique.

*}

context partial_order

begin

lemma least_unique:
  assumes
    a1: "is_least Y a" and
    a2: "is_least Y x"
  shows
    "x = a"
proof -
  from a1 have
    b1: "a \<in> Y"
    by (simp add: is_least_def)
  from a2 have
    b2: "x \<in> Y"
    by (simp add: is_least_def)
  from a1 b2 have
    b3: "a \<preceq> x"
    by (simp add: is_least_def)
  also from a2 b1 have
    b4: "x \<preceq> a"
    by (simp add: is_least_def)
  finally show
      "x = a"
    by (auto)
qed

lemma greatest_unique:
  assumes
    a1: "is_greatest Y a" and
    a2: "is_greatest Y x"
  shows
    "x = a"
proof -
  from a1 have
    b1: "a \<in> Y"
    by (simp add: is_greatest_def)
  from a2 have
    b2: "x \<in> Y"
    by (simp add: is_greatest_def)
  from a1 b2 have
      "x \<preceq> a"
    by (simp add: is_greatest_def)
  also from a2 b1 have
      "a \<preceq> x"
    by (simp add: is_greatest_def)
  finally show
      "x = a"
    by (auto)
qed

lemma lub_unique:
  assumes
    a1: "is_lub Y a" and
    a2: "is_lub Y x"
  shows
    "x = a"
  apply (rule least_unique)
  using a1 a2
  apply (auto simp add: is_lub_def)
  done

lemma glb_unique:
  assumes
    a1: "is_glb Y a" and
    a2: "is_glb Y x"
  shows
    "x = a"
  apply (rule greatest_unique)
  using a1 a2
  apply (auto simp add: is_glb_def)
  done

end

text {*

Finally we develop introduction and elimination rules for bounds.

*}

context setrel_sig

begin

lemma is_ubI:
    "\<lbrakk> a \<in> X; (\<And> x \<bullet> x \<in> A \<turnstile> x \<hookrightarrow> a) \<rbrakk> \<turnstile> is_ub A a"
  by (auto simp add: is_ub_def)

lemma is_lbI:
    "\<lbrakk> a \<in> X; (\<And> x \<bullet> x \<in> A \<turnstile> a \<hookrightarrow> x) \<rbrakk> \<turnstile> is_lb A a"
  by (auto simp add: is_lb_def)

end

context setrel

begin

lemma is_leastI:
    "\<lbrakk> a \<in> A; (\<And> x \<bullet> x \<in> A \<turnstile> a \<hookrightarrow> x) \<rbrakk> \<turnstile> is_least A a"
  by (auto intro!: relD1 simp add: is_least_def)

lemma is_lubI:
    "\<lbrakk>
      a \<in> X;
      (\<And> x \<bullet> x \<in> A \<turnstile> x \<hookrightarrow> a);
      (\<And> b \<bullet> \<lbrakk> b \<in> X; (\<forall> x \<bullet> x \<in> A \<Rightarrow> x \<hookrightarrow> b) \<rbrakk> \<turnstile> a \<hookrightarrow> b)
     \<rbrakk> \<turnstile> is_lub A a"
  by (auto simp add: is_lub_def is_least_def is_ub_def)

lemma is_greatestI:
    "\<lbrakk> a \<in> A; (\<And> x \<bullet> x \<in> A \<turnstile> x \<hookrightarrow> a) \<rbrakk> \<turnstile> is_greatest A a"
  by (auto intro!: relD1 simp add: is_greatest_def)

lemma is_glbI:
    "\<lbrakk>
      a \<in> X;
      (\<And> x \<bullet> x \<in> A \<turnstile> a \<hookrightarrow> x);
      (\<And> b \<bullet> \<lbrakk> b \<in> X; (\<forall> x \<bullet> x \<in> A \<Rightarrow> b \<hookrightarrow> x) \<rbrakk>  \<turnstile> b \<hookrightarrow> a)
     \<rbrakk> \<turnstile> is_glb A a"
  by (auto simp add: is_glb_def is_greatest_def is_lb_def)

lemma is_ubD:
    "\<lbrakk> is_ub A a; x \<in> A \<rbrakk> \<turnstile> x \<hookrightarrow> a"
  by (simp add: is_ub_def)

lemma is_lbD:
    "\<lbrakk> is_lb A a; x \<in> A \<rbrakk> \<turnstile> a \<hookrightarrow> x"
  by (simp add: is_lb_def)

lemma is_leastD:
    "\<lbrakk> is_least A a; x \<in> A \<rbrakk> \<turnstile> a \<hookrightarrow> x"
  by (simp add: is_least_def)

lemma is_greatestD:
    "\<lbrakk> is_greatest A a; x \<in> A \<rbrakk> \<turnstile> x \<hookrightarrow> a"
  by (simp add: is_greatest_def)

lemma is_lubD1:
    "is_lub A a \<turnstile> is_ub A a"
  by (simp add: is_lub_def is_ub_def is_least_def)

lemma is_lubD1':
    "\<lbrakk> is_lub A a; x \<in> A\<rbrakk> \<turnstile> x \<hookrightarrow> a"
  by (auto intro: is_ubD [OF is_lubD1])

lemma is_lubD2:
    "is_lub A a \<turnstile> is_least {x | is_ub A x} a"
  by (simp add: is_lub_def is_ub_def is_least_def)

lemma is_lubD2':
    "\<lbrakk> is_lub A a;  x \<in> X; (\<And> y \<bullet> y \<in> A \<turnstile> y \<hookrightarrow> x)\<rbrakk> \<turnstile> a \<hookrightarrow> x"
  by (auto intro: is_lubD2 [THEN is_leastD, simplified, OF _ is_ubI])

lemma is_glbD1:
    "is_glb A a \<turnstile> is_lb A a"
  by (simp add: is_glb_def is_lb_def is_greatest_def)

lemma is_glbD1':
    "\<lbrakk> is_glb A a; x \<in> A\<rbrakk> \<turnstile> a \<hookrightarrow> x"
  by (auto intro: is_lbD [OF is_glbD1])

lemma is_glbD2:
    "is_glb A a \<turnstile> is_greatest {x | is_lb A x} a"
  by (simp add: is_glb_def is_lb_def is_greatest_def)

lemma is_glbD2':
    "\<lbrakk> is_glb A a;  x \<in> X; (\<And> y \<bullet> y \<in> A \<turnstile> x \<hookrightarrow> y)\<rbrakk> \<turnstile> x \<hookrightarrow> a"
  by (auto intro: is_glbD2 [THEN is_greatestD, simplified, OF _ is_lbI])

end

text {*

If linearly ordered then of course the bounds can be computed.

*}

definition
  minimum :: "['a set, 'a orderT, 'a, 'a] \<rightarrow> 'a"
where
  minimum_def: "minimum \<defs> (\<olambda> X r x y \<bullet> \<if> \<^infop>{:x:}{:r:}{:y:} \<then> x \<else> y \<fi>)"

definition
  maximum :: "['a set, 'a orderT, 'a, 'a] \<rightarrow> 'a"
where
  maximum_def: "maximum \<defs> (\<olambda> X r x y \<bullet> \<if> \<^infop>{:x:}{:r:}{:y:} \<then> y \<else> x \<fi>)"

notation (zed)
  minimum ("\<^min>{:_:}{:_:}") and
  maximum ("\<^max>{:_:}{:_:}")

context setrel_sig

begin

abbreviation
  minimum :: "['a, 'a] \<rightarrow> 'a"
where
  "minimum \<defs> \<^min>{:X:}{:(op \<hookrightarrow>):}"

abbreviation
  maximum :: "['a, 'a] \<rightarrow> 'a"
where
  "maximum \<defs> \<^max>{:X:}{:(op \<hookrightarrow>):}"

end

context order

begin

lemma is_glb_eq:
  assumes
    A1: "x \<in> X" and
    A2: "y \<in> X"
  shows
    "is_glb {x, y} (minimum x y)"
  apply (unfold minimum_def)
  apply (rule is_glbI)
  using A1 A2
  apply (simp)
  apply (simp, elim disjE, simp_all, msafe(inference))
  apply (rule A1 [THEN refl [rule_format]])
  using A2 [THEN A1 [THEN linD]]
  apply (simp)
  apply (rule A2 [THEN refl [rule_format]])
  done

lemma is_lub_eq:
  assumes
    A1: "x \<in> X" and
    A2: "y \<in> X"
  shows
    "is_lub {x,y} (maximum x y)"
  apply (unfold maximum_def)
  apply (rule is_lubI)
  using A1 A2
  apply (simp)
  apply (simp_all, elim disjE, simp_all, msafe(inference))
  apply (rule A1 [THEN refl [rule_format]])
  apply (rule A2 [THEN refl [rule_format]])
  using A2 [THEN A1 [THEN linD]]
  apply (simp)
  done

end

text {*

The two notions of bounds/extremals are mutually dual.

*}

context setrel_sig

begin

lemma is_lb_dual:
    "\<^lbp>{:X:}{:(op \<hookleftarrow>):} = is_ub"
  by (simp add: is_lb_def is_ub_def converse_rel_def)

lemma is_ub_dual:
    "\<^ubp>{:X:}{:(op \<hookleftarrow>):} = is_lb"
  by (simp add: is_lb_def is_ub_def converse_rel_def)

lemma is_least_dual:
  "\<^lp>{:X:}{:(op \<hookleftarrow>):} = is_greatest"
  by (simp add: is_greatest_def is_least_def converse_rel_def)

lemma is_greatest_dual:
    "\<^gp>{:X:}{:(op \<hookleftarrow>):} = is_least"
  by (simp add: is_greatest_def is_least_def converse_rel_def)

lemma is_lub_dual:
    "\<^lubp>{:X:}{:(op \<hookleftarrow>):} = is_glb"
  by (simp add: is_lub_def is_glb_def is_least_dual is_ub_dual)

lemma is_glb_dual:
    "\<^glbp>{:X:}{:(op \<hookleftarrow>):} = is_lub"
  by (simp add: is_lub_def is_glb_def is_greatest_dual is_lb_dual)

end

end