\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsection \<open>Partial Orders\<close>
theory Partial_Orders
  imports
    Binary_Relations_Antisymmetric
    Preorders
begin

definition "partial_order_on P R \<equiv> preorder_on P R \<and> antisymmetric_on P R"

lemma partial_order_onI [intro]:
  assumes "preorder_on P R"
  and "antisymmetric_on P R"
  shows "partial_order_on P R"
  unfolding partial_order_on_def using assms by blast

lemma partial_order_onE [elim]:
  assumes "partial_order_on P R"
  obtains "preorder_on P R" "antisymmetric_on P R"
  using assms unfolding partial_order_on_def by blast

lemma transitive_if_partial_order_on_in_field:
  assumes "partial_order_on (in_field R) R"
  shows "transitive R"
  using assms by (elim partial_order_onE) (rule transitive_if_preorder_on_in_field)

lemma antisymmetric_if_partial_order_on_in_field:
  assumes "partial_order_on (in_field R) R"
  shows "antisymmetric R"
  using assms by (elim partial_order_onE)
    (rule antisymmetric_if_antisymmetric_on_in_field)

definition "partial_order (R :: 'a \<Rightarrow> _) \<equiv> partial_order_on (\<top> :: 'a \<Rightarrow> bool) R"

lemma partial_order_eq_partial_order_on:
  "partial_order (R :: 'a \<Rightarrow> _) = partial_order_on (\<top> :: 'a \<Rightarrow> bool) R"
  unfolding partial_order_def ..

lemma partial_orderI [intro]:
  assumes "preorder R"
  and "antisymmetric R"
  shows "partial_order R"
  unfolding partial_order_eq_partial_order_on using assms
  by (intro partial_order_onI preorder_on_if_preorder antisymmetric_on_if_antisymmetric)

lemma partial_orderE [elim]:
  assumes "partial_order R"
  obtains "preorder R" "antisymmetric R"
  using assms unfolding partial_order_eq_partial_order_on
  by (elim partial_order_onE)
  (simp only: preorder_eq_preorder_on antisymmetric_eq_antisymmetric_on)

lemma partial_order_on_if_partial_order:
  fixes P :: "'a \<Rightarrow> bool" and R :: "'a \<Rightarrow> _"
  assumes "partial_order R"
  shows "partial_order_on P R"
  using assms by (elim partial_orderE)
  (intro partial_order_onI preorder_on_if_preorder antisymmetric_on_if_antisymmetric)

end


theory Clock imports Complex_Main
(*  "~~/src/HOL/Library/Extended_Real"*)

begin

type_synonym clock = "nat \<Rightarrow> real"

definition head :: "clock \<Rightarrow> real"
      where
   "head c \<equiv> c (0::nat)"

definition suffix :: "clock \<Rightarrow> nat \<Rightarrow> clock"
             (infixl "|." 60)  where
   "c |. i \<equiv> \<lambda> n. c (n+i)"

definition tail :: "clock \<Rightarrow> clock"
    where
  "tail c \<equiv> \<lambda> n. c (n+1)"

definition app :: "real \<Rightarrow> clock \<Rightarrow> clock"
    (infixl "##" 60)  where
  "t ## c \<equiv> \<lambda> n. if n=0  then t  else c (n-(1::nat))"

definition isClock::"clock \<Rightarrow> bool"
   where
  "isClock c \<equiv> \<forall>i.  (c (i)) > 0 \<and> (c (i+1)) - (c i) > 0 "

definition low_rate::"clock \<Rightarrow> real"
    ("\<triangle> (_)" 60)   where
 "low_rate c \<equiv> Inf {a. \<exists>i. a = (c (i+1)) - (c i)}"

definition high_rate::"clock \<Rightarrow> real"
    ("\<dtriangle>" 60) where
 "high_rate c \<equiv> Sup{a. \<exists>i. a=(c (i+1))- (c i)}"

definition healthy_clock::"clock \<Rightarrow> bool"
   where
  "healthy_clock c \<equiv> isClock c \<and> \<triangle>(c) > 0"

locale partial_order =
  fixes less_eq :: "'a \<Rightarrow> 'a \<Rightarrow>bool" (infixl "\<sqsubseteq>" 50)
  assumes refl:"x \<sqsubseteq> x"
  and  antisym:"\<lbrakk> x \<sqsubseteq> y ; y \<sqsubseteq> x \<rbrakk>\<Longrightarrow> x = y "
  and  trans: "\<lbrakk>x \<sqsubseteq> y; y\<sqsubseteq> z \<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"

text{*
  Clock c is finer than clock d if d is subsequence of c,
  c \<sqsupseteq> d \<equiv> Set(d) \<subseteq> Set(c)
*}

definition  finer:: "clock \<Rightarrow> clock \<Rightarrow> bool"
     (infixl "\<sqsupseteq>" 60)  where
  "finer c d \<equiv> (isClock c) \<and> (isClock d) \<and> { x. \<exists>i. x= (c i) }  \<subseteq> {x. \<exists>i. x= (d i)} "

definition  faster::"clock\<Rightarrow>clock\<Rightarrow>bool"
    (infixl "\<lesssim>" 60 ) where
"faster c d  \<equiv> \<forall>i. (c i) \<le> (d i)"

definition clock_dis::"clock\<Rightarrow>clock\<Rightarrow>real"
   ("\<rho> _ _" 60) where
"clock_dis c d \<equiv> Sup {a. \<exists>i. a= abs((c i) - (d i)) \<and> i > 0}"

lemma suffix_first: "head (c |. n) = c n"
  by (auto simp add: suffix_def head_def)

lemma suffix_plus: "c |. n |. m = c |. (m + n)"
apply (simp add: suffix_def nat_add_assoc)
done

lemma suffix_commute: "((c |. n) |. m) = ((c |. m) |. n)"
apply (simp add: suffix_plus nat_add_commute)
done

lemma suffix_plus_com:
 "c |. m |. n = c |. (m + n)"
apply (subst suffix_plus)
apply (simp add:suffix_plus nat_add_commute)
done

lemma suffix_zero:
 "c |. 0 = c"
by (simp add: suffix_def)

lemma suffix_tail:
 "c |. 1 = tail c"
by (simp add: tail_def suffix_def)

lemma tail_suffix_suc:
  "c |. (Suc n) = tail (c |. n)"
apply (simp add: suffix_def tail_def)
done

lemma seq_app_second: "(t ## c) 1 = c 0 "
by (simp add: app_def)

lemma seq_app_first: "(t ## c) 0 = t"
 by (simp add: app_def)

lemma seq_app_first_tail: "(head c) ## (tail c) = c"
by (auto simp: app_def head_def tail_def)

lemma low_rate_le_n:
assumes a1:"isClock c"
shows "\<triangle>(c)\<le> (c (n+1)) - (c n)"
proof-
  from a1 have s1:"\<forall>i. 0 < (c (i+1))- (c i)"
       apply (simp add:isClock_def) done
  from s1 have s2:"\<forall>i. 0 \<le> (c (i+1))- (c i)"
       apply (simp add:order_less_imp_le) done
  let ?A="{a. \<exists>i. a = c (Suc i) - c i}"
    and ?x="c (Suc n) - c n"
  have s3:"?x\<in>?A" thm Inf_lower apply auto done
  from s2 have s4:"\<And>y. y\<in>?A \<Longrightarrow> 0 \<le> y"  apply auto done
  from s3 s4 have s5:"Inf ?A \<le> ?x" apply (rule Inf_lower) apply blast done
  thus  ?thesis by(simp add: low_rate_def)
qed

lemma low_rate_le_each:
"\<lbrakk> isClock c \<rbrakk> \<Longrightarrow> \<forall>n. \<triangle>(c)\<le> (c (n+(1::nat))) - (c n)"
apply (insert low_rate_le_n)
apply auto
done

lemma low_rate_le_sum:
assumes a1:"isClock c "
shows "((real (Suc n))*(\<triangle> c))\<le> (\<Sum>i = 0..n. ((c (Suc i)) - (c i)))"
proof(induct n)
  case 0
    let ?X0 = "(\<Sum>i = 0..0. ((c (Suc i)) - (c i)))"
    have s1:"((real (Suc 0))*(\<triangle> c))= (\<triangle> c)" by simp
    have s2: "?X0= ((c (Suc 0)) - (c 0))"  by simp
    from a1 have s4:"(\<triangle> c) \<le> ((c (Suc 0)) - (c 0))"
       using  low_rate_le_each  by auto
    from s1 s4 show ?case by simp
next
   case (Suc n)
   let ?Xn="(\<Sum>i=0..n. ((c (Suc i)) - (c i)))"
     and ?Yn="(\<Sum>i = 0..(Suc n). (c (Suc i)) - (c i))"
   have s5: "?Yn = ?Xn + (c (Suc (Suc n))) - (c (Suc n))"
    apply simp  done
   from a1 have s7 : "(\<triangle> c)\<le> (c (Suc (Suc n))) - (c (Suc n))"
      using  low_rate_le_each  apply simp done
   have s8:"(real (Suc n)) * (\<triangle> c) \<le>  ?Xn" apply (rule Suc.hyps) done
   from s5 s7 s8 have s9:"(real (Suc n)) * (\<triangle> c) + (\<triangle> c) \<le> ?Yn"
      apply simp done
   have s10:"(real (Suc (Suc n)))*(\<triangle> c) = ((real (Suc n)) + (1::real))*(\<triangle> c)"
      apply simp done
   have s11:"((real (Suc n)) + (1::real)) * (\<triangle> c) = (real (Suc n)) * (\<triangle> c) + (\<triangle> c)"
      apply (auto simp: mult_Real add_Real algebra_simps) done
   from s10 s11 have  s12: "(real (Suc (Suc n))) * (\<triangle> c)= (real (Suc n)) * (\<triangle> c) + (\<triangle> c)"
      apply simp done
   from s8 s9 s12 show ?case apply simp  done
qed

lemma clock_le:
  assumes a0:"isClock c"
  and    a1:"i< j"
  shows "(c i) < (c j)"
proof-
  from a0 have s1: "\<And>i. 0 < (c (Suc i) - (c i))" apply (simp add:isClock_def) done
   from s1 have s2:"\<And>i. (c i) < c (Suc i)"

             apply m  done

thm lift_Suc_mono_less
lemma clock_le_order:
  "\<lbrakk>isClock c; i<j \<rbrakk> \<Longrightarrow> (c i) < (c j)"
