(*
  File: Coset.thy
  Author: Bohua Zhan

  Cosets, normal subgroups, and quotient groups.
*)

theory Coset
  imports Group EquivRel
begin

section \<open>Normal subgroups\<close>

definition is_normal_subgroup_set :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "is_normal_subgroup_set(G,H) \<longleftrightarrow> (
    is_subgroup_set(G,H) \<and> (\<forall>a\<in>.G. \<forall>h\<in>H. a *\<^sub>G h *\<^sub>G inv(G,a) \<in> H))"

lemma is_normal_subgroup_setD1 [forward]:
  "is_normal_subgroup_set(G,H) \<Longrightarrow> is_subgroup_set(G,H)" by auto2

lemma is_normal_subgroup_setD2 [typing]:
  "a \<in>. G \<Longrightarrow> is_normal_subgroup_set(G,H) \<Longrightarrow> h \<in> H \<Longrightarrow> a *\<^sub>G h *\<^sub>G inv(G,a) \<in> H" by auto2
setup {* del_prfstep_thm_eqforward @{thm is_normal_subgroup_set_def} *}

lemma is_normal_subgroup_setD3 [typing]:
  "a \<in>. G \<Longrightarrow> is_normal_subgroup_set(G,H) \<Longrightarrow> h \<in> H \<Longrightarrow> inv(G,a) *\<^sub>G h *\<^sub>G a \<in> H"
@proof @have "a = inv(G, inv(G,a))" @qed

section \<open>Cosets as equivalence classes\<close>

definition rcoset_equiv :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "rcoset_equiv(G,H) = Equiv(carrier(G), \<lambda>x y. \<exists>h\<in>H. h *\<^sub>G x = y)"
setup {* register_wellform_data ("rcoset_equiv(G,H)", ["is_subgroup_set(G,H)"]) *}

lemma rcoset_equiv_is_rawequiv [typing]:
  "rcoset_equiv(G,H) \<in> rawequiv_space(carrier(G))" by auto2

lemma rcoset_equiv_eval1 [backward1]:
  "R = rcoset_equiv(G,H) \<Longrightarrow> is_group(G) \<Longrightarrow> is_subgroup_set(G,H) \<Longrightarrow> x \<in>. G \<Longrightarrow>
   h \<in> H \<Longrightarrow> h *\<^sub>G x = y \<Longrightarrow> x \<sim>\<^sub>R y" by auto2

lemma rcoset_equiv_eval2 [resolve]:
  "R = rcoset_equiv(G,H) \<Longrightarrow> x \<sim>\<^sub>R y \<Longrightarrow> \<exists>h\<in>H. h *\<^sub>G x = y" by auto2
setup {* del_prfstep_thm @{thm rcoset_equiv_def} *}

lemma rcoset_equiv_is_equiv [typing]:
  "is_group(G) \<Longrightarrow> is_subgroup_set(G,H) \<Longrightarrow> rcoset_equiv(G,H) \<in> equiv_space(carrier(G))"
@proof
  @let "S = carrier(G)"
  @let "R = rcoset_equiv(G,H)"
  @have "\<forall>x\<in>.R. x \<sim>\<^sub>R x" @with @have "x = \<one>\<^sub>G *\<^sub>G x" @end
  @have "\<forall>x y. x \<sim>\<^sub>R y \<longrightarrow> y \<sim>\<^sub>R x" @with
    @obtain "h\<in>H" where "h *\<^sub>G x = y"
    @have "inv(G,h) *\<^sub>G y = x" @with @have "h *\<^sub>G (inv(G,h) *\<^sub>G y) = h *\<^sub>G inv(G,h) *\<^sub>G y" @end @end
  @have "\<forall>x y z. x \<sim>\<^sub>R y \<longrightarrow> y \<sim>\<^sub>R z \<longrightarrow> x \<sim>\<^sub>R z" @with
    @obtain "h1\<in>H" where "h1 *\<^sub>G x = y"
    @obtain "h2\<in>H" where "h2 *\<^sub>G y = z"
    @have "(h2 *\<^sub>G h1) *\<^sub>G x = z" @with @have "(h2 *\<^sub>G h1) *\<^sub>G x = h2 *\<^sub>G (h1 *\<^sub>G x)" @end @end
@qed

lemma rcoset_mult_compat2 [backward]:
  "R = rcoset_equiv(G,H) \<Longrightarrow> x \<in>. G \<Longrightarrow>
   is_normal_subgroup_set(G,H) \<Longrightarrow> y \<sim>\<^sub>R z \<Longrightarrow> x *\<^sub>G y \<sim>\<^sub>R x *\<^sub>G z"
@proof
  @obtain "h\<in>H" where "h *\<^sub>G y = z"
  @have "(x *\<^sub>G h *\<^sub>G inv(G,x)) *\<^sub>G (x *\<^sub>G y) = x *\<^sub>G (h *\<^sub>G (inv(G,x) *\<^sub>G x) *\<^sub>G y)"
@qed

lemma rcoset_mult_compat1 [backward]:
  "R = rcoset_equiv(G,H) \<Longrightarrow> x \<in>. G \<Longrightarrow>
   is_subgroup_set(G,H) \<Longrightarrow> y \<sim>\<^sub>R z \<Longrightarrow> y *\<^sub>G x \<sim>\<^sub>R z *\<^sub>G x"
@proof
  @obtain "h\<in>H" where "h *\<^sub>G y = z"
  @have "h *\<^sub>G (y *\<^sub>G x) = (h *\<^sub>G y) *\<^sub>G x"
@qed

definition rcoset_quot :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "rcoset_quot(G,H) = carrier(rcoset_equiv(G,H)) // rcoset_equiv(G,H)"
setup {* register_wellform_data ("rcoset_quot(G,H)", ["is_subgroup_set(G,H)"]) *}

definition rcoset_mult :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "rcoset_mult(G,H,x,y) =
     equiv_class(rcoset_equiv(G,H), rep(rcoset_equiv(G,H),x) *\<^sub>G rep(rcoset_equiv(G,H),y))"
setup {* register_wellform_data ("rcoset_mult(G,H,x,y)", ["x \<in> rcoset_quot(G,H)", "y \<in> rcoset_quot(G,H)"]) *}

lemma rcoset_mult_type [typing]:
  "is_subgroup_set(G,H) \<Longrightarrow> S = rcoset_quot(G,H) \<Longrightarrow> x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> rcoset_mult(G,H,x,y) \<in> S"
  by auto2

lemma rcoset_mult_eval [rewrite]:
  "R = rcoset_equiv(G,H) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> is_normal_subgroup_set(G,H) \<Longrightarrow>
   rcoset_mult(G,H,equiv_class(R,x),equiv_class(R,y)) = equiv_class(R,x *\<^sub>G y)"
@proof @have "compat_meta_bin(R, \<lambda>x y. x *\<^sub>G y)" @qed

lemma rcoset_mult_assoc [rewrite]:
  "S = rcoset_quot(G,H) \<Longrightarrow> x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> z \<in> S \<Longrightarrow>
   is_normal_subgroup_set(G,H) \<Longrightarrow>
   rcoset_mult(G,H,rcoset_mult(G,H,x,y),z) = rcoset_mult(G,H,x,rcoset_mult(G,H,y,z))" by auto2

definition rcoset_id :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "rcoset_id(G,H) = equiv_class(rcoset_equiv(G,H), \<one>\<^sub>G)"

lemma rcoset_id_type [typing]:
  "is_normal_subgroup_set(G,H) \<Longrightarrow> rcoset_id(G,H) \<in> rcoset_quot(G,H)" by auto2

lemma rcoset_mult_id1 [rewrite]:
  "x \<in> rcoset_quot(G,H) \<Longrightarrow> is_normal_subgroup_set(G,H) \<Longrightarrow>
   rcoset_mult(G,H,rcoset_id(G,H),x) = x" by auto2

lemma rcoset_mult_id2 [rewrite]:
  "x \<in> rcoset_quot(G,H) \<Longrightarrow> is_normal_subgroup_set(G,H) \<Longrightarrow>
   rcoset_mult(G,H,x,rcoset_id(G,H)) = x" by auto2

definition rcoset_inv :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "rcoset_inv(G,H,x) = equiv_class(rcoset_equiv(G,H), inv(G,rep(rcoset_equiv(G,H),x)))"

lemma rcoset_inv_type [typing]:
  "is_normal_subgroup_set(G,H) \<Longrightarrow> x \<in> rcoset_quot(G,H) \<Longrightarrow> rcoset_inv(G,H,x) \<in> rcoset_quot(G,H)" by auto2

lemma rcoset_inv_prop [rewrite]:
  "x \<in> rcoset_quot(G,H) \<Longrightarrow> is_normal_subgroup_set(G,H) \<Longrightarrow>
   rcoset_mult(G,H,rcoset_inv(G,H,x),x) = rcoset_id(G,H)" by auto2
setup {* del_prfstep_thm @{thm rcoset_inv_def} *}

section \<open>Construction of the quotient group\<close>

definition quotient_group :: "i \<Rightarrow> i \<Rightarrow> i" (infix "'/'/\<^sub>G" 90) where [rewrite]:
  "G //\<^sub>G H = Group(rcoset_quot(G,H), rcoset_id(G,H), \<lambda>x y. rcoset_mult(G,H,x,y))"
setup {* register_wellform_data ("G //\<^sub>G H", ["is_normal_subgroup_set(G,H)"]) *}

lemma quotient_group_is_group_raw:
  "is_normal_subgroup_set(G,H) \<Longrightarrow> group_form(G //\<^sub>G H)" by auto2
setup {* add_forward_prfstep_cond @{thm quotient_group_is_group_raw} [with_term "?G //\<^sub>G ?H"] *}

lemma quotient_group_sel1:
  "carrier(G //\<^sub>G H) = rcoset_quot(G,H)"
  "one(G //\<^sub>G H) = equiv_class(rcoset_equiv(G,H), \<one>\<^sub>G)" by auto2+
setup {* fold (fn th => add_forward_prfstep_cond th [with_term "?G //\<^sub>G ?H"]) @{thms quotient_group_sel1} *}

lemma quotient_group_sel2 [rewrite]:
  "K = G //\<^sub>G H \<Longrightarrow> is_normal_subgroup_set(G,H) \<Longrightarrow> x \<in>. K \<Longrightarrow> y \<in>. K \<Longrightarrow> R = rcoset_equiv(G,H) \<Longrightarrow>
   x *\<^sub>K y = equiv_class(R,rep(R,x) *\<^sub>G rep(R,y))" by auto2

lemma quotient_group_is_group:
  "is_normal_subgroup_set(G,H) \<Longrightarrow> is_group(G //\<^sub>G H)"
@proof
  @let "Q = G //\<^sub>G H"
  @have "is_monoid(Q)"
  @have "\<forall>x\<in>.Q. rcoset_inv(G,H,x) *\<^sub>Q x = \<one>\<^sub>Q"
@qed
setup {* add_forward_prfstep_cond @{thm quotient_group_is_group} [with_term "?G //\<^sub>G ?H"] *}

section \<open>Canonical surjection\<close>

definition qsurj_group :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "qsurj_group(G,H) = Mor(G, G //\<^sub>G H, \<lambda>x. equiv_class(rcoset_equiv(G,H), x))"
setup {* register_wellform_data ("qsurj_group(G,H)", ["is_normal_subgroup_set(G,H)"]) *}

lemma qsurj_group_is_morphism [typing]:
  "is_normal_subgroup_set(G,H) \<Longrightarrow> qsurj_group(G,H) \<in> G \<rightharpoonup>\<^sub>G G //\<^sub>G H" by auto2

lemma qsurj_group_is_surjective:
  "is_normal_subgroup_set(G,H) \<Longrightarrow> surjective(qsurj_group(G,H))"
@proof
  @let "R = rcoset_equiv(G,H)"
  @have (@rule) "\<forall>x \<in>. G //\<^sub>G H. qsurj_group(G,H)`rep(R,x) = x"
@qed
setup {* add_forward_prfstep_cond @{thm qsurj_group_is_surjective} [with_term "qsurj_group(?G,?H)"] *}

