(*
  File: Rat.thy
  Author: Bohua Zhan

  Construction of the rational numbers (as pairs of integers (a,b) where b is
  nonzero, under the equivalence relation (a,b) ~ (c,d) when a * d = b * c.
*)

theory Rat
  imports Int Field
begin

section \<open>Definition of rational numbers\<close>

definition rat_rel_space :: i where [rewrite]:
  "rat_rel_space = carrier(\<int>)\<times>pos_elts(\<int>)"

definition rat_rel :: i where [rewrite]:
  "rat_rel = Equiv(rat_rel_space, \<lambda>p q. let \<langle>a,b\<rangle> = p; \<langle>c,d\<rangle> = q in a *\<^sub>\<int> d = b *\<^sub>\<int> c)"
notation rat_rel ("\<R>")

lemma rat_rel_spaceI [typing]: "x \<in> int \<Longrightarrow> y >\<^sub>\<int> \<zero>\<^sub>\<int> \<Longrightarrow> \<langle>x,y\<rangle> \<in>. \<R>" by auto2
lemma rat_rel_spaceI' [typing]: "x \<in> int \<Longrightarrow> \<langle>x,\<one>\<^sub>\<int>\<rangle> \<in>. \<R>" by auto2
lemma rat_rel_spaceD [forward]: "p \<in>. \<R> \<Longrightarrow> p = \<langle>fst(p),snd(p)\<rangle> \<and> fst(p) \<in> int \<and> snd(p) >\<^sub>\<int> \<zero>\<^sub>\<int>" by auto2
setup {* del_prfstep_thm @{thm rat_rel_space_def} *}

lemma rat_rel_trans [backward1]:
  "a1 \<in>. \<int> \<Longrightarrow> a2 \<in>. \<int> \<Longrightarrow> b1 \<in>. \<int> \<Longrightarrow> b2 \<in>. \<int> \<Longrightarrow> c1 \<in>. \<int> \<Longrightarrow> c2 \<in>. \<int> \<Longrightarrow> b2 \<noteq> \<zero>\<^sub>\<int> \<Longrightarrow>
   a1 *\<^sub>\<int> b2 = a2 *\<^sub>\<int> b1 \<Longrightarrow> b1 *\<^sub>\<int> c2 = b2 *\<^sub>\<int> c1 \<Longrightarrow> a1 *\<^sub>\<int> c2 = a2 *\<^sub>\<int> c1"
@proof
  @have "(a1 *\<^sub>\<int> c2) *\<^sub>\<int> b2 = (a1 *\<^sub>\<int> b2) *\<^sub>\<int> c2"
  @have "(a2 *\<^sub>\<int> b1) *\<^sub>\<int> c2 = a2 *\<^sub>\<int> (b1 *\<^sub>\<int> c2)"
  @have "a2 *\<^sub>\<int> (b2 *\<^sub>\<int> c1) = (a2 *\<^sub>\<int> c1) *\<^sub>\<int> b2"
@qed

lemma rat_rel_is_rel [typing]: "\<R> \<in> equiv_space(rat_rel_space)" by auto2
setup {* del_prfstep_thm @{thm rat_rel_trans} *}

lemma rat_rel_eval:
  "x \<in>. \<R> \<Longrightarrow> y \<in>. \<R> \<Longrightarrow> x \<sim>\<^sub>\<R> y \<longleftrightarrow> (fst(x) *\<^sub>\<int> snd(y) = snd(x) *\<^sub>\<int> fst(y))" by auto2
setup {* add_rewrite_rule_cond @{thm rat_rel_eval} [with_cond "?x \<noteq> ?y"] *}
setup {* del_prfstep_thm @{thm rat_rel_def} *}

definition rat :: i where [rewrite_bidir]:
  "rat = carrier(\<R>) // \<R>"

abbreviation Rat :: "i \<Rightarrow> i" where "Rat(p) \<equiv> equiv_class(\<R>,p)"

section \<open>Rationals as a ring\<close>

definition rat_mult_raw :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "rat_mult_raw(p,q) = \<langle>fst(p)*\<^sub>\<int>fst(q),snd(p)*\<^sub>\<int>snd(q)\<rangle>"
setup {* register_wellform_data ("rat_mult_raw(p,q)", ["p \<in>. \<R>", "q \<in>. \<R>"]) *}

lemma rat_mult_raw_eval [rewrite]: "rat_mult_raw(\<langle>a,b\<rangle>,\<langle>c,d\<rangle>) = \<langle>a*\<^sub>\<int>c, b*\<^sub>\<int>d\<rangle>" by auto2
setup {* del_prfstep_thm @{thm rat_mult_raw_def} *}

definition rat_add_raw :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "rat_add_raw(p,q) = \<langle>fst(p)*\<^sub>\<int>snd(q)+\<^sub>\<int>snd(p)*\<^sub>\<int>fst(q), snd(p)*\<^sub>\<int>snd(q)\<rangle>"
setup {* register_wellform_data ("rat_add_raw(p,q)", ["p \<in>. \<R>", "q \<in>. \<R>"]) *}

lemma rat_add_raw_eval [rewrite]: "rat_add_raw(\<langle>a,b\<rangle>,\<langle>c,d\<rangle>) = \<langle>a*\<^sub>\<int>d+\<^sub>\<int>b*\<^sub>\<int>c, b*\<^sub>\<int>d\<rangle>" by auto2
setup {* del_prfstep_thm @{thm rat_add_raw_def} *}

definition nonneg_rat_raw :: "i \<Rightarrow> o" where [rewrite]:
  "nonneg_rat_raw(p) \<longleftrightarrow> fst(p) \<ge>\<^sub>\<int> \<zero>\<^sub>\<int>"

definition nonneg_rat :: "i \<Rightarrow> o" where [rewrite]:
  "nonneg_rat(x) \<longleftrightarrow> nonneg_rat_raw(rep(\<R>,x))"

definition nonneg_rats :: i where [rewrite]:
  "nonneg_rats = {x\<in>rat. nonneg_rat(x)}"

definition rat_ring :: i where [rewrite]:
  "rat_ring = Ring(rat, Rat(\<langle>\<zero>\<^sub>\<int>,\<one>\<^sub>\<int>\<rangle>), \<lambda>x y. Rat(rat_add_raw(rep(\<R>,x), rep(\<R>,y))),
                        Rat(\<langle>\<one>\<^sub>\<int>,\<one>\<^sub>\<int>\<rangle>), \<lambda>x y. Rat(rat_mult_raw(rep(\<R>,x), rep(\<R>,y))))"

lemma rat_ring_is_ring_raw [forward]: "ring_form(rat_ring)" by auto2

definition rat_ord_ring :: i  ("\<rat>") where [rewrite]:
  "rat_ord_ring = ord_ring_from_nonneg(rat_ring, nonneg_rats)"

lemma rat_is_ring_raw [forward]: "is_ring_raw(\<rat>)" by auto2
lemma rat_carrier [rewrite_bidir]: "carrier(\<rat>) = rat" by auto2
lemma rat_evals [rewrite]:
  "\<zero>\<^sub>\<rat> = Rat(\<langle>\<zero>\<^sub>\<int>,\<one>\<^sub>\<int>\<rangle>)"
  "\<one>\<^sub>\<rat> = Rat(\<langle>\<one>\<^sub>\<int>,\<one>\<^sub>\<int>\<rangle>)"
  "x \<in>. \<rat> \<Longrightarrow> y \<in>. \<rat> \<Longrightarrow> x +\<^sub>\<rat> y = Rat(rat_add_raw(rep(\<R>,x), rep(\<R>,y)))"
  "x \<in>. \<rat> \<Longrightarrow> y \<in>. \<rat> \<Longrightarrow> x *\<^sub>\<rat> y = Rat(rat_mult_raw(rep(\<R>,x), rep(\<R>,y)))" by auto2+

lemma rat_is_ord_field_prep [forward]:
  "is_field(\<rat>) \<Longrightarrow> nonneg_compat(\<rat>,nonneg_rats) \<Longrightarrow> is_ord_field(\<rat>)" by auto2

setup {* fold del_prfstep_thm [@{thm rat_ring_def}, @{thm rat_ord_ring_def}] *}

lemma rat_zero_raw_mem [typing]: "\<langle>\<zero>\<^sub>\<int>,\<one>\<^sub>\<int>\<rangle> \<in>. \<R>" by auto2
lemma rat_one_raw_mem [typing]: "\<langle>\<one>\<^sub>\<int>,\<one>\<^sub>\<int>\<rangle> \<in>. \<R>" by auto2

lemma rat_choose_rep: "r \<in>. \<rat> \<Longrightarrow> r = Rat(rep(\<R>,r))" by auto2
setup {* add_rewrite_rule_cond @{thm rat_choose_rep} [with_filt (size1_filter "r")] *}

section \<open>Multiplication on rationals\<close>

lemma rat_mult_raw_type [typing]:
  "\<langle>a,b\<rangle> \<in>. \<R> \<Longrightarrow> \<langle>c,d\<rangle> \<in>. \<R> \<Longrightarrow> rat_mult_raw(\<langle>a,b\<rangle>,\<langle>c,d\<rangle>) \<in>. \<R>" by auto2

lemma rat_mult_eval [rewrite]:
  "x \<in>. \<R> \<Longrightarrow> y \<in>. \<R> \<Longrightarrow> Rat(x) *\<^sub>\<rat> Rat(y) = Rat(rat_mult_raw(x,y))"
@proof
  @have "compat_meta_bin1(\<R>, rat_mult_raw)" @with
    @have (@rule) "\<forall>a b c d a' b'. \<langle>c,d\<rangle> \<in>. \<R> \<longrightarrow> \<langle>a',b'\<rangle> \<sim>\<^sub>\<R> \<langle>a,b\<rangle> \<longrightarrow>
                   rat_mult_raw(\<langle>a',b'\<rangle>,\<langle>c,d\<rangle>) \<sim>\<^sub>\<R> rat_mult_raw(\<langle>a,b\<rangle>,\<langle>c,d\<rangle>)" @with
      @have "(a' *\<^sub>\<int> c) *\<^sub>\<int> (b *\<^sub>\<int> d) = (a' *\<^sub>\<int> b) *\<^sub>\<int> (c *\<^sub>\<int> d)"
      @have "(b' *\<^sub>\<int> d) *\<^sub>\<int> (a *\<^sub>\<int> c) = (b' *\<^sub>\<int> a) *\<^sub>\<int> (c *\<^sub>\<int> d)"
    @end
  @end
  @have "compat_meta_bin2(\<R>, rat_mult_raw)" @with
    @have (@rule) "\<forall>a b c d c' d'. \<langle>a,b\<rangle> \<in>. \<R> \<longrightarrow> \<langle>c',d'\<rangle> \<sim>\<^sub>\<R> \<langle>c,d\<rangle> \<longrightarrow>
                   rat_mult_raw(\<langle>a,b\<rangle>,\<langle>c',d'\<rangle>) \<sim>\<^sub>\<R> rat_mult_raw(\<langle>a,b\<rangle>,\<langle>c,d\<rangle>)" @with
      @have "(a *\<^sub>\<int> c') *\<^sub>\<int> (b *\<^sub>\<int> d) = (a *\<^sub>\<int> b) *\<^sub>\<int> (c' *\<^sub>\<int> d)"
      @have "(b *\<^sub>\<int> d') *\<^sub>\<int> (a *\<^sub>\<int> c) = (a *\<^sub>\<int> b) *\<^sub>\<int> (d' *\<^sub>\<int> c)"
    @end
  @end
  @have "compat_meta_bin(\<R>, rat_mult_raw)"
@qed
setup {* del_prfstep_thm @{thm rat_evals(4)} *}

lemma rat_mult_comm [forward]: "is_times_comm(\<rat>)" by auto2
lemma rat_mult_assoc [forward]: "is_times_assoc(\<rat>)" by auto2

section \<open>Addition on rationals\<close>

lemma rat_add_raw_type [typing]:
  "\<langle>a,b\<rangle> \<in>. \<R> \<Longrightarrow> \<langle>c,d\<rangle> \<in>. \<R> \<Longrightarrow> rat_add_raw(\<langle>a,b\<rangle>,\<langle>c,d\<rangle>) \<in>. \<R>" by auto2

lemma rat_add_eval [rewrite]:
  "x \<in>. \<R> \<Longrightarrow> y \<in>. \<R> \<Longrightarrow> Rat(x) +\<^sub>\<rat> Rat(y) = Rat(rat_add_raw(x,y))"
@proof
  @have "compat_meta_bin1(\<R>, rat_add_raw)" @with
    @have (@rule) "\<forall>a b c d a' b'. \<langle>c,d\<rangle> \<in>. \<R> \<longrightarrow> \<langle>a',b'\<rangle> \<sim>\<^sub>\<R> \<langle>a,b\<rangle> \<longrightarrow>
                   rat_add_raw(\<langle>a',b'\<rangle>,\<langle>c,d\<rangle>) \<sim>\<^sub>\<R> rat_add_raw(\<langle>a,b\<rangle>,\<langle>c,d\<rangle>)" @with
      @have "(a'*\<^sub>\<int>d +\<^sub>\<int> b'*\<^sub>\<int>c) *\<^sub>\<int> (b*\<^sub>\<int>d) = (a'*\<^sub>\<int>b)*\<^sub>\<int>d*\<^sub>\<int>d +\<^sub>\<int> b*\<^sub>\<int>b'*\<^sub>\<int>c*\<^sub>\<int>d"
      @have "(b'*\<^sub>\<int>d) *\<^sub>\<int> (a*\<^sub>\<int>d +\<^sub>\<int> b*\<^sub>\<int>c) = (b'*\<^sub>\<int>a)*\<^sub>\<int>d*\<^sub>\<int>d +\<^sub>\<int> b*\<^sub>\<int>b'*\<^sub>\<int>c*\<^sub>\<int>d"
    @end
  @end
  @have "compat_meta_bin2(\<R>, rat_add_raw)" @with
    @have (@rule) "\<forall>a b c d c' d'. \<langle>a,b\<rangle> \<in>. \<R> \<longrightarrow> \<langle>c',d'\<rangle> \<sim>\<^sub>\<R> \<langle>c,d\<rangle> \<longrightarrow>
                   rat_add_raw(\<langle>a,b\<rangle>,\<langle>c',d'\<rangle>) \<sim>\<^sub>\<R> rat_add_raw(\<langle>a,b\<rangle>,\<langle>c,d\<rangle>)" @with
      @have "(a*\<^sub>\<int>d' +\<^sub>\<int> b*\<^sub>\<int>c') *\<^sub>\<int> (b*\<^sub>\<int>d) = (c'*\<^sub>\<int>d)*\<^sub>\<int>b*\<^sub>\<int>b +\<^sub>\<int> a*\<^sub>\<int>b*\<^sub>\<int>d*\<^sub>\<int>d'"
      @have "(b*\<^sub>\<int>d') *\<^sub>\<int> (a*\<^sub>\<int>d +\<^sub>\<int> b*\<^sub>\<int>c)  = (d'*\<^sub>\<int>c)*\<^sub>\<int>b*\<^sub>\<int>b +\<^sub>\<int> a*\<^sub>\<int>b*\<^sub>\<int>d*\<^sub>\<int>d'"
    @end
  @end
  @have "compat_meta_bin(\<R>, rat_add_raw)"
@qed
setup {* del_prfstep_thm @{thm rat_evals(3)} *}

lemma rat_add_comm [forward]: "is_plus_comm(\<rat>)" by auto2