apply (unfold isClock_def)
apply (rule_tac f=c and n=i and n'=j in lift_Suc_mono_less)
apply (subgoal_tac "0< c (Suc n) - (c n)")
apply (rotate_tac 2)
apply
proof(induct i)
case 0
   have "(\<Sum>n = 0..(j - (1::nat)). c (Suc n) - c n) = c j - c 0"
     proof(induct "j-(1::nat)")
     case 0
       have s1:"0 =j-(1::nat)"  apply (rule Suc.hyps) done
       have s2:"0 = j - 1 \<Longrightarrow> (\<Sum>n = 0..j - 1. c (Suc n) - c n) = c j - c 0"
         proof-
            assume aa1:"(0::nat)= j - (1::nat)"
            show  ss1: "(\<Sum>n = 0..(j - (1::nat)). c (Suc n) - c n) = c j - c 0"
            proof-
               from a1 aa1 have ss2:"j= Suc 0" apply simp    done
               from ss2 have ss3:"(\<Sum>n = (0::nat)..(0::nat). ((c (Suc 0)) - (c (0::nat))))
                                  = ((c (Suc 0)) - (c (0::nat)))" apply auto done
             from ss3 ss2 show ?thesis apply auto done
             qed
         qed
         thus  ?case  apply simp apply auto
      next
       case Suc
       have

case (Suc i)
  "\<lbrakk> \<forall>(k::nat). (c k)< c (Suc k); i<j\<rbrakk>\<Longrightarrow> c i < c j"
apply(induct i)
apply b
apply (simp add:isClock_def)
apply ()
apply auto
done

lemma healthy_clock_0:
 assumes a1:"isClock c"
 shows "(\<Sum>i=0..n. ((c (Suc i)) - (c i))) = ((c (Suc n)) - (c (0::nat)))"
proof (induct n)
case 0
  have "(\<Sum>i = 0..0. ((c (Suc i)) - (c i))) = ((c (Suc (0::nat))) - (c (0::nat)))"
     by auto
  thus  ?case .
next
  case (Suc n)
  let ?X = "\<Sum>i = 0..(Suc n). ((c (Suc i)) - (c i)) "
   and ?Y = "\<Sum>i = 0..n. (c (Suc i) - (c i))"
  have s1: "?X = ?Y + (c (Suc (Suc n))) - (c (Suc n))"
    apply simp done
  also have s2:"?Y = (c (Suc n)) - (c (0::nat))"
     apply (rule Suc.hyps) done
  from s1 s2 have s3: "?Y + ((c (Suc (Suc n))) - (c (Suc n))) =
            ((c (Suc n)) - (c (0::nat)))
           +((c (Suc (Suc n))) - (c (Suc n)))"
  apply (auto simp:s1 s2)  done
  from s3 have s4: "?Y
           + ((c (Suc (Suc n))) - (c (Suc n)))
        = (c (Suc (Suc n))) - (c (0::nat))"
   by auto
  from s1 s4 have s5:"?X = (c (Suc (Suc n))) - (c (0::nat))" by auto
  from s5 show ?case by auto
qed

lemma healthy_clock_1:
  "isClock c \<Longrightarrow>((real (Suc n))*(\<triangle> c))  \<le> c (Suc n) -  (c 0)"
  apply (insert low_rate_le_sum)
  apply (insert healthy_clock_0)
  apply simp
done

lemma healthy_clock_2:
  "isClock c \<Longrightarrow> ( (real (n::nat)) * (\<triangle> c) \<le> ((c n) - (c 0)))"
apply(induct n)
apply simp
apply (simp add:healthy_clock_1)
done

lemma real_le_0: "\<lbrakk>a \<le> b - c; (0::real) < c\<rbrakk> \<Longrightarrow> a <b"
apply simp
done

lemma healthy_clock_3:
 "isClock c \<Longrightarrow> ( (real (n::nat)) * (\<triangle> c) < ((c n))) "
apply(rule_tac c="(c 0)" in real_le_0)
apply(simp add: healthy_clock_2)
apply(simp add:isClock_def)
done

lemma  real_mult_le: "\<lbrakk> a \<le> b ; 0 < d \<rbrakk> \<Longrightarrow> a*d \<le> b*(d::real)"
apply simp
done

lemma real_mult_add:"(a + 1)*b = a*b + (b::real)"
apply (auto simp: mult_Real add_Real algebra_simps)
done

lemma non_zeno_behaviour:"healthy_clock c \<Longrightarrow> \<forall>E. \<exists>N. E < (c N)"
proof
 fix E assume a0:"healthy_clock c"
  show  "\<exists>N. E < (c N)"
proof-
 from a0 have s1:"isClock c"  by (simp add:healthy_clock_def)
 from a0 have s2:"0 < \<triangle>(c)" by (simp add:healthy_clock_def)
   let ?M="(E/(\<triangle> c))"
   from s1 s2 have s3: "E = (?M*(\<triangle> c))" by auto
   have s4:"?M \<le> (natceiling ?M)"
    using real_natceiling_ge[of "?M"] apply blast  done
   from s2 s4 have s5:"(?M*(\<triangle> c)) \<le> (natceiling ?M)*(\<triangle> c)"
     using  real_mult_le[of "?M" "(natceiling ?M)" "(\<triangle> c)"]
     apply simp done
   from s3 s5 have s6:"E \<le> (natceiling ?M)*(\<triangle> c) " by simp
   from s2 s6 have s7: "E < (natceiling ?M)*(\<triangle> c) + (\<triangle> c)"
      apply auto done
   from s2 have s8: "(natceiling ?M)*(\<triangle> c) + (\<triangle> c) =((natceiling ?M)+(1::real))*(\<triangle> c)"
      apply(auto simp: mult_Real add_Real algebra_simps)  done
   from s2 have s9:"((natceiling ?M)+(1::real))*(\<triangle> c) =
                    (Suc(natceiling ?M))*(\<triangle> c)"
      apply auto done
   from s8 s9 have s10: "(natceiling ?M)*(\<triangle> c) + (\<triangle> c) = (Suc(natceiling ?M))*(\<triangle> c)"
      apply simp done
   from s1 have  s11:" (Suc(natceiling ?M))*(\<triangle> c) < (c (Suc(natceiling ?M)))"
      using  healthy_clock_3[of "c" "(Suc(natceiling ?M))"]
        apply auto done
   from s11 have s12:"\<lbrakk> E < (Suc(natceiling ?M))*(\<triangle> c)\<rbrakk> \<Longrightarrow> \<exists>(N::nat). E < (c N)"
      apply(rule_tac x=" (Suc(natceiling ?M))" in exI)
      apply (simp) done
   from s7 s10 s12
    show ?thesis apply auto  done
  qed
qed

subsection{*Paritial order on clocks*}

lemma finer_refl:"isClock c \<Longrightarrow>finer c c"
apply (simp add:finer_def)
done

lemma "\<lbrakk>c \<sqsupseteq> d; d \<sqsupseteq> c \<rbrakk> \<Longrightarrow> \<forall>i. \<exists>j. d i = c j"
apply (simp add:finer_def)
apply blast
done

lemma "\<lbrakk>c \<sqsupseteq> d; d \<sqsupseteq> c \<rbrakk> \<Longrightarrow> \<forall>i. \<exists>j. c i = d j"
apply (simp add:finer_def)
apply blast
done
lemma finer_antisym_0:
  assumes a0:"c \<sqsupseteq> d"
   and    a1:"d \<sqsupseteq> c "
  shows   "(d 0) < (c 0) \<Longrightarrow> False"
proof-
  assume a2:"(d 0) < (c 0)"
  show "False"
  proof-
  from a0 a1 have s1: "\<exists>i. d 0 = c i"
     apply (simp add:finer_def)
     apply blast done
  from a2 s1 have s2 : "\<exists>i. (c i) < (c 0)"  apply auto done
  from a0 a1 have ""
qed
lemma finer_antisym_0:
  assumes a0:"c \<sqsupseteq> d"
   and    a1:"d \<sqsupseteq> c "
  shows   "d 0 = c 0"
proof-
   have  a3: "d 0 \<noteq> c 0 \<Longrightarrow> False"
   proof-
      assume a4:"d 0 \<noteq> c 0"
      show "False"
      proof-
        assume a5:"(d 0) < (c 0)"
        assume a6:"(c 0)< (d 0)"

lemma finer_antisym:"\<lbrakk>isClock c ; isClock d;finer c d ; finer d c\<rbrakk> \<Longrightarrow> c = d "
apply(simp add:finer_def isClock_def)
apply blast
apply
text{*
  \<sqsupseteq> is a partial order on the set of clocks.
*}

thm

(*
lemma
*)

subsection{*Least upper bound*}
text{*
  Let c and d be clocks. We define c \<parallel> d as the least upper bound of c and d
with respect the partial order \<sqsupseteq>:
*}
(*lub \<equiv>  Least upper bound*)

(*function lub :: "clock\<Rightarrow>clock\<Rightarrow>clock"
   where
"lub c d =(if (head c) = (head d) then (head c)##(lub (tail c) (tail d))
           else (if (head c)>(head d) then (head d)##(lub c (tail d))
                 else (head c)##(lub (tail c) d)))"
apply auto
 *)

fun lub_c lub_d :: "clock \<Rightarrow> clock \<Rightarrow>nat \<Rightarrow> nat"
   where
"lub_c c d zero = zero"|
"lub_d c d zero = zero"|
"lub_c c d n =(if  (c ((lub_c c d (n-one))+one)) = (d ((lub_d c d (n-one))+one)) then  (lub_c c d (n-one))+one
               else (if (c ((lub_c c d (n-one))+ one)) > (d ((lub_d c d (n-one))+one)) then (lub_c c d (n-one))
                     else (lub_c c d (n-one))+one ))"|

"lub_d c d n =(if (c ((lub_c c d (n-one))+one)) = (d ((lub_d c d (n-one))+one)) then  (lub_d c d (n-one))+one
               else (if (c ((lub_c c d (n-one))+one)) > (d ((lub_d c d (n-one))+one)) then (lub_d c d (n-one))+one
                     else (lub_d c d (n-one))))"

lemma  lub_c_d_zero_eq:"lub_c c c zero = lub_d c c zero"
by auto

lemma lub_c_zero_eq:"lub_c c c zero = zero"
by auto
lemma lub_d_zero_eq : "lub_d c c zero = zero"
by auto

lemma lub_c_n_eq:"lub_c c c n = n"
apply(induct_tac n)
apply (simp add: lub_c_zero_eq)
sorry
(*
apply (auto simp:lub_d_def lub_c_def lub_c_lub_d_sumC_def lub_c_lub_d_graph_def Inl_def )

lemma lub_c_d_n_eq:"lub_c c c n = lub_d c c n"
apply (induct_tac n)
by auto

definition lub ::"clock\<Rightarrow> clock\<Rightarrow>clock"
   (infixl "\<parallel>" 60) where
"lub c d \<equiv> \<lambda>n. (if (c (lub_c c d n)) = (d (lub_d c d n)) then (c (lub_c c d n))
                 else (if (c (lub_c c d n)) > (d (lub_d c d n)) then (d (lub_d c d n))
                       else (c (lub_c c d n))  ))"

lemma lub_eq:
  assumes a0:"(c \<parallel> c) n = c n"
  shows "(c \<parallel> c) (Suc n) = c (Suc n)"
proof-
 from a0 have s1:"luc_c c c n = c n"
           apply (auto simp:lub_def)
           apply (auto simp:lub_c_d_n_eq )
