(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Rational Factorization\<close>

text \<open>We combine the rational root test, the
  formulas for explicit roots, and the Kronecker's factorization algorithm to provide a
  basic factorization algorithm for polynomial over rational numbers. Moreover, also the roots
  of a rational polynomial can be determined.\<close>

theory Rational_Factorization
imports
  Explicit_Roots
  Kronecker_Factorization
  Square_Free_Factorization
  Rational_Root_Test
  Gcd_Rat_Poly
  Show.Show_Poly
begin

function roots_of_rat_poly_main :: "rat poly \<Rightarrow> rat list" where
  "roots_of_rat_poly_main p = (let n = degree p in if n = 0 then [] else if n = 1 then [roots1 p]
  else if n = 2 then rat_roots2 p else
  case rational_root_test p of None \<Rightarrow> [] | Some x \<Rightarrow> x # roots_of_rat_poly_main (p div [:-x,1:]))"
  by pat_completeness auto

termination by (relation "measure degree",
  auto dest: rational_root_test(1) intro!: degree_div_less simp: poly_eq_0_iff_dvd)

lemma roots_of_rat_poly_main_code[code]: "roots_of_rat_poly_main p = (let n = degree p in if n = 0 then [] else if n = 1 then [roots1 p]
  else if n = 2 then rat_roots2 p else
  case rational_root_test p of None \<Rightarrow> [] | Some x \<Rightarrow> x # roots_of_rat_poly_main (p div [:-x,1:]))"
proof -
  note d = roots_of_rat_poly_main.simps[of p] Let_def
  show ?thesis
  proof (cases "rational_root_test p")
    case (Some x)
    let ?x = "[:-x,1:]"
    from rational_root_test(1)[OF Some] have  "?x dvd p"
      by (simp add: poly_eq_0_iff_dvd)
    from dvd_mult_div_cancel[OF this]
    have pp: "p div ?x = ?x * (p div ?x) div ?x" by simp
    then show ?thesis unfolding d Some by auto
  qed (simp add: d)
qed

lemma roots_of_rat_poly_main: "p \<noteq> 0 \<Longrightarrow> set (roots_of_rat_poly_main p) = {x. poly p x = 0}"
proof (induct p rule: roots_of_rat_poly_main.induct)
  case (1 p)
  note IH = 1(1)
  note p = 1(2)
  let ?n = "degree p"
  let ?rr = "roots_of_rat_poly_main"
  show ?case
  proof (cases "?n = 0")
    case True
    from roots0[OF p True] True show ?thesis by simp
  next
    case False note 0 = this
    show ?thesis
    proof (cases "?n = 1")
      case True
      from roots1[OF True] True show ?thesis by simp
    next
      case False note 1 = this
      show ?thesis
      proof (cases "?n = 2")
        case True
        from rat_roots2[OF True] True show ?thesis by simp
      next
        case False note 2 = this
        from 0 1 2 have id: "?rr p = (case rational_root_test p of None \<Rightarrow> [] | Some x \<Rightarrow>
          x # ?rr (p div [: -x, 1 :]))" by simp
        show ?thesis
        proof (cases "rational_root_test p")
          case None
          from rational_root_test(2)[OF None] None id show ?thesis by simp
        next
          case (Some x)
          from rational_root_test(1)[OF Some] have "[: -x, 1:] dvd p"
            by (simp add: poly_eq_0_iff_dvd)
          from dvd_mult_div_cancel[OF this]
          have pp: "p = [: -x, 1:] * (p div [: -x, 1:])" by simp
          with p have p: "p div [:- x, 1:] \<noteq> 0" by auto
          from arg_cong[OF pp, of "\<lambda> p. {x. poly p x = 0}"]
             rational_root_test(1)[OF Some] IH[OF refl 0 1 2 Some p]  show ?thesis
            unfolding id Some by auto
        qed
      qed
    qed
  qed
qed

declare roots_of_rat_poly_main.simps[simp del]

definition roots_of_rat_poly :: "rat poly \<Rightarrow> rat list" where
  "roots_of_rat_poly p \<equiv> let (c,pis) = yun_factorization gcd_rat_poly p in
    concat (map (roots_of_rat_poly_main o fst) pis)"

lemma roots_of_rat_poly: assumes p: "p \<noteq> 0"
  shows "set (roots_of_rat_poly p) = {x. poly p x = 0}"
proof -
  obtain c pis where yun: "yun_factorization gcd p = (c,pis)" by force
  from yun
  have res: "roots_of_rat_poly p = concat (map (roots_of_rat_poly_main \<circ> fst) pis)"
    by (auto simp: roots_of_rat_poly_def split: if_splits)
  note yun = square_free_factorizationD(1,2,4)[OF yun_factorization(1)[OF yun]]
  from yun(1) p have c: "c \<noteq> 0" by auto
  from yun(1) have p: "p = smult c (\<Prod>(a, i)\<in>set pis. a ^ Suc i)" .
  have "{x. poly p x = 0} = {x. poly (\<Prod>(a, i)\<in>set pis. a ^ Suc i) x = 0}"
    unfolding p using c by auto
  also have "\<dots> = \<Union> ((\<lambda> p. {x. poly p x = 0}) ` fst ` set pis)" (is "_ = ?r")
    by (subst poly_prod_0, force+)
  finally have r: "{x. poly p x = 0} = ?r" .
  {
    fix p i
    assume p: "(p,i) \<in> set pis"
    have "set (roots_of_rat_poly_main p) = {x. poly p x = 0}"
      by (rule roots_of_rat_poly_main, insert yun(2) p, force)
  } note main = this
  have "set (roots_of_rat_poly p) = \<Union> ((\<lambda> (p, i). set (roots_of_rat_poly_main p)) ` set pis)"
    unfolding res o_def by auto
  also have "\<dots> = ?r" using main by auto
  finally show ?thesis unfolding r by simp
qed

definition root_free :: "'a :: comm_semiring_0 poly \<Rightarrow> bool" where
  "root_free p = (degree p = 1 \<or> (\<forall> x. poly p x \<noteq> 0))"

lemma irreducible_root_free:
  fixes p :: "'a :: idom poly"
  assumes "irreducible p" shows "root_free p"
proof-
  from assms have p0: "p \<noteq> 0" by auto
  {
    fix x
    assume "poly p x = 0" and degp: "degree p \<noteq> 1"
    hence "[:-x,1:] dvd p" using poly_eq_0_iff_dvd by blast
    then obtain q where p: "p = [:-x,1:] * q" by (elim dvdE)
    with p0 have q0: "q \<noteq> 0" by auto
    from irreducibleD[OF assms p]
    have "q dvd 1" by (metis one_neq_zero poly_1 poly_eq_0_iff_dvd)
    then have "degree q = 0" by (simp add: poly_dvd_1)
    with degree_mult_eq[of "[:-x,1:]" q, folded p] q0 degp
    have False by auto
  }
  thus ?thesis unfolding root_free_def by auto
qed

partial_function (tailrec) factorize_root_free_main :: "rat poly \<Rightarrow> rat list \<Rightarrow> rat poly list \<Rightarrow> rat \<times> rat poly list" where
  [code]: "factorize_root_free_main p xs fs = (case xs of Nil \<Rightarrow>
     let l = coeff p (degree p); q = smult (inverse l) p in (l, (if q = 1 then fs else q # fs) )
  | x # xs \<Rightarrow>
    if poly p x = 0 then factorize_root_free_main (p div [:-x,1:]) (x # xs) ([:-x,1:] # fs)
    else factorize_root_free_main p xs fs)"

definition factorize_root_free :: "rat poly \<Rightarrow> rat \<times> rat poly list" where
  "factorize_root_free p = (if degree p = 0 then (coeff p 0,[]) else
     factorize_root_free_main p (roots_of_rat_poly p) [])"

lemma factorize_root_free_0[simp]: "factorize_root_free 0 = (0,[])"
  unfolding factorize_root_free_def by simp

lemma factorize_root_free: assumes res: "factorize_root_free p = (c,qs)"
  shows "p = smult c (prod_list qs)"
  "\<And> q. q \<in> set qs \<Longrightarrow> root_free q \<and> monic q \<and> degree q \<noteq> 0"
proof -
  have "p = smult c (prod_list qs) \<and> (\<forall> q \<in> set qs. root_free q \<and> monic q \<and> degree q \<noteq> 0)"
  proof (cases "degree p = 0")
    case True
    thus ?thesis using res unfolding factorize_root_free_def by (auto dest: degree0_coeffs)
  next
    case False
    hence p0: "p \<noteq> 0" by auto
    define fs where "fs = ([] :: rat poly list)"
    define xs where "xs = roots_of_rat_poly p"
    define q where "q = p"
    obtain n  where n: "n = degree q + length xs" by auto
    have prod: "p = q * prod_list fs" unfolding q_def fs_def by auto
    have sub: "{x. poly q x = 0} \<subseteq> set xs" using roots_of_rat_poly[OF p0] unfolding q_def xs_def by auto
    have fs: "\<And> q. q \<in> set fs \<Longrightarrow> root_free q \<and> monic q \<and> degree q \<noteq> 0" unfolding fs_def by auto
    have res: "factorize_root_free_main q xs fs = (c,qs)" using res False
      unfolding xs_def fs_def q_def factorize_root_free_def by auto
    from False have "q \<noteq> 0" unfolding q_def by auto
    from prod sub fs res n this show ?thesis
    proof (induct n arbitrary: q fs xs rule: wf_induct[OF wf_less])
      case (1 n q fs xs)
      note simp = factorize_root_free_main.simps[of q xs fs]
      note IH = 1(1)[rule_format]
      note 0 = 1(2-)[unfolded simp]
      show ?case
      proof (cases xs)
        case Nil
        note 0 = 0[unfolded Nil Let_def]
        hence no_rt: "\<And> x. poly q x \<noteq> 0" by auto
        hence q: "q \<noteq> 0" by auto
        let ?r = "smult (inverse c) q"
        define r where "r = ?r"
        from 0(4-5) have c: "c = coeff q (degree q)" and qs: "qs = (if r = 1 then fs else r # fs)" by (auto simp: r_def)
        from q c qs 0(1) have c0: "c \<noteq> 0" and p: "p = smult c (prod_list (r # fs))" by (auto simp: r_def)
        from p have p: "p = smult c (prod_list qs)" unfolding qs by auto
        from 0(2,5) c0 c have "root_free ?r" "monic ?r"
          unfolding root_free_def by auto
        with 0(3) have "\<And> q. q \<in> set qs \<Longrightarrow> root_free q \<and> monic q \<and> degree q \<noteq> 0" unfolding qs
          by (cases "degree q = 0", insert degree0_coeffs[of q], auto split: if_splits simp: r_def)
        with p show ?thesis by auto
      next
        case (Cons x xs)
        note 0 = 0[unfolded Cons]
        show ?thesis
        proof (cases "poly q x = 0")
          case True
          let ?q = "q div [:-x,1:]"
          let ?x = "[:-x,1:]"
          let ?fs = "?x # fs"
          let ?xs = "x # xs"
          from True have q: "q = ?q * ?x"
            by (metis dvd_mult_div_cancel mult.commute poly_eq_0_iff_dvd)
          with 0(6) have q': "?q \<noteq> 0" by auto
          have deg: "degree q = Suc (degree ?q)" unfolding arg_cong[OF q, of degree]
            by (subst degree_mult_eq[OF q'], auto)
          hence n: "degree ?q + length ?xs < n" unfolding 0(5) by auto
          from arg_cong[OF q, of poly] 0(2) have rt: "{x. poly ?q x = 0} \<subseteq> set ?xs" by auto
          have p: "p = ?q * prod_list ?fs" unfolding prod_list.Cons 0(1) mult.assoc[symmetric] q[symmetric] ..
          have "root_free ?x" unfolding root_free_def by auto
          with 0(3) have rf: "\<And> f. f \<in> set ?fs \<Longrightarrow> root_free f \<and> monic f \<and> degree f \<noteq> 0" by auto
          from True 0(4) have res: "factorize_root_free_main ?q ?xs ?fs = (c,qs)" by simp
          show ?thesis
            by (rule IH[OF _ p rt rf res refl q'], insert n, auto)
        next
          case False
          with 0(4) have res: "factorize_root_free_main q xs fs = (c,qs)" by simp
          from 0(5) obtain m where m: "m = degree q + length xs" and n: "n = Suc m" by auto
          from False 0(2) have rt: "{x. poly q x = 0} \<subseteq> set xs" by auto
          show ?thesis by (rule IH[OF _ 0(1) rt 0(3) res m 0(6)], unfold n, auto)
        qed
      qed
    qed
  qed
  thus "p = smult c (prod_list qs)"
    "\<And> q. q \<in> set qs \<Longrightarrow> root_free q \<and> monic q \<and> degree q \<noteq> 0" by auto
qed

definition rational_proper_factor :: "rat poly \<Rightarrow> rat poly option" where
  "rational_proper_factor p = (if degree p \<le> 1 then None
    else if degree p = 2 then (case rat_roots2 p of Nil \<Rightarrow> None | Cons x xs \<Rightarrow> Some [:-x,1 :])
    else if degree p = 3 then (case rational_root_test p of None \<Rightarrow> None | Some x \<Rightarrow> Some [:-x,1:])
    else kronecker_factorization_rat p)"

lemma degree_1_dvd_root: assumes q: "degree (q :: 'a :: field poly) = 1"
  and rt: "\<And> x. poly p x \<noteq> 0"
  shows "\<not> q dvd p"
proof -
  from degree1_coeffs[OF q] obtain a b where q: "q = [: b, a :]" and a: "a \<noteq> 0" by auto
  have q: "q = smult a [: - (- b / a), 1 :]" unfolding q
    by (rule poly_eqI, unfold coeff_smult, insert a, auto simp: field_simps coeff_pCons
      split: nat.splits)
  show ?thesis unfolding q smult_dvd_iff poly_eq_0_iff_dvd[symmetric, of _ p] using a rt by auto
qed

lemma rational_proper_factor:
  "degree p > 0 \<Longrightarrow> rational_proper_factor p = None \<Longrightarrow> irreducible\<^sub>d p"
  "rational_proper_factor p = Some q \<Longrightarrow> q dvd p \<and> degree q \<ge> 1 \<and> degree q < degree p"
proof -
  let ?rp = "rational_proper_factor p"
  let ?rr = "rational_root_test"
  note d = rational_proper_factor_def[of p]
  have "(degree p > 0 \<longrightarrow> ?rp = None \<longrightarrow> irreducible\<^sub>d p) \<and>
        (?rp = Some q \<longrightarrow> q dvd p \<and> degree q \<ge> 1 \<and> degree q < degree p)"
  proof (cases "degree p = 0")
    case True
    thus ?thesis unfolding d by auto
  next
    case False note 0 = this
    show ?thesis
    proof (cases "degree p = 1")
      case True
      hence "?rp = None" unfolding d by auto
      with linear_irreducible\<^sub>d[OF True] show ?thesis by auto
    next
      case False note 1 = this
      show ?thesis
      proof (cases "degree p = 2")
        case True
        hence rp: "?rp = (case rat_roots2 p of Nil \<Rightarrow> None | Cons x xs \<Rightarrow> Some [:-x,1 :])" unfolding d by auto
        show ?thesis
        proof (cases "rat_roots2 p")
          case Nil
          with rp have rp: "?rp = None" by auto
          from Nil rat_roots2[OF True] have nex: "\<not> (\<exists> x. poly p x = 0)" by auto
          have "irreducible\<^sub>d p"
          proof (rule irreducible\<^sub>dI)
            fix q r :: "rat poly"
            assume "degree q > 0" "degree q < degree p" and p: "p = q * r"
            with True have dq: "degree q = 1" by auto
            have "\<not> q dvd p" by (rule degree_1_dvd_root[OF dq], insert nex, auto)
            with p show False by auto
          qed (insert True, auto)
          with rp show ?thesis by auto
        next
          case (Cons x xs)
          from Cons rat_roots2[OF True] have "poly p x = 0" by auto
          from this[unfolded poly_eq_0_iff_dvd] have x: "[: -x , 1 :] dvd p" by auto
          from Cons rp have rp: "?rp = Some ([: - x, 1 :])" by auto
          show ?thesis using True x unfolding rp by auto
        qed
      next
        case False note 2 = this
        show ?thesis
        proof (cases "degree p = 3")
          case True
          hence rp: "?rp = (case ?rr p of None \<Rightarrow> None | Some x \<Rightarrow> Some [:- x, 1:])" unfolding d by auto
          show ?thesis
          proof (cases "?rr p")
            case None
            from rational_root_test(2)[OF None] have nex: "\<not> (\<exists> x. poly p x = 0)" by auto
            from rp[unfolded None] have rp: "?rp = None" by auto
            have "irreducible\<^sub>d p"
            proof (rule irreducible\<^sub>dI2)
              fix q :: "rat poly"
              assume "degree q > 0" "degree q \<le> degree p div 2"
              with True have dq: "degree q = 1" by auto
              show "\<not> q dvd p"
                by (rule degree_1_dvd_root[OF dq], insert nex, auto)
            qed (insert True, auto)
            with rp show ?thesis by auto
          next
            case (Some x)
            from rational_root_test(1)[OF Some] have "poly p x = 0" .
            from this[unfolded poly_eq_0_iff_dvd] have x: "[: -x , 1 :] dvd p" by auto
            from Some rp have rp: "?rp = Some ([: - x, 1 :])" by auto
            show ?thesis using True x unfolding rp by auto
          qed
        next
          case False note 3 = this
          let ?kp = "kronecker_factorization_rat p"
          from 0 1 2 3 have d4: "degree p \<ge> 4" and d1: "degree p \<ge> 1" by auto
          hence rp: "?rp = ?kp" using d4 d by auto
          show ?thesis
          proof (cases ?kp)
            case None
            with rp kronecker_factorization_rat(2)[OF None d1] show ?thesis by auto
          next
            case (Some q)
            with rp kronecker_factorization_rat(1)[OF Some] show ?thesis by auto
          qed
        qed
      qed
    qed
  qed
  thus "degree p > 0 \<Longrightarrow> rational_proper_factor p = None \<Longrightarrow> irreducible\<^sub>d p"
    "rational_proper_factor p = Some q \<Longrightarrow> q dvd p \<and> degree q \<ge> 1 \<and> degree q < degree p" by auto
qed

function factorize_rat_poly_main :: "rat \<Rightarrow> rat poly list \<Rightarrow> rat poly list \<Rightarrow> rat \<times> rat poly list" where
  "factorize_rat_poly_main c irr [] = (c,irr)"
| "factorize_rat_poly_main c irr (p # ps) = (if degree p = 0
    then factorize_rat_poly_main (c * coeff p 0) irr ps
    else (case rational_proper_factor p of
      None \<Rightarrow> factorize_rat_poly_main c (p # irr) ps
    | Some q \<Rightarrow> factorize_rat_poly_main c irr (q # p div q # ps)))"
  by pat_completeness auto

definition "factorize_rat_poly_main_wf_rel = inv_image (mult1 {(x, y). x < y}) (\<lambda>(c, irr, ps). mset (map degree ps))"

lemma wf_factorize_rat_poly_main_wf_rel: "wf factorize_rat_poly_main_wf_rel"
  unfolding factorize_rat_poly_main_wf_rel_def using wf_mult1[OF wf_less] by auto

lemma factorize_rat_poly_main_wf_rel_sub:
  "((a, b, ps), (c, d, p # ps)) \<in> factorize_rat_poly_main_wf_rel"
  unfolding factorize_rat_poly_main_wf_rel_def
  by (auto intro: mult1I [of _ _ _ _ "{#}"])

lemma factorize_rat_poly_main_wf_rel_two: assumes "degree q < degree p" "degree r < degree p"
  shows "((a,b,q # r # ps), (c,d,p # ps)) \<in> factorize_rat_poly_main_wf_rel"
  unfolding factorize_rat_poly_main_wf_rel_def mult1_def
  using add_eq_conv_ex assms ab_semigroup_add_class.add_ac
    by fastforce

termination
proof (relation factorize_rat_poly_main_wf_rel,
  rule wf_factorize_rat_poly_main_wf_rel, rule factorize_rat_poly_main_wf_rel_sub,
  rule factorize_rat_poly_main_wf_rel_sub, rule factorize_rat_poly_main_wf_rel_two)
  fix p q
  assume rf: "rational_proper_factor p = Some q" and dp: "degree p \<noteq> 0"
  from rational_proper_factor(2)[OF rf]
  have dvd: "q dvd p" and deg: "1 \<le> degree q" "degree q < degree p" by auto
  show "degree q < degree p" by fact
  from dvd have "p = q * (p div q)" by auto
  from arg_cong[OF this, of degree]
  have "degree p = degree q + degree (p div q)"
    by (subst degree_mult_eq[symmetric], insert dp, auto)
  with deg
  show "degree (p div q) < degree p" by simp
qed

declare factorize_rat_poly_main.simps[simp del]

lemma factorize_rat_poly_main:
  assumes "factorize_rat_poly_main c irr ps = (d,qs)"
    and "Ball (set irr) irreducible\<^sub>d"
  shows "Ball (set qs) irreducible\<^sub>d" (is ?g1)
    and "smult c (prod_list (irr @ ps)) = smult d (prod_list qs)" (is ?g2)
proof (atomize(full), insert assms, induct c irr ps rule: factorize_rat_poly_main.induct)
  case (1 c irr)
  thus ?case by (auto simp: factorize_rat_poly_main.simps)
next
  case (2 c irr p ps)
  note IH = 2(1-3)
  note res = 2(4)[unfolded factorize_rat_poly_main.simps(2)[of c irr p ps]]
  note irr = 2(5)
  let ?f = factorize_rat_poly_main
  show ?case
  proof (cases "degree p = 0")
    case True
    with res have res: "?f (c * coeff p 0) irr ps = (d,qs)" by simp
    from degree0_coeffs[OF True] obtain a where p: "p = [: a :]" by auto
    from IH(1)[OF True res irr]
    show ?thesis using p by simp
  next
    case False
    note IH = IH(2-)[OF False]
    from False have "(degree p = 0) = False" by auto
    note res = res[unfolded this if_False]
    let ?rf = "rational_proper_factor p"
    show ?thesis
    proof (cases ?rf)
      case None
      with res have res: "?f c (p # irr) ps = (d,qs)" by auto
      from rational_proper_factor(1)[OF _ None] False
      have irp: "irreducible\<^sub>d p" by auto
      note IH(1)[OF None res, unfolded atomize_imp imp_conjR, simplified]
      note 1 = conjunct1[OF this, rule_format] conjunct2[OF this, rule_format]
      from irr irp show ?thesis by (auto intro:1 simp: ac_simps)
    next
      case (Some q)
      define pq where "pq = p div q"
      from Some res have res: "?f c irr (q # pq # ps) = (d,qs)" unfolding pq_def by auto
      from rational_proper_factor(2)[OF Some] have "q dvd p" by auto
      hence p: "p = q * pq" unfolding pq_def by auto
      from IH(2)[OF Some, folded pq_def, OF res irr] show ?thesis unfolding p
        by (auto simp: ac_simps)
    qed
  qed
qed

definition "factorize_rat_poly_basic p = factorize_rat_poly_main 1 [] [p]"

lemma factorize_rat_poly_basic: assumes res: "factorize_rat_poly_basic p = (c,qs)"
  shows "p = smult c (prod_list qs)"
  "\<And> q. q \<in> set qs \<Longrightarrow> irreducible\<^sub>d q"
  using factorize_rat_poly_main[OF res[unfolded factorize_rat_poly_basic_def]] by auto

text \<open>We removed the factorize-rat-poly function from this theory, since the one in
  Berlekamp-Zassenhaus is easier to use and implements a more efficient algorithm.\<close>

end


(*<*)
theory Szpilrajn
  imports Main
begin
  (*>*)

text \<open>
  We formalize a more general version of Szpilrajn's extension theorem~\<^cite>\<open>"Szpilrajn:1930"\<close>,
  employing the terminology of Bossert and Suzumura~\<^cite>\<open>"Bossert:2010"\<close>. We also formalize
  Theorem 2.7 of their book. Our extension theorem states that any preorder can be extended to a
  total preorder while maintaining its structure. The proof of the extension theorem follows the
  proof presented in the Wikipedia article~\<^cite>\<open>Wiki\<close>.
\<close>

section \<open>Definitions\<close>

subsection \<open>Symmetric and asymmetric factor of a relation\<close>

text \<open>
  According to Bossert and Suzumura, every relation can be partitioned into its symmetric
  and asymmetric factor. The symmetric factor of a relation \<^term>\<open>r\<close> contains all pairs
  \<^term>\<open>(x, y) \<in> r\<close> where \<^term>\<open>(y, x) \<in> r\<close>. Conversely, the asymmetric factor contains all pairs
   where this is not the case. In terms of an order \<^term>\<open>(\<le>)\<close>, the asymmetric factor contains all
  \<^term>\<open>(x, y) \<in> {(x, y) |x y. x \<le> y}\<close> where \<^term>\<open>x < y\<close>.
\<close>
definition sym_factor :: "'a rel \<Rightarrow> 'a rel"
  where "sym_factor r \<equiv> {(x, y) \<in> r. (y, x) \<in> r}"

lemma sym_factor_def': "sym_factor r = r \<inter> r\<inverse>"
  unfolding sym_factor_def by fast

definition asym_factor :: "'a rel \<Rightarrow> 'a rel"
  where "asym_factor r = {(x, y) \<in> r. (y, x) \<notin> r}"

subsubsection \<open>Properties of the symmetric factor\<close>

lemma sym_factorI[intro]: "(x, y) \<in> r \<Longrightarrow> (y, x) \<in> r \<Longrightarrow> (x, y) \<in> sym_factor r"
  unfolding sym_factor_def by blast

lemma sym_factorE[elim?]:
  assumes "(x, y) \<in> sym_factor r" obtains "(x, y) \<in> r" "(y, x) \<in> r"
  using assms[unfolded sym_factor_def] by blast

lemma sym_sym_factor[simp]: "sym (sym_factor r)"
  unfolding sym_factor_def
  by (auto intro!: symI)

lemma trans_sym_factor[simp]: "trans r \<Longrightarrow> trans (sym_factor r)"
  unfolding sym_factor_def' using trans_Int by force

lemma refl_on_sym_factor[simp]: "refl_on A r \<Longrightarrow> refl_on A (sym_factor r)"
  unfolding sym_factor_def
  by (auto intro!: refl_onI dest: refl_onD refl_onD1)

lemma sym_factor_absorb_if_sym[simp]: "sym r \<Longrightarrow> sym_factor r = r"
  unfolding sym_factor_def'
  by (simp add: sym_conv_converse_eq)

lemma sym_factor_idem[simp]: "sym_factor (sym_factor r) = sym_factor r"
  using sym_factor_absorb_if_sym[OF sym_sym_factor] .

lemma sym_factor_reflc[simp]: "sym_factor (r\<^sup>=) = (sym_factor r)\<^sup>="
  unfolding sym_factor_def by auto

lemma sym_factor_Restr[simp]: "sym_factor (Restr r A) = Restr (sym_factor r) A"
  unfolding sym_factor_def by blast

text \<open>
  In contrast to \<^term>\<open>asym_factor\<close>, the \<^term>\<open>sym_factor\<close> is monotone.
\<close>
lemma sym_factor_mono: "r \<subseteq> s \<Longrightarrow> sym_factor r \<subseteq> sym_factor s"
  unfolding sym_factor_def by auto

subsubsection \<open>Properties of the asymmetric factor\<close>

lemma asym_factorI[intro]: "(x, y) \<in> r \<Longrightarrow> (y, x) \<notin> r \<Longrightarrow> (x, y) \<in> asym_factor r"
  unfolding asym_factor_def by blast

lemma asym_factorE[elim?]:
  assumes "(x, y) \<in> asym_factor r" obtains "(x, y) \<in> r"
  using assms unfolding asym_factor_def by blast

lemma refl_not_in_asym_factor[simp]: "(x, x) \<notin> asym_factor r"
  unfolding asym_factor_def by blast

lemma irrefl_asym_factor[simp]: "irrefl (asym_factor r)"
  unfolding asym_factor_def irrefl_def by fast

lemma asym_asym_factor[simp]: "asym (asym_factor r)"
  using irrefl_asym_factor
  by (auto intro!: asymI simp: asym_factor_def)

lemma trans_asym_factor[simp]: "trans r \<Longrightarrow> trans (asym_factor r)"
  unfolding asym_factor_def trans_def by fast

lemma asym_if_irrefl_trans: "irrefl r \<Longrightarrow> trans r \<Longrightarrow> asym r"
  by (intro asymI) (auto simp: irrefl_def trans_def)

lemma antisym_if_irrefl_trans: "irrefl r \<Longrightarrow> trans r \<Longrightarrow> antisym r"
  using antisym_def asym_if_irrefl_trans by (auto dest: asymD)

lemma asym_factor_asym_rel[simp]: "asym r \<Longrightarrow> asym_factor r = r"
  unfolding asym_factor_def
  by (auto dest: asymD)

lemma irrefl_trans_asym_factor_id[simp]: "irrefl r \<Longrightarrow> trans r \<Longrightarrow> asym_factor r = r"
  using asym_factor_asym_rel[OF asym_if_irrefl_trans] .

lemma asym_factor_id[simp]: "asym_factor (asym_factor r) = asym_factor r"
  using asym_factor_asym_rel[OF asym_asym_factor] .

lemma asym_factor_rtrancl: "asym_factor (r\<^sup>*) = asym_factor (r\<^sup>+)"
  unfolding asym_factor_def
  by (auto simp add: rtrancl_eq_or_trancl)

lemma asym_factor_Restr[simp]: "asym_factor (Restr r A) = Restr (asym_factor r) A"
  unfolding asym_factor_def by blast

lemma acyclic_asym_factor[simp]: "acyclic r \<Longrightarrow> acyclic (asym_factor r)"
  unfolding asym_factor_def by (auto intro: acyclic_subset)

subsubsection \<open>Relations between symmetric and asymmetric factor\<close>

text \<open>
  We prove that \<^term>\<open>sym_factor\<close> and \<^term>\<open>asym_factor\<close> partition the input relation.
\<close>
lemma sym_asym_factor_Un: "sym_factor r \<union> asym_factor r = r"
  unfolding sym_factor_def asym_factor_def by blast

lemma disjnt_sym_asym_factor[simp]: "disjnt (sym_factor r) (asym_factor r)"
  unfolding disjnt_def
  unfolding sym_factor_def asym_factor_def by blast

lemma Field_sym_asym_factor_Un:
  "Field (sym_factor r) \<union> Field (asym_factor r) = Field r"
  using sym_asym_factor_Un Field_Un by metis

lemma asym_factor_tranclE:
  assumes "(a, b) \<in> (asym_factor r)\<^sup>+" shows "(a, b) \<in> r\<^sup>+"
  using assms sym_asym_factor_Un
  by (metis UnCI subsetI trancl_mono)

subsection \<open>Extension of Orders\<close>

text \<open>
  We use the definition of Bossert and Suzumura for \<open>extends\<close>. The requirement \<^term>\<open>r \<subseteq> R\<close> is
  obvious. The second requirement \<^term>\<open>asym_factor r \<subseteq> asym_factor R\<close> enforces that the
  extension \<^term>\<open>R\<close> maintains all strict preferences of \<^term>\<open>r\<close> (viewing \<^term>\<open>r\<close> as a
  preference relation).
\<close>

definition extends :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> bool"
  where "extends R r \<equiv> r \<subseteq> R \<and> asym_factor r \<subseteq> asym_factor R"

text \<open>
  We define a stronger notion of \<^term>\<open>extends\<close> where we also demand that
  \<^term>\<open>sym_factor R \<subseteq> (sym_factor r)\<^sup>=\<close>. This enforces that the extension does not introduce
  preference cycles between previously unrelated pairs \<^term>\<open>(x, y) \<in> R - r\<close>.
\<close>

definition strict_extends :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> bool"
  where "strict_extends R r \<equiv> extends R r \<and> sym_factor R \<subseteq> (sym_factor r)\<^sup>="

lemma extendsI[intro]: "r \<subseteq> R \<Longrightarrow> asym_factor r \<subseteq> asym_factor R \<Longrightarrow> extends R r"
  unfolding extends_def by (intro conjI)

lemma extendsE:
  assumes "extends R r"
  obtains "r \<subseteq> R" "asym_factor r \<subseteq> asym_factor R"
  using assms unfolding extends_def by blast

lemma trancl_subs_extends_if_trans: "extends r_ext r \<Longrightarrow> trans r_ext \<Longrightarrow> r\<^sup>+ \<subseteq> r_ext"
  unfolding extends_def asym_factor_def
  by (metis subrelI trancl_id trancl_mono)

lemma extends_if_strict_extends: "strict_extends r_ext ext \<Longrightarrow> extends r_ext ext"
  unfolding strict_extends_def by blast

lemma strict_extendsI[intro]:
  assumes "r \<subseteq> R" "asym_factor r \<subseteq> asym_factor R" "sym_factor R \<subseteq> (sym_factor r)\<^sup>="
  shows "strict_extends R r"
  unfolding strict_extends_def using assms by (intro conjI extendsI)

lemma strict_extendsE:
  assumes "strict_extends R r"
  obtains "r \<subseteq> R" "asym_factor r \<subseteq> asym_factor R" "sym_factor R \<subseteq> (sym_factor r)\<^sup>="
  using assms extendsE unfolding strict_extends_def by blast

lemma strict_extends_antisym_Restr:
  assumes "strict_extends R r"
  assumes "antisym (Restr r A)"
  shows "antisym ((R - r) \<union> Restr r A)"
proof(rule antisymI, rule ccontr)
  fix x y assume "(x, y) \<in> (R - r) \<union> Restr r A" "(y, x) \<in> (R - r) \<union> Restr r A" "x \<noteq> y"
  with \<open>strict_extends R r\<close> have "(x, y) \<in> sym_factor R"
    unfolding sym_factor_def by (auto elim!: strict_extendsE)
  with assms \<open>x \<noteq> y\<close> have "(x, y) \<in> sym_factor r"
    by (auto elim!: strict_extendsE)
  then have "(x, y) \<in> r" "(y, x) \<in> r"
    unfolding sym_factor_def by simp_all
  with \<open>antisym (Restr r A)\<close> \<open>x \<noteq> y\<close> \<open>(y, x) \<in> R - r \<union> Restr r A\<close> show False
    using antisymD by fastforce
qed

text \<open>Here we prove that we have no preference cycles between previously unrelated pairs.\<close>
lemma antisym_Diff_if_strict_extends:
  assumes "strict_extends R r"
  shows "antisym (R - r)"
  using strict_extends_antisym_Restr[OF assms, where ?A="{}"] by simp

lemma strict_extends_antisym:
  assumes "strict_extends R r"
  assumes "antisym r"
  shows "antisym R"
  using assms strict_extends_antisym_Restr[OF assms(1), where ?A=UNIV]
  by (auto elim!: strict_extendsE simp: antisym_def)

lemma strict_extends_if_strict_extends_reflc:
  assumes "strict_extends r_ext (r\<^sup>=)"
  shows "strict_extends r_ext r"
proof(intro strict_extendsI)
  from assms show "r \<subseteq> r_ext"
    by (auto elim: strict_extendsE)

  from assms \<open>r \<subseteq> r_ext\<close> show "asym_factor r \<subseteq> asym_factor r_ext"
    unfolding strict_extends_def
    by (auto simp: asym_factor_def sym_factor_def)

  from assms show "sym_factor r_ext \<subseteq> (sym_factor r)\<^sup>="
    by (auto simp: sym_factor_def strict_extends_def)
qed

lemma strict_extends_diff_Id:
  assumes "irrefl r" "trans r"
  assumes "strict_extends r_ext (r\<^sup>=)"
  shows "strict_extends (r_ext - Id) r"
proof(intro strict_extendsI)
  from assms show "r \<subseteq> r_ext - Id"
    by (auto elim: strict_extendsE simp: irrefl_def)

  note antisym_r = antisym_if_irrefl_trans[OF assms(1,2)]
  with assms strict_extends_if_strict_extends_reflc show "asym_factor r \<subseteq> asym_factor (r_ext - Id)"
    unfolding asym_factor_def
    by (auto intro: strict_extends_antisym[THEN antisymD] elim: strict_extendsE transE)

  from assms antisym_r show "sym_factor (r_ext - Id) \<subseteq> (sym_factor r)\<^sup>="
    unfolding sym_factor_def
    by (auto intro: strict_extends_antisym[THEN antisymD])
qed

text \<open>
  Both \<^term>\<open>extends\<close> and \<^term>\<open>strict_extends\<close> form a partial order since they
  are reflexive, transitive, and antisymmetric.
\<close>
lemma shows
    reflp_extends: "reflp extends" and
    transp_extends: "transp extends" and
    antisymp_extends: "antisymp extends"
  unfolding extends_def reflp_def transp_def antisymp_def
  by auto

lemma shows
    reflp_strict_extends: "reflp strict_extends" and
    transp_strict_extends: "transp strict_extends" and
    antisymp_strict_extends: "antisymp strict_extends"
  using reflp_extends transp_extends antisymp_extends
  unfolding strict_extends_def reflp_def transp_def antisymp_def
  by auto

subsection \<open>Missing order definitions\<close>

lemma preorder_onD[dest?]:
  assumes "preorder_on A r"
  shows "refl_on A r" "trans r"
  using assms unfolding preorder_on_def by blast+

lemma preorder_onI[intro]: "refl_on A r \<Longrightarrow> trans r \<Longrightarrow> preorder_on A r"
  unfolding preorder_on_def by (intro conjI)

abbreviation "preorder \<equiv> preorder_on UNIV"

lemma preorder_rtrancl: "preorder (r\<^sup>*)"
  by (intro preorder_onI refl_rtrancl trans_rtrancl)

definition "total_preorder_on A r \<equiv> preorder_on A r \<and> total_on A r"

abbreviation "total_preorder r \<equiv> total_preorder_on UNIV r"

lemma total_preorder_onI[intro]:
  "refl_on A r \<Longrightarrow> trans r \<Longrightarrow> total_on A r \<Longrightarrow> total_preorder_on A r"
  unfolding total_preorder_on_def by (intro conjI preorder_onI)

lemma total_preorder_onD[dest?]:
  assumes "total_preorder_on A r"
  shows "refl_on A r" "trans r" "total_on A r"
  using assms unfolding total_preorder_on_def preorder_on_def by blast+

definition "strict_partial_order r \<equiv> trans r \<and> irrefl r"

lemma strict_partial_orderI[intro]:
  "trans r \<Longrightarrow> irrefl r \<Longrightarrow> strict_partial_order r"
  unfolding strict_partial_order_def by blast

lemma strict_partial_orderD[dest?]:
  assumes "strict_partial_order r"
  shows "trans r" "irrefl r"
  using assms unfolding strict_partial_order_def by blast+

lemma strict_partial_order_acyclic:
  assumes "strict_partial_order r"
  shows "acyclic r"
  by (metis acyclic_irrefl assms strict_partial_order_def trancl_id)

abbreviation "partial_order \<equiv> partial_order_on UNIV"

lemma partial_order_onI[intro]:
  "refl_on A r \<Longrightarrow> trans r \<Longrightarrow> antisym r \<Longrightarrow> partial_order_on A r"
  using partial_order_on_def by blast

lemma linear_order_onI[intro]:
  "refl_on A r \<Longrightarrow> trans r \<Longrightarrow> antisym r \<Longrightarrow> total_on A r \<Longrightarrow> linear_order_on A r"
  using linear_order_on_def by blast

lemma linear_order_onD[dest?]:
  assumes "linear_order_on A r"
  shows "refl_on A r" "trans r" "antisym r" "total_on A r"
  using assms[unfolded linear_order_on_def] partial_order_onD by blast+

text \<open>A typical example is \<^term>\<open>(\<subset>)\<close> on sets:\<close>

lemma strict_partial_order_subset:
  "strict_partial_order {(x,y). x \<subset> y}"
proof
  show "trans {(x,y). x \<subset> y}"
    by (auto simp add: trans_def)
  show "irrefl {(x, y). x \<subset> y}"
    by (simp add: irrefl_def)
qed

text \<open>We already have a definition of a strict linear order in \<^term>\<open>strict_linear_order\<close>.\<close>

section \<open>Extending preorders to total preorders\<close>

text \<open>
  We start by proving that a preorder with two incomparable elements \<^term>\<open>x\<close> and \<^term>\<open>y\<close> can be
  strictly extended to a preorder where \<^term>\<open>x < y\<close>.
\<close>

lemma can_extend_preorder:
  assumes "preorder_on A r"
    and "y \<in> A" "x \<in> A" "(y, x) \<notin> r"
  shows
    "preorder_on A ((insert (x, y) r)\<^sup>+)" "strict_extends ((insert (x, y) r)\<^sup>+) r"
proof -
  note preorder_onD[OF \<open>preorder_on A r\<close>]
  then have "insert (x, y) r \<subseteq> A \<times> A"
    using \<open>y \<in> A\<close> \<open>x \<in> A\<close> refl_on_domain by fast
  with \<open>refl_on A r\<close> show "preorder_on A ((insert (x, y) r)\<^sup>+)"
    by (intro preorder_onI refl_onI trans_trancl)
       (auto simp: trancl_subset_Sigma intro!: r_into_trancl' dest: refl_onD)

  show "strict_extends ((insert (x, y) r)\<^sup>+) r"
  proof(intro strict_extendsI)
    from preorder_onD(2)[OF \<open>preorder_on A r\<close>] \<open>(y, x) \<notin> r\<close>
    show "asym_factor r \<subseteq> asym_factor ((insert (x, y) r)\<^sup>+)"
       unfolding asym_factor_def trancl_insert
       using rtranclD rtrancl_into_trancl1 r_r_into_trancl
       by fastforce

     from assms have "(y, x) \<notin> (insert (x, y) r)\<^sup>+"
       unfolding preorder_on_def trancl_insert
       using refl_onD rtranclD by fastforce
     with \<open>trans r\<close> show "sym_factor ((insert (x, y) r)\<^sup>+) \<subseteq> (sym_factor r)\<^sup>="
       unfolding trancl_insert sym_factor_def by (fastforce intro: rtrancl_trans)
  qed auto
qed

text \<open>
  With this, we can start the proof of our main extension theorem.
  For this we will use a variant of Zorns Lemma, which only considers nonempty chains:
\<close>
lemma Zorns_po_lemma_nonempty:
  assumes po: "Partial_order r"
    and u: "\<And>C. \<lbrakk>C \<in> Chains r; C\<noteq>{}\<rbrakk> \<Longrightarrow> \<exists>u\<in>Field r. \<forall>a\<in>C. (a, u) \<in> r"
    and "r \<noteq> {}"
  shows "\<exists>m\<in>Field r. \<forall>a\<in>Field r. (m, a) \<in> r \<longrightarrow> a = m"
proof -
  from \<open>r \<noteq> {}\<close> obtain x where "x \<in> Field r"
    using FieldI2 by fastforce
  with assms show ?thesis
    using Zorns_po_lemma by (metis empty_iff)
qed

theorem strict_extends_preorder_on:
  assumes "preorder_on A base_r"
  shows "\<exists>r. total_preorder_on A r \<and> strict_extends r base_r"
proof -

  text \<open>
    We define an order on the set of strict extensions of the base relation \<^term>\<open>base_r\<close>,
    where \<^term>\<open>r \<le> s\<close> iff \<^term>\<open>strict_extends r base_r\<close> and \<^term>\<open>strict_extends s r\<close>:
  \<close>

  define order_of_orders :: "('a rel) rel" where "order_of_orders =
    Restr {(r, s). strict_extends r base_r \<and> strict_extends s r} {r. preorder_on A r}"

  text \<open>
    We show that this order consists of those relations that are preorders and that strictly extend
    the base relation \<^term>\<open>base_r\<close>
  \<close>

  have Field_order_of_orders: "Field order_of_orders =
    {r. preorder_on A r \<and> strict_extends r base_r}"
    using transp_strict_extends
  proof(safe)
    fix r assume "preorder_on A r" "strict_extends r base_r"
    with reflp_strict_extends have
      "(r, r) \<in> {(r, s). strict_extends r base_r \<and> strict_extends s r}"
      by (auto elim!: reflpE)
    with \<open>preorder_on A r\<close> show "r \<in> Field order_of_orders"
      unfolding order_of_orders_def by (auto simp: Field_def)
  qed (auto simp: order_of_orders_def Field_def elim: transpE)

  text \<open>
    We now show that this set has a maximum and that any maximum of this set is a total preorder
    and as thus is one of the extensions we are looking for.
    We begin by showing the existence of a maximal element using Zorn's lemma.
  \<close>

  have "\<exists>m \<in> Field order_of_orders.
      \<forall>a \<in> Field order_of_orders. (m, a) \<in> order_of_orders \<longrightarrow> a = m"
  proof (rule Zorns_po_lemma_nonempty)

    text \<open>
      Zorn's Lemma requires us to prove that our \<^term>\<open>order_of_orders\<close> is a nonempty partial order
      and that every nonempty chain has an upper bound.
      The partial order property is trivial, since we used \<^term>\<open>strict_extends\<close> for the relation,
      which is a partial order as shown above.
    \<close>

    from reflp_strict_extends transp_strict_extends
    have "Refl {(r, s). strict_extends r base_r \<and> strict_extends s r}"
      unfolding refl_on_def Field_def by (auto elim: transpE reflpE)
    moreover have "trans {(r, s). strict_extends r base_r \<and> strict_extends s r}"
      using transp_strict_extends  by (auto elim: transpE intro: transI)
    moreover have "antisym {(r, s). strict_extends r base_r \<and> strict_extends s r}"
      using antisymp_strict_extends by (fastforce dest: antisympD intro: antisymI)

    ultimately show "Partial_order order_of_orders"
      unfolding order_of_orders_def order_on_defs
      using Field_order_of_orders Refl_Restr trans_Restr antisym_Restr
      by blast

    text \<open>Also, our order is obviously not empty since it contains \<^term>\<open>(base_r, base_r)\<close>:\<close>

    have "(base_r, base_r) \<in> order_of_orders"
      unfolding order_of_orders_def
      using assms reflp_strict_extends by (auto dest: reflpD)
    thus "order_of_orders \<noteq> {}" by force

    text \<open>
      Next we show that each chain has an upper bound.
      For the upper bound we take the union of all relations in the chain.
    \<close>

    show "\<exists>u \<in> Field order_of_orders. \<forall>a \<in> C. (a, u) \<in> order_of_orders"
      if C_def: "C \<in> Chains order_of_orders" and C_nonempty: "C \<noteq> {}"
      for C
    proof (rule bexI[where x="\<Union>C"])

      text \<open>
        Obviously each element in the chain is a strict extension of \<^term>\<open>base_r\<close> by definition
        and as such it is also a preorder.
      \<close>

      have preorder_r: "preorder_on A r" and extends_r: "strict_extends r base_r" if "r \<in> C" for r
        using that C_def[unfolded order_of_orders_def Chains_def] by blast+

      text \<open>
        Because a chain is partially ordered, the union of the chain is reflexive and transitive.
      \<close>

      have total_subs_C: "r \<subseteq> s \<or> s \<subseteq> r" if "r \<in> C" and "s \<in> C" for r s
        using C_def that
        unfolding Chains_def order_of_orders_def strict_extends_def extends_def
        by blast

      have preorder_UnC: "preorder_on A (\<Union>C)"
      proof(intro preorder_onI)
        show "refl_on A (\<Union>C)"
          using preorder_onD(1)[OF preorder_r] C_nonempty
          unfolding refl_on_def by auto

        from total_subs_C show "trans (\<Union>C)"
          using chain_subset_trans_Union[unfolded chain_subset_def]
          by (metis preorder_onD(2)[OF preorder_r])
      qed

      text \<open>We show that \<^term>\<open>\<Union>C\<close> strictly extends the base relation.\<close>

      have strict_extends_UnC: "strict_extends (\<Union>C) base_r"
      proof(intro strict_extendsI)
        note extends_r_unfolded = extends_r[unfolded extends_def strict_extends_def]

        show "base_r \<subseteq> (\<Union>C)"
          using C_nonempty extends_r_unfolded
          by blast

        then show "asym_factor base_r \<subseteq> asym_factor (\<Union>C)"
          using extends_r_unfolded
          unfolding asym_factor_def by auto

        show "sym_factor (\<Union>C) \<subseteq> (sym_factor base_r)\<^sup>="
        proof(safe)
          fix x y assume "(x, y) \<in> sym_factor (\<Union>C)" "(x, y) \<notin> sym_factor base_r"
          then have "(x, y) \<in> \<Union>C" "(y, x) \<in> \<Union>C"
            unfolding sym_factor_def by blast+

          with extends_r obtain c where "c \<in> C" "(x, y) \<in> c" "(y, x) \<in> c"
            "strict_extends c base_r"
            using total_subs_C by blast
          then have "(x, y) \<in> sym_factor c"
            unfolding sym_factor_def by blast
          with \<open>strict_extends c base_r\<close> \<open>(x, y) \<notin> sym_factor base_r\<close>
          show "x = y"
            unfolding strict_extends_def by blast
        qed
      qed

      from preorder_UnC strict_extends_UnC show "(\<Union>C) \<in> Field order_of_orders"
        unfolding Field_order_of_orders by simp

      text \<open>
        Lastly, we prove by contradiction that \<^term>\<open>\<Union>C\<close> is an upper bound for the chain.
      \<close>

      show "\<forall>a \<in> C. (a, \<Union>C) \<in> order_of_orders"
      proof(rule ccontr)
        presume "\<exists>a \<in> C. (a, \<Union>C) \<notin> order_of_orders"
        then obtain m where m: "m \<in> C" "(m, \<Union>C) \<notin> order_of_orders"
          by blast

        hence strict_extends_m: "strict_extends m base_r" "preorder_on A m"
          using extends_r preorder_r by blast+
        with m have "\<not> strict_extends (\<Union>C) m"
          using preorder_UnC unfolding order_of_orders_def by blast

        from m have "m \<subseteq> \<Union>C"
          by blast
        moreover
        have "sym_factor (\<Union>C) \<subseteq> (sym_factor m)\<^sup>="
        proof(safe)
          fix a b
          assume "(a, b) \<in> sym_factor (\<Union> C)" "(a, b) \<notin> sym_factor m"
          then have "(a, b) \<in> sym_factor base_r \<or> (a, b) \<in> Id"
            using strict_extends_UnC[unfolded strict_extends_def] by blast
          with \<open>(a, b) \<notin> sym_factor m\<close> strict_extends_m(1) show "a = b"
            by (auto elim: strict_extendsE simp: sym_factor_mono[THEN in_mono])
        qed
        ultimately
        have "\<not> asym_factor m \<subseteq> asym_factor (\<Union>C)"
          using \<open>\<not> strict_extends (\<Union>C) m\<close> unfolding strict_extends_def extends_def by blast

        then obtain x y where
          "(x, y) \<in> m" "(y, x) \<notin> m" "(x, y) \<in> asym_factor m" "(x, y) \<notin> asym_factor (\<Union>C)"
          unfolding asym_factor_def by blast

        then obtain w where "w \<in> C" "(y, x) \<in> w"
          unfolding asym_factor_def using \<open>m \<in> C\<close> by auto

        with \<open>(y, x) \<notin> m\<close> have "\<not> extends m w"
          unfolding extends_def by auto
        moreover
        from \<open>(x, y) \<in> m\<close> have "\<not> extends w m"
        proof(cases "(x, y) \<in> w")
          case True
          with \<open>(y, x) \<in> w\<close> have "(x, y) \<notin> asym_factor w"
            unfolding asym_factor_def by simp
          with \<open>(x, y) \<in> asym_factor m\<close> show "\<not> extends w m"
            unfolding extends_def by auto
        qed (auto simp: extends_def)

        ultimately show False
          using \<open>m \<in> C\<close> \<open>w \<in> C\<close>
          using C_def[unfolded Chains_def order_of_orders_def strict_extends_def]
          by auto
      qed blast
    qed
  qed

  text \<open>Let our maximal element be named \<^term>\<open>max\<close>:\<close>

  from this obtain max
    where max_field: "max \<in> Field order_of_orders"
      and is_max:
        "\<forall>a\<in>Field order_of_orders. (max, a) \<in> order_of_orders \<longrightarrow> a = max"
    by auto

  from max_field have max_extends_base: "preorder_on A max" "strict_extends max base_r"
    using Field_order_of_orders by blast+

  text \<open>
    We still have to show, that \<^term>\<open>max\<close> is a strict linear order,
    meaning that it is also a total order:
  \<close>

  have "total_on A max"
  proof
    fix x y :: 'a
    assume "x \<noteq> y" "x \<in> A" "y \<in> A"

    show "(x, y) \<in> max \<or> (y, x) \<in> max"
    proof (rule ccontr)

      text \<open>
        Assume that \<^term>\<open>max\<close> is not total, and \<^term>\<open>x\<close> and \<^term>\<open>y\<close> are incomparable.
        Then we can extend \<^term>\<open>max\<close> by setting $x < y$:
      \<close>

      presume "(x, y) \<notin> max" and "(y, x) \<notin> max"
      let ?max' = "(insert (x, y) max)\<^sup>+"

      note max'_extends_max = can_extend_preorder[OF
          \<open>preorder_on A max\<close> \<open>y \<in> A\<close> \<open>x \<in> A\<close> \<open>(y, x) \<notin> max\<close>]

      hence max'_extends_base: "strict_extends ?max' base_r"
        using \<open>strict_extends max base_r\<close> transp_strict_extends by (auto elim: transpE)

      text \<open>The extended relation is greater than \<^term>\<open>max\<close>, which is a contradiction.\<close>

      have "(max, ?max') \<in> order_of_orders"
        using max'_extends_base max'_extends_max max_extends_base
        unfolding order_of_orders_def by simp
      thus False
        using FieldI2 \<open>(x, y) \<notin> max\<close> is_max by fastforce
    qed simp_all
  qed

  with \<open>preorder_on A max\<close> have "total_preorder_on A max"
    unfolding total_preorder_on_def by simp

  with \<open>strict_extends max base_r\<close> show "?thesis" by blast
qed

text \<open>
  With this extension theorem, we can easily prove Szpilrajn's theorem and its equivalent for
  partial orders.
\<close>

corollary partial_order_extension:
  assumes "partial_order_on A r"
  shows "\<exists>r_ext. linear_order_on A r_ext \<and> r \<subseteq> r_ext"
proof -
  from assms strict_extends_preorder_on obtain r_ext where r_ext:
    "total_preorder_on A r_ext" "strict_extends r_ext r"
    unfolding partial_order_on_def by blast

  with assms have "antisym r_ext"
    unfolding partial_order_on_def using strict_extends_antisym by blast

  with assms r_ext have "linear_order_on A r_ext \<and> r \<subseteq> r_ext"
    unfolding total_preorder_on_def order_on_defs strict_extends_def extends_def
    by blast
  then show ?thesis ..
qed

corollary Szpilrajn:
  assumes "strict_partial_order r"
  shows "\<exists>r_ext. strict_linear_order r_ext \<and> r \<subseteq> r_ext"
proof -
  from assms have "partial_order (r\<^sup>=)"
    by (auto simp: antisym_if_irrefl_trans strict_partial_order_def)
  from partial_order_extension[OF this] obtain r_ext where "linear_order r_ext" "(r\<^sup>=) \<subseteq> r_ext"
    by blast
  with assms have "r \<subseteq> r_ext - Id" "strict_linear_order (r_ext - Id)"
    by (auto simp: irrefl_def strict_linear_order_on_diff_Id dest: strict_partial_orderD(2))
  then show ?thesis by blast
qed

corollary acyclic_order_extension:
  assumes "acyclic r"
  shows "\<exists>r_ext. strict_linear_order r_ext \<and> r \<subseteq> r_ext"
proof -
  from assms have "strict_partial_order (r\<^sup>+)"
    unfolding strict_partial_order_def using acyclic_irrefl trans_trancl by blast
  thus ?thesis
    by (meson Szpilrajn r_into_trancl' subset_iff)
qed

section \<open>Consistency\<close>

text \<open>
  As a weakening of transitivity, Suzumura introduces the notion of consistency which rules out
  all preference cycles that contain at least one strict preference.
  Consistency characterises those order relations which can be extended (in terms of \<^term>\<open>extends\<close>)
  to a total order relation.
\<close>

definition consistent :: "'a rel \<Rightarrow> bool"
  where "consistent r = (\<forall>(x, y) \<in> r\<^sup>+. (y, x) \<notin> asym_factor r)"

lemma consistentI: "(\<And>x y. (x, y) \<in> r\<^sup>+ \<Longrightarrow> (y, x) \<notin> asym_factor r) \<Longrightarrow> consistent r"
  unfolding consistent_def by blast

lemma consistent_if_preorder_on[simp]:
  "preorder_on A r \<Longrightarrow> consistent r"
  unfolding preorder_on_def consistent_def asym_factor_def by auto

lemma consistent_asym_factor[simp]: "consistent r \<Longrightarrow> consistent (asym_factor r)"
  unfolding consistent_def
  using asym_factor_tranclE by fastforce

lemma acyclic_asym_factor_if_consistent[simp]: "consistent r \<Longrightarrow> acyclic (asym_factor r)"
  unfolding consistent_def acyclic_def
  using asym_factor_tranclE by (metis case_prodD trancl.simps)

lemma consistent_Restr[simp]: "consistent r \<Longrightarrow> consistent (Restr r A)"
  unfolding consistent_def asym_factor_def
  using trancl_mono by fastforce

text \<open>
  This corresponds to Theorem 2.2~\<^cite>\<open>"Bossert:2010"\<close>.
\<close>
theorem trans_if_refl_total_consistent:
  assumes "refl r" "total r" and "consistent r"
  shows "trans r"
proof
  fix x y z assume "(x, y) \<in> r" "(y, z) \<in> r"

  from \<open>(x, y) \<in> r\<close> \<open>(y, z) \<in> r\<close> have "(x, z) \<in> r\<^sup>+"
    by simp
  hence "(z, x) \<notin> asym_factor r"
    using \<open>consistent r\<close> unfolding consistent_def by blast
  hence "x \<noteq> z \<Longrightarrow> (x, z) \<in> r"
    unfolding asym_factor_def using \<open>total r\<close>
    by (auto simp: total_on_def)
  then show "(x, z) \<in> r"
    apply(cases "x = z")
    using refl_onD[OF \<open>refl r\<close>] by blast+
qed

lemma order_extension_if_consistent:
  assumes "consistent r"
  obtains r_ext where "extends r_ext r" "total_preorder r_ext"
proof -
  from assms have extends: "extends (r\<^sup>*) r"
    unfolding extends_def consistent_def asym_factor_def
    using rtranclD by (fastforce simp: Field_def)
  have preorder: "preorder (r\<^sup>*)"
    unfolding preorder_on_def using refl_on_def trans_def by fastforce

  from strict_extends_preorder_on[OF preorder] extends obtain r_ext where
    "total_preorder r_ext" "extends r_ext r"
    using transpE[OF transp_extends] unfolding strict_extends_def by blast
  then show thesis using that by blast
qed

lemma consistent_if_extends_trans:
  assumes "extends r_ext r" "trans r_ext"
  shows "consistent r"
proof(rule consistentI, standard)
  fix x y assume *: "(x, y) \<in> r\<^sup>+" "(y, x) \<in> asym_factor r"
  with assms have "(x, y) \<in> r_ext"
    using trancl_subs_extends_if_trans[OF assms] by blast
  moreover from * assms have "(x, y) \<notin> r_ext"
    unfolding extends_def asym_factor_def by auto
  ultimately show False by blast
qed

text \<open>
  With Theorem 2.6~\<^cite>\<open>"Bossert:2010"\<close>, we show that \<^term>\<open>consistent\<close> characterises the existence
  of order extensions.
\<close>
corollary order_extension_iff_consistent:
  "(\<exists>r_ext. extends r_ext r \<and> total_preorder r_ext) \<longleftrightarrow> consistent r"
  using order_extension_if_consistent consistent_if_extends_trans
  by (metis total_preorder_onD(2))

text \<open>
  The following theorem corresponds to Theorem 2.7~\<^cite>\<open>"Bossert:2010"\<close>.
  Bossert and Suzumura claim that this theorem generalises Szpilrajn's theorem; however, we cannot
  use the theorem to strictly extend a given order \<^term>\<open>Q\<close>. Therefore, it is not strong enough to
  extend a strict partial order to a strict linear order. It works for total preorders (called
  orderings by Bossert and Suzumura). Unfortunately, we were not able to generalise the theorem
  to allow for strict extensions.
\<close>

theorem general_order_extension_iff_consistent:
  assumes "\<And>x y. \<lbrakk> x \<in> S; y \<in> S; x \<noteq> y \<rbrakk> \<Longrightarrow> (x, y) \<notin> Q\<^sup>+"
  assumes "total_preorder_on S Ord"
  shows "(\<exists>Ext. extends Ext Q \<and> total_preorder Ext \<and> Restr Ext S = Ord)
     \<longleftrightarrow> consistent Q" (is "?ExExt \<longleftrightarrow> _")
proof
  assume "?ExExt"
  then obtain Ext where
    "extends Ext Q"
    "refl Ext" "trans Ext" "total Ext"
    "Restr Ext S = Restr Ord S"
    using total_preorder_onD by fast
  show "consistent Q"
  proof(rule consistentI)
    fix x y assume "(x, y) \<in> Q\<^sup>+"
    with \<open>extends Ext Q\<close> \<open>trans Ext\<close> have "(x, y) \<in> Ext"
      unfolding extends_def by (metis trancl_id trancl_mono)
    then have "(y, x) \<notin> asym_factor Ext"
      unfolding asym_factor_def by blast
    with \<open>extends Ext Q\<close> show "(y, x) \<notin> asym_factor Q"
      unfolding extends_def asym_factor_def by blast
  qed
next
  assume "consistent Q"

  define Q' where "Q' \<equiv> Q\<^sup>* \<union> Ord \<union> Ord O Q\<^sup>* \<union> Q\<^sup>* O Ord \<union> (Q\<^sup>* O Ord) O Q\<^sup>*"

  have "refl (Q\<^sup>*)" "trans (Q\<^sup>*)" "refl_on S Ord" "trans Ord" "total_on S Ord"
    using refl_rtrancl trans_rtrancl total_preorder_onD[OF \<open>total_preorder_on S Ord\<close>]
    by - assumption

  have preorder_Q': "preorder Q'"
  proof
    show "refl Q'"
      unfolding Q'_def refl_on_def by auto

    from \<open>trans (Q\<^sup>*)\<close> \<open>refl_on S Ord\<close> \<open>trans Ord\<close> show "trans Q'"
      unfolding Q'_def[simplified]
      apply(safe intro!: transI)
      unfolding relcomp.simps
      by (metis assms(1) refl_on_domain rtranclD transD)+
  qed

  have "consistent Q'"
    using consistent_if_preorder_on preorder_Q' by blast

  have "extends Q' Q"
  proof(rule extendsI)
    have "Q \<subseteq> Restr (Q\<^sup>*) (Field Q)"
      by (auto intro: FieldI1 FieldI2)
    then show "Q \<subseteq> Q'"
      unfolding Q'_def by blast

    from \<open>consistent Q\<close> have consistentD: "(x, y) \<in> Q\<^sup>+ \<Longrightarrow> (y, x) \<in> Q \<Longrightarrow> (x, y) \<in> Q" for x y
      unfolding consistent_def asym_factor_def using rtranclD by fastforce
    have refl_on_domainE: "\<lbrakk> (x, y) \<in> Ord; x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P" for x y P
      using refl_on_domain[OF \<open>refl_on S Ord\<close>] by blast

    show "asym_factor Q \<subseteq> asym_factor Q'"
      unfolding Q'_def asym_factor_def Field_def
      apply(safe)
      using assms(1) consistentD refl_on_domainE
      by (metis r_into_rtrancl rtranclD rtrancl_trancl_trancl)+
  qed

  with strict_extends_preorder_on[OF \<open>preorder Q'\<close>]
  obtain Ext where Ext: "extends Ext Q'" "extends Ext Q" "total_preorder Ext"
    unfolding strict_extends_def
    by (metis transpE transp_extends)

  have not_in_Q': "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> (x, y) \<notin> Ord \<Longrightarrow> (x, y) \<notin> Q'" for x y
    using assms(1) unfolding Q'_def
    apply(safe)
    by (metis \<open>refl_on S Ord\<close> refl_on_def refl_on_domain rtranclD)+

  have "Restr Ext S = Ord"
  proof
    from \<open>extends Ext Q'\<close> have "Ord \<subseteq> Ext"
      unfolding Q'_def extends_def by auto
    with \<open>refl_on S Ord\<close> show "Ord \<subseteq> Restr Ext S"
      using refl_on_domain by fast
  next
    have "(x, y) \<in> Ord" if "x \<in> S" and "y \<in> S" and "(x, y) \<in> Ext" for x y
    proof(rule ccontr)
      assume "(x, y) \<notin> Ord"
      with that not_in_Q' have "(x, y) \<notin> Q'"
        by blast
      with \<open>refl_on S Ord\<close> \<open>total_on S Ord\<close> \<open>x \<in> S\<close> \<open>y \<in> S\<close> \<open>(x, y) \<notin> Ord\<close>
      have "(y, x) \<in> Ord"
        unfolding refl_on_def total_on_def by fast
      hence "(y, x) \<in> Q'"
        unfolding Q'_def by blast
      with \<open>(x, y) \<notin> Q'\<close> \<open>(y, x) \<in> Q'\<close> \<open>extends Ext Q'\<close>
      have "(x, y) \<notin> Ext"
        unfolding extends_def asym_factor_def by auto
      with \<open>(x, y) \<in> Ext\<close> show False by blast
    qed
    then show "Restr Ext S \<subseteq> Ord"
      by blast
  qed

  with Ext show "?ExExt" by blast
qed

section \<open>Strong consistency\<close>

text \<open>
  We define a stronger version of \<^term>\<open>consistent\<close> which requires that the relation does not
  contain hidden preference cycles, i.e. if there is a preference cycle then all the elements
  in the cycle should already be related (in both directions).
  In contrast to consistency which characterises relations that can be extended, strong consistency
  characterises relations that can be extended strictly (cf. \<^term>\<open>strict_extends\<close>).
\<close>

definition "strongly_consistent r \<equiv> sym_factor (r\<^sup>+) \<subseteq> sym_factor (r\<^sup>=)"

lemma consistent_if_strongly_consistent: "strongly_consistent r \<Longrightarrow> consistent r"
  unfolding strongly_consistent_def consistent_def
  by (auto simp: sym_factor_def asym_factor_def)

lemma strongly_consistentI: "sym_factor (r\<^sup>+) \<subseteq> sym_factor (r\<^sup>=) \<Longrightarrow> strongly_consistent r"
  unfolding strongly_consistent_def by blast

lemma strongly_consistent_if_trans_strict_extension:
  assumes "strict_extends r_ext r"
  assumes "trans r_ext"
  shows   "strongly_consistent r"
proof(unfold strongly_consistent_def, standard)
  fix x assume "x \<in> sym_factor (r\<^sup>+)"
  then show "x \<in> sym_factor (r\<^sup>=)"
    using assms trancl_subs_extends_if_trans[OF extends_if_strict_extends]
    by (metis sym_factor_mono strict_extendsE subsetD sym_factor_reflc)
qed

lemma strict_order_extension_if_consistent:
  assumes "strongly_consistent r"
  obtains r_ext where "strict_extends r_ext r" "total_preorder r_ext"
proof -
  from assms have "strict_extends (r\<^sup>+) r"
    unfolding strongly_consistent_def strict_extends_def extends_def asym_factor_def sym_factor_def
    by (auto simp: Field_def dest: tranclD)
  moreover have "strict_extends (r\<^sup>*) (r\<^sup>+)"
    unfolding strict_extends_def extends_def
    by (auto simp: asym_factor_rtrancl sym_factor_def dest: rtranclD)
  ultimately have extends: "strict_extends (r\<^sup>*) r"
    using transpE[OF transp_strict_extends] by blast

  have "preorder (r\<^sup>*)"
    unfolding preorder_on_def using refl_on_def trans_def by fastforce
  from strict_extends_preorder_on[OF this] extends obtain r_ext where
    "total_preorder r_ext" "strict_extends r_ext r"
    using transpE[OF transp_strict_extends] by blast
  then show thesis using that by blast
qed

experiment begin

text \<open>We can instantiate the above theorem to get Szpilrajn's theorem.\<close>
lemma
  assumes "strict_partial_order r"
  shows "\<exists>r_ext. strict_linear_order r_ext \<and> r \<subseteq> r_ext"
proof -
  from assms[unfolded strict_partial_order_def] have "strongly_consistent r" "antisym r"
    unfolding strongly_consistent_def by (simp_all add: antisym_if_irrefl_trans)
  from strict_order_extension_if_consistent[OF this(1)] obtain r_ext
    where "strict_extends r_ext r" "total_preorder r_ext"
    by blast
  with assms[unfolded strict_partial_order_def]
  have "trans (r_ext - Id)" "irrefl (r_ext - Id)" "total (r_ext - Id)" "r \<subseteq> (r_ext - Id)"
    using strict_extends_antisym[OF _ \<open>antisym r\<close>]
    by (auto simp: irrefl_def elim: strict_extendsE intro: trans_diff_Id dest: total_preorder_onD)
  then show ?thesis
    unfolding strict_linear_order_on_def by blast
qed

end

(*<*)
end
(*>*)


header {* Graphs *}
theory Graph
imports Main
begin
text {*
  This theory defines a notion of graphs. A graph is a record that
  contains a set of nodes @{text "V"} and a set of labeled edges
  @{text "E \<subseteq> V\<times>W\<times>V"}, where @{text "W"} are the edge labels.
*}

subsection {* Definitions *}
  text {* A graph is represented by a record. *}
  record ('v,'w) graph =
    nodes :: "'v set"
    edges :: "('v \<times> 'w \<times> 'v) set"

  text {* In a valid graph, edges only go from nodes to nodes. *}
  locale valid_graph =
    fixes G :: "('v,'w) graph"
    assumes E_valid: "fst`edges G \<subseteq> nodes G"
                     "snd`snd`edges G \<subseteq> nodes G"
  begin
    abbreviation "V \<equiv> nodes G"
    abbreviation "E \<equiv> edges G"

    lemma E_validD: assumes "(v,e,v')\<in>E"
      shows "v\<in>V" "v'\<in>V"
      apply -
      apply (rule set_mp[OF E_valid(1)])
      using assms apply force
      apply (rule set_mp[OF E_valid(2)])
      using assms apply force
      done

  end

  subsection {* Basic operations on Graphs *}

  text {* The empty graph. *}
  definition empty where
    "empty \<equiv> \<lparr> nodes = {}, edges = {} \<rparr>"
  text {* Adds a node to a graph. *}
  definition add_node where
    "add_node v g \<equiv> \<lparr> nodes = insert v (nodes g), edges=edges g\<rparr>"
  text {* Deletes a node from a graph. Also deletes all adjacent edges. *}
  definition delete_node where "delete_node v g \<equiv> \<lparr>
    nodes = nodes g - {v},
    edges = edges g \<inter> (-{v})\<times>UNIV\<times>(-{v})
    \<rparr>"
  text {* Adds an edge to a graph. *}
  definition add_edge where "add_edge v e v' g \<equiv> \<lparr>
    nodes = {v,v'} \<union> nodes g,
    edges = insert (v,e,v') (edges g)
    \<rparr>"
  text {* Deletes an edge from a graph. *}
  definition delete_edge where "delete_edge v e v' g \<equiv> \<lparr>
    nodes = nodes g, edges = edges g - {(v,e,v')} \<rparr>"
  text {* Successors of a node. *}
  definition succ :: "('v,'w) graph \<Rightarrow> 'v \<Rightarrow> ('w\<times>'v) set"
    where "succ G v \<equiv> {(w,v'). (v,w,v')\<in>edges G}"

  text {* Now follow some simplification lemmas. *}
  lemma empty_valid[simp]: "valid_graph empty"
    unfolding empty_def by unfold_locales auto
  lemma add_node_valid[simp]: assumes "valid_graph g"
    shows "valid_graph (add_node v g)"
  proof -
    interpret valid_graph g by fact
    show ?thesis
      unfolding add_node_def
      by unfold_locales (auto dest: E_validD)
  qed
  lemma delete_node_valid[simp]: assumes "valid_graph g"
    shows "valid_graph (delete_node v g)"
  proof -
    interpret valid_graph g by fact
    show ?thesis
      unfolding delete_node_def
      by unfold_locales (auto dest: E_validD)
  qed
  lemma add_edge_valid[simp]: assumes "valid_graph g"
    shows "valid_graph (add_edge v e v' g)"
  proof -
    interpret valid_graph g by fact
    show ?thesis
      unfolding add_edge_def
      by unfold_locales (auto dest: E_validD)
  qed
  lemma delete_edge_valid[simp]: assumes "valid_graph g"
    shows "valid_graph (delete_edge v e v' g)"
  proof -
    interpret valid_graph g by fact
    show ?thesis
      unfolding delete_edge_def
      by unfold_locales (auto dest: E_validD)
  qed

  lemma succ_finite[simp, intro]: "finite (edges G) \<Longrightarrow> finite (succ G v)"
    unfolding succ_def
    by (rule finite_subset[where B="snd`edges G"]) force+

  lemma nodes_empty[simp]: "nodes empty = {}" unfolding empty_def by simp
  lemma edges_empty[simp]: "edges empty = {}" unfolding empty_def by simp
  lemma succ_empty[simp]: "succ empty v = {}" unfolding empty_def succ_def by auto

  lemma nodes_add_node[simp]: "nodes (add_node v g) = insert v (nodes g)"
    by (simp add: add_node_def)
  lemma nodes_add_edge[simp]:
    "nodes (add_edge v e v' g) = insert v (insert v' (nodes g))"
    by (simp add: add_edge_def)

  lemma (in valid_graph) succ_subset: "succ G v \<subseteq> UNIV\<times>V"
    unfolding succ_def using E_valid
    by (force)

subsection {* Paths *}
  text {* A path is represented by a list of adjacent edges. *}
  type_synonym ('v,'w) path = "('v\<times>'w\<times>'v) list"

  context valid_graph
  begin
    text {* The following predicate describes a valid path: *}
    fun is_path :: "'v \<Rightarrow> ('v,'w) path \<Rightarrow> 'v \<Rightarrow> bool" where
      "is_path v [] v' \<longleftrightarrow> v=v' \<and> v'\<in>V" |
      "is_path v ((v1,w,v2)#p) v' \<longleftrightarrow> v=v1 \<and> (v1,w,v2)\<in>E \<and> is_path v2 p v'"

    lemma is_path_simps[simp, intro!]:
      "is_path v [] v \<longleftrightarrow> v\<in>V"
      "is_path v [(v,w,v')] v' \<longleftrightarrow> (v,w,v')\<in>E"
      by (auto dest: E_validD)

    lemma is_path_memb[simp]:
      "is_path v p v' \<Longrightarrow> v\<in>V \<and> v'\<in>V"
      apply (induct p arbitrary: v)
      apply (auto dest: E_validD)
      done

    lemma is_path_split:
      "is_path v (p1@p2) v' \<longleftrightarrow> (\<exists>u. is_path v p1 u \<and> is_path u p2 v')"
      by (induct p1 arbitrary: v) auto

    lemma is_path_split'[simp]:
      "is_path v (p1@(u,w,u')#p2) v'
        \<longleftrightarrow> is_path v p1 u \<and> (u,w,u')\<in>E \<and> is_path u' p2 v'"
      by (auto simp add: is_path_split)
  end

  text {* Set of intermediate vertices of a path. These are all vertices but
    the last one. Note that, if the last vertex also occurs earlier on the path,
    it is contained in @{text "int_vertices"}. *}
  definition int_vertices :: "('v,'w) path \<Rightarrow> 'v set" where
    "int_vertices p \<equiv> set (map fst p)"

  lemma int_vertices_simps[simp]:
    "int_vertices [] = {}"
    "int_vertices (vv#p) = insert (fst vv) (int_vertices p)"
    "int_vertices (p1@p2) = int_vertices p1 \<union> int_vertices p2"
    by (auto simp add: int_vertices_def)

  lemma (in valid_graph) int_vertices_subset:
    "is_path v p v' \<Longrightarrow> int_vertices p \<subseteq> V"
    apply (induct p arbitrary: v)
    apply (simp)
    apply (force dest: E_validD)
    done

  lemma int_vertices_empty[simp]: "int_vertices p = {} \<longleftrightarrow> p=[]"
    by (cases p) auto

subsubsection {* Splitting Paths *}
  text {*Split a path at the point where it first leaves the set @{text W}: *}
  lemma (in valid_graph) path_split_set:
    assumes "is_path v p v'" and "v\<in>W" and "v'\<notin>W"
    obtains p1 p2 u w u' where
    "p=p1@(u,w,u')#p2" and
    "int_vertices p1 \<subseteq> W" and "u\<in>W" and "u'\<notin>W"
    using assms
  proof (induct p arbitrary: v thesis)
    case Nil thus ?case by auto
  next
    case (Cons vv p)
    note [simp, intro!] = `v\<in>W` `v'\<notin>W`
    from Cons.prems obtain w u' where
      [simp]: "vv=(v,w,u')" and
        REST: "is_path u' p v'"
      by (cases vv) auto

    txt {* Distinguish wether the second node @{text u'} of the path is
      in @{text W}. If yes, the proposition follows by the
      induction hypothesis, otherwise it is straightforward, as
      the split takes place at the first edge of the path. *}
    {
      assume A [simp, intro!]: "u'\<in>W"
      from Cons.hyps[OF _ REST] obtain p1 uu ww uu' p2 where
        "p=p1@(uu,ww,uu')#p2" "int_vertices p1 \<subseteq> W" "uu \<in> W" "uu' \<notin> W"
        by blast
      with Cons.prems(1)[of "vv#p1" uu ww uu' p2] have thesis by auto
    } moreover {
      assume "u'\<notin>W"
      with Cons.prems(1)[of "[]" v w u' p] have thesis by auto
    } ultimately show thesis by blast
  qed

  text {*Split a path at the point where it first enters the set @{text W}:*}
  lemma (in valid_graph) path_split_set':
    assumes "is_path v p v'" and "v'\<in>W"
    obtains p1 p2 u where
    "p=p1@p2" and
    "is_path v p1 u" and
    "is_path u p2 v'" and
    "int_vertices p1 \<subseteq> -W" and "u\<in>W"
    using assms
  proof (cases "v\<in>W")
    case True with that[of "[]" p] assms show ?thesis
      by auto
  next
    case False with assms that show ?thesis
    proof (induct p arbitrary: v thesis)
      case Nil thus ?case by auto
    next
      case (Cons vv p)
      note [simp, intro!] = `v'\<in>W` `v\<notin>W`
      from Cons.prems obtain w u' where
        [simp]: "vv=(v,w,u')" and [simp]: "(v,w,u')\<in>E" and
          REST: "is_path u' p v'"
        by (cases vv) auto

      txt {* Distinguish wether the second node @{text u'} of the path is
        in @{text W}. If yes, the proposition is straightforward, otherwise,
        it follows by the induction hypothesis.
        *}
      {
        assume A [simp, intro!]: "u'\<in>W"
        from Cons.prems(3)[of "[vv]" p u'] REST have ?case by auto
      } moreover {
        assume [simp, intro!]: "u'\<notin>W"
        from Cons.hyps[OF REST] obtain p1 p2 u'' where
          [simp]: "p=p1@p2" and
            "is_path u' p1 u''" and
            "is_path u'' p2 v'" and
            "int_vertices p1 \<subseteq> -W" and
            "u''\<in>W" by blast
        with Cons.prems(3)[of "vv#p1"] have ?case by auto
      } ultimately show ?case by blast
    qed
  qed

  text {* Split a path at the point where a given vertex is first visited: *}
  lemma (in valid_graph) path_split_vertex:
    assumes "is_path v p v'" and "u\<in>int_vertices p"
    obtains p1 p2 where
    "p=p1@p2" and
    "is_path v p1 u" and
    "u \<notin> int_vertices p1"
    using assms
  proof (induct p arbitrary: v thesis)
    case Nil thus ?case by auto
  next
    case (Cons vv p)
    from Cons.prems obtain w u' where
      [simp]: "vv=(v,w,u')" "v\<in>V" "(v,w,u')\<in>E" and
        REST: "is_path u' p v'"
      by (cases vv) auto

    {
      assume "u=v"
      with Cons.prems(1)[of "[]" "vv#p"] have thesis by auto
    } moreover {
      assume [simp]: "u\<noteq>v"
      with Cons.hyps(1)[OF _ REST] Cons.prems(3) obtain p1 p2 where
        "p=p1@p2" "is_path u' p1 u" "u\<notin>int_vertices p1"
        by auto
      with Cons.prems(1)[of "vv#p1" p2] have thesis
        by auto
    } ultimately show ?case by blast
  qed

subsection {* Weighted Graphs *}
  locale valid_mgraph = valid_graph G for G::"('v,'w::monoid_add) graph"

  definition path_weight :: "('v,'w::monoid_add) path \<Rightarrow> 'w"
    where "path_weight p \<equiv> listsum (map (fst \<circ> snd) p)"

  (*
    lemma path_weight_alt: "path_weight p \<equiv> listsum (map (fst \<circ> snd) p)"
    unfolding path_weight_def foldl_conv_fold
    by (simp add: listsum_foldl)
  *)

  lemma path_weight_split[simp]:
    "(path_weight (p1@p2)::'w::monoid_add) = path_weight p1 + path_weight p2"
    unfolding path_weight_def
    by (auto)

  lemma path_weight_empty[simp]: "path_weight [] = 0"
    unfolding path_weight_def
    by auto

  lemma path_weight_cons[simp]:
    "(path_weight (e#p)::'w::monoid_add) = fst (snd e) + path_weight p"
    unfolding path_weight_def
    by (auto)

end


(*  Title:      HOL/Algebra/Bij.thy
    Author:     Florian Kammueller, with new proofs by L C Paulson
*)

theory Bij
imports Group
begin

section \<open>Bijections of a Set, Permutation and Automorphism Groups\<close>

definition
  Bij :: "'a set \<Rightarrow> ('a \<Rightarrow> 'a) set"
    \<comment> \<open>Only extensional functions, since otherwise we get too many.\<close>
   where "Bij S = extensional S \<inter> {f. bij_betw f S S}"

definition
  BijGroup :: "'a set \<Rightarrow> ('a \<Rightarrow> 'a) monoid"
  where "BijGroup S =
    \<lparr>carrier = Bij S,
     mult = \<lambda>g \<in> Bij S. \<lambda>f \<in> Bij S. compose S g f,
     one = \<lambda>x \<in> S. x\<rparr>"

declare Id_compose [simp] compose_Id [simp]

lemma Bij_imp_extensional: "f \<in> Bij S \<Longrightarrow> f \<in> extensional S"
  by (simp add: Bij_def)

lemma Bij_imp_funcset: "f \<in> Bij S \<Longrightarrow> f \<in> S \<rightarrow> S"
  by (auto simp add: Bij_def bij_betw_imp_funcset)

subsection \<open>Bijections Form a Group\<close>

lemma restrict_inv_into_Bij: "f \<in> Bij S \<Longrightarrow> (\<lambda>x \<in> S. (inv_into S f) x) \<in> Bij S"
  by (simp add: Bij_def bij_betw_inv_into)

lemma id_Bij: "(\<lambda>x\<in>S. x) \<in> Bij S "
  by (auto simp add: Bij_def bij_betw_def inj_on_def)

lemma compose_Bij: "\<lbrakk>x \<in> Bij S; y \<in> Bij S\<rbrakk> \<Longrightarrow> compose S x y \<in> Bij S"
  by (auto simp add: Bij_def bij_betw_compose)

lemma Bij_compose_restrict_eq:
     "f \<in> Bij S \<Longrightarrow> compose S (restrict (inv_into S f) S) f = (\<lambda>x\<in>S. x)"
  by (simp add: Bij_def compose_inv_into_id)

theorem group_BijGroup: "group (BijGroup S)"
  apply (simp add: BijGroup_def)
  apply (rule groupI)
      apply (auto simp: compose_Bij id_Bij Bij_imp_funcset Bij_imp_extensional compose_assoc [symmetric])
  apply (blast intro: Bij_compose_restrict_eq restrict_inv_into_Bij)
  done

subsection\<open>Automorphisms Form a Group\<close>

lemma Bij_inv_into_mem: "\<lbrakk> f \<in> Bij S;  x \<in> S\<rbrakk> \<Longrightarrow> inv_into S f x \<in> S"
by (simp add: Bij_def bij_betw_def inv_into_into)

lemma Bij_inv_into_lemma:
  assumes eq: "\<And>x y. \<lbrakk>x \<in> S; y \<in> S\<rbrakk> \<Longrightarrow> h(g x y) = g (h x) (h y)"
      and hg: "h \<in> Bij S" "g \<in> S \<rightarrow> S \<rightarrow> S" and "x \<in> S" "y \<in> S"
  shows "inv_into S h (g x y) = g (inv_into S h x) (inv_into S h y)"
proof -
  have "h ` S = S"
    by (metis (no_types) Bij_def Int_iff assms(2) bij_betw_def mem_Collect_eq)
  with \<open>x \<in> S\<close> \<open>y \<in> S\<close> have "\<exists>x'\<in>S. \<exists>y'\<in>S. x = h x' \<and> y = h y'"
    by auto
  then show ?thesis
    using assms
    by (auto simp add: Bij_def bij_betw_def eq [symmetric] inv_f_f funcset_mem [THEN funcset_mem])
qed

definition
  auto :: "('a, 'b) monoid_scheme \<Rightarrow> ('a \<Rightarrow> 'a) set"
  where "auto G = hom G G \<inter> Bij (carrier G)"

definition
  AutoGroup :: "('a, 'c) monoid_scheme \<Rightarrow> ('a \<Rightarrow> 'a) monoid"
  where "AutoGroup G = BijGroup (carrier G) \<lparr>carrier := auto G\<rparr>"

lemma (in group) id_in_auto: "(\<lambda>x \<in> carrier G. x) \<in> auto G"
  by (simp add: auto_def hom_def restrictI group.axioms id_Bij)

lemma (in group) mult_funcset: "mult G \<in> carrier G \<rightarrow> carrier G \<rightarrow> carrier G"
  by (simp add:  Pi_I group.axioms)

lemma (in group) restrict_inv_into_hom:
      "\<lbrakk>h \<in> hom G G; h \<in> Bij (carrier G)\<rbrakk>
       \<Longrightarrow> restrict (inv_into (carrier G) h) (carrier G) \<in> hom G G"
  by (simp add: hom_def Bij_inv_into_mem restrictI mult_funcset
                group.axioms Bij_inv_into_lemma)

lemma inv_BijGroup:
     "f \<in> Bij S \<Longrightarrow> m_inv (BijGroup S) f = (\<lambda>x \<in> S. (inv_into S f) x)"
apply (rule group.inv_equality [OF group_BijGroup])
apply (simp_all add:BijGroup_def restrict_inv_into_Bij Bij_compose_restrict_eq)
done

lemma (in group) subgroup_auto:
      "subgroup (auto G) (BijGroup (carrier G))"
proof (rule subgroup.intro)
  show "auto G \<subseteq> carrier (BijGroup (carrier G))"
    by (force simp add: auto_def BijGroup_def)
next
  fix x y
  assume "x \<in> auto G" "y \<in> auto G"
  thus "x \<otimes>\<^bsub>BijGroup (carrier G)\<^esub> y \<in> auto G"
    by (force simp add: BijGroup_def is_group auto_def Bij_imp_funcset
                        group.hom_compose compose_Bij)
next
  show "\<one>\<^bsub>BijGroup (carrier G)\<^esub> \<in> auto G" by (simp add:  BijGroup_def id_in_auto)
next
  fix x
  assume "x \<in> auto G"
  thus "inv\<^bsub>BijGroup (carrier G)\<^esub> x \<in> auto G"
    by (simp del: restrict_apply
        add: inv_BijGroup auto_def restrict_inv_into_Bij restrict_inv_into_hom)
qed

theorem (in group) AutoGroup: "group (AutoGroup G)"
by (simp add: AutoGroup_def subgroup.subgroup_is_group subgroup_auto
              group_BijGroup)

end


section\<open>Sum of divisors function\<close>

theory Sigma
imports PerfectBasics "HOL-Library.Infinite_Set"
begin

definition divisors :: "nat => nat set" where
    "divisors (m::nat) == {n . n dvd m}"

definition sigma :: "nat => nat" where
    "sigma m == \<Sum> n | n dvd m . n"

lemma sigma_divisors: "sigma(n) = \<Sum> (divisors(n))"
by (auto simp: sigma_def divisors_def)

lemma divisors_eq_dvd[iff]: "(a:divisors(n)) = (a dvd n)"
by(simp add: divisors_def)

lemma mult_divisors: "(a::nat)*b=c==>a: divisors c"
by (unfold divisors_def dvd_def,blast)
lemma mult_divisors2: "(a::nat)*b=c==>b: divisors c"
by (unfold divisors_def dvd_def,auto)

lemma divisorsfinite[simp]:
   assumes "n>0"
   shows "finite (divisors n)"
proof -
  from assms have  "divisors n = {m . m dvd n & m <= n}"
    by (auto simp only:divisors_def dvd_imp_le)
  hence "divisors n <= {m . m<=n}" by auto
  thus "finite (divisors n)"
    by (metis finite_Collect_le_nat finite_subset)
qed

lemma divs_of_zero_UNIV[simp]: "divisors(0) = UNIV"
by(auto simp add: divisors_def)

lemma sigma0[simp]: "sigma(0) = 0"
by (simp add: sigma_def)
lemma sigma1[simp]: "sigma(1) = 1"
by (simp add: sigma_def)

lemma prime_divisors: "prime (p::nat) \<longleftrightarrow> divisors p = {1,p} & p>1"
  by (auto simp add: divisors_def prime_nat_iff)

lemma prime_imp_sigma: "prime (p::nat) ==> sigma(p) = p+1"
proof -
  assume "prime (p::nat)"
  hence "p>1 \<and> divisors(p) = {1,p}" by (simp add: prime_divisors)
  hence "p>1 \<and> sigma(p) = \<Sum> {1,p}" by (auto simp only: sigma_divisors divisors_def)
  thus "sigma(p) = p+1" by simp
qed

lemma sigma_third_divisor:
  assumes  "1 < a" "a < n" "a : divisors n"
  shows "1+a+n <= sigma(n)"
proof -
  from assms have "finite {1,a,n} & finite (divisors n) & {1,a,n} <= divisors n" by auto
  hence "\<Sum> {1,a,n} <= \<Sum> (divisors n)" by (simp only: sum_mono2)
  hence "\<Sum> {1,a,n} <= sigma n" by (simp add: sigma_divisors)
  with assms show "?thesis" by auto
qed

lemma sigma_imp_divisors: "sigma(n)=n+1 ==> n>1 & divisors n = {n,1}"
proof
  assume ass:"sigma(n)=n+1"
  hence "n\<noteq>0 & n\<noteq>1"
    by (metis Suc_eq_plus1 n_not_Suc_n sigma0 sigma1)
  thus conc1: "n>1" by simp

  show "divisors n = {n,1}" (*TODO: use sigma_third_divisor *)
  proof (rule ccontr)
    assume "divisors n \<noteq> {n,1}"
    with conc1 have "divisors n \<noteq> {n,1} & 1<n" by auto
    moreover
    from ass conc1 have "1 : divisors(n) & n : divisors n & ~0 : divisors n"
      by (simp add: dvd_def divisors_def)
    ultimately
    have  "(\<exists>a. a\<noteq>n & a\<noteq>1 & 1<n & a : divisors n) & 0 ~: divisors n" by auto
    hence "(\<exists>a. a\<noteq>n & a\<noteq>1 & 1<n & a\<noteq>0 & a : divisors n)" by metis
    hence "\<exists>a . a\<noteq>n & a\<noteq>1 & 1\<noteq>n & a\<noteq>0 & finite {1,a,n} & finite (divisors n) & {1,a,n} <= divisors n" by auto
    hence "\<exists>a. a\<noteq>n & a\<noteq>1 & 1\<noteq>n & a\<noteq>0 & \<Sum> {1,a,n} <= sigma n"
      by (metis sum_mono2_nat sigma_divisors)
    hence "\<exists>a. a\<noteq>0 & (1+a+n) <= sigma n" by auto
    hence "1+n<sigma n" by auto (*TODO: this step can be deleted, should i?*)
    with ass show "False" by auto
  qed
qed

lemma sigma_imp_prime: "sigma(n)=n+1 ==> prime n"
proof -
  assume ass: "sigma(n)=n+1"
  hence "n>1 & divisors(n)={1,n}" by (metis insert_commute sigma_imp_divisors)
  thus "prime n" by (simp add: prime_divisors)
qed

lemma pr_pow_div_eq_sm_pr_pow:
  fixes p::nat
  assumes prime: "prime p"
  shows "{d . d dvd p^n} = {p^f| f . f<=n}"
proof
  show "{p^f | f . f<=n} <= { d .  d dvd p^n}"
  proof
    fix x
    assume "x: {p ^ f | f . f <= n}"
    hence "\<exists>i . x = p^i & i<= n"   by auto
    with prime have  "x dvd p^n"
      by (metis le_imp_power_dvd)
    thus "x : { d . d dvd p^n}" by auto
  qed
  next
  show "{d. d dvd p ^ n} <= {p ^ f | f . f <= n}"
  proof
    fix x
    assume "x : {d . d dvd p^n}"
    hence "x dvd p^n" by auto
    with prime obtain "i" where  "i <= n & x = p^i" using prime_dvd_power_nat_iff prime_dvd_power_nat
      by (auto simp only: divides_primepow_nat)
    hence "x = p^i & i <=n" by auto
    thus "x : { p^f | f . f<=n }" by auto
  qed
qed

lemma rewrite_sum_of_powers:
assumes p: "(p::nat)>1"
shows "(\<Sum> {p^m | m . m<=(n::nat)}) = (\<Sum> i = 0 .. n . p^i)" (is "?l = ?r")
proof -
  have "?l = sum (%x. x) {((^) p) m |m . m<= n}" by auto
  also have "... = sum (%x. x) (((^) p)`{m . m<= n})"
    by (simp add: setcompr_eq_image)
  moreover with p have "inj_on ((^) p) {m . m<=n}"
    by (simp add: inj_on_def)
  ultimately have "?l = sum ((^) p) {m . m<=n}"
    by (simp add: sum.reindex)
  moreover have "{m::nat . m<=n} = {0..n}" by auto
  ultimately show "?l = (\<Sum> i = 0 .. n . p^i)" by auto
qed

theorem sigma_primepower:
  "prime p ==> (p - 1)*sigma(p^(e::nat)) = (p^(e+1) - 1)"
proof -
  assume "prime p"
  hence "sigma(p^(e::nat)) = (\<Sum>i=0 .. e . p^i)"
    by (simp add: pr_pow_div_eq_sm_pr_pow sigma_def rewrite_sum_of_powers prime_nat_iff)
  thus "(p - 1)*sigma(p^e)=p^(e+1) - 1" by (simp only: simplify_sum_of_powers)
qed

lemma sigma_prime_power_two: "sigma(2^(n::nat)) = 2^(n+1) - 1"
proof -
  have "(2 - 1)*sigma(2^(n::nat))=2^(n+1) - 1"
    by (auto simp only: sigma_primepower two_is_prime_nat)
  thus ?thesis by simp
qed

declare [[simproc add: finite_Collect]]

lemma rewrite_for_sigma_semimultiplicative:
fixes p::nat
assumes "prime p"
shows "{p^f*b |f b. f<=n & b dvd m} = {a*b |a b. a dvd (p^n) & b dvd m}"
proof
  show "{p^f * b |f b. f <= n & b dvd m} <= {a*b |a b. a dvd p ^ n & b dvd m}"
  proof
    fix x
    assume "x : {p ^ f * b | f b. f <= n & b dvd m}"
    then obtain b f where "x = p^f*b & f <= n & b dvd m" by auto
    with \<open>prime p\<close> show "x : {a * b |a b. a dvd p ^ n & b dvd m}"
      by (auto simp add: divides_primepow_nat)
  qed
next
  show "{a*b |a b. a dvd p ^ n & b dvd m} <= {p^f * b |f b. f <= n & b dvd m}"
    using \<open>prime p\<close> by auto (metis assms divides_primepow_nat)
qed

lemma div_decomp_comp:
  fixes a::nat
  shows "coprime m n \<Longrightarrow> a dvd m*n \<longleftrightarrow> (\<exists>b c. a = b * c & b dvd m & c dvd n)"
by (auto simp only: division_decomp mult_dvd_mono)

theorem sigma_semimultiplicative:
  assumes p: "prime p" and cop: "coprime p m"
  shows "sigma (p^n) * sigma m = sigma (p^n * m)" (is "?l = ?r")
proof -
  from cop have cop2: "coprime (p^n) m"
    by simp
  have "?l = (\<Sum> {a . a dvd p^n})*(\<Sum> {b . b dvd m})" by (simp add: sigma_def)
  also from p have "... = (\<Sum> {p^f| f . f<=n})*(\<Sum> {b . b dvd m})"
    by (simp add: pr_pow_div_eq_sm_pr_pow)
  also from cop  have "... = (\<Sum> {p^f*b| f b . f<=n & b dvd m})"
    by (auto simp add: prodsums_eq_sumprods prime_nat_iff)
  also have "... = (\<Sum> {a*b| a b . a dvd (p^n) & b dvd m})"
    by (simp add: p rewrite_for_sigma_semimultiplicative)
  finally have "?l = \<Sum>{c. c dvd (p^n*m)}" by (subst div_decomp_comp[OF cop2])
  thus "?l = sigma (p^n*m)" by (auto simp add: sigma_def)
qed

end


header {* \isaheader{Operations on sorted Lists} *}
theory Sorted_List_Operations
imports Main "../../Automatic_Refinement/Lib/Misc"
begin

fun inter_sorted :: "'a::{linorder} list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   "inter_sorted [] l2 = []"
 | "inter_sorted l1 [] = []"
 | "inter_sorted (x1 # l1) (x2 # l2) =
    (if (x1 < x2) then (inter_sorted l1 (x2 # l2)) else
     (if (x1 = x2) then x1 # (inter_sorted l1 l2) else inter_sorted (x1 # l1) l2))"

lemma inter_sorted_correct :
assumes l1_OK: "distinct l1 \<and> sorted l1"
assumes l2_OK: "distinct l2 \<and> sorted l2"
shows "distinct (inter_sorted l1 l2) \<and> sorted (inter_sorted l1 l2) \<and>
       set (inter_sorted l1 l2) = set l1 \<inter> set l2"
using assms
proof (induct l1 arbitrary: l2)
  case Nil thus ?case by simp
next
  case (Cons x1 l1 l2)
  note x1_l1_props = Cons(2)
  note l2_props = Cons(3)

  from x1_l1_props have l1_props: "distinct l1 \<and> sorted l1"
                    and x1_nin_l1: "x1 \<notin> set l1"
                    and x1_le: "\<And>x. x \<in> set l1 \<Longrightarrow> x1 \<le> x"
    by (simp_all add: sorted_Cons Ball_def)

  note ind_hyp_l1 = Cons(1)[OF l1_props]

  show ?case
  using l2_props
  proof (induct l2)
    case Nil with x1_l1_props show ?case by simp
  next
    case (Cons x2 l2)
    note x2_l2_props = Cons(2)
    from x2_l2_props have l2_props: "distinct l2 \<and> sorted l2"
                    and x2_nin_l2: "x2 \<notin> set l2"
                    and x2_le: "\<And>x. x \<in> set l2 \<Longrightarrow> x2 \<le> x"
    by (simp_all add: sorted_Cons Ball_def)

    note ind_hyp_l2 = Cons(1)[OF l2_props]
    show ?case
    proof (cases "x1 < x2")
      case True note x1_less_x2 = this

      from ind_hyp_l1[OF x2_l2_props] x1_less_x2 x1_nin_l1 x1_le x2_le
      show ?thesis
        apply (auto simp add: sorted_Cons Ball_def)
        apply (metis linorder_not_le)
      done
    next
      case False note x2_le_x1 = this

      show ?thesis
      proof (cases "x1 = x2")
        case True note x1_eq_x2 = this

        from ind_hyp_l1[OF l2_props] x1_le x2_le x2_nin_l2 x1_eq_x2 x1_nin_l1
        show ?thesis by (simp add: x1_eq_x2 sorted_Cons Ball_def)
      next
        case False note x1_neq_x2 = this
        with x2_le_x1 have x2_less_x1 : "x2 < x1" by auto

        from ind_hyp_l2 x2_le_x1 x1_neq_x2 x2_le x2_nin_l2 x1_le
        show ?thesis
          apply (auto simp add: x2_less_x1 sorted_Cons Ball_def)
          apply (metis linorder_not_le x2_less_x1)
        done
      qed
    qed
  qed
qed

fun diff_sorted :: "'a::{linorder} list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   "diff_sorted [] l2 = []"
 | "diff_sorted l1 [] = l1"
 | "diff_sorted (x1 # l1) (x2 # l2) =
    (if (x1 < x2) then x1 # (diff_sorted l1 (x2 # l2)) else
     (if (x1 = x2) then (diff_sorted l1 l2) else diff_sorted (x1 # l1) l2))"

lemma diff_sorted_correct :
assumes l1_OK: "distinct l1 \<and> sorted l1"
assumes l2_OK: "distinct l2 \<and> sorted l2"
shows "distinct (diff_sorted l1 l2) \<and> sorted (diff_sorted l1 l2) \<and>
       set (diff_sorted l1 l2) = set l1 - set l2"
using assms
proof (induct l1 arbitrary: l2)
  case Nil thus ?case by simp
next
  case (Cons x1 l1 l2)
  note x1_l1_props = Cons(2)
  note l2_props = Cons(3)

  from x1_l1_props have l1_props: "distinct l1 \<and> sorted l1"
                    and x1_nin_l1: "x1 \<notin> set l1"
                    and x1_le: "\<And>x. x \<in> set l1 \<Longrightarrow> x1 \<le> x"
    by (simp_all add: sorted_Cons Ball_def)

  note ind_hyp_l1 = Cons(1)[OF l1_props]

  show ?case
  using l2_props
  proof (induct l2)
    case Nil with x1_l1_props show ?case by simp
  next
    case (Cons x2 l2)
    note x2_l2_props = Cons(2)
    from x2_l2_props have l2_props: "distinct l2 \<and> sorted l2"
                    and x2_nin_l2: "x2 \<notin> set l2"
                    and x2_le: "\<And>x. x \<in> set l2 \<Longrightarrow> x2 \<le> x"
    by (simp_all add: sorted_Cons Ball_def)

    note ind_hyp_l2 = Cons(1)[OF l2_props]
    show ?case
    proof (cases "x1 < x2")
      case True note x1_less_x2 = this

      from ind_hyp_l1[OF x2_l2_props] x1_less_x2 x1_nin_l1 x1_le x2_le
      show ?thesis
        apply simp
        apply (simp add: sorted_Cons Ball_def set_eq_iff)
        apply (metis linorder_not_le order_less_imp_not_eq2)
      done
    next
      case False note x2_le_x1 = this

      show ?thesis
      proof (cases "x1 = x2")
        case True note x1_eq_x2 = this

        from ind_hyp_l1[OF l2_props] x1_le x2_le x2_nin_l2 x1_eq_x2 x1_nin_l1
        show ?thesis by (simp add: x1_eq_x2 sorted_Cons Ball_def)
      next
        case False note x1_neq_x2 = this
        with x2_le_x1 have x2_less_x1 : "x2 < x1" by auto

        from x2_less_x1 x1_le have x2_nin_l1: "x2 \<notin> set l1"
           by (metis linorder_not_less)

        from ind_hyp_l2 x1_le x2_nin_l1
        show ?thesis
          apply (simp add: x2_less_x1 x1_neq_x2 x2_le_x1 x1_nin_l1 sorted_Cons Ball_def set_eq_iff)
          apply (metis x1_neq_x2)
        done
      qed
    qed
  qed
qed

fun subset_sorted :: "'a::{linorder} list \<Rightarrow> 'a list \<Rightarrow> bool" where
   "subset_sorted [] l2 = True"
 | "subset_sorted (x1 # l1) [] = False"
 | "subset_sorted (x1 # l1) (x2 # l2) =
    (if (x1 < x2) then False else
     (if (x1 = x2) then (subset_sorted l1 l2) else subset_sorted (x1 # l1) l2))"

lemma subset_sorted_correct :
assumes l1_OK: "distinct l1 \<and> sorted l1"
assumes l2_OK: "distinct l2 \<and> sorted l2"
shows "subset_sorted l1 l2 \<longleftrightarrow> set l1 \<subseteq> set l2"
using assms
proof (induct l1 arbitrary: l2)
  case Nil thus ?case by simp
next
  case (Cons x1 l1 l2)
  note x1_l1_props = Cons(2)
  note l2_props = Cons(3)

  from x1_l1_props have l1_props: "distinct l1 \<and> sorted l1"
                    and x1_nin_l1: "x1 \<notin> set l1"
                    and x1_le: "\<And>x. x \<in> set l1 \<Longrightarrow> x1 \<le> x"
    by (simp_all add: sorted_Cons Ball_def)

  note ind_hyp_l1 = Cons(1)[OF l1_props]

  show ?case
  using l2_props
  proof (induct l2)
    case Nil with x1_l1_props show ?case by simp
  next
    case (Cons x2 l2)
    note x2_l2_props = Cons(2)
    from x2_l2_props have l2_props: "distinct l2 \<and> sorted l2"
                    and x2_nin_l2: "x2 \<notin> set l2"
                    and x2_le: "\<And>x. x \<in> set l2 \<Longrightarrow> x2 \<le> x"
    by (simp_all add: sorted_Cons Ball_def)

    note ind_hyp_l2 = Cons(1)[OF l2_props]
    show ?case
    proof (cases "x1 < x2")
      case True note x1_less_x2 = this

      from ind_hyp_l1[OF x2_l2_props] x1_less_x2 x1_nin_l1 x1_le x2_le
      show ?thesis
        apply (auto simp add: sorted_Cons Ball_def)
        apply (metis linorder_not_le)
      done
    next
      case False note x2_le_x1 = this

      show ?thesis
      proof (cases "x1 = x2")
        case True note x1_eq_x2 = this

        from ind_hyp_l1[OF l2_props] x1_le x2_le x2_nin_l2 x1_eq_x2 x1_nin_l1
        show ?thesis
          apply (simp add: subset_iff x1_eq_x2 sorted_Cons Ball_def)
          apply metis
        done
      next
        case False note x1_neq_x2 = this
        with x2_le_x1 have x2_less_x1 : "x2 < x1" by auto

        from ind_hyp_l2 x2_le_x1 x1_neq_x2 x2_le x2_nin_l2 x1_le
        show ?thesis
          apply (simp add: subset_iff x2_less_x1 sorted_Cons Ball_def)
          apply (metis linorder_not_le x2_less_x1)
        done
      qed
    qed
  qed
qed

lemma set_eq_sorted_correct :
  assumes l1_OK: "distinct l1 \<and> sorted l1"
  assumes l2_OK: "distinct l2 \<and> sorted l2"
  shows "l1 = l2 \<longleftrightarrow> set l1 = set l2"
  using assms
proof -
  have l12_eq: "l1 = l2 \<longleftrightarrow> subset_sorted l1 l2 \<and> subset_sorted l2 l1"
  proof (induct l1 arbitrary: l2)
    case Nil thus ?case by (cases l2) auto
  next
    case (Cons x1 l1')
    note ind_hyp = Cons(1)

    show ?case
    proof (cases l2)
      case Nil thus ?thesis by simp
    next
      case (Cons x2 l2')
      thus ?thesis by (simp add: ind_hyp)
    qed
  qed
  also have "\<dots> \<longleftrightarrow> ((set l1 \<subseteq> set l2) \<and> (set l2 \<subseteq> set l1))"
    using subset_sorted_correct[OF l1_OK l2_OK] subset_sorted_correct[OF l2_OK l1_OK]
    by simp
  also have "\<dots> \<longleftrightarrow> set l1 = set l2" by auto
  finally show ?thesis .
qed

fun memb_sorted where
   "memb_sorted [] x = False"
 | "memb_sorted (y # xs) x =
    (if (y < x) then memb_sorted xs x else (x = y))"

lemma memb_sorted_correct :
  "sorted xs \<Longrightarrow> memb_sorted xs x \<longleftrightarrow> x \<in> set xs"
by (induct xs) (auto simp add: sorted_Cons Ball_def)

fun insertion_sort where
   "insertion_sort x [] = [x]"
 | "insertion_sort x (y # xs) =
    (if (y < x) then y # insertion_sort x xs else
     (if (x = y) then y # xs else x # y # xs))"

lemma insertion_sort_correct :
  "sorted xs \<Longrightarrow> distinct xs \<Longrightarrow>
   distinct (insertion_sort x xs) \<and>
   sorted (insertion_sort x xs) \<and>
   set (insertion_sort x xs) = set (x # xs)"
by (induct xs) (auto simp add: sorted_Cons Ball_def)

fun delete_sorted where
   "delete_sorted x [] = []"
 | "delete_sorted x (y # xs) =
    (if (y < x) then y # delete_sorted x xs else
     (if (x = y) then xs else y # xs))"

lemma delete_sorted_correct :
  "sorted xs \<Longrightarrow> distinct xs \<Longrightarrow>
   distinct (delete_sorted x xs) \<and>
   sorted (delete_sorted x xs) \<and>
   set (delete_sorted x xs) = set xs - {x}"
apply (induct xs)
apply simp
apply (simp add: sorted_Cons Ball_def set_eq_iff)
apply (metis order_less_le)
done

end