lemma rat_add_raw_assoc [rewrite]:
  "\<langle>a,b\<rangle> \<in>. \<R> \<Longrightarrow> \<langle>c,d\<rangle> \<in>. \<R> \<Longrightarrow> \<langle>e,f\<rangle> \<in>. \<R> \<Longrightarrow>
   rat_add_raw(rat_add_raw(\<langle>a,b\<rangle>,\<langle>c,d\<rangle>),\<langle>e,f\<rangle>) = rat_add_raw(\<langle>a,b\<rangle>,rat_add_raw(\<langle>c,d\<rangle>,\<langle>e,f\<rangle>))"
@proof
  @have "(a*\<^sub>\<int>d +\<^sub>\<int> b*\<^sub>\<int>c) *\<^sub>\<int> f +\<^sub>\<int> (b*\<^sub>\<int>d)*\<^sub>\<int>e = a*\<^sub>\<int>(d*\<^sub>\<int>f) +\<^sub>\<int> b *\<^sub>\<int> (c*\<^sub>\<int>f +\<^sub>\<int> d*\<^sub>\<int>e)"
@qed

lemma rat_add_assoc [forward]: "is_plus_assoc(\<rat>)" by auto2
setup {* del_prfstep_thm @{thm rat_add_raw_assoc} *}

lemma rat_distrib_l_raw [resolve]:
  "\<langle>a,b\<rangle> \<in>. \<R> \<Longrightarrow> \<langle>c,d\<rangle> \<in>. \<R> \<Longrightarrow> \<langle>e,f\<rangle> \<in>. \<R> \<Longrightarrow>
   rat_mult_raw(\<langle>a,b\<rangle>,rat_add_raw(\<langle>c,d\<rangle>,\<langle>e,f\<rangle>)) \<sim>\<^sub>\<R> rat_add_raw(rat_mult_raw(\<langle>a,b\<rangle>,\<langle>c,d\<rangle>),rat_mult_raw(\<langle>a,b\<rangle>,\<langle>e,f\<rangle>))"
@proof
  @have "a*\<^sub>\<int>(c*\<^sub>\<int>f+\<^sub>\<int>d*\<^sub>\<int>e) *\<^sub>\<int> ((b*\<^sub>\<int>d)*\<^sub>\<int>(b*\<^sub>\<int>f)) = b*\<^sub>\<int>(d*\<^sub>\<int>f) *\<^sub>\<int> ((a*\<^sub>\<int>c)*\<^sub>\<int>(b*\<^sub>\<int>f) +\<^sub>\<int> (b*\<^sub>\<int>d)*\<^sub>\<int>(a*\<^sub>\<int>e))"
@qed

lemma rat_distrib_l [forward]: "is_left_distrib(\<rat>)" by auto2
setup {* del_prfstep_thm @{thm rat_distrib_l_raw} *}

section \<open>0 and 1\<close>

lemma rat_is_add_id [forward]: "is_add_id(\<rat>)" by auto2
lemma rat_is_mult_id [forward]: "is_mult_id(\<rat>)" by auto2
lemma rat_zero_neq_one [resolve]: "\<zero>\<^sub>\<rat> \<noteq> \<one>\<^sub>\<rat>" by auto2

section \<open>Negation on rationals\<close>

definition rat_neg_raw :: "i \<Rightarrow> i" where [rewrite]:
  "rat_neg_raw(p) = \<langle>-\<^sub>\<int> fst(p), snd(p)\<rangle>"

definition rat_neg :: "i \<Rightarrow> i" where [rewrite]:
  "rat_neg(x) = Rat(rat_neg_raw(rep(\<R>,x)))"

lemma rat_neg_typing [typing]: "x \<in>. \<rat> \<Longrightarrow> rat_neg(x) \<in>. \<rat>" by auto2

lemma rat_add_raw_eval_eq_denom [rewrite]:
  "\<langle>p,r\<rangle> \<in>. \<R> \<Longrightarrow> \<langle>q,r\<rangle> \<in>. \<R> \<Longrightarrow> Rat(\<langle>p,r\<rangle>) +\<^sub>\<rat> Rat(\<langle>q,r\<rangle>) = Rat(\<langle>p+\<^sub>\<int>q, r\<rangle>)"
@proof @have "(p*\<^sub>\<int>r +\<^sub>\<int> r*\<^sub>\<int>q) *\<^sub>\<int> r = r *\<^sub>\<int> r *\<^sub>\<int> (p +\<^sub>\<int> q)" @qed

lemma rat_equiv_class_zero [rewrite]: "q >\<^sub>\<int> \<zero>\<^sub>\<int> \<Longrightarrow> Rat(\<langle>\<zero>\<^sub>\<int>,q\<rangle>) = \<zero>\<^sub>\<rat>" by auto2

lemma rat_has_add_inverse [forward]: "has_add_inverse(\<rat>)"
@proof @have "\<forall>x\<in>.\<rat>. x +\<^sub>\<rat> rat_neg(x) = \<zero>\<^sub>\<rat>" @qed

lemma rat_is_comm_ring [forward]: "is_comm_ring(\<rat>)" by auto2

section \<open>Inverse in rationals\<close>

definition rat_inverse_raw :: "i \<Rightarrow> i" where [rewrite]:
  "rat_inverse_raw(p) = (if fst(p) >\<^sub>\<int> \<zero>\<^sub>\<int> then \<langle>snd(p),fst(p)\<rangle> else \<langle>-\<^sub>\<int> snd(p), -\<^sub>\<int> fst(p)\<rangle>)"
setup {* register_wellform_data ("rat_inverse_raw(p)", ["p \<in>. \<R>"]) *}

lemma rat_inverse_raw_eval [rewrite]:
  "\<langle>a,b\<rangle> \<in>. \<R> \<Longrightarrow> a >\<^sub>\<int> \<zero>\<^sub>\<int> \<Longrightarrow> rat_inverse_raw(\<langle>a,b\<rangle>) = \<langle>b,a\<rangle>"
  "\<langle>a,b\<rangle> \<in>. \<R> \<Longrightarrow> a <\<^sub>\<int> \<zero>\<^sub>\<int> \<Longrightarrow> rat_inverse_raw(\<langle>a,b\<rangle>) = \<langle>-\<^sub>\<int> b, -\<^sub>\<int> a\<rangle>" by auto2+
setup {* del_prfstep_thm @{thm rat_inverse_raw_def} *}

lemma rat_inverse_raw_type [typing]:
  "\<langle>a,b\<rangle> \<in>. \<R> \<Longrightarrow> a \<noteq> \<zero>\<^sub>\<int> \<Longrightarrow> rat_inverse_raw(\<langle>a,b\<rangle>) \<in>. \<R>"
@proof @case "a >\<^sub>\<int> \<zero>\<^sub>\<int>" @qed

definition rat_inverse :: "i \<Rightarrow> i" where [rewrite]:
  "rat_inverse(r) = Rat(rat_inverse_raw(rep(\<R>,r)))"

lemma rat_equiv_zero [rewrite]:
  "\<langle>a,b\<rangle> \<in>. \<R> \<Longrightarrow> Rat(\<langle>a,b\<rangle>) = \<zero>\<^sub>\<rat> \<longleftrightarrow> a = \<zero>\<^sub>\<int>" by auto2

lemma rat_inverse_typing [typing]:
  "x \<in>. \<rat> \<Longrightarrow> x \<noteq> \<zero>\<^sub>\<rat> \<Longrightarrow> rat_inverse(x) \<in>. \<rat>" by auto2

lemma rat_inverse_raw_mult_inv [rewrite]:
  "\<langle>p,q\<rangle> \<in>. \<R> \<Longrightarrow> p \<noteq> \<zero>\<^sub>\<int> \<Longrightarrow> Rat(rat_mult_raw(\<langle>p,q\<rangle>,rat_inverse_raw(\<langle>p,q\<rangle>))) = \<one>\<^sub>\<rat>"
@proof @case "p >\<^sub>\<int> \<zero>\<^sub>\<int>" @qed

lemma rat_is_field [forward]: "is_field(\<rat>)"
@proof @have "\<forall>x\<in>.\<rat>. x \<noteq> \<zero>\<^sub>\<rat> \<longrightarrow> x *\<^sub>\<rat> rat_inverse(x) = \<one>\<^sub>\<rat>" @qed

section \<open>Nonnegative rationals\<close>

lemma nonneg_rat_eval [rewrite]:
  "x \<in>. \<R> \<Longrightarrow> nonneg_rat(Rat(x)) \<longleftrightarrow> nonneg_rat_raw(x)" by auto2
setup {* del_prfstep_thm @{thm nonneg_rat_def} *}

lemma rat_neg_eval [rewrite]: "x \<in>. \<R> \<Longrightarrow> -\<^sub>\<rat> Rat(x) = Rat(rat_neg_raw(x))"
@proof @have "Rat(x) +\<^sub>\<rat> Rat(rat_neg_raw(x)) = \<zero>\<^sub>\<rat>" @qed

lemma rat_nonneg_compat [resolve]: "nonneg_compat(\<rat>, nonneg_rats)" by auto2
setup {* fold del_prfstep_thm [
  @{thm nonneg_rat_eval}, @{thm nonneg_rat_raw_def}, @{thm nonneg_rats_def}] *}

lemma rat_is_ord_field [forward]: "is_ord_field(\<rat>)"
@proof @have "nonneg_compat(\<rat>, nonneg_rats)" @qed
setup {* del_prfstep_thm @{thm rat_is_ord_field_prep} *}

section \<open>Rational as a quotient of two integers\<close>

lemma rat_of_nat [rewrite]:
  "n \<in> nat \<Longrightarrow> of_nat(\<rat>,n) = Rat(\<langle>of_nat(\<int>,n),1\<^sub>\<int>\<rangle>)"
@proof @var_induct "n \<in> nat" @qed

lemma rat_diff_raw_eval [rewrite]:
  "\<langle>p,r\<rangle> \<in>. \<R> \<Longrightarrow> \<langle>q,r\<rangle> \<in>. \<R> \<Longrightarrow> Rat(\<langle>p,r\<rangle>) -\<^sub>\<rat> Rat(\<langle>q,r\<rangle>) = Rat(\<langle>p-\<^sub>\<int>q, r\<rangle>)"
@proof
  @have "Rat(\<langle>p,r\<rangle>) -\<^sub>\<rat> Rat(\<langle>q,r\<rangle>) = Rat(\<langle>p,r\<rangle>) +\<^sub>\<rat> (-\<^sub>\<rat> Rat(\<langle>q,r\<rangle>))"
  @have "p -\<^sub>\<int> q = p +\<^sub>\<int> (-\<^sub>\<int> q)"
@qed

lemma rat_of_int [rewrite]: "z \<in> int \<Longrightarrow> of_int(\<rat>,z) = Rat(\<langle>z,1\<^sub>\<int>\<rangle>)"
@proof @obtain "a\<in>.\<nat>" "b\<in>.\<nat>" where "z = of_nat(\<int>,a) -\<^sub>\<int> of_nat(\<int>,b)" @qed

lemma rat_inverse_eval [rewrite]:
  "\<langle>a,b\<rangle> \<in>. \<R> \<Longrightarrow> a >\<^sub>\<int> \<zero>\<^sub>\<int> \<Longrightarrow> inv(\<rat>,Rat(\<langle>a,b\<rangle>)) = Rat(\<langle>b,a\<rangle>)"
@proof @have "Rat(\<langle>a,b\<rangle>) *\<^sub>\<rat> Rat(\<langle>b,a\<rangle>) = \<one>\<^sub>\<rat>" @qed

lemma rat_div_eval [rewrite]:
  "\<langle>a,b\<rangle> \<in>. \<R> \<Longrightarrow> \<langle>c,d\<rangle> \<in>. \<R> \<Longrightarrow> c >\<^sub>\<int> \<zero>\<^sub>\<int> \<Longrightarrow> Rat(\<langle>a,b\<rangle>) /\<^sub>\<rat> Rat(\<langle>c,d\<rangle>) = Rat(\<langle>a*\<^sub>\<int>d,b*\<^sub>\<int>c\<rangle>)"
@proof @have "Rat(\<langle>a,b\<rangle>) /\<^sub>\<rat> Rat(\<langle>c,d\<rangle>) = Rat(\<langle>a,b\<rangle>) *\<^sub>\<rat> inv(\<rat>,Rat(\<langle>c,d\<rangle>))" @qed

lemma rat_is_quotient [backward]:
  "r \<in>. \<rat> \<Longrightarrow> \<exists>a\<in>.\<int>. \<exists>b>\<^sub>\<int>0\<^sub>\<int>. r = of_int(\<rat>,a) /\<^sub>\<rat> of_int(\<rat>,b)"
@proof
  @let "p = rep(\<R>,r)"
  @have "r = of_int(\<rat>,fst(p)) /\<^sub>\<rat> of_int(\<rat>,snd(p))"
@qed

setup {* fold del_prfstep_thm [@{thm rat_neg_eval}, @{thm rat_neg_raw_def}] *}

section \<open>Definition of of\_rat\<close>

definition of_rat_raw :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "of_rat_raw(R,p) = of_int(R,fst(p)) /\<^sub>R of_int(R,snd(p))"

lemma of_rat_raw_eval [rewrite]: "of_rat_raw(R,\<langle>a,b\<rangle>) = of_int(R,a) /\<^sub>R of_int(R,b)" by auto2
setup {* del_prfstep_thm @{thm of_rat_raw_def} *}

lemma field_switch_sides4 [resolve]:
  "is_field(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> b \<in> units(R) \<Longrightarrow> c \<in>. R \<Longrightarrow> d \<in> units(R) \<Longrightarrow>
   a *\<^sub>R d = b *\<^sub>R c \<Longrightarrow> a /\<^sub>R b = c /\<^sub>R d"
@proof
  @have "(a /\<^sub>R b) *\<^sub>R (b *\<^sub>R d) = (c /\<^sub>R d) *\<^sub>R (b *\<^sub>R d)" @have "b *\<^sub>R d \<in> units(R)"
@qed

definition of_rat :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "of_rat(R,r) = of_rat_raw(R,rep(\<R>,r))"
setup {* register_wellform_data ("of_rat(R,r)", ["r \<in>. \<rat>"]) *}

lemma of_rat_eval [rewrite]:
  "is_ord_field(R) \<Longrightarrow> x \<in>. \<R> \<Longrightarrow> of_rat(R,Rat(x)) = of_rat_raw(R,x)"
@proof
  @have (@rule) "\<forall>a b c d. \<langle>a,b\<rangle> \<sim>\<^sub>\<R> \<langle>c,d\<rangle> \<longrightarrow> of_rat_raw(R,\<langle>a,b\<rangle>) = of_rat_raw(R,\<langle>c,d\<rangle>)" @with
    @have "of_int(R,d) \<noteq> of_int(R,0\<^sub>\<int>)"
    @have "of_int(R,a) *\<^sub>R of_int(R,d) = of_int(R,b) *\<^sub>R of_int(R,c)"
  @end
@qed
setup {* del_prfstep_thm @{thm of_rat_def} *}

lemma of_int_is_unit [typing]:
  "is_ord_field(R) \<Longrightarrow> x >\<^sub>\<int> \<zero>\<^sub>\<int> \<Longrightarrow> of_int(R,x) \<in> units(R)" by auto2

lemma of_rat_type [typing]:
  "is_ord_field(R) \<Longrightarrow> r \<in>. \<rat> \<Longrightarrow> of_rat(R,r) \<in>. R" by auto2