lemma " (c \<parallel> c) n  = c n"
apply (induct_tac n)
apply (simp add:lub_c_d_zero_eq lub_def)
apply(unfold lub_def)
apply (insert )
apply (auto simp:lub_c_d_n_eq lub_def)
apply auto
lemma *)
  (*

function
  lub:: "clock \<Rightarrow> clock \<Rightarrow> clock"
      (infixl "\<parallel>" 60) where
"lub (c::clock) (d::clock)  = ( if (c 1) = (d 1) then  (c 1)##(lub (tail c) (tail d))
              else  ( if (c 1) > (d 1) then (d 1)##(lub c (tail d))
                else (c 1)##( lub (tail c) d) ))"
by  auto*)

(*termination *)
(*declare lub.simps[simp del]*)
(*apply simp
print_theorems*)
(* lub.cases lub.pinduct lub.psimps *)
(*
lemma "c\<parallel>c = c"
apply (unfold lub_def)
apply (unfold lub_sumC_def)
apply (unfold lub_graph_def)
thm nat.induct

apply auto
primrec
definition mft:: "clock\<Rightarrow>clock\<Rightarrow>real"
  where
"mft c d \<equiv> if (c 1) > (d 1) then (d 1) else (c 1)"

fun lub:: "clock \<Rightarrow> clock \<Rightarrow> clock"
    where
" lub c  d = (mft c d) ##(lub (tail c)  (tail d))"
inductive
*)

lemma " (lub c  d)= lub d  c"
sorry

lemma "(lub c (lub d e)) = (lub (lub c d) e)"
sorry

lemma " c \<subseteq> (lub c d )"
sorry

lemma "\<lbrakk> c \<subseteq> e; d \<subseteq> e  \<rbrakk> \<Longrightarrow> (lub c d) \<subseteq> e"
sorry

lemma " d \<subseteq> c \<Longrightarrow> ( c = (lub c d))"
sorry

lemma "( c = (lub c d)) \<Longrightarrow>d \<subseteq> c  "
sorry

text{*
   Partial Order Again.
c is clock, c runs faster than d if for all i \<ge> 1,
having  c[i]\<le> d[i].
We denote this relation by c \<lesssim> d.
*}

text{*
  Lemma : faster is a partial order on clocks.
  *}
(*
  lemma  faster is a partial order on clocks.
  *)

lemma less_le_real :"(0::real) < (b::real) -a \<Longrightarrow> a \<le> b"
apply arith
done

lemma "\<lbrakk> isClock c\<rbrakk> \<Longrightarrow> c \<lesssim> (tail c)"
apply (auto simp:isClock_def faster_def tail_def)
apply (simp add:less_le_real)
done

lemma "\<lbrakk>isClock c1; isClock c2; isClock d; c1 \<lesssim> c2 \<rbrakk>
    \<Longrightarrow> (lub c1 d) \<lesssim> (lub c2 d) "
sorry

text{*
  Metric Space of Clocks.
Let c and d be clocks.
Define
p (c, d) = sup{abs(c[i] - d[i]) | i \<ge> 1}
*}

lemma "\<rho> c d \<ge> (0 ::real)"
sorry

lemma "\<rho> c d = 0 \<Longrightarrow> c  = d"
sorry

lemma "c = d \<Longrightarrow> \<rho> c d = 0"
sorry

lemma "\<rho> c d  = \<rho> d c"
sorry

lemma "\<rho> c e \<le> (\<rho> c d) + (\<rho> d e)"
sorry

text{*
Example:
  Let in and out be clocks recording time instants when
input and output of a buffer occur respectively.
Because the output is always preceded by the corresponding input,
the buffer meets the following requirement.
in \<lesssim> out
It transmission latecy can be specified by \<rho>(in ,out).
One cell buffer can be specified by
in \<lesssim> out \<lesssim> in'  (tail in)
  *}

text{*
Clock Operations
    *}

text{*
Clock Operations::Projection
Let c be a clock, and P(i):Nat \<longrightarrow> bool a predicate.
The notation P \<lhd> c denotes the clock define by:
(P \<lhd> c  \<equiv>  if P(1)
            then c[1] ## (P(i+1) \<lhd> c')
            else P(i+1) ##

)
    *}

type_synonym projection_predicate = "nat \<Rightarrow> bool"
(*
fun  projectI ::"projection_predicate\<Rightarrow> clock\<Rightarrow>real"
   where
"projectI P c = (if (P (0::nat)) then (head c)
                  else ( projectI (\<lambda>n.(P (n+(1::nat)))) (tail c) ))"
*)
(*
inductive_set clock_project::"nat\<Rightarrow>bool \<Rightarrow> clock"
pro_zero:"\<lambda>n. (if (P n) )"
*)
(*
definition P ::"nat\<Rightarrow>bool"
where
"P i \<equiv> "
*)

text{*
Clock Operations
Filter
    *}

text{*
Clock Operations
Shift
Let r be a real number.
The notation r \<guillemotright> c represents the clock defined by
r\<guillemotright> c  = c[0]+r ## (r \<guillemotright> c')
    *}
definition clock_shift::"real\<Rightarrow>clock\<Rightarrow>clock"
  (infixl "\<guillemotright>" 60) where
"clock_shift r c \<equiv> \<lambda>n. ((c n)+ r)"

lemma "0\<guillemotright>c=c"
apply (simp add:clock_shift_def)
done

lemma "r1\<guillemotright>(r2\<guillemotright>c) = (r1+r2)\<guillemotright>c"
apply (simp add:clock_shift_def)
apply auto
done

lemma "c \<lesssim> d \<Longrightarrow> (r\<guillemotright>c) \<lesssim> (r\<guillemotright>d)"
apply (simp add:clock_shift_def faster_def)
done

text{*
Event vs Clock
Let e be an event.
We will use the notation clock(e) to denote the clock
that records the time instants when the event e occurs.
Let c be a clock.
We will use the notation event(c) to denote the event that
take place at every time instant c[i].
clock(event(c) = c)
    *}

text{*
Local Clock
Let l be a label denoting a logical location,
and c a clock.
The notation  l |:c
represents the clock c that resides at l.
We extend the definitions of
    *}

text{*
Time Difference.
For location l and m,
We use   \<delta> t (l m)
to represent the time difference between l and m.
\<delta> t is subject to the following laws:
Law 1 \<delta> t (l m) = - \<delta> t (m l)
Law 2 \<delta> t (l m) = \<delta> t (l m)
    *}

datatype location ="location"

locale location =
 fixes time_diff ::"location \<Rightarrow>location \<Rightarrow>real"
 assumes td1 :"time_diff m l = -(time_diff l m)"
     and td2 :"time_diff m l = (time_diff m h)+(time_diff h l)"

lemma real_zero:"(a::real) = -a \<Longrightarrow> a=(0::real)"
apply arith
done
lemma (in location) td1_1:"time_diff m m = -(time_diff m m)"
apply (insert td1)
apply blast
done

lemma (in location)"time_diff m m = (0::real)"
apply (insert td1)
apply (insert td1_1)
apply (insert real_zero)
apply blast
done
text{*
  Counterpart
Let l:c be a clock, and m be a location.
The notation m:(l:c) stand for the counterpart of the local clock
l:c at the location m
 m:(l:c) = m:((time_diff l m)\<guillemotright>c)
  *}
(*
lemma "l:(l:c) = l:c"
lemma "l:(m:(l:c))=l:c"
lemma "l1:(l2:(l3:c))=l1:(l3:c)"
*)
thm inv_def
thm Hilbert_Choice.someI
thm Hilbert_Choice.someI2
lemma choice_lemma: "\<lbrakk>P a;\<And>x. P x \<Longrightarrow> Q x \<rbrakk>\<Longrightarrow> Q a"
apply simp
done
lemma nat_indut:"\<lbrakk> (\<And>i. (P (i::nat)) \<Longrightarrow> (Q i)); P (n::nat) \<rbrakk>\<Longrightarrow> Q n"
apply (simp)
done
lemma "\<And>i. \<lbrakk>f (0::nat) = (d 0::nat);
        \<And>n. (f n::nat) = d n \<Longrightarrow> f (Suc n)= d (Suc n)\<rbrakk>\<Longrightarrow>
       f i = d i"
apply (induct_tac i)
apply blast
apply (erule_tac P="\<lambda>j. (f j = d j)" and Q="\<lambda>j.(f (Suc j)) = d (Suc j)"
  in nat_indut)
apply assumption
done

end


theory Parser
imports Main
begin

(* basic parsers *)

type_synonym ('ch, 'a) parser = "'ch list \<Rightarrow> ('a \<times> 'ch list) option"

primrec item :: "('ch, 'ch) parser" where
  "item [] = None"
| "item (ch # s) = Some (ch, s)"

fun fmap :: "('a \<Rightarrow> 'b) \<Rightarrow> ('ch, 'a) parser \<Rightarrow> ('ch, 'b) parser" (infix "<$>" 70) where
  "fmap f pa s = (case pa s of Some (a, s') \<Rightarrow> Some (f a, s') | None \<Rightarrow> None)"

fun pure :: "'a \<Rightarrow> ('ch, 'a) parser" where
  "pure a s = Some (a, s)"

fun ap :: "('ch, 'a \<Rightarrow> 'b) parser \<Rightarrow> ('ch, 'a) parser \<Rightarrow> ('ch, 'b) parser" (infixl "<**>" 70) where
  "ap pf pa s = (case pf s of
      Some (f, s') \<Rightarrow> (case pa s' of
          Some (a, s'') \<Rightarrow> Some (f a, s'')
        | None \<Rightarrow> None)
    | None \<Rightarrow> None)"

fun fail :: "('ch, 'a) parser" where
  "fail s = None"

fun alt :: "('ch, 'a) parser \<Rightarrow> ('ch, 'a) parser \<Rightarrow> ('ch, 'a) parser" (infixl "<|>" 60) where
  "alt a b s = (case a s of Some as \<Rightarrow> Some as | None \<Rightarrow> b s)"

fun sat :: "('ch, 'a) parser \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('ch, 'a) parser" (infixl "where" 65) where
  "sat pa f s = (case pa s of Some (a, s') \<Rightarrow> if f a then Some (a, s') else None | None \<Rightarrow> None)"

function pfix :: "(('ch, 'a) parser \<Rightarrow> ('ch, 'a) parser) \<Rightarrow> ('ch, 'a) parser" where
  "pfix f s = f (\<lambda>s'. if length s' < length s then pfix f s' else None) s"
  by pat_completeness auto
termination
  by (relation "measure (\<lambda>(f, s). length s)") auto

(* derived parsers *)

definition many :: "('ch, 'a) parser \<Rightarrow> ('ch, 'a list) parser" where
  "many pa = pfix (\<lambda>many. (op #) <$> pa <**> many <|> pure [])"

definition constant_parser :: "'ch \<Rightarrow> ('ch, 'ch) parser" where
  "constant_parser ch = item where (op = ch)"

primrec string_parser :: "'ch list \<Rightarrow> ('ch, 'ch list) parser" where
  "string_parser [] = pure []"
| "string_parser (ch # s) = pure (op #) <**> constant_parser ch <**> string_parser s"

definition many1 :: "('ch, 'a) parser \<Rightarrow> ('ch, 'a list) parser" where
  "many1 a = pure (op #) <**> a <**> many a"

definition optional :: "('ch, 'a) parser \<Rightarrow> ('ch, 'a option) parser" where
  "optional a = (Some <$> a) <|> pure None"

definition deoption :: "('ch, 'a option) parser \<Rightarrow> ('ch, 'a) parser" where
  "deoption a = the <$> (a where (\<lambda>x. x \<noteq> None))"

(* parser laws *)

lemma [simp]: "fmap f o fmap g = fmap (f o g)"
  by rule (auto split: option.splits)

lemma [simp]: "pure id <**> v = v"
  by (auto split: option.splits)

lemma [simp]: "pure f <**> pure v = pure (f v)"
  by auto

lemma [simp]: "f <**> pure v = pure (\<lambda>x. x v) <**> f"
  by (auto split: option.splits)

lemma [simp]: "f <**> (g <**> x) = pure (op o) <**> f <**> g <**> x"
  by (auto split: option.splits)

lemma [simp]: "g <$> x = pure g <**> x"
  by auto

lemma [simp]: "fail <**> p = fail"
  by auto

lemma [simp]: "p <**> fail = fail"
  by (auto split: option.splits)

lemma [simp]: "fail <|> p = p"
  by auto

lemma [simp]: "p <|> fail = p"
  by (auto split: option.splits)

lemma [simp]: "a <|> (b <|> c) = a <|> b <|> c"
  by (auto split: option.splits)

lemma [simp]: "a <**> (b <|> c) = a <**> b <|> a <**> c"
  by (auto split: option.splits)

lemma [simp]: "pure x where p = (if p x then pure x else fail)"
  by auto

lemma [simp]: "fail where p = fail"
  by auto

lemma [simp]: "constant_parser ch (ch # s) = Some (ch, s)"
  by (simp add: constant_parser_def)

lemma [simp]: "ch' \<noteq> ch \<Longrightarrow> constant_parser ch (ch' # s) = None"
  by (simp add: constant_parser_def)

lemma [simp]: "constant_parser ch [] = None"
  by (simp add: constant_parser_def)

lemma [simp]: "string_parser s (s @ t) = Some (s, t)"
  by (induction s arbitrary: t) simp_all