lemma qsurj_group_eval [rewrite]:
  "is_normal_subgroup_set(G,H) \<Longrightarrow> x \<in> source(qsurj_group(G,H)) \<Longrightarrow>
   qsurj_group(G,H)`x = equiv_class(rcoset_equiv(G,H),x)" by auto2
setup {* del_prfstep_thm @{thm qsurj_group_def} *}
setup {* del_prfstep_thm @{thm quotient_group_def} *}

lemma qsurj_group_eq_iff1 [rewrite]:
  "is_normal_subgroup_set(G,H) \<Longrightarrow> R = rcoset_equiv(G,H) \<Longrightarrow> x \<sim>\<^sub>R y \<Longrightarrow>
   qsurj_group(G,H)`x = qsurj_group(G,H)`y" by auto2

lemma qsurj_group_eq_iff2 [forward]:
  "is_normal_subgroup_set(G,H) \<Longrightarrow> R = rcoset_equiv(G,H) \<Longrightarrow>
   p = qsurj_group(G,H) \<Longrightarrow>
   x \<in> source(p) \<Longrightarrow> y \<in> source(p) \<Longrightarrow> p`x = p`y \<Longrightarrow> x \<sim>\<^sub>R y" by auto2

section \<open>Kernel is a normal subgroup\<close>

definition kernel :: "i \<Rightarrow> i" where [rewrite]:
  "kernel(f) = {x\<in>source(f). f`x = one(target_str(f))}"

lemma kernelD [forward]: "H = target_str(f) \<Longrightarrow> x \<in> kernel(f) \<Longrightarrow> x \<in> source(f) \<and> f`x = \<one>\<^sub>H" by auto2
lemma kernelI [typing2, backward]: "H = target_str(f) \<Longrightarrow> x \<in> source(f) \<Longrightarrow> f`x = \<one>\<^sub>H \<Longrightarrow> x \<in> kernel(f)" by auto2
setup {* del_prfstep_thm @{thm kernel_def} *}

lemma kernel_is_normal_subgroup:
  "is_group_hom(f) \<Longrightarrow> is_normal_subgroup_set(source_str(f), kernel(f))" by auto2
setup {* add_forward_prfstep_cond @{thm kernel_is_normal_subgroup} [with_term "kernel(?f)"] *}

section \<open>First isomorphism theorem\<close>