lemma of_rat_eval_quotient [rewrite]:
  "is_ord_field(R) \<Longrightarrow> x \<in>. \<int> \<Longrightarrow> y >\<^sub>\<int> 0\<^sub>\<int> \<Longrightarrow>
   of_rat(R,of_int(\<rat>,x) /\<^sub>\<rat> of_int(\<rat>,y)) = of_int(R,x) /\<^sub>R of_int(R,y)" by auto2

lemma of_rat_is_zero [forward]:
  "is_ord_field(R) \<Longrightarrow> x \<in>. \<rat> \<Longrightarrow> of_rat(R,x) = 0\<^sub>R \<Longrightarrow> x = 0\<^sub>\<rat>"
@proof
  @obtain "a\<in>.\<int>" b where "b>\<^sub>\<int>0\<^sub>\<int>" "x = of_int(\<rat>,a) /\<^sub>\<rat> of_int(\<rat>,b)"
  @have "of_int(R,a) = of_int(R,0\<^sub>\<int>)"
@qed

lemma of_rat_of_int [rewrite]:
  "is_ord_field(R) \<Longrightarrow> x \<in>. \<int> \<Longrightarrow> of_rat(R,of_int(\<rat>,x)) = of_int(R,x)" by auto2

lemma of_rat_of_nat [rewrite]:
  "is_ord_field(R) \<Longrightarrow> n \<in> nat \<Longrightarrow> of_rat(R,of_nat(\<rat>,n)) = of_nat(R,n)" by auto2

setup {* fold del_prfstep_thm [@{thm of_rat_eval}, @{thm rat_of_nat}, @{thm rat_of_int}] *}
setup {* fold del_prfstep_thm [@{thm rat_def}, @{thm rat_rel_spaceI}, @{thm rat_rel_spaceD}] *}
setup {* fold del_prfstep_thm @{thms rat_evals(1-2)} *}
setup {* fold del_prfstep_thm [@{thm rat_choose_rep}, @{thm rat_inverse_eval},
  @{thm rat_div_eval}, @{thm rat_mult_eval}, @{thm rat_add_eval}] *}
no_notation rat_rel ("\<R>")
hide_const Rat

section \<open>Further properties\<close>

lemma of_rat_mult [rewrite_bidir]:
  "is_ord_field(R) \<Longrightarrow> x \<in>. \<rat> \<Longrightarrow> y \<in>. \<rat> \<Longrightarrow> of_rat(R,x) *\<^sub>R of_rat(R,y) = of_rat(R,x *\<^sub>\<rat> y)"
@proof
  @obtain "a\<in>.\<int>" b where "b>\<^sub>\<int>0\<^sub>\<int>" "x = of_int(\<rat>,a) /\<^sub>\<rat> of_int(\<rat>,b)"
  @obtain "c\<in>.\<int>" d where "d>\<^sub>\<int>0\<^sub>\<int>" "y = of_int(\<rat>,c) /\<^sub>\<rat> of_int(\<rat>,d)"
  @let "qa = of_int(\<rat>,a)" "qb = of_int(\<rat>,b)" "qc = of_int(\<rat>,c)" "qd = of_int(\<rat>,d)"
  @let "ra = of_int(R,a)" "rb = of_int(R,b)" "rc = of_int(R,c)" "rd = of_int(R,d)"
  @have "(qa /\<^sub>\<rat> qb) *\<^sub>\<rat> (qc /\<^sub>\<rat> qd) = (qa *\<^sub>\<rat> qc) /\<^sub>\<rat> (qb *\<^sub>\<rat> qd)"
  @have "(ra /\<^sub>R rb) *\<^sub>R (rc /\<^sub>R rd) = (ra *\<^sub>R rc) /\<^sub>R (rb *\<^sub>R rd)"
@qed

lemma of_rat_inverse [rewrite_bidir]:
  "is_ord_field(R) \<Longrightarrow> x \<in> units(\<rat>) \<Longrightarrow> inv(R,of_rat(R,x)) = of_rat(R,inv(\<rat>,x))"
@proof @have "of_rat(R,inv(\<rat>,x)) *\<^sub>R of_rat(R,x) = \<one>\<^sub>R" @qed

lemma of_rat_add [rewrite_bidir]:
  "is_ord_field(R) \<Longrightarrow> x \<in>. \<rat> \<Longrightarrow> y \<in>. \<rat> \<Longrightarrow> of_rat(R,x) +\<^sub>R of_rat(R,y) = of_rat(R,x +\<^sub>\<rat> y)"
@proof
  @obtain "a\<in>.\<int>" b where "b>\<^sub>\<int>0\<^sub>\<int>" "x = of_int(\<rat>,a) /\<^sub>\<rat> of_int(\<rat>,b)"
  @obtain "c\<in>.\<int>" d where "d>\<^sub>\<int>0\<^sub>\<int>" "y = of_int(\<rat>,c) /\<^sub>\<rat> of_int(\<rat>,d)"
  @let "qa = of_int(\<rat>,a)" "qb = of_int(\<rat>,b)" "qc = of_int(\<rat>,c)" "qd = of_int(\<rat>,d)"
  @let "ra = of_int(R,a)" "rb = of_int(R,b)" "rc = of_int(R,c)" "rd = of_int(R,d)"
  @have "(qa /\<^sub>\<rat> qb) +\<^sub>\<rat> (qc /\<^sub>\<rat> qd) = (qa *\<^sub>\<rat> qd +\<^sub>\<rat> qb *\<^sub>\<rat> qc) /\<^sub>\<rat> (qb *\<^sub>\<rat> qd)"
  @have "(ra /\<^sub>R rb) +\<^sub>R (rc /\<^sub>R rd) = (ra *\<^sub>R rd +\<^sub>R rb *\<^sub>R rc) /\<^sub>R (rb *\<^sub>R rd)"
@qed

lemma ord_field_le_divide_switch [backward1]:
  "is_ord_field(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> c \<in>. R \<Longrightarrow> b >\<^sub>R 0\<^sub>R \<Longrightarrow> d >\<^sub>R 0\<^sub>R \<Longrightarrow>
   a /\<^sub>R b \<le>\<^sub>R c /\<^sub>R d \<Longrightarrow> a *\<^sub>R d \<le>\<^sub>R b *\<^sub>R c"
@proof
  @have "a /\<^sub>R b *\<^sub>R (b *\<^sub>R d) \<le>\<^sub>R c /\<^sub>R d *\<^sub>R (b *\<^sub>R d)" @have "b *\<^sub>R d >\<^sub>R 0\<^sub>R"
@qed

lemma ord_field_le_divide_switch2 [backward1]:
  "is_ord_field(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> c \<in>. R \<Longrightarrow> b >\<^sub>R 0\<^sub>R \<Longrightarrow> d >\<^sub>R 0\<^sub>R \<Longrightarrow>
   a *\<^sub>R d \<le>\<^sub>R b *\<^sub>R c \<Longrightarrow> a /\<^sub>R b \<le>\<^sub>R c /\<^sub>R d"
@proof
  @have "a *\<^sub>R d /\<^sub>R (b *\<^sub>R d) \<le>\<^sub>R b *\<^sub>R c /\<^sub>R (b *\<^sub>R d)" @have "b *\<^sub>R d >\<^sub>R 0\<^sub>R"
@qed

lemma ord_field_le_divide_switch3 [backward1]:
  "is_ord_field(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> c \<in>. R \<Longrightarrow> b >\<^sub>R 0\<^sub>R \<Longrightarrow> d >\<^sub>R 0\<^sub>R \<Longrightarrow>
   a /\<^sub>R b <\<^sub>R c /\<^sub>R d \<Longrightarrow> a *\<^sub>R d <\<^sub>R b *\<^sub>R c"
@proof
  @have "a /\<^sub>R b *\<^sub>R (b *\<^sub>R d) <\<^sub>R c /\<^sub>R d *\<^sub>R (b *\<^sub>R d)" @have "b *\<^sub>R d >\<^sub>R 0\<^sub>R"
@qed

lemma ord_field_le_divide_switch4 [backward1]:
  "is_ord_field(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> c \<in>. R \<Longrightarrow> b >\<^sub>R 0\<^sub>R \<Longrightarrow> d >\<^sub>R 0\<^sub>R \<Longrightarrow>
   a *\<^sub>R d <\<^sub>R b *\<^sub>R c \<Longrightarrow> a /\<^sub>R b <\<^sub>R c /\<^sub>R d"
@proof
  @have "a *\<^sub>R d /\<^sub>R (b *\<^sub>R d) <\<^sub>R b *\<^sub>R c /\<^sub>R (b *\<^sub>R d)" @have "b *\<^sub>R d >\<^sub>R 0\<^sub>R"
@qed

lemma ord_field_of_rat_le [backward]:
  "is_ord_field(R) \<Longrightarrow> r \<le>\<^sub>\<rat> s \<Longrightarrow> of_rat(R,r) \<le>\<^sub>R of_rat(R,s)"
@proof
  @obtain "a\<in>.\<int>" b where "b>\<^sub>\<int>0\<^sub>\<int>" "r = of_int(\<rat>,a) /\<^sub>\<rat> of_int(\<rat>,b)"
  @obtain "c\<in>.\<int>" d where "d>\<^sub>\<int>0\<^sub>\<int>" "s = of_int(\<rat>,c) /\<^sub>\<rat> of_int(\<rat>,d)"
  @have "of_int(\<rat>,a) *\<^sub>\<rat> of_int(\<rat>,d) \<le>\<^sub>\<rat> of_int(\<rat>,b) *\<^sub>\<rat> of_int(\<rat>,c)"
  @have "of_int(R,a) *\<^sub>R of_int(R,d) \<le>\<^sub>R of_int(R,b) *\<^sub>R of_int(R,c)"
@qed

lemma ord_field_of_rat_less [backward]:
  "is_ord_field(R) \<Longrightarrow> r <\<^sub>\<rat> s \<Longrightarrow> of_rat(R,r) <\<^sub>R of_rat(R,s)"
@proof
  @obtain "a\<in>.\<int>" b where "b>\<^sub>\<int>0\<^sub>\<int>" "r = of_int(\<rat>,a) /\<^sub>\<rat> of_int(\<rat>,b)"
  @obtain "c\<in>.\<int>" d where "d>\<^sub>\<int>0\<^sub>\<int>" "s = of_int(\<rat>,c) /\<^sub>\<rat> of_int(\<rat>,d)"
  @have "of_int(\<rat>,a) *\<^sub>\<rat> of_int(\<rat>,d) <\<^sub>\<rat> of_int(\<rat>,b) *\<^sub>\<rat> of_int(\<rat>,c)"
  @have "of_int(R,a) *\<^sub>R of_int(R,d) <\<^sub>R of_int(R,b) *\<^sub>R of_int(R,c)"
@qed

lemma ord_field_of_rat_positive:
  "is_ord_field(R) \<Longrightarrow> r >\<^sub>\<rat> \<zero>\<^sub>\<rat> \<Longrightarrow> of_rat(R,r) >\<^sub>R \<zero>\<^sub>R"
@proof @have "of_rat(R,r) >\<^sub>R of_rat(R,0\<^sub>\<rat>)" @qed
setup {* add_forward_prfstep_cond @{thm ord_field_of_rat_positive} [with_term "of_rat(?R,?r)"] *}

section \<open>Rationals is an archimedean field\<close>

lemma int_has_of_nat_ge [forward]: "is_archimedean(\<int>)"
@proof
  @have "\<forall>z\<in>.\<int>. \<exists>n\<in>nat. of_nat(\<int>,n) \<ge>\<^sub>\<int> z" @with
    @obtain "a\<in>.\<nat>" "b\<in>.\<nat>" where "z = of_nat(\<int>,a) -\<^sub>\<int> of_nat(\<int>,b)"
    @have "of_nat(\<int>,a) \<ge>\<^sub>\<int> z"
  @end
@qed

lemma is_archimedeanI_pos_of_int [forward]:
  "is_ord_ring(R) \<Longrightarrow> \<forall>x >\<^sub>R 0\<^sub>R. \<exists>z\<in>.\<int>. of_int(R,z) \<ge>\<^sub>R x \<Longrightarrow> is_archimedean(R)"
@proof
  @have "\<forall>x >\<^sub>R 0\<^sub>R. \<exists>n\<in>nat. of_nat(R,n) \<ge>\<^sub>R x" @with
    @obtain "z\<in>.\<int>" where "of_int(R,z) \<ge>\<^sub>R x"
    @obtain "n\<in>nat" where "of_nat(\<int>,n) \<ge>\<^sub>\<int> z"
    @have "of_nat(R,n) = of_int(R,of_nat(\<int>,n))"
  @end
@qed

lemma rat_is_archimedean [forward]: "is_archimedean(\<rat>)"
@proof
  @have "\<forall>r >\<^sub>\<rat> 0\<^sub>\<rat>. \<exists>z\<in>.\<int>. of_int(\<rat>,z) \<ge>\<^sub>\<rat> r" @with
    @obtain "a\<in>.\<int>" b where "b>\<^sub>\<int>0\<^sub>\<int>" "r = of_int(\<rat>,a) /\<^sub>\<rat> of_int(\<rat>,b)"
    @have "of_int(\<rat>,b) \<ge>\<^sub>\<rat> of_int(\<rat>,1\<^sub>\<int>)" @end
@qed

lemma is_archimedeanI_pos_of_rat [forward]:
  "is_ord_field(R) \<Longrightarrow> \<forall>x >\<^sub>R 0\<^sub>R. \<exists>z\<in>.\<rat>. of_rat(R,z) \<ge>\<^sub>R x \<Longrightarrow> is_archimedean(R)"
@proof
  @have "\<forall>x >\<^sub>R 0\<^sub>R. \<exists>n\<in>nat. of_nat(R,n) \<ge>\<^sub>R x" @with
    @obtain "r\<in>.\<rat>" where "of_rat(R,r) \<ge>\<^sub>R x"
    @obtain "n\<in>nat" where "of_nat(\<rat>,n) \<ge>\<^sub>\<rat> r"
    @have "of_nat(R,n) = of_rat(R,of_nat(\<rat>,n))"
    @have "of_rat(R,of_nat(\<rat>,n)) \<ge>\<^sub>R of_rat(R,r)"
  @end
@qed

section \<open>More properties of archimedean fields\<close>

lemma is_archimedeanD_rat [backward]:
  "is_archimedean(R) \<Longrightarrow> is_field(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> \<exists>r\<in>.\<rat>. of_rat(R,r) >\<^sub>R x"
@proof
  @obtain "n\<in>nat" where "of_nat(R,n) >\<^sub>R x"
  @have "of_rat(R,of_nat(\<rat>,n)) = of_nat(R,n)"
@qed

lemma is_archimedeanD_rat_pos [backward]:
  "is_archimedean(R) \<Longrightarrow> is_field(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> \<exists>r>\<^sub>\<rat>\<zero>\<^sub>\<rat>. of_rat(R,r) >\<^sub>R x"
@proof
  @obtain "r\<in>.\<rat>" where "of_rat(R,r) >\<^sub>R x"
  @obtain "r'\<in>.\<rat>" where "r' >\<^sub>\<rat> \<zero>\<^sub>\<rat>" "r' \<ge>\<^sub>\<rat> r"
@qed

lemma is_archimedeanD_rat_less [backward]:
  "is_archimedean(R) \<Longrightarrow> is_field(R) \<Longrightarrow> x >\<^sub>R \<zero>\<^sub>R \<Longrightarrow> \<exists>r>\<^sub>\<rat>\<zero>\<^sub>\<rat>. of_rat(R,r) <\<^sub>R x"