lemma [simp]: "length s = length s' \<Longrightarrow> s \<noteq> s' \<Longrightarrow> string_parser s (s' @ t) = None"
  proof (induction s arbitrary: s' t)
  case Nil
    thus ?case by simp
  next case (Cons ch s)
    then obtain ch' s'' where "s' = ch' # s''" by (metis length_Suc_conv)
    with Cons show ?case by (cases "ch = ch'") simp_all
  qed

lemma [simp]: "length s' < length s \<Longrightarrow> string_parser s s' = None"
  proof (induction s arbitrary: s')
  case Nil
    thus ?case by simp
  next case (Cons ch s)
    thus ?case
      proof (induction s')
      case Nil
        thus ?case by simp
      next case (Cons ch' s')
        thus ?case by (cases "ch = ch'") simp_all
      qed
  qed

lemma [simp]: "p s = Some (a, t) \<Longrightarrow> optional p s = Some (Some a, t)"
  by (simp add: optional_def)

lemma [simp]: "p s = None \<Longrightarrow> optional p s = Some (None, s)"
  by (simp add: optional_def)

lemma [simp]: "p s = Some (Some a, t) \<Longrightarrow> deoption p s = Some (a, t)"
  by (simp add: deoption_def)

lemma [simp]: "p s = Some (None, t) \<Longrightarrow> deoption p s = None"
  by (simp add: deoption_def)

lemma [simp]: "p s = None \<Longrightarrow> deoption p s = None"
  by (simp add: deoption_def)

end


(*
  File: Connected.thy
  Author: Bohua Zhan

  Connected topological spaces.
*)

theory Connected
  imports ProductTopology OrderTopology
begin

section \<open>Connected spaces\<close>

definition separation :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "separation(X,U,V) \<longleftrightarrow> (is_open(X,U) \<and> is_open(X,V) \<and> U \<noteq> \<emptyset> \<and> V \<noteq> \<emptyset> \<and> U \<inter> V = \<emptyset> \<and> U \<union> V = carrier(X))"

lemma separation_eq_str_top [rewrite]:
  "eq_str_top(X,Y) \<Longrightarrow> separation(X,A,B) \<longleftrightarrow> separation(Y,A,B)" by auto2

lemma separation_sym [resolve]: "separation(X,A,B) \<Longrightarrow> separation(X,B,A)" by auto2

definition connected :: "i \<Rightarrow> o" where [rewrite]:
  "connected(X) \<longleftrightarrow> (is_top_space(X) \<and> \<not>(\<exists>U V. separation(X,U,V)))"

lemma connectedD1 [forward]: "connected(X) \<Longrightarrow> is_top_space(X)" by auto2
lemma connectedD2 [resolve]: "connected(X) \<Longrightarrow> \<not>separation(X,U,V)" by auto2
lemma connectedI [resolve]: "is_top_space(X) \<Longrightarrow> \<not>connected(X) \<Longrightarrow> \<exists>U V. separation(X,U,V)" by auto2

lemma connected_empty [resolve]: "is_top_space(X) \<Longrightarrow> carrier(X) = \<emptyset> \<Longrightarrow> connected(X)" by auto2
setup {* del_prfstep_thm @{thm connected_def} *}

lemma connectedD':
  "connected(X) \<Longrightarrow> is_open(X,A) \<Longrightarrow> is_closed(X,A) \<Longrightarrow> A = \<emptyset> \<or> A = carrier(X)"
@proof @contradiction @have "separation(X,A,carrier(X) \<midarrow> A)" @qed

lemma connectedI':
  "is_top_space(X) \<Longrightarrow> \<forall>A\<in>open_sets(X). is_closed(X,A) \<longrightarrow> A = \<emptyset> \<or> A = carrier(X) \<Longrightarrow> connected(X)"
@proof
  @contradiction
  @obtain U V where "separation(X,U,V)" @have "U = carrier(X) \<midarrow> V"
@qed

definition connected_subset :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "connected_subset(X,Y) \<longleftrightarrow> (Y \<subseteq> carrier(X) \<and> connected(subspace(X,Y)))"

lemma connected_subset_sep [forward]:
  "is_top_space(X) \<Longrightarrow> separation(X,C,D) \<Longrightarrow> connected_subset(X,Y) \<Longrightarrow> Y \<subseteq> C \<or> Y \<subseteq> D"
@proof
  @case "Y \<inter> C \<noteq> \<emptyset> \<and> Y \<inter> D \<noteq> \<emptyset>" @with
    @have "separation(subspace(X,Y),Y \<inter> C,Y \<inter> D)" @end
@qed

lemma connected_subset_full [forward]:
  "is_top_space(X) \<Longrightarrow> connected_subset(X,carrier(X)) \<Longrightarrow> connected(X)"
@proof @contradiction @obtain U V where "separation(X,U,V)" @qed

lemma connected_union [backward1]:
  "is_top_space(X) \<Longrightarrow> \<forall>a\<in>A. connected_subset(X,a) \<Longrightarrow> (\<Inter>A) \<noteq> \<emptyset> \<Longrightarrow> connected_subset(X, \<Union>A)"
@proof
  @contradiction
  @let "Y = (\<Union>A)"
  @obtain p where "p \<in> (\<Inter>A)"
  @have (@rule) "\<forall>a\<in>A. connected_subset(subspace(X,Y),a)"
  @obtain C D where "separation(subspace(X,Y), C, D)"
  @case "p \<in> C" @with @have "\<forall>a\<in>A. a \<subseteq> C" @end
@qed

lemma connected_union' [backward1]:
  "is_top_space(X) \<Longrightarrow> \<forall>a\<in>A. connected_subset(X,a) \<Longrightarrow> carrier(X) \<subseteq> (\<Union>A) \<Longrightarrow> (\<Inter>A) \<noteq> \<emptyset> \<Longrightarrow> connected(X)"
@proof
  @have "carrier(X) = (\<Union>A)"
  @have "connected_subset(X, carrier(X))"
@qed

lemma connected_union2 [backward1]:
  "is_top_space(X) \<Longrightarrow> connected_subset(X,A) \<Longrightarrow> connected_subset(X,B) \<Longrightarrow>
   A \<inter> B \<noteq> \<emptyset> \<Longrightarrow> connected_subset(X, A \<union> B)"
@proof @have "A \<union> B = \<Union>{A,B}" @have "A \<inter> B = \<Inter>{A,B}" @qed

lemma connected_continuous_surj [forward,resolve]:
  "continuous(f) \<Longrightarrow> surjective(f) \<Longrightarrow> connected(source_str(f)) \<Longrightarrow> connected(target_str(f))"
@proof
  @contradiction
  @obtain U V where "separation(target_str(f),U,V)"
  @have "separation(source_str(f), f-``U, f-``V)"
@qed

lemma connected_continuous [backward]:
  "continuous(f) \<Longrightarrow> connected(source_str(f)) \<Longrightarrow> connected_subset(target_str(f),image(f))"
@proof
  @let "f' = mor_restrict_image_top(f,image(f))" @have "surjective(f')"
@qed

lemma connected_continuous_subspace [backward]:
  "continuous(f) \<Longrightarrow> connected_subset(source_str(f),A) \<Longrightarrow> connected_subset(target_str(f),f``A)"
@proof @contradiction @have "connected_subset(source(f),image(f |\<^sub>T A))" @qed

lemma connected_is_top_prop [forward]:
  "connected(X) \<Longrightarrow> homeomorphic(X,Y) \<Longrightarrow> connected(Y)"
@proof @obtain "f \<in> X \<cong>\<^sub>T Y" @qed

lemma connected_is_top_prop2 [forward]:
  "connected(X) \<Longrightarrow> eq_str_top(X,Y) \<Longrightarrow> connected(Y)"
@proof @have "homeomorphic(X,Y)" @qed

section \<open>Connected-ness on product spaces\<close>

lemma product_connected [forward]:
  "connected(X) \<Longrightarrow> connected(Y) \<Longrightarrow> connected(X \<times>\<^sub>T Y)"
@proof
  @case "carrier(X) = \<emptyset>" @case "carrier(Y) = \<emptyset>"
  @obtain "x \<in>. X"
  @let "A = {{x} \<times> carrier(Y) \<union> carrier(X) \<times> {y}. y\<in>.Y}"
  @have "(\<Inter>A) \<noteq> \<emptyset>" @with
    @obtain "y \<in>. Y" @have "\<langle>x,y\<rangle> \<in> (\<Inter>A)" @end
  @have "carrier(X \<times>\<^sub>T Y) \<subseteq> (\<Union>A)" @with
    @have "\<forall>p\<in>carrier(X \<times>\<^sub>T Y). p \<in> (\<Union>A)" @with
      @have "p \<in> {x} \<times> carrier(Y) \<union> carrier(X) \<times> {snd(p)}" @end @end
  @have "\<forall>a\<in>A. connected_subset(X \<times>\<^sub>T Y,a)" @with
    @obtain "y\<in>.Y" where "a = {x} \<times> carrier(Y) \<union> carrier(X) \<times> {y}"
    @have "{x} \<times> carrier(Y) \<inter> carrier(X) \<times> {y} \<noteq> \<emptyset>" @with
      @have "\<langle>x,y\<rangle> \<in> {x} \<times> carrier(Y) \<inter> carrier(X) \<times> {y}" @end
    @have "connected_subset(X \<times>\<^sub>T Y, {x} \<times> carrier(Y))" @with
      @have "homeomorphic(Y, subspace(X \<times>\<^sub>T Y, {x} \<times> carrier(Y)))" @end
    @have "connected_subset(X \<times>\<^sub>T Y, carrier(X) \<times> {y})" @with
      @have "homeomorphic(X, subspace(X \<times>\<^sub>T Y, carrier(X) \<times> {y}))" @end
  @end
@qed

section \<open>Connected-ness on order topology\<close>

lemma connected_convex [resolve]:
  "order_topology(X) \<Longrightarrow> connected_subset(X,A) \<Longrightarrow> order_convex(X,A)"
@proof
  @have "\<forall>a\<in>A. \<forall>b\<in>A. closed_interval(X,a,b) \<subseteq> A" @with
    @have "\<forall>c\<in>closed_interval(X,a,b). c \<in> A" @with
      @contradiction
      @let "U = A \<inter> less_interval(X,c)"
      @let "V = A \<inter> greater_interval(X,c)"
      @have "U \<inter> V = \<emptyset>" @have "U \<union> V = A"
      @have "separation(subspace(X,A),U,V)" @end @end
@qed

lemma continuum_connected_aux [backward1]:
  "order_topology(X) \<Longrightarrow> linear_continuum(X) \<Longrightarrow> a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow>
   carrier(X) = closed_interval(X,a,b) \<Longrightarrow> \<not>separation(X,A,B)"
@proof
  @contradiction
  @have "has_sup(X,A)" @with @have "b \<in> upper_bound(X,A)" @end
  @let "c = sup(X,A)"
  @case "c \<in> A" @with
    @have "c \<noteq> b"
    @obtain e where "e >\<^sub>X c" "closed_open_interval(X,c,e) \<subseteq> A"
    @obtain z where "c <\<^sub>X z \<and> z <\<^sub>X e"
    @have "z \<in> closed_open_interval(X,c,e)" @end
  @case "c \<in> B" @with
    @have "c \<noteq> a"
    @obtain d where "d <\<^sub>X c" "open_closed_interval(X,d,c) \<subseteq> B"
    @have "d \<in> upper_bound(X,A)" @with
      @have "\<forall>x\<in>A. d \<ge>\<^sub>X x" @with
        @have "x \<notin> open_closed_interval(X,d,c)" @end @end @end
@qed

lemma separation_subspace [backward2]:
  "C \<subseteq> carrier(X) \<Longrightarrow> separation(X,A,B) \<Longrightarrow> C \<inter> A \<noteq> \<emptyset> \<Longrightarrow> C \<inter> B \<noteq> \<emptyset> \<Longrightarrow>
   separation(subspace(X,C), C \<inter> A, C \<inter> B)" by auto2

lemma continuum_connected [forward]:
  "order_topology(X) \<Longrightarrow> linear_continuum(X) \<Longrightarrow> connected(X)"
@proof
  @contradiction
  @obtain A B where "separation(X,A,B)"
  @obtain "a \<in> A" @obtain "b \<in> B"
  @case "a <\<^sub>X b" @with
    @let "I = closed_interval(X,a,b)"
    @let "Y = ord_subspace(X,I)"
    @have "linear_continuum(Y)" @with @have "eq_str_order(suborder(X,I),Y)" @end
    @have "carrier(Y) = closed_interval(Y,a,b)"
    @have "separation(Y,I \<inter> A,I \<inter> B)" @with @have "eq_str_top(subspace(X,I),Y)" @end @end
  @case "b <\<^sub>X a" @with
    @let "I = closed_interval(X,b,a)"
    @let "Y = ord_subspace(X,I)"
    @have "linear_continuum(Y)" @with @have "eq_str_order(suborder(X,I),Y)" @end
    @have "carrier(Y) = closed_interval(Y,b,a)"
    @have "separation(X,B,A)"
    @have "separation(Y,I \<inter> B,I \<inter> A)" @with @have "eq_str_top(subspace(X,I),Y)" @end @end
@qed

end


(*  Title:      Sort.thy
    Author:     Danijela Petrovi\'c, Facylty of Mathematics, University of Belgrade *)

section \<open>Verification of Imperative Heap Sort\<close>

theory HeapImperative
imports Heap
begin

primrec left :: "'a Tree \<Rightarrow> 'a Tree" where
  "left (T v l r) = l"

abbreviation left_val :: "'a Tree \<Rightarrow> 'a" where
  "left_val t \<equiv> val (left t)"

primrec right :: "'a Tree \<Rightarrow> 'a Tree" where
  "right (T v l r) = r"

abbreviation right_val :: "'a Tree \<Rightarrow> 'a" where
  "right_val t \<equiv> val (right t)"

abbreviation set_val :: "'a Tree \<Rightarrow> 'a \<Rightarrow> 'a Tree" where
  "set_val t x \<equiv> T x (left t) (right t)"

text\<open>The first step is to implement function {\em siftDown}. If some node
does not satisfy heap property, this function moves it down the heap
until it does. For a node is checked weather it satisfies heap property or not. If it
does nothing is changed. If it does not, value of the root node
becomes a value of the larger child and the value of that child
becomes the value of the root node. This is the reason this function
is called {\tt siftDown} -- value of the node is places down in the
heap. Now, the problem is that the child node may not satisfy the heap
property and that is the reason why function {\tt siftDown} is
recursively applied.\<close>

fun siftDown :: "'a::linorder Tree \<Rightarrow> 'a Tree" where
   "siftDown E = E"
|  "siftDown (T v E E) = T v E E"
|  "siftDown (T v l E) =
        (if v \<ge> val l then T v l E else T (val l) (siftDown (set_val l v)) E)"
|  "siftDown (T v E r) =
        (if v \<ge> val r then T v E r else T (val r) E (siftDown (set_val r v)))"
|  "siftDown (T v l r) =
        (if val l \<ge> val r then
            if v \<ge> val l then T v l r else T (val l) (siftDown (set_val l v)) r
        else
            if v \<ge> val r then T v l r else T (val r) l (siftDown (set_val r v)))"

lemma siftDown_Node:
  assumes "t = T v l r"
  shows "\<exists> l' v' r'. siftDown t = T v' l' r' \<and> v' \<ge> v"
using assms
apply(induct t rule:siftDown.induct)
by auto

lemma siftDown_in_tree:
  assumes "t \<noteq> E"
  shows "in_tree (val (siftDown t)) t"
using assms
apply(induct t rule:siftDown.induct)
by auto

lemma siftDown_in_tree_set:
  shows "in_tree v t \<longleftrightarrow> in_tree v (siftDown t)"
proof
  assume "in_tree v t"
  thus "in_tree v (siftDown t)"
    apply (induct t rule:siftDown.induct)
    by auto
next
  assume " in_tree v (siftDown t)"
  thus "in_tree v t"
  proof (induct t rule:siftDown.induct)
    case 1
    thus ?case
      by auto
  next
    case (2 v1)
    thus ?case
      by auto
  next
    case (3 v2 v1 l1 r1)
    show ?case
    proof(cases "v2 \<ge> v1")
      case True
      thus ?thesis
        using 3
        by auto
    next
      case False
      show ?thesis
      proof(cases "v1 = v")
        case True
        thus ?thesis
          using 3 False
          by auto
      next
        case False
        hence "in_tree v (siftDown (set_val (T v1 l1 r1) v2))"
          using \<open>\<not> v2 \<ge> v1\<close> 3(2)
          by auto
        hence "in_tree v (T v2 l1 r1)"
          using 3(1) \<open>\<not> v2 \<ge> v1\<close>
          by auto
        thus ?thesis
        proof(cases "v2 = v")
          case True
          thus ?thesis
            by auto
        next
          case False
          hence "in_tree v (T v1 l1 r1)"
            using \<open>in_tree v (T v2 l1 r1)\<close>
            by auto
          thus ?thesis
            by auto
        qed
      qed
    qed
  next
    case (4 v2 v1 l1 r1)
    show ?case
    proof(cases "v2 \<ge> v1")
      case True
      thus ?thesis
        using 4
        by auto
    next
      case False
      show ?thesis
      proof(cases "v1 = v")
        case True
        thus ?thesis
          using 4 False
          by auto
      next
        case False
        hence "in_tree v (siftDown (set_val (T v1 l1 r1) v2))"
          using \<open>\<not> v2 \<ge> v1\<close> 4(2)
          by auto
        hence "in_tree v (T v2 l1 r1)"
          using 4(1) \<open>\<not> v2 \<ge> v1\<close>
          by auto
        thus ?thesis
        proof(cases "v2 = v")
          case True
          thus ?thesis
            by auto
        next
          case False
          hence "in_tree v (T v1 l1 r1)"
            using \<open>in_tree v (T v2 l1 r1)\<close>
            by auto
          thus ?thesis
            by auto
        qed
      qed
    qed
  next
    case ("5_1" v' v1 l1 r1 v2 l2 r2)
    show ?case
    proof(cases "v = v' \<or> v= v1 \<or> v = v2")
      case True
      thus ?thesis
        by auto
    next
      case False
      show ?thesis
      proof(cases "v1 \<ge> v2")
        case True
        show ?thesis
        proof(cases "v' \<ge> v1")
          case True
          thus ?thesis
            using \<open>v1 \<ge> v2\<close> "5_1"
            by auto
        next
          case False
          thus ?thesis
          proof(cases "in_tree v (T v2 l2 r2)")
            case True
            thus ?thesis
              by auto
          next
            case False
            hence "in_tree v (siftDown (set_val (T v1 l1 r1) v'))"
              using "5_1"(3) \<open>\<not> in_tree v (T v2 l2 r2)\<close> \<open>v1 \<ge> v2\<close> \<open>\<not> v' \<ge> v1\<close>
              using \<open> \<not> (v = v' \<or> v = v1 \<or> v = v2)\<close>
              by auto
            hence "in_tree v (T v' l1 r1)"
              using "5_1"(1) \<open>v1 \<ge> v2\<close> \<open>\<not> v' \<ge> v1\<close>
              by auto
            hence "in_tree v (T v1 l1 r1)"
              using  \<open>\<not> (v = v' \<or> v = v1 \<or> v = v2)\<close>
              by auto
            thus ?thesis
              by auto
          qed
        qed
      next
        case False
        show ?thesis
        proof(cases "v' \<ge> v2")
          case True
          thus ?thesis
            using \<open>\<not> v1 \<ge> v2\<close> "5_1"
            by auto
        next
          case False
          thus ?thesis
          proof(cases "in_tree v (T v1 l1 r1)")
            case True
            thus ?thesis
              by auto
          next
            case False
            hence "in_tree v (siftDown (set_val (T v2 l2 r2) v'))"
              using "5_1"(3) \<open>\<not> in_tree v (T v1 l1 r1)\<close> \<open>\<not> v1 \<ge> v2\<close> \<open>\<not> v' \<ge> v2\<close>
              using \<open> \<not> (v = v' \<or> v = v1 \<or> v = v2)\<close>
              by auto
            hence "in_tree v (T v' l2 r2)"
              using "5_1"(2) \<open>\<not> v1 \<ge> v2\<close> \<open>\<not> v' \<ge> v2\<close>
              by auto
            hence "in_tree v (T v2 l2 r2)"
              using  \<open>\<not> (v = v' \<or> v = v1 \<or> v = v2)\<close>
              by auto
            thus ?thesis
              by auto
          qed
        qed
      qed
    qed
  next
    case ("5_2" v' v1 l1 r1 v2 l2 r2)
    show ?case
    proof(cases "v = v' \<or> v= v1 \<or> v = v2")
      case True
      thus ?thesis
        by auto
    next
      case False
      show ?thesis
      proof(cases "v1 \<ge> v2")
        case True
        show ?thesis
        proof(cases "v' \<ge> v1")
          case True
          thus ?thesis
            using \<open>v1 \<ge> v2\<close> "5_2"
            by auto
        next
          case False
          thus ?thesis
          proof(cases "in_tree v (T v2 l2 r2)")
            case True
            thus ?thesis
              by auto
          next
            case False
            hence "in_tree v (siftDown (set_val (T v1 l1 r1) v'))"
              using "5_2"(3) \<open>\<not> in_tree v (T v2 l2 r2)\<close> \<open>v1 \<ge> v2\<close> \<open>\<not> v' \<ge> v1\<close>
              using \<open> \<not> (v = v' \<or> v = v1 \<or> v = v2)\<close>
              by auto
            hence "in_tree v (T v' l1 r1)"
              using "5_2"(1) \<open>v1 \<ge> v2\<close> \<open>\<not> v' \<ge> v1\<close>
              by auto
            hence "in_tree v (T v1 l1 r1)"
              using  \<open>\<not> (v = v' \<or> v = v1 \<or> v = v2)\<close>
              by auto
            thus ?thesis
              by auto
          qed
        qed
      next
        case False
        show ?thesis
        proof(cases "v' \<ge> v2")
          case True
          thus ?thesis
            using \<open>\<not> v1 \<ge> v2\<close> "5_2"
            by auto
        next
          case False
          thus ?thesis
          proof(cases "in_tree v (T v1 l1 r1)")
            case True
            thus ?thesis
              by auto
          next
            case False
            hence "in_tree v (siftDown (set_val (T v2 l2 r2) v'))"
              using "5_2"(3) \<open>\<not> in_tree v (T v1 l1 r1)\<close> \<open>\<not> v1 \<ge> v2\<close> \<open>\<not> v' \<ge> v2\<close>
              using \<open> \<not> (v = v' \<or> v = v1 \<or> v = v2)\<close>
              by auto
            hence "in_tree v (T v' l2 r2)"
              using "5_2"(2) \<open>\<not> v1 \<ge> v2\<close> \<open>\<not> v' \<ge> v2\<close>
              by auto
            hence "in_tree v (T v2 l2 r2)"
              using  \<open>\<not> (v = v' \<or> v = v1 \<or> v = v2)\<close>
              by auto
            thus ?thesis
              by auto
          qed
        qed
      qed
    qed
  qed
qed

lemma siftDown_heap_is_heap:
  assumes "is_heap l" "is_heap r" "t = T v l r"
  shows "is_heap (siftDown t)"
using assms
proof (induct t arbitrary: v l r  rule:siftDown.induct)
  case 1
  thus ?case
    by simp
next
  case (2 v')
  show ?case
    by simp
next
  case (3 v2 v1 l1 r1)
  show ?case
  proof (cases "v2 \<ge> v1")
    case True
    thus ?thesis
      using 3(2) 3(4)
      by auto
  next
    case False
    show ?thesis
    proof-
      let ?t = "siftDown (T v2 l1 r1)"
      obtain l' v' r' where *: "?t = T v' l' r'" "v' \<ge> v2"
        using siftDown_Node[of "T v2 l1 r1" v2 l1 r1]
        by auto
      have "l = T v1 l1 r1"
        using 3(4)
        by auto
      hence "is_heap l1" "is_heap r1"
        using 3(2)
        apply (induct l rule:is_heap.induct)
        by auto
      hence "is_heap ?t"
        using 3(1)[of l1 r1 v2] False 3
        by auto
      show ?thesis
      proof (cases "v' = v2")
        case True
        thus ?thesis
          using False \<open>is_heap ?t\<close> *
          by auto
      next
        case False
        have "in_tree v' ?t"
          using *
          using siftDown_in_tree[of ?t]
          by simp
        hence "in_tree v' (T v2 l1 r1)"
          using siftDown_in_tree_set[symmetric, of v' "T v2 l1 r1"]
          by auto
        hence "in_tree v' (T v1 l1 r1)"
          using False
          by simp
        hence "v1 \<ge> v'"
          using 3
          using is_heap_max[of v' "T v1 l1 r1"]
          by auto
        thus ?thesis
          using \<open>is_heap ?t\<close> * \<open>\<not> v2 \<ge> v1\<close>
          by auto
      qed
    qed
  qed
next
  case (4 v2 v1 l1 r1)
  show ?case
  proof(cases "v2 \<ge> v1")
    case True
    thus ?thesis
      using 4(2-4)
      by auto
  next
    case False
    let ?t = "siftDown (T v2 l1 r1)"
    obtain v' l' r' where *: "?t = T v' l' r'" "v' \<ge> v2"
      using siftDown_Node[of "T v2 l1 r1" v2 l1 r1]
      by auto
    have "r = T v1 l1 r1"
      using 4(4)
      by auto
    hence "is_heap l1" "is_heap r1"
      using 4(3)
      apply (induct r rule:is_heap.induct)
      by auto
    hence "is_heap ?t"
      using False  4(1)[of l1 r1 v2]
      by auto
    show ?thesis
    proof(cases "v' = v2")
      case True
      thus ?thesis
        using * \<open>is_heap ?t\<close> False
        by auto
    next
      case False
      have "in_tree v' ?t"
        using *
        using siftDown_in_tree[of ?t]
        by auto
      hence "in_tree v' (T v2 l1 r1)"
        using * siftDown_in_tree_set[of v' "T v2 l1 r1"]
        by auto
      hence "in_tree v' (T v1 l1 r1)"
        using False
        by auto
      hence "v1 \<ge> v'"
        using is_heap_max[of v' "T v1 l1 r1"] 4
        by auto
      thus ?thesis
        using \<open>is_heap ?t\<close> False *
        by auto
    qed
  qed
next
  case ("5_1" v1 v2 l2 r2 v3 l3 r3)
  show ?case
  proof(cases "v2 \<ge> v3")
    case True
    show ?thesis
    proof(cases "v1 \<ge> v2")
      case True
      thus ?thesis
        using \<open>v2 \<ge> v3\<close> "5_1"
        by auto
    next
      case False
      let ?t = "siftDown (T v1 l2 r2)"
      obtain l' v' r' where *: "?t = T v' l' r'" "v' \<ge> v1"
        using siftDown_Node
        by blast
      have "is_heap l2" "is_heap r2"
        using "5_1"(3, 5)
        apply(induct l rule:is_heap.induct)
        by auto
      hence "is_heap ?t"
        using "5_1"(1)[of l2 r2 v1] \<open>v2 \<ge> v3\<close> False
        by auto
      have "v2 \<ge> v'"
      proof(cases "v' = v1")
        case True
        thus ?thesis
          using False
          by auto
      next
        case False
        have "in_tree v' ?t"
          using * siftDown_in_tree
          by auto
        hence "in_tree v' (T v1 l2 r2)"
          using siftDown_in_tree_set[of v' "T v1 l2 r2"]
          by auto
        hence "in_tree v' (T v2 l2 r2)"
          using False
          by auto
        thus ?thesis
          using is_heap_max[of v' "T v2 l2 r2"] "5_1"
          by auto
      qed
      thus ?thesis
        using \<open>is_heap ?t\<close> \<open>v2 \<ge> v3\<close> * False "5_1"
        by auto
    qed
  next
    case False
    show ?thesis
    proof(cases "v1 \<ge> v3")
      case True
      thus ?thesis
        using \<open>\<not> v2 \<ge> v3\<close> "5_1"
        by auto
    next
      case False
      let ?t = "siftDown (T v1 l3 r3)"
      obtain l' v' r' where *: "?t = T v' l' r'" "v' \<ge> v1"
        using siftDown_Node
        by blast
      have "is_heap l3" "is_heap r3"
        using "5_1"(4, 5)
        apply(induct r rule:is_heap.induct)
        by auto
      hence "is_heap ?t"
        using "5_1"(2)[of l3 r3 v1] \<open>\<not> v2 \<ge> v3\<close> False
        by auto
      have "v3 \<ge> v'"
      proof(cases "v' = v1")
        case True
        thus ?thesis
          using False
          by auto
      next
        case False
        have "in_tree v' ?t"
          using * siftDown_in_tree
          by auto
        hence "in_tree v' (T v1 l3 r3)"
          using siftDown_in_tree_set[of v' "T v1 l3 r3"]
          by auto
        hence "in_tree v' (T v3 l3 r3)"
          using False
          by auto
        thus ?thesis
          using is_heap_max[of v' "T v3 l3 r3"] "5_1"
          by auto
      qed
      thus ?thesis
        using \<open>is_heap ?t\<close> \<open>\<not> v2 \<ge> v3\<close> * False "5_1"
        by auto
    qed
  qed
next
  case ("5_2" v1 v2 l2 r2 v3 l3 r3)
  show ?case
  proof(cases "v2 \<ge> v3")
    case True
    show ?thesis
    proof(cases "v1 \<ge> v2")
      case True
      thus ?thesis
        using \<open>v2 \<ge> v3\<close> "5_2"
        by auto
    next
      case False
      let ?t = "siftDown (T v1 l2 r2)"
      obtain l' v' r' where *: "?t = T v' l' r'" "v1 \<le> v'"
        using siftDown_Node
        by blast
      have "is_heap l2" "is_heap r2"
        using "5_2"(3, 5)
        apply(induct l rule:is_heap.induct)
        by auto
      hence "is_heap ?t"
        using "5_2"(1)[of l2 r2 v1] \<open>v2 \<ge> v3\<close> False
        by auto
      have "v2 \<ge> v'"
      proof(cases "v' = v1")
        case True
        thus ?thesis
          using False
          by auto
      next
        case False
        have "in_tree v' ?t"
          using * siftDown_in_tree
          by auto
        hence "in_tree v' (T v1 l2 r2)"
          using siftDown_in_tree_set[of v' "T v1 l2 r2"]
          by auto
        hence "in_tree v' (T v2 l2 r2)"
          using False
          by auto
        thus ?thesis
          using is_heap_max[of v' "T v2 l2 r2"] "5_2"
          by auto
      qed
      thus ?thesis
        using \<open>is_heap ?t\<close> \<open>v2 \<ge> v3\<close> * False "5_2"
        by auto
    qed
  next
    case False
    show ?thesis
    proof(cases "v1 \<ge> v3")
      case True
      thus ?thesis
        using \<open>\<not> v2 \<ge> v3\<close> "5_2"
        by auto
    next
      case False
      let ?t = "siftDown (T v1 l3 r3)"
      obtain l' v' r' where *: "?t = T v' l' r'" "v' \<ge> v1"
        using siftDown_Node
        by blast
      have "is_heap l3" "is_heap r3"
        using "5_2"(4, 5)
        apply(induct r rule:is_heap.induct)
        by auto
      hence "is_heap ?t"
        using "5_2"(2)[of l3 r3 v1] \<open>\<not> v2 \<ge> v3\<close> False
        by auto
      have "v3 \<ge> v'"
      proof(cases "v' = v1")
        case True
        thus ?thesis
          using False
          by auto
      next
        case False
        have "in_tree v' ?t"
          using * siftDown_in_tree
          by auto
        hence "in_tree v' (T v1 l3 r3)"
          using siftDown_in_tree_set[of v' "T v1 l3 r3"]
          by auto
        hence "in_tree v' (T v3 l3 r3)"
          using False
          by auto
        thus ?thesis
          using is_heap_max[of v' "T v3 l3 r3"] "5_2"
          by auto
      qed
      thus ?thesis
        using \<open>is_heap ?t\<close> \<open>\<not> v2 \<ge> v3\<close> * False "5_2"
        by auto
    qed
  qed
qed

text\<open>Definition of the function {\em heapify} which
makes a heap from any given binary tree.\<close>

primrec heapify where
   "heapify E = E"
|  "heapify (T v l r) = siftDown (T v (heapify l) (heapify r))"

lemma heapify_heap_is_heap:
  "is_heap (heapify t)"
proof(induct t)
  case E
  thus ?case
    by auto
next
  case (T v l r)
  thus ?case
    using siftDown_heap_is_heap[of "heapify l" "heapify r" "T v (heapify l) (heapify r)" v]
    by auto
qed

text\<open>Definition of {\em removeLeaf} function.  Function returns two values. The first one
is the value of romoved leaf element. The second returned value is tree without that leaf.\<close>

fun removeLeaf:: "'a::linorder Tree \<Rightarrow> 'a \<times> 'a Tree" where
  "removeLeaf (T v E E) = (v, E)"
| "removeLeaf (T v l E) = (fst (removeLeaf l), T v (snd (removeLeaf l)) E)"
| "removeLeaf (T v E r) = (fst (removeLeaf r), T v E (snd (removeLeaf r)))"
| "removeLeaf (T v l r) = (fst (removeLeaf l), T v (snd (removeLeaf l)) r)"

text\<open>Function {\em of\_list\_tree} makes a binary tree from any given
list.\<close>

primrec of_list_tree:: "'a::linorder list \<Rightarrow> 'a Tree" where
  "of_list_tree [] = E"
| "of_list_tree (v # tail) = T v (of_list_tree tail) E"

text\<open>By applying {\em heapify} binary tree is transformed into
heap.\<close>

definition hs_of_list where
  "hs_of_list l = heapify (of_list_tree l)"

text\<open>Definition of function {\em hs\_remove\_max}. As it is already well
established, finding maximum is not a problem, since it is in the root
element of the heap. The root element is replaced with leaf of the
heap and that leaf is erased from its previous position. However, now
the new root element may not satisfy heap property and that is the
reason to apply function {\em siftDown}.\<close>

definition hs_remove_max :: "'a::linorder Tree \<Rightarrow> 'a \<times> 'a Tree" where
  "hs_remove_max t \<equiv>
     (let v' = fst (removeLeaf t);
          t' = snd (removeLeaf t) in
     (if t' = E then (val t, E)
      else (val t, siftDown (set_val t' v'))))"

definition hs_is_empty where
[simp]: "hs_is_empty t \<longleftrightarrow>  t = E"

lemma siftDown_multiset:
  "multiset (siftDown t) = multiset t"
proof(induct t rule:siftDown.induct)
  case 1
  thus ?case
    by simp
next
  case (2 v)
  thus ?case
    by simp
next
  case (3 v1 v l r)
  thus ?case
  proof(cases "v \<le> v1")
    case True
    thus ?thesis
      by auto
  next
    case False
    hence "multiset (siftDown (T v1 (T v l r) E)) =
           multiset l + {#v1#} + multiset r + {#v#}"
      using 3
      by auto
    moreover
    have "multiset (T v1 (T v l r) E) =
          multiset l + {#v#} + multiset r + {#v1#}"
      by auto
    moreover
    have "multiset l + {#v1#} + multiset r + {#v#} =
          multiset l + {#v#} + multiset r + {#v1#}"
      by (metis union_commute union_lcomm)
    ultimately
    show ?thesis
      by auto
  qed
next
  case (4 v1 v l r)
  thus ?case
  proof(cases "v \<le> v1")
    case True
    thus ?thesis
      by auto
  next
    case False
    have "multiset (set_val (T v l r) v1) =
          multiset l + {#v1#} + multiset r"
      by auto
    hence "multiset (siftDown (T v1 E (T v l r))) =
           {#v#} +  multiset (set_val (T v l r) v1)"
      using 4 False
      by auto
    hence "multiset (siftDown (T v1 E (T v l r))) =
           {#v#} + multiset l + {#v1#} + multiset r"
      using \<open>multiset (set_val (T v l r) v1) =
             multiset l + {#v1#} + multiset r\<close>
      by (metis union_commute union_lcomm)
    moreover
    have "multiset (T v1 E (T v l r)) =
          {#v1#} + multiset l + {#v#} + multiset r"
      by (metis calculation monoid_add_class.add.left_neutral
          multiset.simps(1) multiset.simps(2) union_commute union_lcomm)
    moreover
    have "{#v#} + multiset l + {#v1#} + multiset r =
          {#v1#} + multiset l + {#v#} + multiset r"
      by (metis union_commute union_lcomm)
    ultimately
    show ?thesis
      by auto
  qed
next
  case ("5_1" v v1 l1 r1 v2 l2 r2)
  thus ?case
  proof(cases "v1 \<ge> v2")
    case True
    thus ?thesis
    proof(cases "v \<ge> v1")
      case True
      thus ?thesis
        using \<open>v1 \<ge> v2\<close>
        by auto
    next
      case False
      hence "multiset (siftDown (T v (T v1 l1 r1) (T v2 l2 r2))) =
             multiset l1 + {#v#} + multiset r1 + {#v1#} +
             multiset (T v2 l2 r2)"
        using \<open>v1 \<ge> v2\<close> "5_1"(1)
        by auto
      moreover
      have "multiset (T v (T v1 l1 r1) (T v2 l2 r2)) =
              multiset l1 + {#v1#} + multiset r1 + {#v#} +
              multiset(T v2 l2 r2)"
        by auto
      moreover
      have "multiset l1 + {#v1#} + multiset r1 + {#v#} +
            multiset(T v2 l2 r2) =
                multiset l1 + {#v#} + multiset r1 + {#v1#} +
                multiset (T v2 l2 r2)"
        by (metis union_commute union_lcomm)
      ultimately
      show ?thesis
        by auto
    qed
  next
    case False
    show ?thesis
    proof(cases "v \<ge> v2")
      case True
      thus ?thesis
        using False
        by auto
    next
      case False
      hence "multiset (siftDown (T v (T v1 l1 r1) (T v2 l2 r2))) =
             multiset (T v1 l1 r1) + {#v2#} +
             multiset l2 + {#v#} + multiset r2"
        using \<open>\<not> v1 \<ge> v2\<close> "5_1"(2)
        by (simp add: ac_simps)
      moreover
      have
        "multiset (T v (T v1 l1 r1) (T v2 l2 r2)) =
         multiset (T v1 l1 r1) + {#v#} + multiset l2 +
         {#v2#} + multiset r2"
        by simp
      moreover
      have
        "multiset (T v1 l1 r1) + {#v#} + multiset l2 + {#v2#} +
         multiset r2 =
            multiset (T v1 l1 r1) + {#v2#} + multiset l2 +
            {#v#} + multiset r2"
        by (metis union_commute union_lcomm)
      ultimately
      show ?thesis
        by auto
    qed
  qed
next
  case ("5_2" v v1 l1 r1 v2 l2 r2)
  thus ?case
  proof(cases "v1 \<ge> v2")
    case True
    thus ?thesis
    proof(cases "v \<ge> v1")
      case True
      thus ?thesis
        using \<open>v1 \<ge> v2\<close>
        by auto
    next
      case False
      hence "multiset (siftDown (T v (T v1 l1 r1) (T v2 l2 r2))) =
               multiset l1 + {#v#} + multiset r1 + {#v1#} +
               multiset (T v2 l2 r2)"
        using \<open>v1 \<ge> v2\<close> "5_2"(1)
        by auto
      moreover
      have "multiset (T v (T v1 l1 r1) (T v2 l2 r2)) =
              multiset l1 + {#v1#} + multiset r1 +
              {#v#} + multiset(T v2 l2 r2)"
        by auto
      moreover
      have "multiset l1 + {#v1#} + multiset r1 + {#v#} +
            multiset(T v2 l2 r2) =
              multiset l1 + {#v#} + multiset r1 + {#v1#} +
              multiset (T v2 l2 r2)"
        by (metis union_commute union_lcomm)
      ultimately
      show ?thesis
        by auto
    qed
  next
    case False
    show ?thesis
    proof(cases "v \<ge> v2")
      case True
      thus ?thesis
        using False
        by auto
    next
      case False
      hence "multiset (siftDown (T v (T v1 l1 r1) (T v2 l2 r2))) =
               multiset (T v1 l1 r1) + {#v2#} + multiset l2 + {#v#} +
               multiset r2"
        using \<open>\<not> v1 \<ge> v2\<close> "5_2"(2)
        by (simp add: ac_simps)
      moreover
      have "multiset (T v (T v1 l1 r1) (T v2 l2 r2)) =
              multiset (T v1 l1 r1) + {#v#} + multiset l2 + {#v2#} +
              multiset r2"
        by simp
      moreover
      have "multiset (T v1 l1 r1) + {#v#} + multiset l2 + {#v2#} +
            multiset r2 =
              multiset (T v1 l1 r1) + {#v2#} + multiset l2 + {#v#} +
              multiset r2"
        by (metis union_commute union_lcomm)
      ultimately
      show ?thesis
        by auto
    qed
  qed
qed

lemma mset_list_tree:
 "multiset (of_list_tree l) = mset l"
proof(induct l)
  case Nil
  thus ?case
    by auto
next
  case (Cons v tail)
  hence "multiset (of_list_tree (v # tail)) = mset tail + {#v#}"
    by auto
  also have "... = mset (v # tail)"
    by auto
  finally show "multiset (of_list_tree (v # tail)) = mset (v # tail)"
    by auto
qed

lemma multiset_heapify:
  "multiset (heapify t) = multiset t"
proof(induct t)
  case E
  thus ?case
    by auto
next
  case (T v l r)
  hence "multiset (heapify (T v l r)) = multiset l + {#v#} + multiset r"
    using siftDown_multiset[of "T v (heapify l) (heapify r)"]
    by auto
  thus ?case
    by auto
qed

lemma multiset_heapify_of_list_tree:
  "multiset (heapify (of_list_tree l)) = mset l"
using multiset_heapify[of "of_list_tree l"]
using mset_list_tree[of l]
by auto

lemma removeLeaf_val_val:
  assumes "snd (removeLeaf t) \<noteq> E" "t \<noteq> E"
  shows "val t = val (snd (removeLeaf t))"
using assms
apply (induct t rule:removeLeaf.induct)
by auto

lemma removeLeaf_heap_is_heap:
  assumes "is_heap t" "t \<noteq> E"
  shows "is_heap (snd (removeLeaf t))"
using assms
proof(induct t rule:removeLeaf.induct)
  case (1 v)
  thus ?case
    by auto
next
  case (2 v v1 l1 r1)
  have "is_heap (T v1 l1 r1)"
    using 2(3)
    by auto
  hence "is_heap (snd (removeLeaf (T v1 l1 r1)))"
    using 2(1)
    by auto
  let ?t = "(snd (removeLeaf (T v1 l1 r1)))"
  show ?case
  proof(cases "?t = E")
    case True
    thus ?thesis
      by auto
  next
    case False
    have "v \<ge> v1"
      using 2(3)
      by auto
    hence "v \<ge> val ?t"
      using False removeLeaf_val_val[of "T v1 l1 r1"]
      by auto
    hence "is_heap (T v (snd (removeLeaf (T v1 l1 r1))) E)"
      using \<open>is_heap (snd (removeLeaf (T v1 l1 r1)))\<close>
      by (metis Tree.exhaust is_heap.simps(2) is_heap.simps(4))
    thus ?thesis
      using 2
      by auto
  qed
next
  case (3 v v1 l1 r1)
  have "is_heap (T v1 l1 r1)"
    using 3(3)
    by auto
  hence "is_heap (snd (removeLeaf (T v1 l1 r1)))"
    using 3(1)
    by auto
  let ?t = "(snd (removeLeaf (T v1 l1 r1)))"
  show ?case
  proof(cases "?t = E")
    case True
    thus ?thesis
      by auto
  next
    case False
    have "v \<ge> v1"
      using 3(3)
      by auto
    hence "v \<ge> val ?t"
      using False removeLeaf_val_val[of "T v1 l1 r1"]
      by auto
    hence "is_heap (T v E (snd (removeLeaf (T v1 l1 r1))))"
      using \<open>is_heap (snd (removeLeaf (T v1 l1 r1)))\<close>
      by (metis False Tree.exhaust is_heap.simps(3))
    thus ?thesis
      using 3
      by auto
  qed
next
  case ("4_1" v v1 l1 r1 v2 l2 r2)
  have "is_heap (T v1 l1 r1)" "is_heap (T v2 l2 r2)" "v \<ge> v1" "v \<ge> v2"
    using "4_1"(3)
    by (simp add:is_heap.simps(5))+
  hence "is_heap (snd (removeLeaf (T v1 l1 r1)))"
    using "4_1"(1)
    by auto
  let ?t = "(snd (removeLeaf (T v1 l1 r1)))"
  show ?case
  proof(cases "?t = E")
    case True
    thus ?thesis
      using \<open>is_heap (T v2 l2 r2)\<close> \<open>v \<ge> v2\<close>
      by auto
  next
    case False
    then obtain v1' l1' r1' where "?t = T v1' l1' r1'"
      by (metis Tree.exhaust)
    hence "is_heap (T v1' l1' r1')"
      using \<open>is_heap (snd (removeLeaf (T v1 l1 r1)))\<close>
      by auto
    have "v \<ge> v1"
      using "4_1"(3)
      by auto
    hence "v \<ge> val ?t"
      using False removeLeaf_val_val[of "T v1 l1 r1"]
      by auto
    hence "v \<ge> v1'"
      using \<open>?t = T v1' l1' r1'\<close>
      by auto
    hence "is_heap (T v (T v1' l1' r1') (T v2 l2 r2))"
      using \<open>is_heap (T v1' l1' r1')\<close>
      using \<open>is_heap (T v2 l2 r2)\<close> \<open>v \<ge> v2\<close>
      by (simp add: is_heap.simps(5))
    thus ?thesis
      using "4_1" \<open>?t = T v1' l1' r1'\<close>
      by auto
  qed
next
  case ("4_2" v v1 l1 r1 v2 l2 r2)
  have "is_heap (T v1 l1 r1)" "is_heap (T v2 l2 r2)" "v \<ge> v1" "v \<ge> v2"
    using "4_2"(3)
    by (simp add:is_heap.simps(5))+
  hence "is_heap (snd (removeLeaf (T v1 l1 r1)))"
    using "4_2"(1)
    by auto
  let ?t = "(snd (removeLeaf (T v1 l1 r1)))"
  show ?case
  proof(cases "?t = E")
    case True
    thus ?thesis
      using \<open>is_heap (T v2 l2 r2)\<close> \<open>v \<ge> v2\<close>
      by auto
  next
    case False
    then obtain v1' l1' r1' where "?t = T v1' l1' r1'"
      by (metis Tree.exhaust)
    hence "is_heap (T v1' l1' r1')"
      using \<open>is_heap (snd (removeLeaf (T v1 l1 r1)))\<close>
      by auto
    have "v \<ge> v1"
      using "4_2"(3)
      by auto
    hence "v \<ge> val ?t"
      using False removeLeaf_val_val[of "T v1 l1 r1"]
      by auto
    hence "v \<ge> v1'"
      using \<open>?t = T v1' l1' r1'\<close>
      by auto
    hence "is_heap (T v (T v1' l1' r1') (T v2 l2 r2))"
      using \<open>is_heap (T v1' l1' r1')\<close>
      using \<open>is_heap (T v2 l2 r2)\<close> \<open>v \<ge> v2\<close>
      by (simp add: is_heap.simps(5))
    thus ?thesis
      using "4_2" \<open>?t = T v1' l1' r1'\<close>
      by auto
  qed
next
  case 5
  thus ?case
    by auto
qed

text\<open>Difined functions satisfy conditions of locale {\em Collection} and thus represent
       interpretation of this locale.\<close>

interpretation HS: Collection "E" hs_is_empty hs_of_list multiset
proof
  fix t
  assume "hs_is_empty t"
  thus "t = E"
    by auto
next
  show "hs_is_empty E"
    by auto
next
  show "multiset E = {#}"
    by auto
next
  fix l
  show "multiset (hs_of_list l) = mset l"
    unfolding hs_of_list_def
    using multiset_heapify_of_list_tree[of l]
    by auto
qed

lemma removeLeaf_multiset:
  assumes "(v', t') = removeLeaf t" "t \<noteq> E"
  shows "{#v'#} + multiset t' = multiset t"
using assms
proof(induct t arbitrary: v' t' rule:removeLeaf.induct)
  case 1
  thus ?case
    by auto
next
  case (2 v v1 l1 r1)
  have "t' = T v (snd (removeLeaf (T v1 l1 r1))) E"
    using 2(3)
    by auto
  have "v' = fst (removeLeaf (T v1 l1 r1))"
    using 2(3)
    by auto
  hence "{#v'#} + multiset t' =
           {#fst (removeLeaf (T v1 l1 r1))#} +
           multiset (snd (removeLeaf (T v1 l1 r1))) +
           {#v#}"
    using \<open>t' = T v (snd (removeLeaf (T v1 l1 r1))) E\<close>
    by (simp add: ac_simps)
  have "{#fst (removeLeaf (T v1 l1 r1))#} +
        multiset (snd (removeLeaf (T v1 l1 r1))) =
          multiset (T v1 l1 r1)"
    using 2(1)
    by auto
  hence "{#v'#} + multiset t' = multiset (T v1 l1 r1) + {#v#}"
    using \<open>{#v'#} + multiset t' =
           {#fst (removeLeaf (T v1 l1 r1))#} +
           multiset (snd (removeLeaf (T v1 l1 r1))) + {#v#}\<close>
    by auto
  thus ?case
    by auto
next
  case (3 v v1 l1 r1)
  have "t' = T v E (snd (removeLeaf (T v1 l1 r1)))"
    using 3(3)
    by auto
  have "v' = fst (removeLeaf (T v1 l1 r1))"
    using 3(3)
    by auto
  hence "{#v'#} + multiset t' =
          {#fst (removeLeaf (T v1 l1 r1))#} +
          multiset (snd (removeLeaf (T v1 l1 r1))) +
          {#v#}"
    using \<open>t' = T v E (snd (removeLeaf (T v1 l1 r1)))\<close>
    by (simp add: ac_simps)
  have "{#fst (removeLeaf (T v1 l1 r1))#} +
        multiset (snd (removeLeaf (T v1 l1 r1))) =
          multiset (T v1 l1 r1)"
    using 3(1)
    by auto
  hence "{#v'#} + multiset t' = multiset (T v1 l1 r1) + {#v#}"
    using \<open>{#v'#} + multiset t' =
           {#fst (removeLeaf (T v1 l1 r1))#} +
           multiset (snd (removeLeaf (T v1 l1 r1))) + {#v#}\<close>
    by auto
  thus ?case
    by (metis monoid_add_class.add.right_neutral
        multiset.simps(1) multiset.simps(2) union_commute)
next
  case ("4_1" v v1 l1 r1 v2 l2 r2)
  have "t' = T v (snd (removeLeaf (T v1 l1 r1))) (T v2 l2 r2)"
    using "4_1"(3)
    by auto
  have "v' = fst (removeLeaf (T v1 l1 r1))"
    using "4_1"(3)
    by auto
  hence "{#v'#} + multiset t' =
         {#fst (removeLeaf (T v1 l1 r1))#} +
         multiset (snd (removeLeaf (T v1 l1 r1))) +
         {#v#} + multiset (T v2 l2 r2)"
    using \<open>t' = T v (snd (removeLeaf (T v1 l1 r1))) (T v2 l2 r2)\<close>
    by (metis multiset.simps(2) union_assoc)
  have "{#fst (removeLeaf (T v1 l1 r1))#} +
        multiset (snd (removeLeaf (T v1 l1 r1))) =
          multiset (T v1 l1 r1)"
    using "4_1"(1)
    by auto
  hence "{#v'#} + multiset t' =
           multiset (T v1 l1 r1) + {#v#} + multiset (T v2 l2 r2)"
    using \<open>{#v'#} + multiset t' =
           {#fst (removeLeaf (T v1 l1 r1))#} +
           multiset (snd (removeLeaf (T v1 l1 r1))) +
           {#v#} + multiset (T v2 l2 r2)\<close>
    by auto
  thus ?case
    by auto
next
  case ("4_2" v v1 l1 r1 v2 l2 r2)
  have "t' = T v (snd (removeLeaf (T v1 l1 r1))) (T v2 l2 r2)"
    using "4_2"(3)
    by auto
  have "v' = fst (removeLeaf (T v1 l1 r1))"
    using "4_2"(3)
    by auto
  hence "{#v'#} + multiset t' =
         {#fst (removeLeaf (T v1 l1 r1))#} +
         multiset (snd (removeLeaf (T v1 l1 r1))) +
         {#v#} + multiset (T v2 l2 r2)"
    using \<open>t' = T v (snd (removeLeaf (T v1 l1 r1))) (T v2 l2 r2)\<close>
    by (metis multiset.simps(2) union_assoc)
  have "{#fst (removeLeaf (T v1 l1 r1))#} +
        multiset (snd (removeLeaf (T v1 l1 r1))) =
          multiset (T v1 l1 r1)"
    using "4_2"(1)
    by auto
  hence "{#v'#} + multiset t' =
         multiset (T v1 l1 r1) + {#v#} + multiset (T v2 l2 r2)"
    using \<open>{#v'#} + multiset t' =
           {#fst (removeLeaf (T v1 l1 r1))#} +
           multiset (snd (removeLeaf (T v1 l1 r1))) +
           {#v#} + multiset (T v2 l2 r2)\<close>
    by auto
  thus ?case
    by auto
next
  case 5
  thus ?case
    by auto
qed

lemma set_val_multiset:
  assumes "t \<noteq> E"
  shows "multiset (set_val t v') +  {#val t#} = {#v'#} + multiset t"
proof-
  obtain v l r where "t = T v l r"
    using assms
    by (metis Tree.exhaust)
  hence "multiset (set_val t v') + {#val t#} =
         multiset l + {#v'#} + multiset r + {#v#}"
    by auto
  have "{#v'#} + multiset t =
        {#v'#} + multiset l + {#v#} + multiset r"
    using \<open>t = T v l r\<close>
    by (metis multiset.simps(2) union_assoc)
  have "{#v'#} + multiset l + {#v#} + multiset r =
        multiset l + {#v'#} + multiset r + {#v#}"
    by (metis union_commute union_lcomm)
  thus ?thesis
    using \<open>multiset (set_val t v') + {#val t#} =
           multiset l + {#v'#} + multiset r + {#v#}\<close>
    using \<open>{#v'#} + multiset t =
           {#v'#} + multiset l + {#v#} + multiset r\<close>
    by auto
qed

lemma hs_remove_max_multiset:
  assumes "(m, t') = hs_remove_max t" "t \<noteq> E"
  shows "{#m#} + multiset t' = multiset t"
proof-
  let ?v1 = "fst (removeLeaf t)"
  let ?t1 = "snd (removeLeaf t)"
  show ?thesis
  proof(cases "?t1 = E")
    case True
    hence "{#m#} + multiset t' = {#m#}"
      using assms
      unfolding hs_remove_max_def
      by auto
    have "?v1 = val t"
      using True assms(2)
      apply (induct t rule:removeLeaf.induct)
      by auto
    hence "?v1 = m"
      using assms(1) True
      unfolding hs_remove_max_def
      by auto
    hence "multiset t = {#m#}"
      using removeLeaf_multiset[of ?v1 ?t1 t] True assms(2)
      by (metis empty_neutral(2) multiset.simps(1) prod.collapse)
    thus ?thesis
      using \<open>{#m#} + multiset t' = {#m#}\<close>
      by auto
  next
    case False
    hence "t' = siftDown (set_val ?t1 ?v1)"
      using assms(1)
      by (auto simp add: hs_remove_max_def) (metis prod.inject)
    hence "multiset t' + {#val ?t1#} = multiset t"
      using siftDown_multiset[of "set_val ?t1 ?v1"]
      using removeLeaf_multiset[of ?v1 ?t1 t] assms(2)
      using set_val_multiset[of ?t1 ?v1] False
      by auto
    have "val ?t1 = val t"
      using False assms(2)
      apply (induct t rule:removeLeaf.induct)
      by auto
    have "val t = m"
      using assms(1) False
      using \<open>t' = siftDown (set_val ?t1 ?v1)\<close>
      unfolding hs_remove_max_def
      by (metis (full_types) fst_conv removeLeaf.simps(1))
    hence "val ?t1 = m"
      using \<open>val ?t1 = val t\<close>
      by auto
    hence "multiset t' + {#m#} = multiset t"
      using \<open>multiset t' + {#val ?t1#} = multiset t\<close>
      by metis
    thus ?thesis
      by (metis union_commute)
  qed
qed

text\<open>Difined functions satisfy conditions of locale {\em Heap} and thus represent
       interpretation of this locale.\<close>

interpretation Heap "E" hs_is_empty hs_of_list multiset id hs_remove_max
proof
  fix t
  show "multiset t = multiset (id t)"
    by auto
next
  fix t
  show " is_heap (id (hs_of_list t))"
    unfolding hs_of_list_def
    using heapify_heap_is_heap[of "of_list_tree t"]
    by auto
next
  fix t
  show "(id t = E) = hs_is_empty t"
    by auto
next
  fix t m t'
  assume "\<not> hs_is_empty t" "(m, t') = hs_remove_max t"
  thus "add_mset m (multiset t') = multiset t"
    using hs_remove_max_multiset[of m t' t]
    by auto
next
  fix t v' t'
  assume "\<not> hs_is_empty t" "is_heap (id t)" "(v', t') = hs_remove_max t"
  let ?v1 = "fst (removeLeaf t)"
  let ?t1 = "snd (removeLeaf t)"
  have "is_heap ?t1"
    using \<open>\<not> hs_is_empty t\<close> \<open>is_heap (id t)\<close>
    using removeLeaf_heap_is_heap[of t]
    by auto
  show "is_heap (id t')"
  proof(cases "?t1 = E")
    case True
    hence "t' = E"
      using \<open>(v', t') = hs_remove_max t\<close>
      unfolding hs_remove_max_def
      by auto
    thus ?thesis
      by auto
  next
    case False
    then obtain v_t1 l_t1 r_t1 where "?t1 = T v_t1 l_t1 r_t1"
      by (metis Tree.exhaust)
    hence "is_heap l_t1" "is_heap r_t1"
      using \<open>is_heap ?t1\<close>
      by (auto, metis (full_types) Tree.exhaust
         is_heap.simps(1) is_heap.simps(4) is_heap.simps(5))
         (metis (full_types) Tree.exhaust
          is_heap.simps(1) is_heap.simps(3) is_heap.simps(5))
    have "set_val ?t1 ?v1 = T ?v1 l_t1 r_t1"
      using \<open>?t1 = T v_t1 l_t1 r_t1\<close>
      by auto
    hence "is_heap (siftDown (set_val ?t1 ?v1))"
      using \<open>is_heap l_t1\<close> \<open>is_heap r_t1\<close>
      using siftDown_heap_is_heap[of l_t1 r_t1 "set_val ?t1 ?v1" ?v1]
      by auto
    have "t' = siftDown (set_val ?t1 ?v1)"
      using \<open>(v', t') = hs_remove_max t\<close> False
      by (auto simp add: hs_remove_max_def) (metis prod.inject)
    thus ?thesis
      using \<open>is_heap (siftDown (set_val ?t1 ?v1))\<close>
      by auto
  qed
next
  fix t m t'
  let ?t1 = "snd (removeLeaf t)"
  assume "\<not> hs_is_empty t" "(m, t') = hs_remove_max t"
  hence "m = val t"
    apply (simp add: hs_remove_max_def)
    apply (cases "?t1 = E")
    by (auto, metis prod.inject)
  thus "m = val (id t)"
    by auto
qed

end