lemma exists_induced_group_mor [backward]:
  "is_normal_subgroup_set(G,K) \<Longrightarrow> f \<in> G \<rightharpoonup>\<^sub>G H \<Longrightarrow> K \<subseteq> kernel(f) \<Longrightarrow>
   \<exists>!h. h\<in>(G //\<^sub>G K)\<rightharpoonup>H \<and> f = h \<circ>\<^sub>m qsurj_group(G,K)"
@proof
  @let "p = qsurj_group(G,K)"
  @have "\<forall>x\<in>.G. \<forall>y\<in>.G. p`x = p`y \<longrightarrow> f`x = f`y" @with
    @obtain "k \<in> K" where "k *\<^sub>G x = y" @end
@qed

(* Given f \<in> G \<rightharpoonup>\<^sub>G H and a normal subgroup K of G, obtain f' \<in> G//K \<rightharpoonup>\<^sub>G H
   (assuming various requirements hold. *)
definition induced_group_mor :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "induced_group_mor(f,K) =
    (THE h. h \<in> (source_str(f) //\<^sub>G K) \<rightharpoonup> target_str(f) \<and> f = h \<circ>\<^sub>m qsurj_group(source_str(f),K))"
setup {* register_wellform_data ("induced_group_mor(f,K)",
  ["is_normal_subgroup_set(source_str(f),K)", "K \<subseteq> kernel(f)"]) *}
setup {* add_prfstep_check_req ("induced_group_mor(f,K)", "K \<subseteq> kernel(f)") *}

lemma induced_group_mor_prop:
  "is_normal_subgroup_set(G,K) \<Longrightarrow> mor_form(f) \<Longrightarrow> is_group_hom(f) \<Longrightarrow>
   G = source_str(f) \<Longrightarrow> H = target_str(f) \<Longrightarrow> K \<subseteq> kernel(f) \<Longrightarrow>
   induced_group_mor(f,K) \<in> G //\<^sub>G K \<rightharpoonup> H \<and> f = induced_group_mor(f,K) \<circ>\<^sub>m qsurj_group(G,K)" by auto2
setup {* add_forward_prfstep_cond @{thm induced_group_mor_prop} [with_term "induced_group_mor(?f,?K)"] *}

lemma induced_group_mor_eval [rewrite]:
  "mor_form(f) \<Longrightarrow> is_group_hom(f) \<Longrightarrow> G = source_str(f) \<Longrightarrow> is_normal_subgroup_set(G,K) \<Longrightarrow>
   K \<subseteq> kernel(f) \<Longrightarrow> R = rcoset_equiv(G,K) \<Longrightarrow>
   x \<in>. R \<Longrightarrow> induced_group_mor(f,K) ` equiv_class(R,x) = f ` x" by auto2
setup {* del_prfstep_thm @{thm induced_group_mor_def} *}

lemma induced_group_mor_is_hom:
  "mor_form(f) \<Longrightarrow> is_group_hom(f) \<Longrightarrow> is_normal_subgroup_set(source_str(f),K) \<Longrightarrow> K \<subseteq> kernel(f) \<Longrightarrow>
   is_group_hom(induced_group_mor(f,K))" by auto2
setup {* add_forward_prfstep_cond @{thm induced_group_mor_is_hom} [with_term "induced_group_mor(?f,?K)"] *}

(* Canonical decomposition *)
lemma injective_induced_group_mor:
  "mor_form(f) \<Longrightarrow> is_group_hom(f) \<Longrightarrow> injective(induced_group_mor(f,kernel(f)))"
@proof
  @let "h = induced_group_mor(f,kernel(f))"
  @let "G = source_str(f)"
  @let "p = qsurj_group(G,kernel(f))"
  @have "\<forall>x\<in>source(h). \<forall>y\<in>source(h). h`x = h`y \<longrightarrow> x = y" @with
    @obtain "x'\<in>source(p)" where "p`x' = x"
    @obtain "y'\<in>source(p)" where "p`y' = y"
    @have "f`x' = f`y'"
    @have "y' *\<^sub>G inv(G,x') \<in> kernel(f)"
    @have "(y' *\<^sub>G inv(G,x')) *\<^sub>G x' = y'"
  @end
@qed
setup {* add_forward_prfstep_cond @{thm injective_induced_group_mor}
  [with_term "induced_group_mor(?f,kernel(?f))"] *}

lemma induced_group_mor_image [rewrite]:
  "mor_form(f) \<Longrightarrow> is_group_hom(f) \<Longrightarrow> image(induced_group_mor(f,kernel(f))) = image(f)"
@proof
  @let "q = qsurj_group(source_str(f),kernel(f))"
  @have (@rule) "\<forall>y\<in>target(q). \<exists>x\<in>source(q). q`x = y"
@qed

lemma first_isomorphism_theorem [typing]:
  "mor_form(f) \<Longrightarrow> is_group_hom(f) \<Longrightarrow> G = source_str(f) \<Longrightarrow> K = kernel(f) \<Longrightarrow>
   group_mor_restrict_image(induced_group_mor(f,K)) \<in> G //\<^sub>G K \<cong>\<^sub>G image_subgroup(f)" by auto2

lemma first_isomorphism_theorem_surj [typing]:
  "mor_form(f) \<Longrightarrow> is_group_hom(f) \<Longrightarrow> surjective(f) \<Longrightarrow> G = source_str(f) \<Longrightarrow> K = kernel(f) \<Longrightarrow>
   induced_group_mor(f,K) \<in> G //\<^sub>G K \<cong>\<^sub>G target_str(f)"
@proof @have (@rule) "\<forall>y\<in>target(f). \<exists>x\<in>source(f). f`x = y" @qed

end


theory Submission
  imports Main "HOL.Real" "HOL.List"
begin

datatype ('a::linorder) treap =
  Leaf ("\<langle>\<rangle>") |
  Node "'a treap" ("key": 'a) ("prio": real) "'a treap" ("(1\<langle>_,/ _,/ _,/ _\<rangle>)")

primrec key :: "('a::linorder) treap \<Rightarrow> 'a" where
  "key \<langle>l, k, p, r\<rangle> = k" |
  "key \<langle>\<rangle> = undefined"

primrec prio :: "('a::linorder) treap \<Rightarrow> real" where
  "prio \<langle>l, k, p, r\<rangle> = p" |
  "prio \<langle>\<rangle> = 1"

primrec left :: "('a::linorder) treap \<Rightarrow> 'a treap" where
  "left \<langle>l, k, p, r\<rangle> = l" |
  "left \<langle>\<rangle> = \<langle>\<rangle>"

primrec right :: "('a::linorder) treap \<Rightarrow> 'a treap" where
  "right \<langle>l, k, p, r\<rangle> = r" |
  "right \<langle>\<rangle> = \<langle>\<rangle>"

fun height :: "('a::linorder) treap \<Rightarrow> nat" where
  "height \<langle>\<rangle> = 0" |
  "height \<langle>l, k, p, r\<rangle> = max (height l) (height r) + 1"

fun min_height :: "('a::linorder) treap \<Rightarrow> nat" where
  "min_height \<langle>\<rangle> = 0" |
  "min_height \<langle>l, k, p, r\<rangle> = min (height l) (height r) + 1"

fun size :: "('a::linorder) treap \<Rightarrow> nat" where
  "size \<langle>\<rangle> = 0" |
  "size \<langle>l, k, p, r\<rangle> = (size l) + (size r) + 1"

fun set :: "('a::linorder) treap \<Rightarrow> ('a \<times> real) set" where
  Leaf: "set \<langle>\<rangle> = {}" |
  Node: "set \<langle>l, k, p, r\<rangle> = {(k, p)} \<union> set l \<union> set r"

lemma set_finite: "finite (set t)" by(induction t, auto)
lemma child_subset: "set (left t) \<subseteq> set t" "set (right t) \<subseteq> set t" by(induction t, auto)
lemma not_in_set_not_in_tree1:
  assumes "t \<noteq> \<langle>\<rangle>"
      and "(k, p) \<notin> set t"
    shows "(k, p) \<noteq> (key t, prio t) \<and> (k, p) \<notin> set (left t) \<and> (k, p) \<notin> set (right t)"
  using assms by(induction t, auto)

inductive descendant_of :: "('a::linorder) treap \<Rightarrow> ('a::linorder) treap \<Rightarrow> bool" where
  Left: "descendant_of l \<langle>l, k, p, r\<rangle>" |
  Right: "descendant_of r \<langle>l, k, p, r\<rangle>" |
  Cont: "\<lbrakk> descendant_of a b; descendant_of b c \<rbrakk> \<Longrightarrow> descendant_of a c"

lemma descendant_subset:
  "descendant_of c t \<Longrightarrow> set c \<subseteq> set t"
  by(induction c t rule: descendant_of.induct, auto)

lemma not_in_set_not_in_tree2:
  assumes "descendant_of c t"
      and "t \<noteq> \<langle>\<rangle>"
      and "c \<noteq> \<langle>\<rangle>"
      and "(k, p) \<notin> set t"
    shows "(k, p) \<noteq> (key t, prio t) \<and> (k, p) \<noteq> (key c, prio c)"
  using assms proof(induction c t rule: descendant_of.induct)
  case (Left l k p r)
  then show ?case using not_in_set_not_in_tree1 by auto
next
  case (Right r l k p)
  then show ?case using not_in_set_not_in_tree1 by auto
next
  case (Cont a b c)
  then have "descendant_of a c"
    using descendant_of.Cont by blast
  with Cont.prems show ?case using descendant_subset not_in_set_not_in_tree1 by blast
qed

lemma not_in_set_not_in_tree3:
  assumes "descendant_of c t"
      and "c \<noteq> \<langle>\<rangle>"
      and "(k, p) \<notin> set t"
    shows "(k, p) \<noteq> (key t, prio t) \<and> (k, p) \<noteq> (key c, prio c)"
proof-
  have "t \<noteq> \<langle>\<rangle>"
    using assms(1,2) descendant_subset not_in_set_not_in_tree1 by fastforce
  then show "(k, p) \<noteq> (key t, prio t) \<and> (k, p) \<noteq> (key c, prio c)"
    using assms(1,2,3) not_in_set_not_in_tree2 by blast
qed

inductive distinct_keys :: "('a::linorder) treap \<Rightarrow> bool" where
  Leaf: "distinct_keys \<langle>\<rangle> " |
  Node: "\<lbrakk> distinct_keys l; distinct_keys r;
        \<forall>(x\<^sub>k, x\<^sub>p) \<in> set l . x\<^sub>k \<noteq> k; \<forall>(x\<^sub>k, x\<^sub>p) \<in> set r . x\<^sub>k \<noteq> k;
        \<forall>(l\<^sub>k, l\<^sub>p) \<in> set l. \<forall>(r\<^sub>k, r\<^sub>p) \<in> set r. l\<^sub>k \<noteq> r\<^sub>k \<rbrakk>
        \<Longrightarrow> distinct_keys \<langle>l, k, p, r\<rangle>"

lemma distinct_keys_rev: "distinct_keys \<langle>l, k, p, r\<rangle> \<Longrightarrow> distinct_keys l \<and> distinct_keys r"
  by(induction "\<langle>l, k, p, r\<rangle>" rule: distinct_keys.induct, auto)

inductive distinct_prios :: "('a::linorder) treap \<Rightarrow> bool" where
  Leaf: "distinct_prios \<langle>\<rangle> " |
  Node: "\<lbrakk> distinct_prios l; distinct_prios r;
        \<forall>(x\<^sub>k, x\<^sub>p) \<in> set l. x\<^sub>p \<noteq> p; \<forall>(x\<^sub>k, x\<^sub>p) \<in> set r. x\<^sub>p \<noteq> p;
        \<forall>(l\<^sub>k, l\<^sub>p) \<in> set l. \<forall>(r\<^sub>k, r\<^sub>p) \<in> set r. l\<^sub>p \<noteq> r\<^sub>p \<rbrakk>
        \<Longrightarrow> distinct_prios \<langle>l, k, p, r\<rangle>"

lemma distinct_prios_rev: "distinct_prios \<langle>l, k, p, r\<rangle> \<Longrightarrow> distinct_prios l \<and> distinct_prios r"
  by(induction "\<langle>l, k, p, r\<rangle>" rule: distinct_prios.induct, auto)

definition is_distinct :: "('a::linorder) treap \<Rightarrow> bool" where
  "is_distinct t \<equiv> distinct_keys t \<and> distinct_prios t"

lemma distinct_rev: "is_distinct \<langle>l, k, p, r\<rangle> \<Longrightarrow> is_distinct l \<and> is_distinct r"
  using distinct_keys_rev distinct_prios_rev is_distinct_def by blast

lemma distinct_root_key: "distinct_keys \<langle>l, k, p, r\<rangle> \<Longrightarrow> (k, p) \<notin> set l \<union> set r"
  by(induction "\<langle>l, k, p, r\<rangle>" arbitrary: k p rule: distinct_keys.induct, auto)

lemma distinct_root: "is_distinct \<langle>l, k, p, r\<rangle> \<Longrightarrow> (k, p) \<notin> set l \<union> set r"
  using distinct_root_key is_distinct_def by blast

lemma child_dist_if_parent_dist:
  assumes "descendant_of c p"
      and "is_distinct p"
    shows "is_distinct c"
  using assms distinct_rev by(induction c p rule: descendant_of.induct, auto)

lemma lrchilds_disjoint_key: "distinct_keys \<langle>l, k, p, r\<rangle> \<Longrightarrow> set l \<inter> set r = {}"
  by(induction "\<langle>l, k, p, r\<rangle>" arbitrary: k p rule: distinct_keys.induct, auto)

lemma lrchilds_disjoint: "is_distinct \<langle>l, k, p, r\<rangle> \<Longrightarrow> set l \<inter> set r = {}"
  using lrchilds_disjoint_key is_distinct_def by blast

lemma size_correct: "is_distinct t \<Longrightarrow> size t = card (set t)"
proof(induction t)
  case (Node l k p r)
  then have "is_distinct l"
    using distinct_rev by auto
  then have "size l = card (set l)"
    by (simp add: Node.IH(1))
  moreover from Node.prems have "is_distinct r"
    using distinct_rev by auto
  then have "size r = card (set r)"
    by (simp add: Node.IH(2))
  ultimately have "size \<langle>l, k, p, r\<rangle> = card (set l) + card (set r) + 1"
    by simp
  also have "... = card (set l \<union> set r) + 1"
    using Node.prems lrchilds_disjoint set_finite card_Un_disjoint
    by metis
  also have "... = card (set \<langle>l, k, p, r\<rangle> - {(k, p)}) + 1"
    using Node.prems distinct_root by fastforce
  also have "... = card (set \<langle>l, k, p, r\<rangle> - {(k, p)}) + card ({(k, p)})"
    by simp
  also have "... = card (set \<langle>l, k, p, r\<rangle> - {(k, p)} \<union> {(k, p)})"
    by (metis Diff_disjoint add.commute card_Un_disjoint finite.emptyI finite.insertI finite_Diff2 set_finite sup_commute)
  also have "... = card (set \<langle>l, k, p, r\<rangle>)"
    by simp
  finally show ?case .
qed(simp)

lemma set_of_childs:
  assumes "is_distinct t"
  shows "set t - {(key t, prio t)} = set (left t) \<union> set (right t)"
using assms proof(induction t rule: set.induct)
  case (2 l k p r)
  let ?t = "\<langle>l, k, p, r\<rangle>"
  from "2.prems" have "(k, p) \<notin> set l \<union> set r"
    using is_distinct_def distinct_root by blast
  then show ?case by simp
qed(simp)

lemma distinct_set_rev: "is_distinct \<langle>l, k, p, r\<rangle> \<Longrightarrow> {(k,p)} \<union> set (l) \<union> set (r) = set \<langle>l, k, p, r\<rangle>"
  by(induction "\<langle>l, k, p, r\<rangle>", auto)

inductive is_bst :: "('a::linorder) treap \<Rightarrow> bool" where
  Leaf: "is_bst \<langle>\<rangle>" |
  Node: "\<lbrakk> is_bst l; is_bst r;
        \<forall>(x\<^sub>k, x\<^sub>p) \<in> set l. x\<^sub>k < k; \<forall>(x\<^sub>k, x\<^sub>p) \<in> set r. k < x\<^sub>k \<rbrakk>
        \<Longrightarrow> is_bst \<langle>l, k, p, r\<rangle>"

lemma bst_rev:
  "is_bst \<langle>l, k, p, r\<rangle> \<Longrightarrow> is_bst l \<and> is_bst r \<and> (\<forall>(x\<^sub>k, x\<^sub>p) \<in> set l . x\<^sub>k < k) \<and> (\<forall>(x\<^sub>k, x\<^sub>p) \<in> set r . k < x\<^sub>k)"
  by(induction "\<langle>l, k, p, r\<rangle>" rule: is_bst.induct, blast)

lemma uni_bst[simp]: "is_bst \<langle>\<langle>\<rangle>, k, p, \<langle>\<rangle>\<rangle>"
proof-
  let ?l = "\<langle>\<rangle>" let ?r = "\<langle>\<rangle>"
  have "set \<langle>\<rangle> = {}" by simp
  have "is_bst ?l" by (simp add: is_bst.Leaf)
  moreover have "is_bst ?r" by (simp add: is_bst.Leaf)
  moreover have "\<forall>(x\<^sub>k, x\<^sub>p) \<in> set ?l. x\<^sub>k < k" by simp
  moreover have "\<forall>(x\<^sub>k, x\<^sub>p) \<in> set ?r. k < x\<^sub>k" by simp
  ultimately have "is_bst \<langle>?l, k, p, ?r\<rangle>"
    using is_bst.simps by fastforce
  then show "is_bst \<langle>\<langle>\<rangle>, k, p, \<langle>\<rangle>\<rangle>" by simp
qed

lemma smaller_key_is_left_child:
  assumes "is_bst t"
and "is_distinct t"
  and "(k, d) \<in> set t"
shows "k < key t \<Longrightarrow> (k, d) \<in> set (left t)"
  using assms by(induction t arbitrary: k d rule: is_bst.induct, auto)

lemma larger_key_is_right_child:
  assumes "is_bst t"
and "is_distinct t"
  and "(k, d) \<in> set t"
shows "key t < k \<Longrightarrow> (k, d) \<in> set (right t)"
  using assms by(induction t arbitrary: k d rule: is_bst.induct, auto)

definition is_valid_prio :: "real \<Rightarrow> bool" where
  "is_valid_prio p \<equiv> 0 < p \<and> p < 1"

inductive is_heap :: "('a::linorder) treap \<Rightarrow> bool" where
  Leaf: "is_heap \<langle>\<rangle>" |
  Node: "\<lbrakk>is_heap l; is_heap r; prio l > p; prio r > p; is_valid_prio p \<rbrakk>
        \<Longrightarrow> is_heap \<langle>l, k, p, r\<rangle>"

lemma uni_heap[simp]: "is_valid_prio p \<Longrightarrow> is_heap \<langle>\<langle>\<rangle>, k, p, \<langle>\<rangle>\<rangle>"
proof-
  assume p_valid: "is_valid_prio p"
  let ?l = "\<langle>\<rangle>" let ?r = "\<langle>\<rangle>"
  have "set \<langle>\<rangle> = {}" by simp
  have "is_heap ?l" by (simp add: is_heap.Leaf)
  moreover have "is_heap ?r" by (simp add: is_heap.Leaf)
  moreover have "prio ?l = 1"
    by simp
  then have "prio ?l > p" using p_valid by (simp add: is_valid_prio_def)
  moreover have "prio ?r = 1"
    by simp
  then have "prio ?r > p" using p_valid by (simp add: is_valid_prio_def)
  ultimately have "is_heap \<langle>?l, k, p, ?r\<rangle>"
    using is_heap.Node p_valid by blast
  then show "is_heap \<langle>\<langle>\<rangle>, k, p, \<langle>\<rangle>\<rangle>" by simp
qed

lemma heap_root_prio_lower_bound:
  assumes "is_heap t"
      and "is_distinct t"
    shows "\<forall>(k', p') \<in> set t. prio t \<le> p'"
using assms proof(induction t arbitrary: p rule: is_heap.induct)
  case (Node l r p k)
  then have
    "\<forall>(k', p') \<in> set l. prio l \<le> p'"
    "\<forall>(k', p') \<in> set r. prio r \<le> p'"
    using distinct_rev by blast+
  then have
    "\<forall>(k', p') \<in>  set l. p < p'"
    "\<forall>(k', p') \<in>  set r. p < p'"
    using Node.hyps(3,4) by fastforce+
  then have "\<forall>(k', p') \<in>  set l \<union> set r. p < p'"
    by blast
  then have "\<forall>(k', p') \<in>  set l \<union> set r. p \<le> p'"
    using less_eq_real_def by auto
  then show ?case
    by simp
qed(simp)

lemma heap_root_has_smallest_prio:
  assumes "is_heap t"
      and "is_distinct t"
    shows "\<forall>(k', p') \<in> set (left t) \<union> set (right t). prio t < p'"
using assms proof(induction t arbitrary: p rule: is_heap.induct)
  case (Node l r p k)
  obtain p\<^sub>l p\<^sub>r where p_defs: "p\<^sub>l = prio l" "p\<^sub>r = prio r" by blast
  have p_less_pl: "p < p\<^sub>l"
    using Node.hyps(3) Node.prems p_defs(1) by auto
  moreover have "p < p\<^sub>r"
    using Node.hyps(4) Node.prems p_defs(2) by auto
  moreover have
    "\<forall>(k', p') \<in> set (left l) \<union> set (right l). p\<^sub>l < p'"
    "\<forall>(k', p') \<in> set (left r) \<union> set (right r). p\<^sub>r < p'"
    using Node.IH(1, 2) Node.prems distinct_rev p_defs by blast+
  ultimately have
    "\<forall>(k', p') \<in> set (left l) \<union> set (right l). p < p'"
    "\<forall>(k', p') \<in> set (left r) \<union> set (right r). p < p'"
    by (smt (verit, ccfv_SIG) case_prodD case_prodI2)+
  then have
    "\<forall>(k', p') \<in> set l. p < p'"
    "\<forall>(k', p') \<in> set r. p < p'"
    using p_less_pl Node.hyps(3,4) Node.prems distinct_rev set_of_childs by blast+
  then show ?case
    by force
qed(simp)

definition is_treap :: "('a::linorder) treap \<Rightarrow> bool" where
  "is_treap t \<equiv> is_bst t \<and> is_heap t"

lemma empty_treap_is_leaf:
"set t = {} \<longleftrightarrow> t = \<langle>\<rangle>"
proof
  assume empty_set: "set t = {}"
  then show "t = \<langle>\<rangle>" by(cases t, auto)
qed(simp)

text \<open>Any two treaps (each with distinct key-priority-pairs) have the same structure.
In other words: For (k\<^sub>1,p\<^sub>1) ... (k\<^sub>n,p\<^sub>n), there exists a unique treap.\<close>
theorem treap_is_unique:
  assumes distinct:      "is_distinct t\<^sub>1" "is_distinct t\<^sub>2"
      and treaps:        "is_treap t\<^sub>1" "is_treap t\<^sub>2"
      and equal_entries[simp]: "set t\<^sub>1 = set t\<^sub>2"
    shows "t\<^sub>1 = t\<^sub>2"
using assms proof(induction t\<^sub>1 arbitrary: t\<^sub>2 rule:treap.induct)
  case Leaf
    then have "set t\<^sub>2 = {}"
      by simp
    then have "t\<^sub>2 = \<langle>\<rangle>"
      using empty_treap_is_leaf by auto
    then show ?case
      by simp
next
  case (Node l\<^sub>1 k\<^sub>1 p\<^sub>1 r\<^sub>1)
  let ?t\<^sub>1 = "\<langle>l\<^sub>1, k\<^sub>1, p\<^sub>1, r\<^sub>1\<rangle>"
  let ?entries = "set ?t\<^sub>1"
  have not_leaf: "t\<^sub>2 \<noteq> \<langle>\<rangle>"
    using Node.prems(5) by force
  then obtain l\<^sub>2 k\<^sub>2 p\<^sub>2 r\<^sub>2 where t2_def: "t\<^sub>2 = \<langle>l\<^sub>2, k\<^sub>2, p\<^sub>2, r\<^sub>2\<rangle>"
    using height.cases by blast
  let ?t\<^sub>2 = "\<langle>l\<^sub>2, k\<^sub>2, p\<^sub>2, r\<^sub>2\<rangle>"
  have "is_treap l\<^sub>2" "is_treap r\<^sub>2"
    using Node.prems(4) is_heap.cases is_bst.cases is_treap_def t2_def by fastforce+

  (* roots equal *)
  have "\<forall>(k', p') \<in> set (left ?t\<^sub>1) \<union> set (right ?t\<^sub>1). prio ?t\<^sub>1 < p'"
    using Node.prems(1, 3) heap_root_has_smallest_prio is_treap_def by blast
  then have "\<forall>(k', p') \<in> ?entries - {(k\<^sub>1, p\<^sub>1)}. prio ?t\<^sub>1 < p'"
    by simp
  then have "\<forall>(k', p') \<in> ?entries - {(k\<^sub>1, p\<^sub>1)}. prio ?t\<^sub>1 \<le> p'"
    using less_imp_le by blast
  then have "\<forall>(k', p') \<in> set ?t\<^sub>1. prio ?t\<^sub>1 \<le> p'" by auto
  moreover have "\<forall>(k', p') \<in> set (left ?t\<^sub>2) \<union> set (right ?t\<^sub>2). prio ?t\<^sub>2 < p'"
    using Node.prems(2, 4) heap_root_has_smallest_prio is_treap_def t2_def by blast
  then have root2_smallest_prio: "\<forall>(k', p') \<in> set ?t\<^sub>2 - {(k\<^sub>2, p\<^sub>2)}. prio ?t\<^sub>2 < p'"
    by simp
  then have "\<forall>(k', p') \<in> set ?t\<^sub>2 - {(k\<^sub>2, p\<^sub>2)}. prio ?t\<^sub>2 \<le> p'"
    using less_imp_le by blast
  then have "\<forall>(k', p') \<in> ?entries. prio ?t\<^sub>2 \<le> p'"
    using Node.prems(5) t2_def by auto
  moreover have root1_in_set: "(k\<^sub>1, p\<^sub>1) \<in> ?entries"
    by force
  moreover have root2_in_set: "(k\<^sub>2, p\<^sub>2) \<in> ?entries"
    using Node.prems(5) t2_def by auto
  ultimately have equal_prio:  "prio ?t\<^sub>1 = prio ?t\<^sub>2"
    by fastforce
  then have roots_eq_prios: "p\<^sub>1 = p\<^sub>2" by simp
  then have roots_eq_keys: "k\<^sub>1 = k\<^sub>2"
    using Node.prems(5) case_prodD root1_in_set root2_smallest_prio t2_def by fastforce

  (* left subtree equal *)
  have "\<forall>(k', p') \<in> ?entries. k' < key ?t\<^sub>1 \<longrightarrow> (k', p') \<in> set (left ?t\<^sub>1)"
    using Node.prems(1,3) is_treap_def smaller_key_is_left_child by fastforce
  moreover have "\<forall>(k', p') \<in> ?entries.  \<not>k' < key ?t\<^sub>1 \<longrightarrow> (k', p') \<notin> set (left ?t\<^sub>1)"
    using Node.prems(3) bst_rev is_treap_def by force
  moreover have "set (left ?t\<^sub>1) \<subseteq> ?entries"
    by auto
  ultimately have left1: "{(k', p') \<in> ?entries. k' < key ?t\<^sub>1} = set (left ?t\<^sub>1)"
    by blast

  have "\<forall>(k', p') \<in> ?entries. k' < key ?t\<^sub>2 \<longrightarrow> (k', p') \<in> set (left ?t\<^sub>2)"
    using Node.prems(2,4,5) is_treap_def smaller_key_is_left_child t2_def by fastforce
  moreover have "\<forall>(k', p') \<in> ?entries.  \<not>k' < key ?t\<^sub>2 \<longrightarrow> (k', p') \<notin> set (left ?t\<^sub>2)"
    using Node.prems(4) bst_rev is_treap_def t2_def
    by (metis (no_types, lifting) case_prodD case_prodI2 key.simps(1) left.simps(1))
  moreover have "set (left ?t\<^sub>2) \<subseteq> ?entries"
    using Node.prems(5) t2_def by auto
  ultimately have left2: "{(k', p') \<in> ?entries. k' < key ?t\<^sub>2} = set (left ?t\<^sub>2)"
    by blast

  from left1 left2 have "set (left ?t\<^sub>1) = set (left ?t\<^sub>2)"
    by (simp add: roots_eq_keys)
  then have left_subtrees_eq: "l\<^sub>1 = l\<^sub>2"
    using Node.IH(1) \<open>is_treap l\<^sub>2\<close> Node.prems distinct_rev bst_rev is_heap.cases is_treap_def t2_def
    by (metis left.simps(1) treap.distinct(1))

  (* right subtree equal *)
  have "\<forall>(k', p') \<in> ?entries. key ?t\<^sub>1 < k' \<longrightarrow> (k', p') \<in> set (right ?t\<^sub>1)"
    using Node.prems(1,3) is_treap_def larger_key_is_right_child by fastforce
  moreover have "\<forall>(k', p') \<in> ?entries.  \<not>key ?t\<^sub>1 < k' \<longrightarrow> (k', p') \<notin> set (right ?t\<^sub>1)"
    using Node.prems(3) bst_rev is_treap_def by force
  moreover have "set (right ?t\<^sub>1) \<subseteq> ?entries"
    by auto
  ultimately have right1: "{(k', p') \<in> ?entries. key ?t\<^sub>1 < k'} = set (right ?t\<^sub>1)"
    by blast

  have "\<forall>(k', p') \<in> ?entries.  key ?t\<^sub>2 < k' \<longrightarrow> (k', p') \<in> set (right ?t\<^sub>2)"
    using Node.prems(2,4,5) is_treap_def larger_key_is_right_child t2_def by fastforce
  moreover have "\<forall>(k', p') \<in> ?entries.  \<not>key ?t\<^sub>2 < k' \<longrightarrow> (k', p') \<notin> set (right ?t\<^sub>2)"
    using Node.prems(4) bst_rev is_treap_def t2_def
    by (metis (no_types, lifting) case_prodD case_prodI2 key.simps(1) right.simps(1))
  moreover have "set (right ?t\<^sub>2) \<subseteq> ?entries"
    using Node.prems(5) t2_def by auto
  ultimately have right2: "{(k', p') \<in> ?entries. key ?t\<^sub>2 < k'} = set (right ?t\<^sub>2)"
    by blast

  from right1 right2 have "set (right ?t\<^sub>1) = set (right ?t\<^sub>2)"
    by (simp add: roots_eq_keys)
  then have right_subtrees_eq: "r\<^sub>1 = r\<^sub>2"
    using Node.IH(2) \<open>is_treap r\<^sub>2\<close> Node.prems distinct_rev bst_rev is_heap.cases is_treap_def t2_def
    by (metis right.simps(1) treap.distinct(1))

  from left_subtrees_eq right_subtrees_eq show ?case
    by (simp add: roots_eq_keys roots_eq_prios t2_def)
qed

fun bst_insert :: "('a::linorder) \<Rightarrow> real \<Rightarrow> 'a treap \<Rightarrow> 'a treap" where
  "bst_insert k p \<langle>\<rangle> = \<langle>\<langle>\<rangle>, k, p, \<langle>\<rangle>\<rangle>" |
  "bst_insert k p \<langle>l, k', p', r\<rangle> = (if k < k' then \<langle>bst_insert k p l, k', p', r\<rangle> else \<langle>l, k', p', bst_insert k p r\<rangle>)"

lemma bst_insert_inserts: "is_bst t \<Longrightarrow> set (bst_insert k p t) = set t \<union> {(k, p)}"
  by(induction t  rule: is_bst.induct, cases "k < k'", auto)

lemma bst_insert_maintains_inv: "is_bst t \<Longrightarrow> \<forall>p. (k, p) \<notin> set t \<Longrightarrow> is_bst (bst_insert k p t)"
proof(induction t arbitrary: k p rule: is_bst.induct)
  case (Node l r k' p')
  then have "k \<noteq> k'" by auto
  then show ?case
  proof(cases "k < k'")
    case True
    then have "\<forall>p. (k, p) \<notin> set l" using Node.prems by auto
    then have lih: "is_bst (bst_insert k p l)" by (simp add: Node.IH(1))
    from True have "bst_insert k p \<langle>l, k', p', r\<rangle> = \<langle>bst_insert k p l, k', p', r\<rangle>" by simp
    moreover have "\<forall>(x\<^sub>k, x\<^sub>p) \<in> set l. x\<^sub>k < k'" by (simp add: Node.hyps(3))
    then have "\<forall>(x\<^sub>k, x\<^sub>p) \<in> set (bst_insert k p l). x\<^sub>k < k'"
      by (simp add: Node.hyps(1) True bst_insert_inserts)
    ultimately show ?thesis
      by (simp add: Node.hyps(2) Node.hyps(4) is_bst.Node lih)
  next
    case False
    then have "k' < k" using \<open>k \<noteq> k'\<close> by auto
    then have "\<forall>p. (k, p) \<notin> set r" using Node.prems by auto
    then have rih: "is_bst (bst_insert k p r)" by (simp add: Node.IH(2))
    from False have "bst_insert k p \<langle>l, k', p', r\<rangle> = \<langle>l, k', p', bst_insert k p r\<rangle>" by simp
    moreover have "\<forall>(x\<^sub>k, x\<^sub>p) \<in> set r. k' < x\<^sub>k" by (simp add: Node.hyps(4))
    then have "\<forall>(x\<^sub>k, x\<^sub>p) \<in> set (bst_insert k p r). k' < x\<^sub>k"
      by (simp add: Node.hyps(2) \<open>k' < k\<close> bst_insert_inserts)
    ultimately show ?thesis
      by (simp add: Node.hyps(1) Node.hyps(3) is_bst.Node rih)
  qed
qed(simp)

lemma bst_insert_root_key_same:
  assumes "is_bst t"
      and "t \<noteq> \<langle>\<rangle>"
    shows "key t = key (bst_insert k p t)"
  using assms by(induction t rule: is_bst.induct, cases "k < k'", auto)

lemma bst_insert_root_prio_same:
  assumes "is_bst t"
      and "t \<noteq> \<langle>\<rangle>"
    shows "prio t = prio (bst_insert k p t)"
  using assms by(induction t rule: is_bst.induct, cases "k < k'", auto)

lemma bst_insert_maintains_heap:
  assumes "is_bst t"
      and "is_heap t"
      and "\<forall>(k', p') \<in> set t. p' < p"
      and "is_valid_prio p"
    shows "is_heap (bst_insert k p t)"
using assms proof(induction t rule: is_bst.induct)
  case (Node l r k' p')
  then have subheaps: "is_heap l" "is_heap r"
    using is_heap.cases by auto
  have sub_larger_prios: "prio l > p'" "prio r > p'"
    using Node.prems(1) is_heap.cases by auto
  then show ?case
  proof(cases "k < k'")
    case True
    then show ?thesis
    proof(cases l)
      case Leaf
      let ?l = "\<langle>\<langle>\<rangle>, k, p, \<langle>\<rangle>\<rangle>"
      have "is_heap ?l"  by (simp add: assms(4))
      moreover have "prio ?l > p'" using Node.prems(2) by auto
      ultimately have "is_heap \<langle>?l, k', p', r\<rangle>"
        using subheaps(2) sub_larger_prios(2) Node.prems(1,3) Node.prems(1)
          is_heap.Node is_heap.simps by blast
      with True Leaf show ?thesis by simp
    next
      case Node
      let ?l = "bst_insert k p l"
      have "\<forall>(k', p') \<in> set l. p' < p" using Node.prems(2) by auto
      then have "is_heap ?l"
        by (simp add: Node.IH(1) assms(4) subheaps(1))
      moreover have "prio ?l > p'" using Node sub_larger_prios(1) by auto
      ultimately have "is_heap \<langle>?l, k', p', r\<rangle>"
        using subheaps(2) sub_larger_prios(2) Node.prems(1,3) Node.prems(1)
          is_heap.Node is_heap.simps by blast
      with True show ?thesis by simp
    qed
  next
    case False
    then show ?thesis
    proof(cases r)
      case Leaf
      let ?r = "\<langle>\<langle>\<rangle>, k, p, \<langle>\<rangle>\<rangle>"
      have "is_heap ?r"  by (simp add: assms(4))
      moreover have "prio ?r > p'" using Node.prems(2) by auto
      ultimately have "is_heap \<langle>l, k', p', ?r\<rangle>"
        using subheaps(1) sub_larger_prios(1) Node.prems(1,3) Node.prems(1)
          is_heap.Node is_heap.simps by blast
      with False Leaf show ?thesis by simp
    next
      case Node
      let ?r = "bst_insert k p r"
      have "\<forall>(k', p') \<in> set r. p' < p" using Node.prems(2) by auto
      then have "is_heap ?r"
        by (simp add: Node.IH(2) assms(4) subheaps(2))
      moreover have "prio ?r > p'" using Node sub_larger_prios(2) by auto
      ultimately have "is_heap \<langle>l, k', p', ?r\<rangle>"
        using subheaps(1) sub_larger_prios(1) Node.prems(1,3) Node.prems(1)
          is_heap.Node is_heap.simps by blast
      with False show ?thesis by simp
    qed
  qed
qed(simp)

lemma bst_insert_maintains_treap:
  assumes "is_treap t"
      and "\<forall>(k', p') \<in> set t. p' < p"
      and "\<forall>(k', p') \<in> set t. k \<noteq> k'"
      and "is_valid_prio p"
    shows "is_treap (bst_insert k p t)"
proof-
  have "is_bst t" using assms(1) is_treap_def by blast
  then have "is_bst (bst_insert k p t)"
    using assms(3) bst_insert_maintains_inv by fastforce
  moreover have "is_heap t" using assms(1) is_treap_def by blast
  then have "is_heap (bst_insert k p t)"
    using \<open>is_bst t\<close> assms(2) assms(4) bst_insert_maintains_heap by blast
  ultimately show "is_treap (bst_insert k p t)" by (simp add: is_treap_def)
qed

lemma foldr_bst_insert_is_bst:
  assumes "t = foldr (\<lambda> (k, p) t. bst_insert k p t) x \<langle>\<rangle>"
      and "\<forall>(k\<^sub>1, p\<^sub>1) \<in> List.set x. \<forall> (k\<^sub>2, p\<^sub>2) \<in> List.set x. k\<^sub>1 = k\<^sub>2 \<longleftrightarrow> p\<^sub>1 = p\<^sub>2"
    shows "is_bst t"
using assms proof(induction x arbitrary: t)
  case (Cons x xs)
  let ?tinter = "foldr (\<lambda> (k, p) t. bst_insert k p t) xs \<langle>\<rangle>"
  obtain k p where kpdef: "x = (k, p)" by fastforce
  then have "t = bst_insert k p ?tinter" by (simp add: Cons.prems(1))
  have "is_bst ?tinter"
    using Cons.IH Cons.prems(2) by fastforce
  moreover have "\<forall>p. (k, p) \<notin> set ?tinter" sorry
  ultimately show ?case
    by (simp add: \<open>t = bst_insert k p (foldr (\<lambda>(k, p). bst_insert k p) xs \<langle>\<rangle>)\<close> bst_insert_maintains_inv)
qed(simp add: is_bst.Leaf)

lemma foldr_bst_insert_sets_eq:
  assumes "t = foldr (\<lambda> (k, p) t. bst_insert k p t) x \<langle>\<rangle>"
      and "\<forall>(k\<^sub>1, p\<^sub>1) \<in> List.set x. \<forall> (k\<^sub>2, p\<^sub>2) \<in> List.set x. k\<^sub>1 = k\<^sub>2 \<longleftrightarrow> p\<^sub>1 = p\<^sub>2"
    shows "set t = List.set x"
using assms proof(induction x arbitrary: t)
  case (Cons x xs)
  let ?tinter = "foldr (\<lambda> (k, p) t. bst_insert k p t) xs \<langle>\<rangle>"
  have "List.set xs \<subseteq> List.set (x#xs)" by auto
  then have "\<forall>(k\<^sub>1, p\<^sub>1) \<in> List.set xs. \<forall> (k\<^sub>2, p\<^sub>2) \<in> List.set xs. k\<^sub>1 = k\<^sub>2 \<longleftrightarrow> p\<^sub>1 = p\<^sub>2"
    using Cons.prems(2) by auto
  then have "is_bst ?tinter" using foldr_bst_insert_is_bst by blast
  obtain k p where kpdef: "x = (k, p)" by fastforce
  have "set ?tinter = List.set xs"
    using Cons.IH Cons.prems(2) list.set_intros(2) by force
  from kpdef have "t = bst_insert k p ?tinter" by (simp add: Cons.prems(1))
  then have "set (bst_insert k p ?tinter) = set ?tinter \<union> {(k, p)}"
    by (simp add: \<open>is_bst (foldr (\<lambda>(k, p). bst_insert k p) xs \<langle>\<rangle>)\<close> bst_insert_inserts)
  then show ?case
    using \<open>set (foldr (\<lambda>(k, p). bst_insert k p) xs \<langle>\<rangle>) = list.set xs\<close>
          \<open>t = bst_insert k p (foldr (\<lambda>(k, p). bst_insert k p) xs \<langle>\<rangle>)\<close> kpdef
    by auto
qed(simp)

text \<open>Any treap has the same tree structure that would result if elements were inserted in the order of their priorities\<close>
lemma treap_has_special_structure1:
  assumes "sorted_wrt (\<lambda> (k\<^sub>1, p\<^sub>1) (k\<^sub>2, p\<^sub>2). p\<^sub>1 > p\<^sub>2) x"
      and "\<forall>(k\<^sub>1, p\<^sub>1) \<in> List.set x. \<forall> (k\<^sub>2, p\<^sub>2) \<in> List.set x. k\<^sub>1 = k\<^sub>2 \<longleftrightarrow> p\<^sub>1 = p\<^sub>2"
      and "\<forall>(k, p) \<in> List.set x. is_valid_prio p"
      and "t = foldr (\<lambda> (k, p) t. bst_insert k p t) x \<langle>\<rangle>"
    shows "is_treap t"
  using assms proof(induction x arbitrary: t)
  case Nil
  then have "t = \<langle>\<rangle>"
    by auto
  then show ?case
    by (simp add: is_bst.Leaf is_heap.Leaf is_treap_def)
next
  case (Cons x xs)
  let ?tinter = "foldr (\<lambda> (k, p) t. bst_insert k p t) xs \<langle>\<rangle>"
  have "List.set xs \<subseteq> List.set (x#xs)" by auto
  then have subkeyid: "\<forall>(k\<^sub>1, p\<^sub>1) \<in> List.set xs. \<forall> (k\<^sub>2, p\<^sub>2) \<in> List.set xs. k\<^sub>1 = k\<^sub>2 \<longleftrightarrow> p\<^sub>1 = p\<^sub>2"
    using Cons.prems(2) by auto
  obtain k p where kpdef: "x = (k, p)" by fastforce
  then have "t = bst_insert k p ?tinter" by (simp add: Cons.prems(4))
  have "is_treap ?tinter"
    using Cons.IH Cons.prems(1) Cons.prems(3) subkeyid by auto
  moreover
  have "\<forall> (k', p') \<in> List.set xs. p > p'"
    using Cons.prems(1) kpdef by auto
  then have "\<forall> (k', p') \<in> set ?tinter. p > p'"
    using foldr_bst_insert_sets_eq subkeyid by blast
  then have "\<forall>(k', p') \<in> set ?tinter. p' < p"
    by simp
  moreover
  have "\<forall>(k\<^sub>1, p\<^sub>1) \<in> List.set xs. \<forall> (k\<^sub>2, p\<^sub>2) \<in> List.set xs. p\<^sub>1 \<noteq> p\<^sub>2 \<longrightarrow> k\<^sub>1 \<noteq> k\<^sub>2"
    using subkeyid by force
  moreover have "\<forall>(k', p') \<in> List.set xs. k \<noteq> k'"
    using Cons.prems(2) \<open>\<forall>(k', p')\<in>list.set xs. p' < p\<close> kpdef by fastforce
  then have "\<forall>(k', p') \<in> set ?tinter. k \<noteq> k'"
    by (simp add: foldr_bst_insert_sets_eq subkeyid)
  moreover
  from \<open>\<forall>(k, p) \<in> List.set (x#xs). is_valid_prio p\<close> have "is_valid_prio p"
    by (simp add: kpdef)
  ultimately have "is_treap (bst_insert k p ?tinter)"
    using bst_insert_maintains_treap by blast
  then show ?case
    by (simp add: \<open>t = bst_insert k p (foldr (\<lambda>(k, p). bst_insert k p) xs \<langle>\<rangle>)\<close>)
qed

(* Runtime of several operations - Not complete *)

fun search :: "('a::linorder) \<Rightarrow> 'a treap \<Rightarrow> bool" where
  "search k \<langle>\<rangle> = False" |
  "search k \<langle>l, k', _, r\<rangle> = (if k = k' then True else if k < k' then search k l else search k r)"

lemma search_correct:
  assumes "is_bst t"
  shows "search k t \<longleftrightarrow> (\<exists>p. (k, p) \<in> set t)"
proof
  from assms have "\<forall>p. (k, p) \<notin> set t \<Longrightarrow> \<not>search k t"
    by(induction t arbitrary: k rule: is_bst.induct, auto)
  then show "search k t \<Longrightarrow> \<exists>p. (k, p) \<in> set t"
    by auto
next
  show "\<exists>p. (k, p) \<in> set t \<Longrightarrow> search k t"
  using assms by(induction t arbitrary: k rule: is_bst.induct, auto)
qed

fun insert_prio :: "('a::linorder) \<Rightarrow> real \<Rightarrow> 'a treap \<Rightarrow> 'a treap" where
  "insert_prio k p \<langle>\<rangle> = \<langle>\<langle>\<rangle>, k, p, \<langle>\<rangle>\<rangle>" |
  "insert_prio k p \<langle>l\<^sub>r, k\<^sub>r, p\<^sub>r, r\<^sub>r\<rangle> =
    (if k < k\<^sub>r then
      (case insert_prio k p l\<^sub>r of
        \<langle>l\<^sub>c, k\<^sub>c, p\<^sub>c, r\<^sub>c\<rangle> \<Rightarrow>
          (if p\<^sub>r > p\<^sub>c then \<langle>l\<^sub>c, k\<^sub>c, p\<^sub>c, \<langle>r\<^sub>c, k\<^sub>r, p\<^sub>r, r\<^sub>r\<rangle>\<rangle>
          else \<langle>\<langle>l\<^sub>c, k\<^sub>c, p\<^sub>c, r\<^sub>c\<rangle>, k\<^sub>r, p\<^sub>r, r\<^sub>r\<rangle>) |
        _ \<Rightarrow> undefined)
    else
      (case insert_prio k p r\<^sub>r of
        \<langle>l\<^sub>c, k\<^sub>c, p\<^sub>c, r\<^sub>c\<rangle> \<Rightarrow>
          (if p\<^sub>r > p\<^sub>c then\<langle>\<langle>l\<^sub>r, k\<^sub>r, p\<^sub>r, l\<^sub>c\<rangle>, k\<^sub>c, p\<^sub>c, r\<^sub>c\<rangle>
          else \<langle>l\<^sub>r, k\<^sub>r, p\<^sub>r, \<langle>l\<^sub>c, k\<^sub>c, p\<^sub>c, r\<^sub>c\<rangle>\<rangle>) |
        _ \<Rightarrow> undefined)
    )"

end


(*  Title:      HOL/HOLCF/UpperPD.thy
    Author:     Brian Huffman
*)

section \<open>Upper powerdomain\<close>

theory UpperPD
imports Compact_Basis
begin

subsection \<open>Basis preorder\<close>

definition
  upper_le :: "'a pd_basis \<Rightarrow> 'a pd_basis \<Rightarrow> bool" (infix "\<le>\<sharp>" 50) where
  "upper_le = (\<lambda>u v. \<forall>y\<in>Rep_pd_basis v. \<exists>x\<in>Rep_pd_basis u. x \<sqsubseteq> y)"

lemma upper_le_refl [simp]: "t \<le>\<sharp> t"
unfolding upper_le_def by fast

lemma upper_le_trans: "\<lbrakk>t \<le>\<sharp> u; u \<le>\<sharp> v\<rbrakk> \<Longrightarrow> t \<le>\<sharp> v"
unfolding upper_le_def
apply (rule ballI)
apply (drule (1) bspec, erule bexE)
apply (drule (1) bspec, erule bexE)
apply (erule rev_bexI)
apply (erule (1) below_trans)
done

interpretation upper_le: preorder upper_le
by (rule preorder.intro, rule upper_le_refl, rule upper_le_trans)

lemma upper_le_minimal [simp]: "PDUnit compact_bot \<le>\<sharp> t"
unfolding upper_le_def Rep_PDUnit by simp

lemma PDUnit_upper_mono: "x \<sqsubseteq> y \<Longrightarrow> PDUnit x \<le>\<sharp> PDUnit y"
unfolding upper_le_def Rep_PDUnit by simp

lemma PDPlus_upper_mono: "\<lbrakk>s \<le>\<sharp> t; u \<le>\<sharp> v\<rbrakk> \<Longrightarrow> PDPlus s u \<le>\<sharp> PDPlus t v"
unfolding upper_le_def Rep_PDPlus by fast

lemma PDPlus_upper_le: "PDPlus t u \<le>\<sharp> t"
unfolding upper_le_def Rep_PDPlus by fast

lemma upper_le_PDUnit_PDUnit_iff [simp]:
  "(PDUnit a \<le>\<sharp> PDUnit b) = (a \<sqsubseteq> b)"
unfolding upper_le_def Rep_PDUnit by fast

lemma upper_le_PDPlus_PDUnit_iff:
  "(PDPlus t u \<le>\<sharp> PDUnit a) = (t \<le>\<sharp> PDUnit a \<or> u \<le>\<sharp> PDUnit a)"
unfolding upper_le_def Rep_PDPlus Rep_PDUnit by fast

lemma upper_le_PDPlus_iff: "(t \<le>\<sharp> PDPlus u v) = (t \<le>\<sharp> u \<and> t \<le>\<sharp> v)"
unfolding upper_le_def Rep_PDPlus by fast

lemma upper_le_induct [induct set: upper_le]:
  assumes le: "t \<le>\<sharp> u"
  assumes 1: "\<And>a b. a \<sqsubseteq> b \<Longrightarrow> P (PDUnit a) (PDUnit b)"
  assumes 2: "\<And>t u a. P t (PDUnit a) \<Longrightarrow> P (PDPlus t u) (PDUnit a)"
  assumes 3: "\<And>t u v. \<lbrakk>P t u; P t v\<rbrakk> \<Longrightarrow> P t (PDPlus u v)"
  shows "P t u"
using le apply (induct u arbitrary: t rule: pd_basis_induct)
apply (erule rev_mp)
apply (induct_tac t rule: pd_basis_induct)
apply (simp add: 1)
apply (simp add: upper_le_PDPlus_PDUnit_iff)
apply (simp add: 2)
apply (subst PDPlus_commute)
apply (simp add: 2)
apply (simp add: upper_le_PDPlus_iff 3)
done

subsection \<open>Type definition\<close>

typedef 'a upper_pd  ("('(_')\<sharp>)") =
  "{S::'a pd_basis set. upper_le.ideal S}"
by (rule upper_le.ex_ideal)

instantiation upper_pd :: (bifinite) below
begin

definition
  "x \<sqsubseteq> y \<longleftrightarrow> Rep_upper_pd x \<subseteq> Rep_upper_pd y"

instance ..
end

instance upper_pd :: (bifinite) po
using type_definition_upper_pd below_upper_pd_def
by (rule upper_le.typedef_ideal_po)

instance upper_pd :: (bifinite) cpo
using type_definition_upper_pd below_upper_pd_def
by (rule upper_le.typedef_ideal_cpo)

definition
  upper_principal :: "'a pd_basis \<Rightarrow> 'a upper_pd" where
  "upper_principal t = Abs_upper_pd {u. u \<le>\<sharp> t}"

interpretation upper_pd:
  ideal_completion upper_le upper_principal Rep_upper_pd
using type_definition_upper_pd below_upper_pd_def
using upper_principal_def pd_basis_countable
by (rule upper_le.typedef_ideal_completion)

text \<open>Upper powerdomain is pointed\<close>

lemma upper_pd_minimal: "upper_principal (PDUnit compact_bot) \<sqsubseteq> ys"
by (induct ys rule: upper_pd.principal_induct, simp, simp)

instance upper_pd :: (bifinite) pcpo
by intro_classes (fast intro: upper_pd_minimal)

lemma inst_upper_pd_pcpo: "\<bottom> = upper_principal (PDUnit compact_bot)"
by (rule upper_pd_minimal [THEN bottomI, symmetric])

subsection \<open>Monadic unit and plus\<close>

definition
  upper_unit :: "'a \<rightarrow> 'a upper_pd" where
  "upper_unit = compact_basis.extension (\<lambda>a. upper_principal (PDUnit a))"

definition
  upper_plus :: "'a upper_pd \<rightarrow> 'a upper_pd \<rightarrow> 'a upper_pd" where
  "upper_plus = upper_pd.extension (\<lambda>t. upper_pd.extension (\<lambda>u.
      upper_principal (PDPlus t u)))"

abbreviation
  upper_add :: "'a upper_pd \<Rightarrow> 'a upper_pd \<Rightarrow> 'a upper_pd"
    (infixl "\<union>\<sharp>" 65) where
  "xs \<union>\<sharp> ys == upper_plus\<cdot>xs\<cdot>ys"

syntax
  "_upper_pd" :: "args \<Rightarrow> logic" ("{_}\<sharp>")

translations
  "{x,xs}\<sharp>" == "{x}\<sharp> \<union>\<sharp> {xs}\<sharp>"
  "{x}\<sharp>" == "CONST upper_unit\<cdot>x"

lemma upper_unit_Rep_compact_basis [simp]:
  "{Rep_compact_basis a}\<sharp> = upper_principal (PDUnit a)"
unfolding upper_unit_def
by (simp add: compact_basis.extension_principal PDUnit_upper_mono)

lemma upper_plus_principal [simp]:
  "upper_principal t \<union>\<sharp> upper_principal u = upper_principal (PDPlus t u)"
unfolding upper_plus_def
by (simp add: upper_pd.extension_principal
    upper_pd.extension_mono PDPlus_upper_mono)

interpretation upper_add: semilattice upper_add proof
  fix xs ys zs :: "'a upper_pd"
  show "(xs \<union>\<sharp> ys) \<union>\<sharp> zs = xs \<union>\<sharp> (ys \<union>\<sharp> zs)"
    apply (induct xs rule: upper_pd.principal_induct, simp)
    apply (induct ys rule: upper_pd.principal_induct, simp)
    apply (induct zs rule: upper_pd.principal_induct, simp)
    apply (simp add: PDPlus_assoc)
    done
  show "xs \<union>\<sharp> ys = ys \<union>\<sharp> xs"
    apply (induct xs rule: upper_pd.principal_induct, simp)
    apply (induct ys rule: upper_pd.principal_induct, simp)
    apply (simp add: PDPlus_commute)
    done
  show "xs \<union>\<sharp> xs = xs"
    apply (induct xs rule: upper_pd.principal_induct, simp)
    apply (simp add: PDPlus_absorb)
    done
qed

lemmas upper_plus_assoc = upper_add.assoc
lemmas upper_plus_commute = upper_add.commute
lemmas upper_plus_absorb = upper_add.idem
lemmas upper_plus_left_commute = upper_add.left_commute
lemmas upper_plus_left_absorb = upper_add.left_idem

text \<open>Useful for \<open>simp add: upper_plus_ac\<close>\<close>
lemmas upper_plus_ac =
  upper_plus_assoc upper_plus_commute upper_plus_left_commute

text \<open>Useful for \<open>simp only: upper_plus_aci\<close>\<close>
lemmas upper_plus_aci =
  upper_plus_ac upper_plus_absorb upper_plus_left_absorb

lemma upper_plus_below1: "xs \<union>\<sharp> ys \<sqsubseteq> xs"
apply (induct xs rule: upper_pd.principal_induct, simp)
apply (induct ys rule: upper_pd.principal_induct, simp)
apply (simp add: PDPlus_upper_le)
done

lemma upper_plus_below2: "xs \<union>\<sharp> ys \<sqsubseteq> ys"
by (subst upper_plus_commute, rule upper_plus_below1)

lemma upper_plus_greatest: "\<lbrakk>xs \<sqsubseteq> ys; xs \<sqsubseteq> zs\<rbrakk> \<Longrightarrow> xs \<sqsubseteq> ys \<union>\<sharp> zs"
apply (subst upper_plus_absorb [of xs, symmetric])
apply (erule (1) monofun_cfun [OF monofun_cfun_arg])
done

lemma upper_below_plus_iff [simp]:
  "xs \<sqsubseteq> ys \<union>\<sharp> zs \<longleftrightarrow> xs \<sqsubseteq> ys \<and> xs \<sqsubseteq> zs"
apply safe
apply (erule below_trans [OF _ upper_plus_below1])
apply (erule below_trans [OF _ upper_plus_below2])
apply (erule (1) upper_plus_greatest)
done

lemma upper_plus_below_unit_iff [simp]:
  "xs \<union>\<sharp> ys \<sqsubseteq> {z}\<sharp> \<longleftrightarrow> xs \<sqsubseteq> {z}\<sharp> \<or> ys \<sqsubseteq> {z}\<sharp>"
apply (induct xs rule: upper_pd.principal_induct, simp)
apply (induct ys rule: upper_pd.principal_induct, simp)
apply (induct z rule: compact_basis.principal_induct, simp)
apply (simp add: upper_le_PDPlus_PDUnit_iff)
done

lemma upper_unit_below_iff [simp]: "{x}\<sharp> \<sqsubseteq> {y}\<sharp> \<longleftrightarrow> x \<sqsubseteq> y"
apply (induct x rule: compact_basis.principal_induct, simp)
apply (induct y rule: compact_basis.principal_induct, simp)
apply simp
done

lemmas upper_pd_below_simps =
  upper_unit_below_iff
  upper_below_plus_iff
  upper_plus_below_unit_iff

lemma upper_unit_eq_iff [simp]: "{x}\<sharp> = {y}\<sharp> \<longleftrightarrow> x = y"
unfolding po_eq_conv by simp

lemma upper_unit_strict [simp]: "{\<bottom>}\<sharp> = \<bottom>"
using upper_unit_Rep_compact_basis [of compact_bot]
by (simp add: inst_upper_pd_pcpo)

lemma upper_plus_strict1 [simp]: "\<bottom> \<union>\<sharp> ys = \<bottom>"
by (rule bottomI, rule upper_plus_below1)

lemma upper_plus_strict2 [simp]: "xs \<union>\<sharp> \<bottom> = \<bottom>"
by (rule bottomI, rule upper_plus_below2)

lemma upper_unit_bottom_iff [simp]: "{x}\<sharp> = \<bottom> \<longleftrightarrow> x = \<bottom>"
unfolding upper_unit_strict [symmetric] by (rule upper_unit_eq_iff)

lemma upper_plus_bottom_iff [simp]:
  "xs \<union>\<sharp> ys = \<bottom> \<longleftrightarrow> xs = \<bottom> \<or> ys = \<bottom>"
apply (induct xs rule: upper_pd.principal_induct, simp)
apply (induct ys rule: upper_pd.principal_induct, simp)
apply (simp add: inst_upper_pd_pcpo upper_pd.principal_eq_iff
                 upper_le_PDPlus_PDUnit_iff)
done

lemma compact_upper_unit: "compact x \<Longrightarrow> compact {x}\<sharp>"
by (auto dest!: compact_basis.compact_imp_principal)

lemma compact_upper_unit_iff [simp]: "compact {x}\<sharp> \<longleftrightarrow> compact x"
apply (safe elim!: compact_upper_unit)
apply (simp only: compact_def upper_unit_below_iff [symmetric])
apply (erule adm_subst [OF cont_Rep_cfun2])
done

lemma compact_upper_plus [simp]:
  "\<lbrakk>compact xs; compact ys\<rbrakk> \<Longrightarrow> compact (xs \<union>\<sharp> ys)"
by (auto dest!: upper_pd.compact_imp_principal)

subsection \<open>Induction rules\<close>

lemma upper_pd_induct1:
  assumes P: "adm P"
  assumes unit: "\<And>x. P {x}\<sharp>"
  assumes insert: "\<And>x ys. \<lbrakk>P {x}\<sharp>; P ys\<rbrakk> \<Longrightarrow> P ({x}\<sharp> \<union>\<sharp> ys)"
  shows "P (xs::'a upper_pd)"
apply (induct xs rule: upper_pd.principal_induct, rule P)
apply (induct_tac a rule: pd_basis_induct1)
apply (simp only: upper_unit_Rep_compact_basis [symmetric])
apply (rule unit)
apply (simp only: upper_unit_Rep_compact_basis [symmetric]
                  upper_plus_principal [symmetric])
apply (erule insert [OF unit])
done

lemma upper_pd_induct
  [case_names adm upper_unit upper_plus, induct type: upper_pd]:
  assumes P: "adm P"
  assumes unit: "\<And>x. P {x}\<sharp>"
  assumes plus: "\<And>xs ys. \<lbrakk>P xs; P ys\<rbrakk> \<Longrightarrow> P (xs \<union>\<sharp> ys)"
  shows "P (xs::'a upper_pd)"
apply (induct xs rule: upper_pd.principal_induct, rule P)
apply (induct_tac a rule: pd_basis_induct)
apply (simp only: upper_unit_Rep_compact_basis [symmetric] unit)
apply (simp only: upper_plus_principal [symmetric] plus)
done

subsection \<open>Monadic bind\<close>

definition
  upper_bind_basis ::
  "'a pd_basis \<Rightarrow> ('a \<rightarrow> 'b upper_pd) \<rightarrow> 'b upper_pd" where
  "upper_bind_basis = fold_pd
    (\<lambda>a. \<Lambda> f. f\<cdot>(Rep_compact_basis a))
    (\<lambda>x y. \<Lambda> f. x\<cdot>f \<union>\<sharp> y\<cdot>f)"

lemma ACI_upper_bind:
  "semilattice (\<lambda>x y. \<Lambda> f. x\<cdot>f \<union>\<sharp> y\<cdot>f)"
apply unfold_locales
apply (simp add: upper_plus_assoc)
apply (simp add: upper_plus_commute)
apply (simp add: eta_cfun)
done

lemma upper_bind_basis_simps [simp]:
  "upper_bind_basis (PDUnit a) =
    (\<Lambda> f. f\<cdot>(Rep_compact_basis a))"
  "upper_bind_basis (PDPlus t u) =
    (\<Lambda> f. upper_bind_basis t\<cdot>f \<union>\<sharp> upper_bind_basis u\<cdot>f)"
unfolding upper_bind_basis_def
apply -
apply (rule fold_pd_PDUnit [OF ACI_upper_bind])
apply (rule fold_pd_PDPlus [OF ACI_upper_bind])
done

lemma upper_bind_basis_mono:
  "t \<le>\<sharp> u \<Longrightarrow> upper_bind_basis t \<sqsubseteq> upper_bind_basis u"
unfolding cfun_below_iff
apply (erule upper_le_induct, safe)
apply (simp add: monofun_cfun)
apply (simp add: below_trans [OF upper_plus_below1])
apply simp
done

definition
  upper_bind :: "'a upper_pd \<rightarrow> ('a \<rightarrow> 'b upper_pd) \<rightarrow> 'b upper_pd" where
  "upper_bind = upper_pd.extension upper_bind_basis"

syntax
  "_upper_bind" :: "[logic, logic, logic] \<Rightarrow> logic"
    ("(3\<Union>\<sharp>_\<in>_./ _)" [0, 0, 10] 10)

translations
  "\<Union>\<sharp>x\<in>xs. e" == "CONST upper_bind\<cdot>xs\<cdot>(\<Lambda> x. e)"

lemma upper_bind_principal [simp]:
  "upper_bind\<cdot>(upper_principal t) = upper_bind_basis t"
unfolding upper_bind_def
apply (rule upper_pd.extension_principal)
apply (erule upper_bind_basis_mono)
done

lemma upper_bind_unit [simp]:
  "upper_bind\<cdot>{x}\<sharp>\<cdot>f = f\<cdot>x"
by (induct x rule: compact_basis.principal_induct, simp, simp)

lemma upper_bind_plus [simp]:
  "upper_bind\<cdot>(xs \<union>\<sharp> ys)\<cdot>f = upper_bind\<cdot>xs\<cdot>f \<union>\<sharp> upper_bind\<cdot>ys\<cdot>f"
by (induct xs rule: upper_pd.principal_induct, simp,
    induct ys rule: upper_pd.principal_induct, simp, simp)

lemma upper_bind_strict [simp]: "upper_bind\<cdot>\<bottom>\<cdot>f = f\<cdot>\<bottom>"
unfolding upper_unit_strict [symmetric] by (rule upper_bind_unit)

lemma upper_bind_bind:
  "upper_bind\<cdot>(upper_bind\<cdot>xs\<cdot>f)\<cdot>g = upper_bind\<cdot>xs\<cdot>(\<Lambda> x. upper_bind\<cdot>(f\<cdot>x)\<cdot>g)"
by (induct xs, simp_all)

subsection \<open>Map\<close>

definition
  upper_map :: "('a \<rightarrow> 'b) \<rightarrow> 'a upper_pd \<rightarrow> 'b upper_pd" where
  "upper_map = (\<Lambda> f xs. upper_bind\<cdot>xs\<cdot>(\<Lambda> x. {f\<cdot>x}\<sharp>))"

lemma upper_map_unit [simp]:
  "upper_map\<cdot>f\<cdot>{x}\<sharp> = {f\<cdot>x}\<sharp>"
unfolding upper_map_def by simp

lemma upper_map_plus [simp]:
  "upper_map\<cdot>f\<cdot>(xs \<union>\<sharp> ys) = upper_map\<cdot>f\<cdot>xs \<union>\<sharp> upper_map\<cdot>f\<cdot>ys"
unfolding upper_map_def by simp

lemma upper_map_bottom [simp]: "upper_map\<cdot>f\<cdot>\<bottom> = {f\<cdot>\<bottom>}\<sharp>"
unfolding upper_map_def by simp

lemma upper_map_ident: "upper_map\<cdot>(\<Lambda> x. x)\<cdot>xs = xs"
by (induct xs rule: upper_pd_induct, simp_all)

lemma upper_map_ID: "upper_map\<cdot>ID = ID"
by (simp add: cfun_eq_iff ID_def upper_map_ident)

lemma upper_map_map:
  "upper_map\<cdot>f\<cdot>(upper_map\<cdot>g\<cdot>xs) = upper_map\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>xs"
by (induct xs rule: upper_pd_induct, simp_all)

lemma upper_bind_map:
  "upper_bind\<cdot>(upper_map\<cdot>f\<cdot>xs)\<cdot>g = upper_bind\<cdot>xs\<cdot>(\<Lambda> x. g\<cdot>(f\<cdot>x))"
by (simp add: upper_map_def upper_bind_bind)

lemma upper_map_bind:
  "upper_map\<cdot>f\<cdot>(upper_bind\<cdot>xs\<cdot>g) = upper_bind\<cdot>xs\<cdot>(\<Lambda> x. upper_map\<cdot>f\<cdot>(g\<cdot>x))"
by (simp add: upper_map_def upper_bind_bind)

lemma ep_pair_upper_map: "ep_pair e p \<Longrightarrow> ep_pair (upper_map\<cdot>e) (upper_map\<cdot>p)"
apply standard
apply (induct_tac x rule: upper_pd_induct, simp_all add: ep_pair.e_inverse)
apply (induct_tac y rule: upper_pd_induct)
apply (simp_all add: ep_pair.e_p_below monofun_cfun del: upper_below_plus_iff)
done

lemma deflation_upper_map: "deflation d \<Longrightarrow> deflation (upper_map\<cdot>d)"
apply standard
apply (induct_tac x rule: upper_pd_induct, simp_all add: deflation.idem)
apply (induct_tac x rule: upper_pd_induct)
apply (simp_all add: deflation.below monofun_cfun del: upper_below_plus_iff)
done

(* FIXME: long proof! *)
lemma finite_deflation_upper_map:
  assumes "finite_deflation d" shows "finite_deflation (upper_map\<cdot>d)"
proof (rule finite_deflation_intro)
  interpret d: finite_deflation d by fact
  from d.deflation_axioms show "deflation (upper_map\<cdot>d)"
    by (rule deflation_upper_map)
  have "finite (range (\<lambda>x. d\<cdot>x))" by (rule d.finite_range)
  hence "finite (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))"
    by (rule finite_vimageI, simp add: inj_on_def Rep_compact_basis_inject)
  hence "finite (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x)))" by simp
  hence "finite (Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))"
    by (rule finite_vimageI, simp add: inj_on_def Rep_pd_basis_inject)
  hence *: "finite (upper_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp
  hence "finite (range (\<lambda>xs. upper_map\<cdot>d\<cdot>xs))"
    apply (rule rev_finite_subset)
    apply clarsimp
    apply (induct_tac xs rule: upper_pd.principal_induct)
    apply (simp add: adm_mem_finite *)
    apply (rename_tac t, induct_tac t rule: pd_basis_induct)
    apply (simp only: upper_unit_Rep_compact_basis [symmetric] upper_map_unit)
    apply simp
    apply (subgoal_tac "\<exists>b. d\<cdot>(Rep_compact_basis a) = Rep_compact_basis b")
    apply clarsimp
    apply (rule imageI)
    apply (rule vimageI2)
    apply (simp add: Rep_PDUnit)
    apply (rule range_eqI)
    apply (erule sym)
    apply (rule exI)
    apply (rule Abs_compact_basis_inverse [symmetric])
    apply (simp add: d.compact)
    apply (simp only: upper_plus_principal [symmetric] upper_map_plus)
    apply clarsimp
    apply (rule imageI)
    apply (rule vimageI2)
    apply (simp add: Rep_PDPlus)
    done
  thus "finite {xs. upper_map\<cdot>d\<cdot>xs = xs}"
    by (rule finite_range_imp_finite_fixes)
qed

subsection \<open>Upper powerdomain is bifinite\<close>

lemma approx_chain_upper_map:
  assumes "approx_chain a"
  shows "approx_chain (\<lambda>i. upper_map\<cdot>(a i))"
  using assms unfolding approx_chain_def
  by (simp add: lub_APP upper_map_ID finite_deflation_upper_map)

instance upper_pd :: (bifinite) bifinite
proof
  show "\<exists>(a::nat \<Rightarrow> 'a upper_pd \<rightarrow> 'a upper_pd). approx_chain a"
    using bifinite [where 'a='a]
    by (fast intro!: approx_chain_upper_map)
qed

subsection \<open>Join\<close>

definition
  upper_join :: "'a upper_pd upper_pd \<rightarrow> 'a upper_pd" where
  "upper_join = (\<Lambda> xss. upper_bind\<cdot>xss\<cdot>(\<Lambda> xs. xs))"

lemma upper_join_unit [simp]:
  "upper_join\<cdot>{xs}\<sharp> = xs"
unfolding upper_join_def by simp

lemma upper_join_plus [simp]:
  "upper_join\<cdot>(xss \<union>\<sharp> yss) = upper_join\<cdot>xss \<union>\<sharp> upper_join\<cdot>yss"
unfolding upper_join_def by simp

lemma upper_join_bottom [simp]: "upper_join\<cdot>\<bottom> = \<bottom>"
unfolding upper_join_def by simp

lemma upper_join_map_unit:
  "upper_join\<cdot>(upper_map\<cdot>upper_unit\<cdot>xs) = xs"
by (induct xs rule: upper_pd_induct, simp_all)

lemma upper_join_map_join:
  "upper_join\<cdot>(upper_map\<cdot>upper_join\<cdot>xsss) = upper_join\<cdot>(upper_join\<cdot>xsss)"
by (induct xsss rule: upper_pd_induct, simp_all)

lemma upper_join_map_map:
  "upper_join\<cdot>(upper_map\<cdot>(upper_map\<cdot>f)\<cdot>xss) =
   upper_map\<cdot>f\<cdot>(upper_join\<cdot>xss)"
by (induct xss rule: upper_pd_induct, simp_all)

end


(*
Title: Modal Quantales
Author: Georg Struth
Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
*)

section \<open>Modal Quantales\<close>

theory Modal_Quantale
  imports Quantale_light MKA_light

begin

class domain_quantale = quantale + dom_op +
  assumes dom_absorb: "x \<le> dom x \<cdot> x"
  and dom_local: "dom (x \<cdot> dom y) = dom (x \<cdot> y)"
  and dom_add: "dom (x \<squnion> y) = dom x \<squnion> dom y"
  and dom_subid: "dom x \<le> 1"
  and dom_zero [simp]: "dom \<bottom> = \<bottom>"

text \<open>The definition is that of a domain semigroup. The following sublocale statement brings all
those properties into scope.\<close>

sublocale domain_quantale \<subseteq> dqmka: domain_kleene_algebra "1" "(\<cdot>)" "(\<squnion>)" "\<bottom>" "(\<le>)" "(<)" qstar dom
  by (unfold_locales, simp_all add: local.dom_absorb local.dom_local local.dom_add local.dom_subid)

context domain_quantale
begin

lemma dom_top [simp]: "dom \<top> = 1"
proof-
  have "1 \<le> \<top>"
    by simp
  hence "dom 1 \<le> dom \<top>"
    using local.dqmka.d_iso by blast
  thus ?thesis
    by (simp add: local.dom_subid local.dual_order.antisym)
qed

lemma dom_top2: "x \<cdot> \<top> \<le> dom x \<cdot> \<top>"
proof-
  have "x \<cdot> \<top> = dom x \<cdot> x \<cdot> \<top>"
    by simp
  also have "\<dots> \<le> dom x \<cdot> \<top> \<cdot> \<top>"
    using local.order_refl local.top_greatest qdual.qd.mult_iso by presburger
  finally show ?thesis
    by (simp add: local.mult.semigroup_axioms semigroup.assoc)
qed

lemma weak_twisted: "x \<cdot> dom y \<le> dom (x \<cdot> y) \<cdot> x"
  using local.dqmka.d_demod by blast

lemma dom_meet: "dom x \<cdot> dom y = dom x \<sqinter> dom y"
  apply (rule order.antisym)
  apply (simp add: local.dqmka.dom_lb1 local.dqmka.dom_lb2)
  by (metis local.dqmka.d_absorb_eq local.dqmka.d_invol local.dqmka.d_iso local.inf.cobounded1 local.inf.cobounded2 qdual.qd.mult_iso)

lemma dom_meet_pres: "dom (dom x \<sqinter> dom y) = dom x \<sqinter> dom y"
  using dom_meet local.dqmka.d_comp_closed by fastforce

lemma dom_meet_distl: "dom x \<cdot> (y \<sqinter> z) = (dom x \<cdot> y) \<sqinter> (dom x \<cdot> z)"
proof-
  have a: "dom x \<cdot> (y \<sqinter> z) \<le> (dom x \<cdot> y) \<sqinter> (dom x \<cdot> z)"
    by (simp add: qdual.qd.mult_isor)
  have "(dom x \<cdot> y) \<sqinter> (dom x \<cdot> z) = dom ((dom x \<cdot> y) \<sqinter> (dom x \<cdot> z)) \<cdot> ((dom x \<cdot> y) \<sqinter> (dom x \<cdot> z))"
    by simp
  also have "\<dots> \<le> dom ((dom x \<cdot> y)) \<cdot> ((dom x \<cdot> y) \<sqinter> (dom x \<cdot> z))"
    using local.dqmka.d_iso local.inf_le1 qdual.qd.mult_isol by blast
  also have "\<dots> \<le> dom x \<cdot> ((dom x \<cdot> y) \<sqinter> (dom x \<cdot> z))"
    by (simp add: dom_meet local.dqmka.d_demod qdual.qd.dd.mult_iso)
  also have "\<dots> \<le> dom x \<cdot> (y \<sqinter> z)"
    by (metis local.dom_subid local.inf_mono local.mult_1_left qdual.qd.mult_isol qdual.qd.mult_isor)
  finally show ?thesis
    using a local.dual_order.antisym by blast
qed

lemma dom_meet_approx: "dom ((dom x \<cdot> y) \<sqinter> (dom x \<cdot> z)) \<le> dom x"
  by (simp add: dom_meet_distl local.dqmka.lla local.qdual.mult_assoc)

lemma dom_inf_pres_aux: "Y \<noteq> {} \<Longrightarrow> dom (\<Sqinter>{dom x \<cdot> y |y. y\<in>Y}) \<le> dom x"
proof-
  assume "Y \<noteq> {}"
  have "\<forall>z\<in>Y. dom (\<Sqinter>{dom x \<cdot> y |y. y\<in>Y}) \<le> dom (dom x \<cdot> z)"
    by (metis (mono_tags, lifting) local.Inf_lower local.dqmka.d_iso mem_Collect_eq)
  hence "\<forall>z\<in>Y. dom (\<Sqinter>{dom x \<cdot> y |y. y\<in>Y}) \<le> dom x \<cdot> dom z"
    using local.dqmka.d_export by fastforce
  hence "\<forall>z\<in>Y. dom (\<Sqinter>{dom x \<cdot> y |y. y\<in>Y}) \<le> dom x"
    using dom_meet by fastforce
  thus "dom (\<Sqinter>{dom x \<cdot> y |y. y\<in>Y}) \<le> dom x"
    using \<open>Y \<noteq> {}\<close> by blast
qed

lemma dom_inf_pres_aux2: "\<Sqinter>{dom x \<cdot> y |y. y\<in>Y} \<le> \<Sqinter>Y"
  by (smt (z3) local.Inf_mono local.dqmka.d_absorb_eq local.dqmka.d_comm local.dqmka.d_export local.dqmka.lla local.order.eq_iff mem_Collect_eq mult_assoc qdual.qd.mult_isol)

lemma dom_inf_pres: "Y \<noteq> {} \<Longrightarrow> dom x \<cdot> (\<Sqinter>Y) = \<Sqinter>{dom x \<cdot> y |y. y\<in>Y}"
proof-
  assume hyp: "Y \<noteq> {}"
  have a: "dom x \<cdot> (\<Sqinter>Y) \<le> \<Sqinter>{dom x \<cdot> y |y. y\<in>Y}"
    by (simp add: Setcompr_eq_image local.Inf_subdistl)
  have "\<Sqinter>{dom x \<cdot> y |y. y\<in>Y} = dom (\<Sqinter>{dom x \<cdot> y |y. y\<in>Y}) \<cdot> \<Sqinter>{dom x \<cdot> y |y. y\<in>Y}"
    by simp
  also have "\<dots> \<le> dom x \<cdot> \<Sqinter>{dom x \<cdot> y |y. y\<in>Y}"
    using dom_inf_pres_aux hyp local.dqmka.lla by force
  also have "\<dots> \<le> dom x \<cdot> \<Sqinter>Y"
    by (simp add: dom_inf_pres_aux2 qdual.qd.mult_isor)
  finally show ?thesis
    using a order.antisym by blast
qed

lemma "x \<cdot> (\<Sqinter>Y) \<le> \<Sqinter>{x \<cdot> y |y. y\<in>Y}"
  by (simp add: Setcompr_eq_image local.Inf_subdistl)

lemma "(\<Sqinter>X) \<cdot> y \<le> \<Sqinter>{x \<cdot> y |x. x\<in>X}"
  by (simp add: Setcompr_eq_image local.Inf_subdistr)

lemma "dom (\<Sqinter>X) \<le> \<Sqinter>{dom x|x. x\<in>X}"
  by (simp add: Setcompr_eq_image local.INF_greatest local.Inf_lower local.dqmka.d_iso)

lemma dom_top_pres: "(x \<le> dom y \<cdot> x) = (x \<le> dom y \<cdot> \<top>)"
  by (smt (verit) local.dqmka.d_export local.dqmka.d_iso local.dqmka.dom_glb_eq local.dqmka.lla local.order.trans local.top_greatest qdual.qd.mult_iso)

lemma dom_lla_var: "(dom x \<le> dom y) = (x \<le> dom y \<cdot> \<top>)"
  using dom_top_pres local.dqmka.lla by presburger

lemma "dom (1 \<sqinter> x) = 1 \<sqinter> x \<Longrightarrow> x \<le> 1 \<Longrightarrow> dom x = x"
  using local.inf_absorb2 by auto

lemma dom_meet_sub: "dom (x \<sqinter> y) \<le> dom x \<sqinter> dom y"
  by (simp add: local.dqmka.d_iso)

lemma dom_top: "dom x \<cdot> \<top> = x \<cdot> \<top>"
  nitpick (* counterexample *)
  oops

definition "fd x y = dom (x \<cdot> y)"

lemma fd_fdia [simp]: "fd x y = dqmka.fdia x y"
  by (simp add: fd_def local.dqmka.fdia_def)

definition "bb x y = \<Squnion>{dom z |z. fd x z \<le> dom y}"

lemma bb_demod: "(dom y \<le> bb x z) = (x \<cdot> dom y \<le> dom z \<cdot> x)"
  oops

lemma  fdbb_galois:
  assumes "dom p = p" and "dom q = q"
  shows "(fd x p \<le> q) = (p \<le> bb x q)"
proof
  assume "fd x p \<le> q"
  hence "p \<in> {dom z |z. fd x z \<le> dom q}"
    using assms(1) assms(2) by force
  hence "p \<le> \<Squnion>{dom z |z. fd x z \<le> dom q}"
    using local.Sup_upper by presburger
  thus "p \<le> bb x q"
    using bb_def by force
next
  assume "p \<le> bb x q"
  hence "p \<le> \<Squnion>{dom z |z. fd x z \<le> dom q}"
    by (simp add: bb_def)
  hence "fd x p \<le> fd x (\<Squnion>{dom z |z. fd x z \<le> dom q})"
    by (simp add: local.dqmka.d_iso local.dqmka.fdia_def qdual.qd.mult_isor)
  also have "\<dots> = dom (x \<cdot> \<Squnion>{dom z |z. fd x z \<le> dom q})"
   sorry
  also have "\<dots> = \<Squnion>{dom (x \<cdot> dom z) |z. fd x z \<le> dom q}"
    sorry  (*this is something we can't prove with Isabelle *)
  also have "\<dots> = \<Squnion>{fd x z |z. fd x z \<le> dom q}"
    using fd_def local.dom_local by force
  also have "\<dots> \<le> dom q"
    by (smt (verit) local.Sup_least mem_Collect_eq)
  finally show "fd x p \<le> q"
    using assms(2) by force
qed

end

class codomain_quantale = quantale + cod_op +
  assumes cod_absorb: "x \<le> x \<cdot> cod x"
  and cod_local: "cod (cod x \<cdot> y) = cod (x \<cdot> y)"
  and cod_add: "cod (x \<squnion> y) = cod x \<squnion> cod y"
  and cod_subid: "cod x \<le> 1"
  and cod_zero: "cod \<bottom> = \<bottom>"

sublocale codomain_quantale \<subseteq> coddual: domain_quantale cod _ _ _ _ _ _ _ _ _ "\<lambda>x y. y \<cdot> x"
  by (unfold_locales, simp_all add: local.cod_absorb local.cod_local local.cod_add local.cod_subid cod_zero)

abbreviation (in codomain_quantale) "bd \<equiv> coddual.fd"

definition  (in codomain_quantale) "fb x y = \<Squnion>{dom z |z. bd x (dom z) \<le> dom y}"

class modal_quantale = domain_quantale + codomain_quantale +
  assumes dc_compat [simp]: "dom (cod x) = cod x"
  and cd_compat [simp]: "cod (dom x) = dom x"

lemma (in modal_quantale)  "dom x \<cdot> \<top> = x \<cdot> \<top>"
  nitpick (* counterexample *)
  oops

sublocale modal_quantale \<subseteq> mqs: modal_kleene_algebra "1" "(\<cdot>)" "(\<squnion>)" "\<bottom>" "(\<le>)" "(<)" "qstar" "cod" "dom"
  by (unfold_locales, simp_all add: local.cod_absorb local.cod_local local.cod_add local.cod_subid)

sublocale modal_quantale \<subseteq> mqdual: modal_quantale  "dom" _ _ _ _ _ _ _ _ _ "\<lambda>x y. y \<cdot> x" "cod"
  by (unfold_locales, simp_all add: local.dom_local local.dom_add local.dom_subid local.cod_local local.cod_add local.cod_subid)

end


(*<*)
theory Tree2 imports Tree begin
(*>*)

text\<open>\noindent In Exercise~\ref{ex:Tree} we defined a function
\<^term>\<open>flatten\<close> from trees to lists. The straightforward version of
\<^term>\<open>flatten\<close> is based on \<open>@\<close> and is thus, like \<^term>\<open>rev\<close>,
quadratic. A linear time version of \<^term>\<open>flatten\<close> again reqires an extra
argument, the accumulator. Define\<close>
(*<*)primrec(*>*)flatten2 :: "'a tree \<Rightarrow> 'a list \<Rightarrow> 'a list"(*<*)where
"flatten2 Tip xs = xs" |
"flatten2 (Node l x r) xs = flatten2 l (x#(flatten2 r xs))"
(*>*)

text\<open>\noindent and prove\<close>
(*<*)

end
(*>*)