@proof
  @obtain r where "r>\<^sub>\<rat>\<zero>\<^sub>\<rat>" "of_rat(R,r) >\<^sub>R inv(R,x)"
  @have "of_rat(R,inv(\<rat>,r)) <\<^sub>R x"
@qed

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsubsection \<open>Transport Between Lists and Sets\<close>
theory Transport_List_Sets
  imports
    Transport_PER
    Transport_Syntax
    "HOL-Library.FSet"
begin

paragraph \<open>Summary\<close>
text \<open>Introductory examples from the Transport paper. Transports between lists
and (finite) sets.  Refer to the paper for more details.\<close>

paragraph \<open>Introductory examples from paper\<close>

context
  includes transport_syntax
begin

text \<open>Left and right relations.\<close>

definition "L1 xs xs' \<equiv> fset_of_list xs = fset_of_list xs'"
abbreviation (input) "(Rfin :: 'a fset \<Rightarrow> _) \<equiv> (=)"
definition "L2 xs xs' \<equiv> set xs = set xs'"
abbreviation (input) "(R :: 'a set \<Rightarrow> _) \<equiv> (=\<^bsub>finite :: 'a set \<Rightarrow> bool\<^esub>)"

context
  includes galois_rel_syntax
begin

interpretation t : transport L2 R l r for L2 R l r .

text \<open>Proofs of equivalences.\<close>

lemma list_fset_PER [per_intro]:
  "(L1 \<equiv>\<^bsub>PER\<^esub> Rfin) fset_of_list sorted_list_of_fset"
  unfolding L1_def by fastforce

lemma list_set_PER [per_intro]: "(L2 \<equiv>\<^bsub>PER\<^esub> R) set sorted_list_of_set"
  unfolding L2_def by fastforce

text \<open>We can rewrite the Galois relators in the following theorems to
the relator of the paper.\<close>

definition "LFS xs s \<equiv> fset_of_list xs = s"
definition "LS xs s \<equiv> set xs = s"

lemma list_fset_Galois_eq: "(\<^bsub>L1\<^esub>\<lessapprox>\<^bsub>Rfin sorted_list_of_fset\<^esub>) \<equiv> LFS"
  unfolding LFS_def L1_def by (intro eq_reflection ext) (auto)
lemma list_fset_Galois_eq_symm: "(\<^bsub>Rfin\<^esub>\<lessapprox>\<^bsub>L1 fset_of_list\<^esub>) \<equiv> LFS\<inverse>"
  unfolding LFS_def L1_def by (intro eq_reflection ext) (auto)
lemma list_set_Galois_eq: "(\<^bsub>L2\<^esub>\<lessapprox>\<^bsub>R sorted_list_of_set\<^esub>) \<equiv> LS"
  unfolding LS_def L2_def by (intro eq_reflection ext) (auto)

declare list_fset_Galois_eq[transport_relator_rewrite, unif_hint]
  list_fset_Galois_eq_symm[transport_relator_rewrite, unif_hint]
  list_set_Galois_eq[transport_relator_rewrite, unif_hint]

end

(*unification hint*)
lemma L1_eq_L2 [unif_hint]: "L1 \<equiv> L2"
  unfolding L1_def L2_def
  by (intro eq_reflection ext) (auto simp: fset_of_list_elem)

definition "max_list xs \<equiv> foldr max xs (0 :: nat)"

text \<open>Proof of parametricity for @{term max_list}.\<close>

lemma max_max_list_removeAll_eq_maxlist:
  assumes "x \<in> set xs"
  shows "max x (max_list (removeAll x xs)) = max_list xs"
  unfolding max_list_def using assms by (induction xs)
  (simp_all, (metis max.left_idem removeAll_id max.left_commute)+)

lemma max_list_parametric [transport_parametric]:
  "(L2 \<Rrightarrow> (=)) max_list max_list"
proof (intro Dep_Fun_Rel_relI)
  fix xs xs' :: "nat list" assume "L2 xs xs'"
  then have "finite (set xs)" "set xs = set xs'" unfolding L2_def by auto
  then show "max_list xs = max_list xs'"
  proof (induction "set xs"  arbitrary: xs xs' rule: finite_induct)
    case (insert x F)
    then have "F = set (removeAll x xs)" by auto
    moreover from insert have "... = set (removeAll x xs')" by auto
    ultimately have "max_list (removeAll x xs) = max_list (removeAll x xs')"
      (is "?lhs = ?rhs") using insert by blast
    then have "max x ?lhs = max x ?rhs" by simp
    then show ?case
      using insert max_max_list_removeAll_eq_maxlist insertI1 by metis
  qed auto
qed

lemma max_list_parametricfin [transport_parametric]:
  "(L1 \<Rrightarrow> (=)) max_list max_list"
  using max_list_parametric by (simp only: L1_eq_L2)

text \<open>Transport from lists to finite sets.\<close>

transport_term max_fset :: "nat fset \<Rightarrow> nat" where x = max_list
  by transport_term_prover

text \<open>Use @{command print_theorems} to show all theorems.\<close>
(*print_theorems*)

lemma "(LFS \<Rrightarrow> (=)) max_list max_fset" by (fact max_fset_related')

lemma [transport_parametric]: "(Rfin \<Rrightarrow> (=)) max_fset max_fset"
  by simp

text \<open>Transport from lists to sets.\<close>

transport_term max_set :: "nat set \<Rightarrow> nat" where x = max_list
  by transport_term_prover

lemma "(LS \<Rrightarrow> (=)) max_list max_set" by (fact max_set_related')

text \<open>The registration of symmetric equivalence rules is not done by default as
of now, but that would not be a problem in principle.\<close>

lemma list_fset_PER_sym [per_intro]:
  "(Rfin \<equiv>\<^bsub>PER\<^esub> L1) sorted_list_of_fset fset_of_list"
  by (subst transport.partial_equivalence_rel_equivalence_right_left_iff_partial_equivalence_rel_equivalence_left_right)
  (fact list_fset_PER)

text \<open>Transport from finite sets to lists.\<close>

transport_term max_list' :: "nat list \<Rightarrow> nat" where x = max_fset
  by transport_term_prover

lemma "(LFS\<inverse> \<Rrightarrow> (=)) max_fset max_list'" by (fact max_list'_related')

text \<open>Transporting higher-order functions.\<close>

lemma map_parametric [transport_parametric]:
  "(((=) \<Rrightarrow> (=)) \<Rrightarrow> L2 \<Rrightarrow> L2) map map"
  unfolding L2_def
  by (intro Dep_Fun_Rel_relI) simp

(*sorted_list_of_fset requires a linorder*)
(*in theory, we could use a different transport function to avoid that constraint*)
transport_term map_set :: "('a :: linorder \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> ('b :: linorder) set"
  where x = "map :: ('a :: linorder \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> ('b :: linorder) list"
  by transport_term_prover

lemma "(((=) \<Rrightarrow> (=)) \<Rrightarrow> LS \<Rrightarrow> LS) map map_set" by (fact map_set_related')

lemma filter_parametric [transport_parametric]:
  "(((=) \<Rrightarrow> (\<longleftrightarrow>)) \<Rrightarrow> L2 \<Rrightarrow> L2) filter filter"
  unfolding L2_def by (intro Dep_Fun_Rel_relI) simp

transport_term filter_set :: "('a :: linorder \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> 'a set"
  where x = "filter :: ('a :: linorder \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list"
  by transport_term_prover

lemma "(((=) \<Rrightarrow> (=)) \<Rrightarrow> LS \<Rrightarrow> LS) filter filter_set"
  by (rule filter_set_related')

lemma append_parametric [transport_parametric]:
  "(L2 \<Rrightarrow> L2 \<Rrightarrow> L2) append append"
  unfolding L2_def by (intro Dep_Fun_Rel_relI) simp

transport_term append_set :: "('a :: linorder) set \<Rightarrow> 'a set \<Rightarrow> 'a set"
  where x = "append :: ('a :: linorder) list \<Rightarrow> 'a list \<Rightarrow> 'a list"
  by transport_term_prover

lemma "(LS \<Rrightarrow> LS \<Rrightarrow> LS) append append_set"
  by (rule append_set_related')

text \<open>The prototype also provides a simplified definition.\<close>
lemma "append_set s s' \<equiv> set (sorted_list_of_set s) \<union> set (sorted_list_of_set s')"
  by (fact append_set_app_eq)

lemma "finite s \<Longrightarrow> finite s' \<Longrightarrow> append_set s s' = s \<union> s'"
  by (auto simp: append_set_app_eq)

end

end


theory NatsBug
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S Nat

fun leq :: "Nat \<Rightarrow> Nat \<Rightarrow> bool" where
  "leq Z _ = True"
| "leq _ Z = False"
| "leq (S x) (S y) = leq x y"

fun eqN :: "Nat \<Rightarrow> Nat \<Rightarrow> bool" where (* own definition for equality *)
  "eqN Z Z = True"
| "eqN (S n) (S m) = eqN n m"
| "eqN _     _     = False"

(* less or equal to Z *)
fun lez :: "Nat \<Rightarrow> bool" where          (* - as a function definition relying on Isabelle's equality *)
  "lez x = (x = Z)"

fun lezP :: "Nat \<Rightarrow> bool" where         (* - as a function definition via pattern matching *)
  "lezP Z = True"
| "lezP _ = False"

fun lezzP :: "Nat \<Rightarrow> bool" where        (* - as a function definition via our own equality *)
  "lezzP x = eqN x Z"

definition leZ :: "Nat \<Rightarrow> bool" where   (* - as a constant definition relying on Isabelle's equality *)
  "leZ x \<equiv> (x = Z)"

definition leZZ :: "Nat \<Rightarrow> bool" where  (* - as a constant definition relying on own equality *)
  "leZZ x \<equiv> eqN x Z"

(* hipster_cond lezzP leq *) (* skipping of conditions in output solved *)
(* hipster_cond lezP leq *)  (* skipping of conditions in output solved *)

(* hipster lezzP *) (* nothing weird, ok *)
(* hipster lezP *)  (* everything trivial, ok*)

(* FIXME: 1. Isabelle's equality = (gets translated as a separate predicate Haskell
             function equal_<Type> which will be missing in the original theory) *)
(* hipster lez *)  (* equations only with lez are trivial, aren't returned *)
lemma unknown [thy_expl]: "equal_Nat x y = equal_Nat y x" (* free variable equal_Nat instead of equality = *)
oops

(** QUICK REFERENCE: Haskell transaltions **)
(*  equal_Nat :: Nat -> Nat -> Bool
    equal_Nat Z (S nat) = False
    equal_Nat (S nat) Z = False
    equal_Nat (S nata) (S nat) = equal_Nat nata nat
    equal_Nat Z Z = True

    leZ :: Nat -> Bool
    leZ x = equal_Nat x Z

    lez :: Nat -> Bool
    lez x = equal_Nat x Z *)

(*  eqN :: Nat -> Nat -> Bool
    eqN Z Z = True
    eqN (S n) (S m) = eqN n m
    eqN (S v) Z = False
    eqN Z (S v) = False

    leZZ :: Nat -> Bool
    leZZ x = eqN x Z

    lezzP :: Nat -> Bool
    lezzP x = eqN x Z

    lezP :: Nat -> Bool
    lezP Z = True
    lezP (S v) = False *)

(*  leq :: Nat -> Nat -> Bool
    leq Z uu = True
    leq (S v) Z = False
    leq (S x) (S y) = leq x y *)

(*  Notes to self  *)
(* cond with: lezP leq*)
lemma dub00 [thy_expl]: "lezP y \<and> lezP x \<Longrightarrow> x = y" (* Hipster fails for some reason: no double induction? *)
apply(induction y, induction x)
by (simp_all)

(* Constant definition issues *)
(* leZ *)
lemma dub01 [thy_expl]: "leZ (S Z) = False" (* Hipster fails *)
(* Hipster does not get leZ_def, but it also fails when provided manually with it:
    by (hipster_induct_simp_metis NatsBug.leZ_def) *)
by (simp add: leZ_def)

(* leZZ *)
lemma dub02 [thy_expl]: "eqN Z x = leZZ x" (* Hipster fails *)
apply (induction x)
by (simp_all add: leZZ_def)

end


(*
Author:  Christian Sternagel <c.sternagel@gmail.com>
Author:  René Thiemann <rene.thiemann@uibk.ac.at>
License: LGPL
*)
subsection \<open>Results on Bijections\<close>

theory Fun_More imports Main begin

lemma finite_card_eq_imp_bij_betw:
  assumes "finite A"
    and "card (f ` A) = card A"
  shows "bij_betw f A (f ` A)"
  using \<open>card (f ` A) = card A\<close>
  unfolding inj_on_iff_eq_card [OF \<open>finite A\<close>, symmetric]
  by (rule inj_on_imp_bij_betw)

text \<open>Every bijective function between two subsets of a set can be turned
into a compatible renaming (with finite domain) on the full set.\<close>
lemma bij_betw_extend:
  assumes *: "bij_betw f A B"
    and "A \<subseteq> V"
    and "B \<subseteq> V"
    and "finite A"
  shows "\<exists>g. finite {x. g x \<noteq> x} \<and>
    (\<forall>x\<in>UNIV - (A \<union> B). g x = x) \<and>
    (\<forall>x\<in>A. g x = f x) \<and>
    bij_betw g V V"
proof -
  have "finite B" using assms by (metis bij_betw_finite)
  have [simp]: "card A = card B" by (metis * bij_betw_same_card)
  have "card (A - B) = card (B - A)"
  proof -
    have "card (A - B) = card A - card (A \<inter> B)"
      by (metis \<open>finite A\<close> card_Diff_subset_Int finite_Int)
    moreover have "card (B - A) = card B - card (A \<inter> B)"
      by (metis \<open>finite A\<close> card_Diff_subset_Int finite_Int inf_commute)
    ultimately show ?thesis by simp
  qed
  then obtain g where **: "bij_betw g (B - A) (A - B)"
    by (metis \<open>finite A\<close> \<open>finite B\<close> bij_betw_iff_card finite_Diff)
  define h where "h = (\<lambda>x. if x \<in> A then f x else if x \<in> B - A then g x else x)"
  have "bij_betw h A B"
    by (metis (full_types) * bij_betw_cong h_def)
  moreover have "bij_betw h (V - (A \<union> B)) (V - (A \<union> B))"
    by (auto simp: bij_betw_def h_def inj_on_def)
  moreover have "B \<inter> (V - (A \<union> B)) = {}" by blast
  ultimately have "bij_betw h (A \<union> (V - (A \<union> B))) (B \<union> (V - (A \<union> B)))"
    by (rule bij_betw_combine)
  moreover have "A \<union> (V - (A \<union> B)) = V - (B - A)"
    and "B \<union> (V - (A \<union> B)) = V - (A - B)"
    using \<open>A \<subseteq> V\<close> and \<open>B \<subseteq> V\<close> by blast+
  ultimately have "bij_betw h (V - (B - A)) (V - (A - B))" by simp
  moreover have "bij_betw h (B - A) (A - B)"
    using ** by (auto simp: bij_betw_def h_def inj_on_def)
  moreover have "(V - (A - B)) \<inter> (A - B) = {}" by blast
  ultimately have "bij_betw h ((V - (B - A)) \<union> (B - A)) ((V - (A - B)) \<union> (A - B))"
    by (rule bij_betw_combine)
  moreover have "(V - (B - A)) \<union> (B - A) = V"
    and "(V - (A - B)) \<union> (A - B) = V"
    using \<open>A \<subseteq> V\<close> and \<open>B \<subseteq> V\<close> by auto
  ultimately have "bij_betw h V V" by simp
  moreover have "\<forall>x\<in>A. h x = f x" by (auto simp: h_def)
  moreover have "finite {x. h x \<noteq> x}"
  proof -
    have "finite (A \<union> (B - A))" using \<open>finite A\<close> and \<open>finite B\<close> by auto
    moreover have "{x. h x \<noteq> x} \<subseteq> (A \<union> (B - A))" by (auto simp: h_def)
    ultimately show ?thesis by (metis finite_subset)
  qed
  moreover have "\<forall>x\<in>UNIV - (A \<union> B). h x = x" by (simp add: h_def)
  ultimately show ?thesis by blast
qed

subsection \<open>Merging Functions\<close>
(* Copied and canonized from IsaFoR's Term theory and Polynomial Factorization in the AFP. *)
definition fun_merge :: "('a \<Rightarrow> 'b)list \<Rightarrow> 'a set list \<Rightarrow> 'a \<Rightarrow> 'b"
  where
    "fun_merge fs as a = (fs ! (LEAST i. i < length as \<and> a \<in> as ! i)) a"

lemma fun_merge_eq_nth:
  assumes i: "i < length as"
    and a: "a \<in> as ! i"
    and ident: "\<And> i j a. i < length as \<Longrightarrow> j < length as \<Longrightarrow> a \<in> as ! i \<Longrightarrow> a \<in> as ! j \<Longrightarrow> (fs ! i) a = (fs ! j) a"
  shows "fun_merge fs as a = (fs ! i) a"
proof -
  let ?p = "\<lambda> i. i < length as \<and> a \<in> as ! i"
  let ?l = "LEAST i. ?p i"
  have p: "?p ?l"
    by (rule LeastI, insert i a, auto)
  show ?thesis unfolding fun_merge_def
    by (rule ident[OF _ i _ a], insert p, auto)
qed

lemma fun_merge_part:
  assumes "\<forall>i<length as.\<forall>j<length as. i \<noteq> j \<longrightarrow> as ! i \<inter> as ! j = {}"
    and "i < length as"
    and "a \<in> as ! i"
  shows "fun_merge fs as a = (fs ! i) a"
proof(rule fun_merge_eq_nth [OF assms(2, 3)])
  fix i j a
  assume "i < length as" and "j < length as" and "a \<in> as ! i" and "a \<in> as ! j"
  then have "i = j" using assms by (cases "i = j") auto
  then show "(fs ! i) a = (fs ! j) a" by simp
qed

lemma fun_merge:
  assumes part: "\<forall>i<length Xs.\<forall>j<length Xs. i \<noteq> j \<longrightarrow> Xs ! i \<inter> Xs ! j = {}"
  shows "\<exists>\<sigma>. \<forall>i<length Xs. \<forall>x\<in> Xs ! i. \<sigma> x = \<tau> i x"
proof -
  let ?\<tau> = "map \<tau> [0 ..< length Xs]"
  let ?\<sigma> = "fun_merge ?\<tau> Xs"
  show ?thesis
    by (rule exI[of _ ?\<sigma>], intro allI impI ballI,
      insert fun_merge_part[OF part, of _ _ ?\<tau>], auto)
qed

end


(*  Title:      HOL/Library/Function_Algebras.thy
    Author:     Jeremy Avigad and Kevin Donnelly; Florian Haftmann, TUM
*)

section \<open>Pointwise instantiation of functions to algebra type classes\<close>

theory Function_Algebras
imports MainRLT
begin

text \<open>Pointwise operations\<close>

instantiation "fun" :: (type, plus) plus
begin

definition "f + g = (\<lambda>x. f x + g x)"
instance ..

end

lemma plus_fun_apply [simp]:
  "(f + g) x = f x + g x"
  by (simp add: plus_fun_def)

instantiation "fun" :: (type, zero) zero
begin

definition "0 = (\<lambda>x. 0)"
instance ..

end

lemma zero_fun_apply [simp]:
  "0 x = 0"
  by (simp add: zero_fun_def)

instantiation "fun" :: (type, times) times
begin

definition "f * g = (\<lambda>x. f x * g x)"
instance ..

end

lemma times_fun_apply [simp]:
  "(f * g) x = f x * g x"
  by (simp add: times_fun_def)

instantiation "fun" :: (type, one) one
begin

definition "1 = (\<lambda>x. 1)"
instance ..

end

lemma one_fun_apply [simp]:
  "1 x = 1"
  by (simp add: one_fun_def)

text \<open>Additive structures\<close>

instance "fun" :: (type, semigroup_add) semigroup_add
  by standard (simp add: fun_eq_iff add.assoc)

instance "fun" :: (type, cancel_semigroup_add) cancel_semigroup_add
  by standard (simp_all add: fun_eq_iff)

instance "fun" :: (type, ab_semigroup_add) ab_semigroup_add
  by standard (simp add: fun_eq_iff add.commute)

instance "fun" :: (type, cancel_ab_semigroup_add) cancel_ab_semigroup_add
  by standard (simp_all add: fun_eq_iff diff_diff_eq)

instance "fun" :: (type, monoid_add) monoid_add
  by standard (simp_all add: fun_eq_iff)

instance "fun" :: (type, comm_monoid_add) comm_monoid_add
  by standard simp

instance "fun" :: (type, cancel_comm_monoid_add) cancel_comm_monoid_add ..

instance "fun" :: (type, group_add) group_add
  by standard (simp_all add: fun_eq_iff)

instance "fun" :: (type, ab_group_add) ab_group_add
  by standard simp_all

text \<open>Multiplicative structures\<close>

instance "fun" :: (type, semigroup_mult) semigroup_mult
  by standard (simp add: fun_eq_iff mult.assoc)

instance "fun" :: (type, ab_semigroup_mult) ab_semigroup_mult
  by standard (simp add: fun_eq_iff mult.commute)

instance "fun" :: (type, monoid_mult) monoid_mult
  by standard (simp_all add: fun_eq_iff)

instance "fun" :: (type, comm_monoid_mult) comm_monoid_mult
  by standard simp

text \<open>Misc\<close>

instance "fun" :: (type, "Rings.dvd") "Rings.dvd" ..

instance "fun" :: (type, mult_zero) mult_zero
  by standard (simp_all add: fun_eq_iff)

instance "fun" :: (type, zero_neq_one) zero_neq_one
  by standard (simp add: fun_eq_iff)

text \<open>Ring structures\<close>

instance "fun" :: (type, semiring) semiring
  by standard (simp_all add: fun_eq_iff algebra_simps)

instance "fun" :: (type, comm_semiring) comm_semiring
  by standard (simp add: fun_eq_iff  algebra_simps)

instance "fun" :: (type, semiring_0) semiring_0 ..

instance "fun" :: (type, comm_semiring_0) comm_semiring_0 ..

instance "fun" :: (type, semiring_0_cancel) semiring_0_cancel ..

instance "fun" :: (type, comm_semiring_0_cancel) comm_semiring_0_cancel ..

instance "fun" :: (type, semiring_1) semiring_1 ..

lemma numeral_fun: \<^marker>\<open>contributor \<open>Akihisa Yamada\<close>\<close>
  \<open>numeral n = (\<lambda>x::'a. numeral n)\<close>
  by (induction n) (simp_all only: numeral.simps plus_fun_def, simp_all)

lemma numeral_fun_apply [simp]: \<^marker>\<open>contributor \<open>Akihisa Yamada\<close>\<close>
  \<open>numeral n x = numeral n\<close>
  by (simp add: numeral_fun)

lemma of_nat_fun: "of_nat n = (\<lambda>x::'a. of_nat n)"
proof -
  have comp: "comp = (\<lambda>f g x. f (g x))"
    by (rule ext)+ simp
  have plus_fun: "plus = (\<lambda>f g x. f x + g x)"
    by (rule ext, rule ext) (fact plus_fun_def)
  have "of_nat n = (comp (plus (1::'b)) ^^ n) (\<lambda>x::'a. 0)"
    by (simp add: of_nat_def plus_fun zero_fun_def one_fun_def comp)
  also have "... = comp ((plus 1) ^^ n) (\<lambda>x::'a. 0)"
    by (simp only: comp_funpow)
  finally show ?thesis by (simp add: of_nat_def comp)
qed

lemma of_nat_fun_apply [simp]:
  "of_nat n x = of_nat n"
  by (simp add: of_nat_fun)

instance "fun" :: (type, comm_semiring_1) comm_semiring_1 ..

instance "fun" :: (type, semiring_1_cancel) semiring_1_cancel ..

instance "fun" :: (type, comm_semiring_1_cancel) comm_semiring_1_cancel
  by standard (auto simp add: times_fun_def algebra_simps)

instance "fun" :: (type, semiring_char_0) semiring_char_0
proof
  from inj_of_nat have "inj (\<lambda>n (x::'a). of_nat n :: 'b)"
    by (rule inj_fun)
  then have "inj (\<lambda>n. of_nat n :: 'a \<Rightarrow> 'b)"
    by (simp add: of_nat_fun)
  then show "inj (of_nat :: nat \<Rightarrow> 'a \<Rightarrow> 'b)" .
qed

instance "fun" :: (type, ring) ring ..

instance "fun" :: (type, comm_ring) comm_ring ..

instance "fun" :: (type, ring_1) ring_1 ..

instance "fun" :: (type, comm_ring_1) comm_ring_1 ..

instance "fun" :: (type, ring_char_0) ring_char_0 ..

text \<open>Ordered structures\<close>

instance "fun" :: (type, ordered_ab_semigroup_add) ordered_ab_semigroup_add
  by standard (auto simp add: le_fun_def intro: add_left_mono)

instance "fun" :: (type, ordered_cancel_ab_semigroup_add) ordered_cancel_ab_semigroup_add ..

instance "fun" :: (type, ordered_ab_semigroup_add_imp_le) ordered_ab_semigroup_add_imp_le
  by standard (simp add: le_fun_def)

instance "fun" :: (type, ordered_comm_monoid_add) ordered_comm_monoid_add ..

instance "fun" :: (type, ordered_cancel_comm_monoid_add) ordered_cancel_comm_monoid_add ..

instance "fun" :: (type, ordered_ab_group_add) ordered_ab_group_add ..

instance "fun" :: (type, ordered_semiring) ordered_semiring
  by standard (auto simp add: le_fun_def intro: mult_left_mono mult_right_mono)

instance "fun" :: (type, dioid) dioid
proof standard
  fix a b :: "'a \<Rightarrow> 'b"
  show "a \<le> b \<longleftrightarrow> (\<exists>c. b = a + c)"
    unfolding le_fun_def plus_fun_def fun_eq_iff choice_iff[symmetric, of "\<lambda>x c. b x = a x + c"]
    by (intro arg_cong[where f=All] ext canonically_ordered_monoid_add_class.le_iff_add)
qed

instance "fun" :: (type, ordered_comm_semiring) ordered_comm_semiring
  by standard (fact mult_left_mono)

instance "fun" :: (type, ordered_cancel_semiring) ordered_cancel_semiring ..

instance "fun" :: (type, ordered_cancel_comm_semiring) ordered_cancel_comm_semiring ..

instance "fun" :: (type, ordered_ring) ordered_ring ..

instance "fun" :: (type, ordered_comm_ring) ordered_comm_ring ..

lemmas func_plus = plus_fun_def
lemmas func_zero = zero_fun_def
lemmas func_times = times_fun_def
lemmas func_one = one_fun_def

end


theory Fibonacci
  imports Syntax
begin

no_notation Set.image (infixr "`" 90)
  and comp_op ("n_" [90] 91)

(* Some numbers written in Suc form *)
lemma numeral_4 [simp]: "4 = Suc (Suc (Suc (Suc 0)))"
  by arith

lemma numeral_6 [simp]: "6 = Suc (Suc (Suc (Suc (Suc (Suc 0)))))"
  by arith

lemma numeral_8 [simp]: "8 = Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc 0)))))))"
  by arith

(* Definition of Fibonacci starting by 1 and 2: [1 2 3 5 8 13 ...] *)
fun fib :: "nat => nat" where
  "fib 0 = 1"
| "fib (Suc 0) = 2"
| "fib (Suc (Suc x)) = fib x + fib (Suc x)"

(* Calculate the sum of even fibonnaci number smaller than m and maximum index n *)
fun sum_efib :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "sum_efib m 0 = 0"
| "sum_efib m (Suc n) = sum_efib m n + (if (fib n) mod 2 \<noteq> 0 \<or> fib n > m then 0 else fib n)"

(* Predicate that indicates whether the sum is the sum of even fibonnaci numbers smaller than m *)
definition is_sum_efib :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
  "is_sum_efib sum m \<equiv> \<exists>n. sum = sum_efib m n \<and> fib n > m"

(* List of even fibonacci number: [2, 8, 34, ...] *)
fun efib :: "nat \<Rightarrow> nat" where
  "efib 0 = 2"
| "efib (Suc 0) = 8"
| "efib (Suc (Suc n)) = 4*efib (Suc n) + efib n"

(* Some lemmas about Fibonacci numbers *)
lemma fib_parity1: "(fib k) mod 2 = 0 \<Longrightarrow> (fib (Suc k)) mod 2 = Suc 0"
  apply (induct k, auto)
  by (metis One_nat_def mod_2_not_eq_zero_eq_one_nat)

lemma fib_parity2: "(fib k) mod 2 = 0 \<Longrightarrow> (fib (Suc (Suc k))) mod 2 = Suc 0"
  apply (induct k, auto)
  by presburger

lemma fib_parity3: "(fib n) mod 2 = 0 \<longleftrightarrow> n mod 3 = 1"
  apply (induct n rule: fib.induct, simp_all, default)
  apply (subgoal_tac "fib x mod 2 = 0 \<or> fib x mod 2 = Suc 0")
  apply (erule disjE)
  apply (subgoal_tac "fib (Suc (Suc x)) mod 2 = Suc 0")
  apply simp
  apply (metis fib_parity2)
  apply (subgoal_tac "x mod 3 = 0 \<or> x mod 3 = Suc (Suc 0)")
  apply (erule disjE)
  apply (metis fib.simps(3) fib_parity1 mod_Suc numeral_plus_numeral one_is_add semiring_norm(3) zero_neq_numeral)
  apply (metis (hide_lams, no_types) Suc_numeral add_One_commute mod_2_not_eq_zero_eq_one_nat mod_Suc numeral_One numeral_plus_numeral one_is_add semiring_norm(3) zero_neq_numeral)
  apply force
  apply force
  apply (subgoal_tac "x mod 3 = 0 \<or> x mod 3 = 1 \<or> x mod 3 = 2")
  apply (erule disjE)
  apply (subgoal_tac "fib x mod 2 = Suc 0 \<and> fib (Suc x) mod 2 = 0")
  apply (metis mod_Suc n_not_Suc_n)
  apply (metis mod_Suc n_not_Suc_n)
  apply (erule disjE)
  apply (subgoal_tac "fib x mod 2 = 0 \<and> fib (Suc x) mod 2 = Suc 0")
  apply (metis Suc_eq_plus1_left Suc_numeral add_2_eq_Suc' mod_add_left_eq mod_self n_not_Suc_n semiring_norm(5))
  apply (metis One_nat_def fib_parity1)
  apply (subgoal_tac "fib x mod 2 = Suc 0 \<and> fib (Suc x) mod 2 = Suc 0")
  apply (simp add: mod_add_eq)
  apply (metis One_nat_def Suc_1 mod_Suc_eq_Suc_mod mod_mod_trivial n_not_Suc_n not_mod_2_eq_1_eq_0)
  by force

lemma efib_correct: "efib n = fib (3*n + 1)"
  apply (induct n rule: fib.induct)
  by simp_all

lemma efib_mod_2_eq_0: "(efib n) mod 2 = 0"
  apply (induct n rule: fib.induct)
  apply force
  apply force
using efib.simps(3) by presburger

lemma fib_6_n: "fib (6 + n) = 4*fib (n + 3) + fib n"
  by (unfold Num.numeral_3_eq_3 numeral_6) simp

lemma sum_efib_fib: "\<lbrakk>(fib k) mod 2 = 0; fib k \<le> m\<rbrakk> \<Longrightarrow> sum_efib m (k + 3) = sum_efib m k + fib k"
proof -
  assume assms: "fib k mod 2 = 0" "fib k \<le> m"
  hence "fib (Suc k) mod 2 = Suc 0"
    by (metis fib_parity1)
  hence "fib (Suc (Suc k)) mod 2 = Suc 0"
    by (simp, metis assms(1) mod_add_left_eq plus_nat.add_0)
  hence "sum_efib m (k + 3) = sum_efib m (k + 1)" using assms
    apply (simp add: Num.numeral_2_eq_2 Num.numeral_3_eq_3)
    by (metis Zero_not_Suc mod_add_left_eq plus_nat.add_0)
  thus ?thesis using assms
    by simp
qed

record sum_efib_state =
  x :: nat
  y :: nat
  n :: nat
  k :: nat
  tmp :: nat
  sum :: nat

lemma sum_efib: "\<turnstile> \<lbrace> True \<rbrace>
    `sum := 0
  \<lbrace> is_sum_efib `sum m \<rbrace>"
  apply hoare
  apply (auto simp: is_sum_efib_def)
  apply (rule_tac x=0 in exI)
  apply auto
oops

lemma sum_efib: "\<turnstile> \<lbrace> True \<rbrace>
    `x := 2;
    `y := 8;
    `sum := 0;
    `n := 0;
    `k := 1;
    while `x \<le> m
    inv
      (`k \<ge> 1) \<and> (`x = efib `n) \<and> (`x = fib `k) \<and>
      (`y = efib (`n + 1)) \<and> (`y = fib (`k + 3)) \<and>
      (`sum = sum_efib m `k)
    do
      `tmp := `x;
      `x := `y;
      `y := 4 * `y + `tmp;
      `sum := `sum + `tmp;
      `n := `n + 1;
      `k := `k + 3
    od
  \<lbrace> is_sum_efib `sum m \<rbrace>"
  apply (hoare, auto)
  apply (force simp: is_sum_efib_def)
  apply (simp add: numeral_3_eq_3)
  by (simp add: efib_mod_2_eq_0 sum_efib_fib)

lemma sum_efib_refinement: "\<lbrakk> True, is_sum_efib `sum m\<rbrakk>
    \<sqsubseteq>
  `x := 2;
  `y := 8;
  `sum := 0;
  `n := 0;
  `k := 1;
  while `x \<le> m do
    `tmp := `x;
    `x := `y;
    `y := 4 * `y + `tmp;
    `sum := `sum + `tmp;
    `n := `n + 1;
    `k := `k + 3
  od"
proof -
  have "\<lbrakk> True, is_sum_efib `sum m\<rbrakk> \<sqsubseteq>
      `x := 2;
      \<lbrakk> `x = efib 0 \<and> `x = fib 1, is_sum_efib `sum m\<rbrakk>"
    by morgan simp
  also have "... \<sqsubseteq>
      `x := 2;
      `y := 8;
      \<lbrakk> `x = efib 0  \<and> `x = fib 1 \<and> `y = efib 1 \<and> `y = fib 4,
        is_sum_efib `sum m\<rbrakk>"
apply morgan_step
    by morgan simp
  also have "... \<sqsubseteq>
      `x := 2;
      `y := 8;
      `sum := 0;
      \<lbrakk> `x = efib 0  \<and> `x = fib 1 \<and> `y = efib 1 \<and> `y = fib 4 \<and> `sum = sum_efib m 1,
        is_sum_efib `sum m\<rbrakk>"
    by morgan simp
  also have "... \<sqsubseteq>
      `x := 2;
      `y := 8;
      `sum := 0;
      `n := 0;
      \<lbrakk> `x = efib `n  \<and> `x = fib 1 \<and> `y = efib (`n + 1) \<and> `y = fib 4 \<and> `n \<ge> 0
        \<and> `sum = sum_efib m 1,
        is_sum_efib `sum m\<rbrakk>"
    by morgan simp
  also have "... \<sqsubseteq>
      `x := 2;
      `y := 8;
      `sum := 0;
      `n := 0;
      `k := 1;
      \<lbrakk> `x = efib `n  \<and> `x = fib `k \<and> `y = efib (`n + 1) \<and> `y = fib (`k + 3) \<and> `n \<ge> 0
        \<and> `k \<ge> 1 \<and> `sum = sum_efib m `k,
        is_sum_efib `sum m\<rbrakk>"
    by morgan simp
  also have "... \<sqsubseteq>
      `x := 2;
      `y := 8;
      `sum := 0;
      `n := 0;
      `k := 1;
      while `x \<le> m do
        \<lbrakk> `x = efib `n  \<and> `x = fib `k \<and> `y = efib (`n + 1) \<and> `y = fib (`k + 3) \<and> `n \<ge> 0
          \<and> `k \<ge> 1 \<and> `sum = sum_efib m `k \<and> `x \<le> m,
          `x = efib `n  \<and> `x = fib `k \<and> `y = efib (`n + 1) \<and> `y = fib (`k + 3) \<and> `n \<ge> 0
          \<and> `k \<ge> 1 \<and> `sum = sum_efib m `k \<rbrakk>
      od"
    by morgan (auto simp: is_sum_efib_def)
  also have "... \<sqsubseteq>
      `x := 2;
      `y := 8;
      `sum := 0;
      `n := 0;
      `k := 1;
      while `x \<le> m do
        \<lbrakk> `x = efib `n  \<and> `x = fib `k \<and> `y = efib (`n + 1) \<and> `y = fib (`k + 3) \<and> `n \<ge> 0
          \<and> `k \<ge> 1 \<and> `sum = sum_efib m `k \<and> `x \<le> m,
          `x = efib `n  \<and> `x = fib (`k + 3) \<and> `y = efib (`n + 1) \<and> `y = fib (6 + `k) \<and> `n \<ge> 0
          \<and> `k + 3 \<ge> 1 \<and> `sum = sum_efib m (`k + 3) \<rbrakk>;
        `k := `k + 3
      od"
    by morgan simp
  also have "... \<sqsubseteq>
      `x := 2;
      `y := 8;
      `sum := 0;
      `n := 0;
      `k := 1;
      while `x \<le> m do
        \<lbrakk> `x = efib `n  \<and> `x = fib `k \<and> `y = efib (`n + 1) \<and> `y = fib (`k + 3) \<and> `n \<ge> 0
          \<and> `k \<ge> 1 \<and> `sum = sum_efib m `k \<and> `x \<le> m,
          `x = efib (`n + 1)  \<and> `x = fib (`k + 3) \<and> `y = efib (`n + 2) \<and> `y = fib (6 + `k)
          \<and> (`n + 1) \<ge> 0 \<and> `k + 3 \<ge> 1 \<and> `sum = sum_efib m (`k + 3) \<rbrakk>;
        `n := `n + 1;
        `k := `k + 3
      od"
    by morgan simp
  also have "... \<sqsubseteq>
      `x := 2;
      `y := 8;
      `sum := 0;
      `n := 0;
      `k := 1;
      while `x \<le> m do
        \<lbrakk> `x = efib `n  \<and> `x = fib `k \<and> `y = efib (`n + 1) \<and> `y = fib (`k + 3) \<and> `n \<ge> 0
          \<and> `k \<ge> 1 \<and> `sum = sum_efib m `k \<and> `x \<le> m,
          `x = efib (`n + 1)  \<and> `x = fib (`k + 3) \<and> `y = efib (`n + 2) \<and> `y = fib (6 + `k)
          \<and> (`n + 1) \<ge> 0 \<and> `k + 3 \<ge> 1 \<and> (`sum + `tmp) = sum_efib m (`k + 3) \<rbrakk>;
        `sum := `sum + `tmp;
        `n := `n + 1;
        `k := `k + 3
      od"
    by morgan simp
  also have "... \<sqsubseteq>
      `x := 2;
      `y := 8;
      `sum := 0;
      `n := 0;
      `k := 1;
      while `x \<le> m do
        \<lbrakk> `x = efib `n  \<and> `x = fib `k \<and> `y = efib (`n + 1) \<and> `y = fib (`k + 3) \<and> `n \<ge> 0
          \<and> `k \<ge> 1 \<and> `sum = sum_efib m `k \<and> `x \<le> m,
          `x = efib (`n + 1)  \<and> `x = fib (`k + 3) \<and> (4*`y + `tmp) = efib (`n + 2)
          \<and> (4*`y + `tmp) = fib (6 + `k) \<and> (`n + 1) \<ge> 0 \<and> `k + 3 \<ge> 1
          \<and> (`sum + `tmp) = sum_efib m (`k + 3) \<rbrakk>;
        `y := 4*`y + `tmp;
        `sum := `sum + `tmp;
        `n := `n + 1;
        `k := `k + 3
      od"
    by morgan simp
  also have "... \<sqsubseteq>
      `x := 2;
      `y := 8;
      `sum := 0;
      `n := 0;
      `k := 1;
      while `x \<le> m do
        \<lbrakk> `x = efib `n  \<and> `x = fib `k \<and> `y = efib (`n + 1) \<and> `y = fib (`k + 3) \<and> `n \<ge> 0
          \<and> `k \<ge> 1 \<and> `sum = sum_efib m `k \<and> `x \<le> m,
          `y = efib (`n + 1)  \<and> `y = fib (`k + 3) \<and> (4*`y + `tmp) = efib (`n + 2)
          \<and> (4*`y + `tmp) = fib (6 + `k) \<and> (`n + 1) \<ge> 0 \<and> `k + 3 \<ge> 1
          \<and> (`sum + `tmp) = sum_efib m (`k + 3) \<rbrakk>;
        `x := `y;
        `y := 4*`y + `tmp;
        `sum := `sum + `tmp;
        `n := `n + 1;
        `k := `k + 3
      od"
    by morgan simp
  also have "... \<sqsubseteq>
      `x := 2;
      `y := 8;
      `sum := 0;
      `n := 0;
      `k := 1;
      while `x \<le> m do
        \<lbrakk> `x = efib `n  \<and> `x = fib `k \<and> `y = efib (`n + 1) \<and> `y = fib (`k + 3) \<and> `n \<ge> 0
          \<and> `k \<ge> 1 \<and> `sum = sum_efib m `k \<and> `x \<le> m,
          `y = efib (`n + 1)  \<and> `y = fib (`k + 3) \<and> (4*`y + `x) = efib (`n + 2)
          \<and> (4*`y + `x) = fib (6 + `k)
          \<and> (`sum + `x) = sum_efib m (`k + 3) \<rbrakk>;
        `tmp := `x;
        `x := `y;
        `y := 4*`y + `tmp;
        `sum := `sum + `tmp;
        `n := `n + 1;
        `k := `k + 3
      od"
    by morgan simp
  also have "... \<sqsubseteq>
      `x := 2;
      `y := 8;
      `sum := 0;
      `n := 0;
      `k := 1;
      while `x \<le> m do
        `tmp := `x;
        `x := `y;
        `y := 4*`y + `tmp;
        `sum := `sum + `tmp;
        `n := `n + 1;
        `k := `k + 3
      od"
    apply (morgan, auto)
    apply (simp add: numeral_3_eq_3)
    by (simp add: efib_mod_2_eq_0 sum_efib_fib)
  finally show ?thesis
    by auto
qed

hide_const x y n k tmp sum

end


(* Author: Lukas Koller *)
theory MinWeightMatching
  imports Main tsp.Misc tsp.WeightedGraph tsp.CompleteGraph
begin

definition "is_perf_match E M \<equiv> M \<subseteq> E \<and> matching M \<and> Vs M = Vs E"

lemma is_perf_matchI:
  assumes "M \<subseteq> E" "matching M" "Vs M = Vs E"
  shows "is_perf_match E M"
  using assms by (auto simp: is_perf_match_def)

lemma is_perf_matchI2:
  assumes "M \<subseteq> E" "\<And>u. u \<in> Vs E \<Longrightarrow> \<exists>!e \<in> M. u \<in> e"
  shows "is_perf_match E M"
proof -
  have "Vs M = Vs E"
    using assms
  proof (intro equalityI)
    show "Vs E \<subseteq> Vs M"
    proof
      fix v
      assume "v \<in> Vs E"
      then obtain e where "e \<in> M" "v \<in> e"
        using assms by meson
      thus "v \<in> Vs M"
        by (auto intro: vs_member_intro)
    qed
  qed (auto simp: Vs_subset)
  moreover hence "matching M"
    unfolding matching_def2 using assms by auto
  ultimately show ?thesis
    using assms by (intro is_perf_matchI)
qed

lemma is_perf_matchE:
  assumes "is_perf_match E M"
  shows "M \<subseteq> E" "matching M" "Vs M = Vs E"
  using assms[unfolded is_perf_match_def] by auto

lemma extend_perf_match:
  assumes "is_perf_match E M" "u \<notin> Vs E" "v \<notin> Vs E" "{{u,v}} \<union> E \<subseteq> E'" "Vs E' = Vs E \<union> {u,v}"
  shows "is_perf_match E' ({{u,v}} \<union> M)"
proof (rule is_perf_matchI2)
  have "M \<subseteq> E"
    using assms by (auto simp: is_perf_matchE)
  thus "{{u,v}} \<union> M \<subseteq> E'"
    using assms by auto

  show "\<And>w. w \<in> Vs E' \<Longrightarrow> \<exists>!e \<in> {{u,v}} \<union> M. w \<in> e"
  proof -
    fix w
    assume "w \<in> Vs E'"
    then consider "w \<in> {u,v}" | "w \<in> Vs E - {u,v}"
      using assms by auto
    thus "\<exists>!e \<in> {{u,v}} \<union> M. w \<in> e"
    proof cases
      assume "w \<in> {u,v}"
      moreover hence "\<exists>!e \<in> {{u,v}}. w \<in> e"
        by auto
      moreover have "w \<notin> Vs M"
        using assms calculation by (auto simp: is_perf_matchE)
      moreover hence "\<forall>e \<in> M. w \<notin> e"
        using vs_member[of w M] by auto
      ultimately show "\<exists>!e \<in> {{u,v}} \<union> M. w \<in> e"
        by auto
    next
      assume "w \<in> Vs E - {u,v}"
      moreover hence "w \<in> Vs M" "matching M"
        using assms by (auto simp: is_perf_matchE)
      moreover hence "\<exists>!e \<in> M. w \<in> e"
        by (auto simp: matching_def2)
      ultimately show "\<exists>!e \<in> {{u,v}} \<union> M. w \<in> e"
        by auto
    qed
  qed
qed

lemma restr_graph_compl':
  "graph_invar E \<Longrightarrow> is_complete E \<Longrightarrow> V \<subseteq> Vs E \<Longrightarrow> is_complete {e \<in> E. e \<subseteq> V}"
  by (intro restr_compl_graph_abs.E\<^sub>V_complete) unfold_locales (* TODO: clean up lemma!? *)

lemma restr_graph_Vs':
  "graph_invar E \<Longrightarrow> is_complete E \<Longrightarrow> V \<subseteq> Vs E \<Longrightarrow> card V \<noteq> 1 \<Longrightarrow> Vs {e \<in> E. e \<subseteq> V} = V"
  by (intro restr_compl_graph_abs.Vs_E\<^sub>V_eq_V) unfold_locales (* TODO: clean up lemma!? *)

context compl_graph_abs
begin

lemma perf_match_exists:
  assumes "even (card (Vs E))"
  obtains M where "is_perf_match E M"
proof -
  have "finite (Vs E)" "even (card (Vs E))"
    using graph assms finite_subset[OF Vs_subset] by auto
  thus ?thesis
    using assms graph complete (* restr_graph_compl restr_graph_Vs *) that
  proof (induction "Vs E" arbitrary: E thesis rule: finite_even_induct)
    case empty
    moreover hence "E = {}"
      by (intro Vs_emptyE) auto
    moreover hence "is_perf_match E {}"
      by (auto intro: is_perf_matchI simp: matching_def)
    ultimately show ?case by auto
  next
    case (insert2 u v V)
    have "even (card V)"
      apply (rule finite_even_cardI)
      using insert2 by auto
    moreover have "V \<subseteq> Vs E"
      using insert2 by auto
    moreover hence "V = Vs {e \<in> E. e \<subseteq> V}" (is "V = Vs ?E'")
      using insert2 calculation by (intro restr_graph_Vs'[symmetric]) auto
    moreover have "even (card (Vs ?E'))"
      using calculation by auto
    moreover have "graph_invar ?E'"
      apply (rule graph_subset)
      using insert2 by auto
    moreover have "is_complete ?E'"
      using insert2 calculation by (intro restr_graph_compl')
    ultimately obtain M where "is_perf_match ?E' M"
      using is_completeE[of ?E'] by (elim insert2.hyps(5))
    moreover have "u \<notin> Vs ?E'" "v \<notin> Vs ?E'" "Vs E = Vs ?E' \<union> {u,v}"
      using insert2 by (auto simp: \<open>V = Vs {e \<in> E. e \<subseteq> V}\<close>[symmetric])
    moreover have "u \<in> Vs E" "v \<in> Vs E"
      using insert2 by auto
    moreover hence "{u,v} \<in> E"
      using insert2 by (intro is_completeE)
    moreover hence "{{u,v}} \<union> ?E' \<subseteq> E"
      by auto
    ultimately have "is_perf_match E ({{u,v}} \<union> M)"
      by (intro extend_perf_match)
    thus ?case
      using insert2 by auto
  qed
qed

end

context restr_compl_graph_abs
begin

lemma perf_match_exists:
  assumes "even (card (Vs E\<^sub>V))"
  obtains M where "is_perf_match E\<^sub>V M"
  apply (rule compl_graph_abs.perf_match_exists[of E\<^sub>V])
  apply unfold_locales
  using graph_E\<^sub>V E\<^sub>V_complete assms that by auto (* TODO: clean up lemma!? *)

end

context compl_graph_abs
begin

lemma restr_perf_match_exists:
  assumes "V \<subseteq> Vs E" "even (card (Vs {e \<in> E. e \<subseteq> V}))"
  obtains M where "is_perf_match {e \<in> E. e \<subseteq> V} M"
  apply (rule restr_compl_graph_abs.perf_match_exists)
  apply unfold_locales
  using assms that by auto (* TODO: clean up lemma!? *)

end

abbreviation "cost_of_match c M \<equiv> sum c M"

context w_graph_abs
begin

abbreviation "cost_of_match\<^sub>c M \<equiv> sum c M"

end

context pos_w_graph_abs
begin

lemma cost_of_match_sum: "cost_of_match\<^sub>c (set M) \<le> \<Sum>\<^sub># (image_mset c (mset M))"
proof (induction M)
  case (Cons e M)
  thus ?case
    by (cases "e \<in> set M") (auto simp: add_left_mono insert_absorb add_increasing costs_ge_0)
qed auto

end

definition "is_min_match E c M \<equiv>
  is_perf_match E M \<and> (\<forall>M'. is_perf_match E M' \<longrightarrow> cost_of_match c M \<le> cost_of_match c M')"

lemma is_min_matchE:
  assumes "is_min_match E c M"
  shows "is_perf_match E M" "\<And>M'. is_perf_match E M' \<Longrightarrow> cost_of_match c M \<le> cost_of_match c M'"
  using assms[unfolded is_min_match_def] by auto

lemma is_min_matchE2:
  assumes "is_min_match E c M"
  shows "M \<subseteq> E" "matching M" "Vs M = Vs E"
    "\<And>M'. is_perf_match E M' \<Longrightarrow> cost_of_match c M \<le> cost_of_match c M'"
  using is_min_matchE[OF assms] is_perf_matchE[of E M] by auto

locale min_weight_matching =
  w_graph_abs E c for E :: "'a set set" and c +
  fixes comp_match
  assumes match: "\<And>E. (\<exists>M. is_perf_match E M) \<Longrightarrow> is_min_match E c (comp_match E c)"

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
paragraph \<open>Reflexive\<close>
theory Binary_Relations_Reflexive
  imports
    Functions_Monotone
begin

consts reflexive_on :: "'a \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> bool"

overloading
  reflexive_on_pred \<equiv> "reflexive_on :: ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
begin
  definition "reflexive_on_pred P R \<equiv> \<forall>x. P x \<longrightarrow> R x x"
end

lemma reflexive_onI [intro]:
  assumes "\<And>x. P x \<Longrightarrow> R x x"
  shows "reflexive_on P R"
  using assms unfolding reflexive_on_pred_def by blast

lemma reflexive_onD [dest]:
  assumes "reflexive_on P R"
  and "P x"
  shows "R x x"
  using assms unfolding reflexive_on_pred_def by blast

lemma le_in_dom_if_reflexive_on:
  assumes "reflexive_on P R"
  shows "P \<le> in_dom R"
  using assms by blast

lemma le_in_codom_if_reflexive_on:
  assumes "reflexive_on P R"
  shows "P \<le> in_codom R"
  using assms by blast

lemma in_codom_eq_in_dom_if_reflexive_on_in_field:
  assumes "reflexive_on (in_field R) R"
  shows "in_codom R = in_dom R"
  using assms by blast

lemma reflexive_on_rel_inv_iff_reflexive_on [iff]:
  "reflexive_on P R\<inverse> \<longleftrightarrow> reflexive_on (P :: 'a \<Rightarrow> bool) (R :: 'a \<Rightarrow> _)"
  by blast

lemma antimono_reflexive_on [iff]:
  "antimono (\<lambda>(P :: 'a \<Rightarrow> bool). reflexive_on P (R :: 'a \<Rightarrow> _))"
  by (intro antimonoI) auto

lemma reflexive_on_if_le_pred_if_reflexive_on:
  fixes P P' :: "'a \<Rightarrow> bool" and R :: "'a \<Rightarrow> _"
  assumes "reflexive_on P R"
  and "P' \<le> P"
  shows "reflexive_on P' R"
  using assms by blast

lemma reflexive_on_sup_eq [simp]:
  "(reflexive_on :: ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> _) \<Rightarrow> _) ((P :: 'a \<Rightarrow> bool) \<squnion> Q)
  = reflexive_on P \<sqinter> reflexive_on Q"
  by (intro ext iffI reflexive_onI)
    (auto intro: reflexive_on_if_le_pred_if_reflexive_on)

lemma reflexive_on_iff_eq_restrict_left_le:
  "reflexive_on (P :: 'a \<Rightarrow> bool) (R :: 'a \<Rightarrow> _) \<longleftrightarrow> ((=)\<restriction>\<^bsub>P\<^esub> \<le> R)"
  by blast

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

lemma reflexive_eq_reflexive_on:
  "reflexive (R :: 'a \<Rightarrow> _) = reflexive_on (\<top> :: 'a \<Rightarrow> bool) R"
  unfolding reflexive_def ..

lemma reflexiveI [intro]:
  assumes "\<And>x. R x x"
  shows "reflexive R"
  unfolding reflexive_eq_reflexive_on using assms by (intro reflexive_onI)

lemma reflexiveD:
  assumes "reflexive R"
  shows "R x x"
  using assms unfolding reflexive_eq_reflexive_on by (blast intro: top1I)

lemma reflexive_on_if_reflexive:
  fixes P :: "'a \<Rightarrow> bool" and R :: "'a \<Rightarrow> _"
  assumes "reflexive R"
  shows "reflexive_on P R"
  using assms by (intro reflexive_onI) (blast dest: reflexiveD)

lemma reflexive_rel_inv_iff_reflexive [iff]:
  "reflexive R\<inverse> \<longleftrightarrow> reflexive R"
  by (blast dest: reflexiveD)

lemma reflexive_iff_eq_le: "reflexive R \<longleftrightarrow> ((=) \<le> R)"
  unfolding reflexive_eq_reflexive_on reflexive_on_iff_eq_restrict_left_le
  by simp

paragraph \<open>Instantiations\<close>

lemma reflexive_eq: "reflexive (=)"
  by (rule reflexiveI) (rule refl)

lemma reflexive_top: "reflexive \<top>"
  by (rule reflexiveI) auto

end


theory Exercise6
  imports Main
begin

type_synonym vname = string
datatype aexp = N int | V vname | Plus aexp aexp

type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V x) s = s x" |
"aval (Plus a1 a2) s = (aval a1 s) + (aval a2 s)"

(* NOTE: aval_rel name is taken by an auto-generated property
   during the definition of aval, so switching to double
   underscore here. *)
inductive aval__rel :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
num: "aval__rel (N n) s n" |
var: "(s v = n) \<Longrightarrow> aval__rel (V v) s n" |
plus: "
  aval__rel a s na
  \<Longrightarrow> aval__rel b s nb
  \<Longrightarrow> aval__rel (Plus a b) s (na + nb)"

theorem rel_thus_aval: "aval__rel a s v \<Longrightarrow> aval a s = v"
  apply (induction rule: aval__rel.induct)
  apply auto
  done

theorem aval_thus_rel: "(aval a s = n) \<Longrightarrow> aval__rel a s n"
  apply (induction a arbitrary: s n)
    apply (simp add: aval__rel.num)
  using aval__rel.var apply (simp add: aval__rel.intros)
  apply (metis aval.simps(3) aval__rel.simps)
  done

theorem rel_is_aval: "aval__rel a s v \<longleftrightarrow> aval a s = v"
  using rel_thus_aval aval_thus_rel apply blast
  done

end


theory VDMSet
imports VDMToolKit
begin

section {* VDM set operators *}

text{*
VDM set operators have a direct correspondence in Isabelle. TODO?
*}

text {* set comprehension *}

(* { expr | var . filter }, { var \<in> type . filter }, { var . filter } *)

(*declare [[show_types]]*)
value "{ x+x | x . x \<in> {(1::nat),2,3} }"

value "{ x+x | x . x \<in> {(1::nat),2,3} }"

(*value "{ x+x | x . x \<in> {(1::nat)..3} }" --"not always work"*)

lemma "{ x . x \<in> {1,(2::nat), 3} | x \<le> 2} = { x \<in> {1,2,3} . x \<le> 2 }"
find_theorems "_ = (_::'a set)" intro
apply (rule equalityI)
apply (rule subsetI, simp)
defer
apply (rule subsetI, simp, elim disjE, simp_all) oops

value "{ [A,B,C,D,E,F] ! i | i . i \<in> {0,2,4} }"

(* { s(i) | i in set inds s & i mod 2 = 0 } *)

text{* Sequences may have invariants within their inner type. *}

type_synonym 'a VDMSet = "'a set"

definition
  inv_SetElems :: "('a \<Rightarrow> \<bool>) \<Rightarrow> 'a VDMSet \<Rightarrow> \<bool>"
where
  "inv_SetElems einv s \<equiv> \<forall> e \<in> s . einv e"

lemma l_inv_SetElems_Cons: "(inv_SetElems f (insert a s)) = (f a \<and> (inv_SetElems f s))"
unfolding inv_SetElems_def
by auto

(*
text {* Useful example for XO if you use set comprehension *}

type_synonym Pos = "(\<nat> \<times> \<nat>)"
type_synonym Line = "Pos set"

abbreviation SIZE :: \<nat> where "SIZE \<equiv> 3"

abbreviation
  BOARD :: "\<nat> set"
where
  "BOARD \<equiv> {1 .. 3}"

definition
  inv_Pos :: "Pos \<Rightarrow> bool"
where
  "inv_Pos z \<equiv> let (x,y) = z in
                  nat1 x \<and> x \<le> SIZE \<and>
                  nat1 y \<and> y \<le> SIZE"

definition
  row :: "nat \<Rightarrow> Line"
where
  "row rr \<equiv> { (rr, c) | c . c \<in> BOARD \<and> inv_Pos (rr, c) }"

lemma "row 1 = A"
unfolding row_def inv_Pos_def nat1G0
apply simp
oops

definition
  col :: "nat \<Rightarrow> Line"
where
  "col cc \<equiv> { (r,cc) | r . r \<in> BOARD \<and> inv_Pos (r, cc) }"

lemma "row 1 = A" unfolding row_def inv_Pos_def apply simp oops

abbreviation
  allRows0 :: "Line set"
where
  "allRows0 \<equiv> { row 1, row 2, row 3 }"

abbreviation
  allRows :: "Line set"
where
  "allRows \<equiv> \<Union> r \<in> BOARD . { row r }"

abbreviation
  allCols :: "Line set"
where
  "allCols \<equiv> \<Union> c \<in> BOARD . { col c }"

abbreviation
  downwardDiag :: "Line"
where
  "downwardDiag \<equiv> { (x,x)| x . x \<in> BOARD }"

abbreviation
  upwardDiag :: "Line"
where
  "upwardDiag \<equiv> { (x,y) . x \<in> BOARD \<and> y = SIZE-x+(1::nat) }"

(* Use definition to tame unfolding *)
definition
  winningLines :: "Line set"
where
   "winningLines \<equiv> allRows \<union> allCols \<union> {downwardDiag, upwardDiag}"

abbreviation
  explicitWinningLines :: "Line set"
where
  "explicitWinningLines \<equiv>
          { {(1, 1), (1, 2), (1, 3)},
					 	{(2, 1), (2, 2), (2, 3)},
					  {(3, 1), (3, 2), (3, 3)},

					  {(1, 1), (2, 1), (3, 1)},
					  {(1, 2), (2, 2), (3, 2)},
					  {(1, 3), (2, 3), (3, 3)},

					  {(1, 1), (2, 2), (3, 3)},

					  {(1, 3), (2, 2), (3, 1)}
				  }"
*)

end


(*
  File:   Prime_Harmonic_Misc.thy
  Author: Manuel Eberl <eberlm@in.tum.de>

*)

section \<open>Auxiliary lemmas\<close>
theory Prime_Harmonic_Misc
imports
  Complex_Main
  "HOL-Number_Theory.Number_Theory"
begin

lemma sum_list_nonneg: "\<forall>x\<in>set xs. x \<ge> 0 \<Longrightarrow> sum_list xs \<ge> (0 :: 'a :: ordered_ab_group_add)"
  by (induction xs) auto

lemma sum_telescope':
  assumes "m \<le> n"
  shows   "(\<Sum>k = Suc m..n. f k - f (Suc k)) = f (Suc m) - (f (Suc n) :: 'a :: ab_group_add)"
  by (rule dec_induct[OF assms]) (simp_all add: algebra_simps)

lemma dvd_prodI:
  assumes "finite A" "x \<in> A"
  shows   "f x dvd prod f A"
proof -
  from assms have "prod f A = f x * prod f (A - {x})"
    by (intro prod.remove) simp_all
  thus ?thesis by simp
qed

lemma dvd_prodD: "finite A \<Longrightarrow> prod f A dvd x \<Longrightarrow> a \<in> A \<Longrightarrow> f a dvd x"
  by (erule dvd_trans[OF dvd_prodI])

lemma multiplicity_power_nat:
  "prime p \<Longrightarrow> n > 0 \<Longrightarrow> multiplicity p (n ^ k :: nat) = k * multiplicity p n"
  by (induction k) (simp_all add: prime_elem_multiplicity_mult_distrib)

lemma multiplicity_prod_prime_powers_nat':
  "finite S \<Longrightarrow> \<forall>p\<in>S. prime p \<Longrightarrow> prime p \<Longrightarrow>
     multiplicity p (\<Prod>S :: nat) = (if p \<in> S then 1 else 0)"
  using multiplicity_prod_prime_powers[of S p "\<lambda>_. 1"] by simp

lemma prod_prime_subset:
  assumes "finite A" "finite B"
  assumes "\<And>x. x \<in> A \<Longrightarrow> prime (x::nat)"
  assumes "\<And>x. x \<in> B \<Longrightarrow> prime x"
  assumes "\<Prod>A dvd \<Prod>B"
  shows   "A \<subseteq> B"
proof
  fix x assume x: "x \<in> A"
  from assms(4)[of 0] have "0 \<notin> B" by auto
  with assms have nonzero: "\<forall>z\<in>B. z \<noteq> 0" by (intro ballI notI) auto

  from x assms have "1 = multiplicity x (\<Prod>A)"
    by (subst multiplicity_prod_prime_powers_nat') simp_all
  also from assms nonzero have "\<dots> \<le> multiplicity x (\<Prod>B)" by (intro dvd_imp_multiplicity_le) auto
  finally have "multiplicity x (\<Prod>B) > 0" by simp
  moreover from assms x have "prime x" by simp
  ultimately show "x \<in> B" using assms(2,4)
    by (subst (asm) multiplicity_prod_prime_powers_nat') (simp_all split: if_split_asm)
qed

lemma prod_prime_eq:
  assumes "finite A" "finite B" "\<And>x. x \<in> A \<Longrightarrow> prime (x::nat)" "\<And>x. x \<in> B \<Longrightarrow> prime x" "\<Prod>A = \<Prod>B"
  shows   "A = B"
  using assms by (intro equalityI prod_prime_subset) simp_all

lemma ln_ln_nonneg:
  assumes x: "x \<ge> (3 :: real)"
  shows   "ln (ln x) \<ge> 0"
proof -
  have "exp 1 \<le> (3::real)" by (rule  exp_le)
  hence "ln (exp 1) \<le> ln (3 :: real)" by (subst ln_le_cancel_iff) simp_all
  also from x have "\<dots> \<le> ln x" by (subst ln_le_cancel_iff) simp_all
  finally have "ln 1 \<le> ln (ln x)" using x by (subst ln_le_cancel_iff) simp_all
  thus ?thesis by simp
qed

end


(*  Title:      HOL/HOLCF/Fix.thy
    Author:     Franz Regensburger
    Author:     Brian Huffman
*)

section \<open>Fixed point operator and admissibility\<close>

theory Fix
imports Cfun
begin

default_sort pcpo

subsection \<open>Iteration\<close>

primrec iterate :: "nat \<Rightarrow> ('a::cpo \<rightarrow> 'a) \<rightarrow> ('a \<rightarrow> 'a)" where
    "iterate 0 = (\<Lambda> F x. x)"
  | "iterate (Suc n) = (\<Lambda> F x. F\<cdot>(iterate n\<cdot>F\<cdot>x))"

text \<open>Derive inductive properties of iterate from primitive recursion\<close>

lemma iterate_0 [simp]: "iterate 0\<cdot>F\<cdot>x = x"
by simp

lemma iterate_Suc [simp]: "iterate (Suc n)\<cdot>F\<cdot>x = F\<cdot>(iterate n\<cdot>F\<cdot>x)"
by simp

declare iterate.simps [simp del]

lemma iterate_Suc2: "iterate (Suc n)\<cdot>F\<cdot>x = iterate n\<cdot>F\<cdot>(F\<cdot>x)"
by (induct n) simp_all

lemma iterate_iterate:
  "iterate m\<cdot>F\<cdot>(iterate n\<cdot>F\<cdot>x) = iterate (m + n)\<cdot>F\<cdot>x"
by (induct m) simp_all

text \<open>The sequence of function iterations is a chain.\<close>

lemma chain_iterate [simp]: "chain (\<lambda>i. iterate i\<cdot>F\<cdot>\<bottom>)"
by (rule chainI, unfold iterate_Suc2, rule monofun_cfun_arg, rule minimal)

subsection \<open>Least fixed point operator\<close>

definition
  "fix" :: "('a \<rightarrow> 'a) \<rightarrow> 'a" where
  "fix = (\<Lambda> F. \<Squnion>i. iterate i\<cdot>F\<cdot>\<bottom>)"

text \<open>Binder syntax for @{term fix}\<close>

abbreviation
  fix_syn :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a"  (binder "\<mu> " 10) where
  "fix_syn (\<lambda>x. f x) \<equiv> fix\<cdot>(\<Lambda> x. f x)"

notation (ASCII)
  fix_syn  (binder "FIX " 10)

text \<open>Properties of @{term fix}\<close>

text \<open>direct connection between @{term fix} and iteration\<close>

lemma fix_def2: "fix\<cdot>F = (\<Squnion>i. iterate i\<cdot>F\<cdot>\<bottom>)"
unfolding fix_def by simp

lemma iterate_below_fix: "iterate n\<cdot>f\<cdot>\<bottom> \<sqsubseteq> fix\<cdot>f"
  unfolding fix_def2
  using chain_iterate by (rule is_ub_thelub)

text \<open>
  Kleene's fixed point theorems for continuous functions in pointed
  omega cpo's
\<close>

lemma fix_eq: "fix\<cdot>F = F\<cdot>(fix\<cdot>F)"
apply (simp add: fix_def2)
apply (subst lub_range_shift [of _ 1, symmetric])
apply (rule chain_iterate)
apply (subst contlub_cfun_arg)
apply (rule chain_iterate)
apply simp
done

lemma fix_least_below: "F\<cdot>x \<sqsubseteq> x \<Longrightarrow> fix\<cdot>F \<sqsubseteq> x"
apply (simp add: fix_def2)
apply (rule lub_below)
apply (rule chain_iterate)
apply (induct_tac i)
apply simp
apply simp
apply (erule rev_below_trans)
apply (erule monofun_cfun_arg)
done

lemma fix_least: "F\<cdot>x = x \<Longrightarrow> fix\<cdot>F \<sqsubseteq> x"
by (rule fix_least_below, simp)

lemma fix_eqI:
  assumes fixed: "F\<cdot>x = x" and least: "\<And>z. F\<cdot>z = z \<Longrightarrow> x \<sqsubseteq> z"
  shows "fix\<cdot>F = x"
apply (rule below_antisym)
apply (rule fix_least [OF fixed])
apply (rule least [OF fix_eq [symmetric]])
done

lemma fix_eq2: "f \<equiv> fix\<cdot>F \<Longrightarrow> f = F\<cdot>f"
by (simp add: fix_eq [symmetric])

lemma fix_eq3: "f \<equiv> fix\<cdot>F \<Longrightarrow> f\<cdot>x = F\<cdot>f\<cdot>x"
by (erule fix_eq2 [THEN cfun_fun_cong])

lemma fix_eq4: "f = fix\<cdot>F \<Longrightarrow> f = F\<cdot>f"
apply (erule ssubst)
apply (rule fix_eq)
done

lemma fix_eq5: "f = fix\<cdot>F \<Longrightarrow> f\<cdot>x = F\<cdot>f\<cdot>x"
by (erule fix_eq4 [THEN cfun_fun_cong])

text \<open>strictness of @{term fix}\<close>

lemma fix_bottom_iff: "(fix\<cdot>F = \<bottom>) = (F\<cdot>\<bottom> = \<bottom>)"
apply (rule iffI)
apply (erule subst)
apply (rule fix_eq [symmetric])
apply (erule fix_least [THEN bottomI])
done

lemma fix_strict: "F\<cdot>\<bottom> = \<bottom> \<Longrightarrow> fix\<cdot>F = \<bottom>"
by (simp add: fix_bottom_iff)

lemma fix_defined: "F\<cdot>\<bottom> \<noteq> \<bottom> \<Longrightarrow> fix\<cdot>F \<noteq> \<bottom>"
by (simp add: fix_bottom_iff)

text \<open>@{term fix} applied to identity and constant functions\<close>

lemma fix_id: "(\<mu> x. x) = \<bottom>"
by (simp add: fix_strict)

lemma fix_const: "(\<mu> x. c) = c"
by (subst fix_eq, simp)

subsection \<open>Fixed point induction\<close>

lemma fix_ind: "\<lbrakk>adm P; P \<bottom>; \<And>x. P x \<Longrightarrow> P (F\<cdot>x)\<rbrakk> \<Longrightarrow> P (fix\<cdot>F)"
unfolding fix_def2
apply (erule admD)
apply (rule chain_iterate)
apply (rule nat_induct, simp_all)
done

lemma cont_fix_ind:
  "\<lbrakk>cont F; adm P; P \<bottom>; \<And>x. P x \<Longrightarrow> P (F x)\<rbrakk> \<Longrightarrow> P (fix\<cdot>(Abs_cfun F))"
by (simp add: fix_ind)

lemma def_fix_ind:
  "\<lbrakk>f \<equiv> fix\<cdot>F; adm P; P \<bottom>; \<And>x. P x \<Longrightarrow> P (F\<cdot>x)\<rbrakk> \<Longrightarrow> P f"
by (simp add: fix_ind)

lemma fix_ind2:
  assumes adm: "adm P"
  assumes 0: "P \<bottom>" and 1: "P (F\<cdot>\<bottom>)"
  assumes step: "\<And>x. \<lbrakk>P x; P (F\<cdot>x)\<rbrakk> \<Longrightarrow> P (F\<cdot>(F\<cdot>x))"
  shows "P (fix\<cdot>F)"
unfolding fix_def2
apply (rule admD [OF adm chain_iterate])
apply (rule nat_less_induct)
apply (case_tac n)
apply (simp add: 0)
apply (case_tac nat)
apply (simp add: 1)
apply (frule_tac x=nat in spec)
apply (simp add: step)
done

lemma parallel_fix_ind:
  assumes adm: "adm (\<lambda>x. P (fst x) (snd x))"
  assumes base: "P \<bottom> \<bottom>"
  assumes step: "\<And>x y. P x y \<Longrightarrow> P (F\<cdot>x) (G\<cdot>y)"
  shows "P (fix\<cdot>F) (fix\<cdot>G)"
proof -
  from adm have adm': "adm (case_prod P)"
    unfolding split_def .
  have "\<And>i. P (iterate i\<cdot>F\<cdot>\<bottom>) (iterate i\<cdot>G\<cdot>\<bottom>)"
    by (induct_tac i, simp add: base, simp add: step)
  hence "\<And>i. case_prod P (iterate i\<cdot>F\<cdot>\<bottom>, iterate i\<cdot>G\<cdot>\<bottom>)"
    by simp
  hence "case_prod P (\<Squnion>i. (iterate i\<cdot>F\<cdot>\<bottom>, iterate i\<cdot>G\<cdot>\<bottom>))"
    by - (rule admD [OF adm'], simp, assumption)
  hence "case_prod P (\<Squnion>i. iterate i\<cdot>F\<cdot>\<bottom>, \<Squnion>i. iterate i\<cdot>G\<cdot>\<bottom>)"
    by (simp add: lub_Pair)
  hence "P (\<Squnion>i. iterate i\<cdot>F\<cdot>\<bottom>) (\<Squnion>i. iterate i\<cdot>G\<cdot>\<bottom>)"
    by simp
  thus "P (fix\<cdot>F) (fix\<cdot>G)"
    by (simp add: fix_def2)
qed

lemma cont_parallel_fix_ind:
  assumes "cont F" and "cont G"
  assumes "adm (\<lambda>x. P (fst x) (snd x))"
  assumes "P \<bottom> \<bottom>"
  assumes "\<And>x y. P x y \<Longrightarrow> P (F x) (G y)"
  shows "P (fix\<cdot>(Abs_cfun F)) (fix\<cdot>(Abs_cfun G))"
by (rule parallel_fix_ind, simp_all add: assms)

subsection \<open>Fixed-points on product types\<close>

text \<open>
  Bekic's Theorem: Simultaneous fixed points over pairs
  can be written in terms of separate fixed points.
\<close>

lemma fix_cprod:
  "fix\<cdot>(F::'a \<times> 'b \<rightarrow> 'a \<times> 'b) =
   (\<mu> x. fst (F\<cdot>(x, \<mu> y. snd (F\<cdot>(x, y)))),
    \<mu> y. snd (F\<cdot>(\<mu> x. fst (F\<cdot>(x, \<mu> y. snd (F\<cdot>(x, y)))), y)))"
  (is "fix\<cdot>F = (?x, ?y)")
proof (rule fix_eqI)
  have 1: "fst (F\<cdot>(?x, ?y)) = ?x"
    by (rule trans [symmetric, OF fix_eq], simp)
  have 2: "snd (F\<cdot>(?x, ?y)) = ?y"
    by (rule trans [symmetric, OF fix_eq], simp)
  from 1 2 show "F\<cdot>(?x, ?y) = (?x, ?y)" by (simp add: prod_eq_iff)
next
  fix z assume F_z: "F\<cdot>z = z"
  obtain x y where z: "z = (x,y)" by (rule prod.exhaust)
  from F_z z have F_x: "fst (F\<cdot>(x, y)) = x" by simp
  from F_z z have F_y: "snd (F\<cdot>(x, y)) = y" by simp
  let ?y1 = "\<mu> y. snd (F\<cdot>(x, y))"
  have "?y1 \<sqsubseteq> y" by (rule fix_least, simp add: F_y)
  hence "fst (F\<cdot>(x, ?y1)) \<sqsubseteq> fst (F\<cdot>(x, y))"
    by (simp add: fst_monofun monofun_cfun)
  hence "fst (F\<cdot>(x, ?y1)) \<sqsubseteq> x" using F_x by simp
  hence 1: "?x \<sqsubseteq> x" by (simp add: fix_least_below)
  hence "snd (F\<cdot>(?x, y)) \<sqsubseteq> snd (F\<cdot>(x, y))"
    by (simp add: snd_monofun monofun_cfun)
  hence "snd (F\<cdot>(?x, y)) \<sqsubseteq> y" using F_y by simp
  hence 2: "?y \<sqsubseteq> y" by (simp add: fix_least_below)
  show "(?x, ?y) \<sqsubseteq> z" using z 1 2 by simp
qed

end