(*  Title:      HOL/ex/Unification.thy
    Author:     Martin Coen, Cambridge University Computer Laboratory
    Author:     Konrad Slind, TUM & Cambridge University Computer Laboratory
    Author:     Alexander Krauss, TUM
*)

section \<open>Substitution and Unification\<close>

theory Unification
imports MainRLT
begin

text \<open>
  Implements Manna \& Waldinger's formalization, with Paulson's
  simplifications, and some new simplifications by Slind and Krauss.

  Z Manna \& R Waldinger, Deductive Synthesis of the Unification
  Algorithm.  SCP 1 (1981), 5-48

  L C Paulson, Verifying the Unification Algorithm in LCF. SCP 5
  (1985), 143-170

  K Slind, Reasoning about Terminating Functional Programs,
  Ph.D. thesis, TUM, 1999, Sect. 5.8

  A Krauss, Partial and Nested Recursive Function Definitions in
  Higher-Order Logic, JAR 44(4):303-336, 2010. Sect. 6.3
\<close>

subsection \<open>Terms\<close>

text \<open>Binary trees with leaves that are constants or variables.\<close>

datatype 'a trm =
  Var 'a
  | Const 'a
  | Comb "'a trm" "'a trm" (infix "\<cdot>" 60)

primrec vars_of :: "'a trm \<Rightarrow> 'a set"
where
  "vars_of (Var v) = {v}"
| "vars_of (Const c) = {}"
| "vars_of (M \<cdot> N) = vars_of M \<union> vars_of N"

fun occs :: "'a trm \<Rightarrow> 'a trm \<Rightarrow> bool" (infixl "\<prec>" 54)
where
  "u \<prec> Var v \<longleftrightarrow> False"
| "u \<prec> Const c \<longleftrightarrow> False"
| "u \<prec> M \<cdot> N \<longleftrightarrow> u = M \<or> u = N \<or> u \<prec> M \<or> u \<prec> N"

lemma finite_vars_of[intro]: "finite (vars_of t)"
  by (induct t) simp_all

lemma vars_iff_occseq: "x \<in> vars_of t \<longleftrightarrow> Var x \<prec> t \<or> Var x = t"
  by (induct t) auto

lemma occs_vars_subset: "M \<prec> N \<Longrightarrow> vars_of M \<subseteq> vars_of N"
  by (induct N) auto

subsection \<open>Substitutions\<close>

type_synonym 'a subst = "('a \<times> 'a trm) list"

fun assoc :: "'a \<Rightarrow> 'b \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> 'b"
where
  "assoc x d [] = d"
| "assoc x d ((p,q)#t) = (if x = p then q else assoc x d t)"

primrec subst :: "'a trm \<Rightarrow> 'a subst \<Rightarrow> 'a trm" (infixl "\<lhd>" 55)
where
  "(Var v) \<lhd> s = assoc v (Var v) s"
| "(Const c) \<lhd> s = (Const c)"
| "(M \<cdot> N) \<lhd> s = (M \<lhd> s) \<cdot> (N \<lhd> s)"

definition subst_eq (infixr "\<doteq>" 52)
where
  "s1 \<doteq> s2 \<longleftrightarrow> (\<forall>t. t \<lhd> s1 = t \<lhd> s2)"

fun comp :: "'a subst \<Rightarrow> 'a subst \<Rightarrow> 'a subst" (infixl "\<lozenge>" 56)
where
  "[] \<lozenge> bl = bl"
| "((a,b) # al) \<lozenge> bl = (a, b \<lhd> bl) # (al \<lozenge> bl)"

lemma subst_Nil[simp]: "t \<lhd> [] = t"
by (induct t) auto

lemma subst_mono: "t \<prec> u \<Longrightarrow> t \<lhd> s \<prec> u \<lhd> s"
by (induct u) auto

lemma agreement: "(t \<lhd> r = t \<lhd> s) \<longleftrightarrow> (\<forall>v \<in> vars_of t. Var v \<lhd> r = Var v \<lhd> s)"
by (induct t) auto

lemma repl_invariance: "v \<notin> vars_of t \<Longrightarrow> t \<lhd> (v,u) # s = t \<lhd> s"
by (simp add: agreement)

lemma remove_var: "v \<notin> vars_of s \<Longrightarrow> v \<notin> vars_of (t \<lhd> [(v, s)])"
by (induct t) simp_all

lemma subst_refl[iff]: "s \<doteq> s"
  by (auto simp:subst_eq_def)

lemma subst_sym[sym]: "\<lbrakk>s1 \<doteq> s2\<rbrakk> \<Longrightarrow> s2 \<doteq> s1"
  by (auto simp:subst_eq_def)

lemma subst_trans[trans]: "\<lbrakk>s1 \<doteq> s2; s2 \<doteq> s3\<rbrakk> \<Longrightarrow> s1 \<doteq> s3"
  by (auto simp:subst_eq_def)

lemma subst_no_occs: "\<not> Var v \<prec> t \<Longrightarrow> Var v \<noteq> t
  \<Longrightarrow> t \<lhd> [(v,s)] = t"
by (induct t) auto

lemma comp_Nil[simp]: "\<sigma> \<lozenge> [] = \<sigma>"
by (induct \<sigma>) auto

lemma subst_comp[simp]: "t \<lhd> (r \<lozenge> s) = t \<lhd> r \<lhd> s"
proof (induct t)
  case (Var v) thus ?case
    by (induct r) auto
qed auto

lemma subst_eq_intro[intro]: "(\<And>t. t \<lhd> \<sigma> = t \<lhd> \<theta>) \<Longrightarrow> \<sigma> \<doteq> \<theta>"
  by (auto simp:subst_eq_def)

lemma subst_eq_dest[dest]: "s1 \<doteq> s2 \<Longrightarrow> t \<lhd> s1 = t \<lhd> s2"
  by (auto simp:subst_eq_def)

lemma comp_assoc: "(a \<lozenge> b) \<lozenge> c \<doteq> a \<lozenge> (b \<lozenge> c)"
  by auto

lemma subst_cong: "\<lbrakk>\<sigma> \<doteq> \<sigma>'; \<theta> \<doteq> \<theta>'\<rbrakk> \<Longrightarrow> (\<sigma> \<lozenge> \<theta>) \<doteq> (\<sigma>' \<lozenge> \<theta>')"
  by (auto simp: subst_eq_def)

lemma var_self: "[(v, Var v)] \<doteq> []"
proof
  fix t show "t \<lhd> [(v, Var v)] = t \<lhd> []"
    by (induct t) simp_all
qed

lemma var_same[simp]: "[(v, t)] \<doteq> [] \<longleftrightarrow> t = Var v"
by (metis assoc.simps(2) subst.simps(1) subst_eq_def var_self)

subsection \<open>Unifiers and Most General Unifiers\<close>

definition Unifier :: "'a subst \<Rightarrow> 'a trm \<Rightarrow> 'a trm \<Rightarrow> bool"
where "Unifier \<sigma> t u \<longleftrightarrow> (t \<lhd> \<sigma> = u \<lhd> \<sigma>)"

definition MGU :: "'a subst \<Rightarrow> 'a trm \<Rightarrow> 'a trm \<Rightarrow> bool" where
  "MGU \<sigma> t u \<longleftrightarrow>
   Unifier \<sigma> t u \<and> (\<forall>\<theta>. Unifier \<theta> t u \<longrightarrow> (\<exists>\<gamma>. \<theta> \<doteq> \<sigma> \<lozenge> \<gamma>))"

lemma MGUI[intro]:
  "\<lbrakk>t \<lhd> \<sigma> = u \<lhd> \<sigma>; \<And>\<theta>. t \<lhd> \<theta> = u \<lhd> \<theta> \<Longrightarrow> \<exists>\<gamma>. \<theta> \<doteq> \<sigma> \<lozenge> \<gamma>\<rbrakk>
  \<Longrightarrow> MGU \<sigma> t u"
  by (simp only:Unifier_def MGU_def, auto)

lemma MGU_sym[sym]:
  "MGU \<sigma> s t \<Longrightarrow> MGU \<sigma> t s"
  by (auto simp:MGU_def Unifier_def)

lemma MGU_is_Unifier: "MGU \<sigma> t u \<Longrightarrow> Unifier \<sigma> t u"
unfolding MGU_def by (rule conjunct1)

lemma MGU_Var:
  assumes "\<not> Var v \<prec> t"
  shows "MGU [(v,t)] (Var v) t"
proof (intro MGUI exI)
  show "Var v \<lhd> [(v,t)] = t \<lhd> [(v,t)]" using assms
    by (metis assoc.simps(2) repl_invariance subst.simps(1) subst_Nil vars_iff_occseq)
next
  fix \<theta> assume th: "Var v \<lhd> \<theta> = t \<lhd> \<theta>"
  show "\<theta> \<doteq> [(v,t)] \<lozenge> \<theta>"
  proof
    fix s show "s \<lhd> \<theta> = s \<lhd> [(v,t)] \<lozenge> \<theta>" using th
      by (induct s) auto
  qed
qed

lemma MGU_Const: "MGU [] (Const c) (Const d) \<longleftrightarrow> c = d"
  by (auto simp: MGU_def Unifier_def)

subsection \<open>The unification algorithm\<close>

function unify :: "'a trm \<Rightarrow> 'a trm \<Rightarrow> 'a subst option"
where
  "unify (Const c) (M \<cdot> N)   = None"
| "unify (M \<cdot> N)   (Const c) = None"
| "unify (Const c) (Var v)   = Some [(v, Const c)]"
| "unify (M \<cdot> N)   (Var v)   = (if Var v \<prec> M \<cdot> N
                                        then None
                                        else Some [(v, M \<cdot> N)])"
| "unify (Var v)   M         = (if Var v \<prec> M
                                        then None
                                        else Some [(v, M)])"
| "unify (Const c) (Const d) = (if c=d then Some [] else None)"
| "unify (M \<cdot> N) (M' \<cdot> N') = (case unify M M' of
                                    None \<Rightarrow> None |
                                    Some \<theta> \<Rightarrow> (case unify (N \<lhd> \<theta>) (N' \<lhd> \<theta>)
                                      of None \<Rightarrow> None |
                                         Some \<sigma> \<Rightarrow> Some (\<theta> \<lozenge> \<sigma>)))"
  by pat_completeness auto

subsection \<open>Properties used in termination proof\<close>

text \<open>Elimination of variables by a substitution:\<close>

definition
  "elim \<sigma> v \<equiv> \<forall>t. v \<notin> vars_of (t \<lhd> \<sigma>)"

lemma elim_intro[intro]: "(\<And>t. v \<notin> vars_of (t \<lhd> \<sigma>)) \<Longrightarrow> elim \<sigma> v"
  by (auto simp:elim_def)

lemma elim_dest[dest]: "elim \<sigma> v \<Longrightarrow> v \<notin> vars_of (t \<lhd> \<sigma>)"
  by (auto simp:elim_def)

lemma elim_eq: "\<sigma> \<doteq> \<theta> \<Longrightarrow> elim \<sigma> x = elim \<theta> x"
  by (auto simp:elim_def subst_eq_def)

lemma occs_elim: "\<not> Var v \<prec> t
  \<Longrightarrow> elim [(v,t)] v \<or> [(v,t)] \<doteq> []"
by (metis elim_intro remove_var var_same vars_iff_occseq)

text \<open>The result of a unification never introduces new variables:\<close>

declare unify.psimps[simp]

lemma unify_vars:
  assumes "unify_dom (M, N)"
  assumes "unify M N = Some \<sigma>"
  shows "vars_of (t \<lhd> \<sigma>) \<subseteq> vars_of M \<union> vars_of N \<union> vars_of t"
  (is "?P M N \<sigma> t")
using assms
proof (induct M N arbitrary:\<sigma> t)
  case (3 c v)
  hence "\<sigma> = [(v, Const c)]" by simp
  thus ?case by (induct t) auto
next
  case (4 M N v)
  hence "\<not> Var v \<prec> M \<cdot> N" by auto
  with 4 have "\<sigma> = [(v, M\<cdot>N)]" by simp
  thus ?case by (induct t) auto
next
  case (5 v M)
  hence "\<not> Var v \<prec> M" by auto
  with 5 have "\<sigma> = [(v, M)]" by simp
  thus ?case by (induct t) auto
next
  case (7 M N M' N' \<sigma>)
  then obtain \<theta>1 \<theta>2
    where "unify M M' = Some \<theta>1"
    and "unify (N \<lhd> \<theta>1) (N' \<lhd> \<theta>1) = Some \<theta>2"
    and \<sigma>: "\<sigma> = \<theta>1 \<lozenge> \<theta>2"
    and ih1: "\<And>t. ?P M M' \<theta>1 t"
    and ih2: "\<And>t. ?P (N\<lhd>\<theta>1) (N'\<lhd>\<theta>1) \<theta>2 t"
    by (auto split:option.split_asm)

  show ?case
  proof
    fix v assume a: "v \<in> vars_of (t \<lhd> \<sigma>)"

    show "v \<in> vars_of (M \<cdot> N) \<union> vars_of (M' \<cdot> N') \<union> vars_of t"
    proof (cases "v \<notin> vars_of M \<and> v \<notin> vars_of M'
        \<and> v \<notin> vars_of N \<and> v \<notin> vars_of N'")
      case True
      with ih1 have l:"\<And>t. v \<in> vars_of (t \<lhd> \<theta>1) \<Longrightarrow> v \<in> vars_of t"
        by auto

      from a and ih2[where t="t \<lhd> \<theta>1"]
      have "v \<in> vars_of (N \<lhd> \<theta>1) \<union> vars_of (N' \<lhd> \<theta>1)
        \<or> v \<in> vars_of (t \<lhd> \<theta>1)" unfolding \<sigma>
        by auto
      hence "v \<in> vars_of t"
      proof
        assume "v \<in> vars_of (N \<lhd> \<theta>1) \<union> vars_of (N' \<lhd> \<theta>1)"
        with True show ?thesis by (auto dest:l)
      next
        assume "v \<in> vars_of (t \<lhd> \<theta>1)"
        thus ?thesis by (rule l)
      qed

      thus ?thesis by auto
    qed auto
  qed
qed (auto split: if_split_asm)

text \<open>The result of a unification is either the identity
substitution or it eliminates a variable from one of the terms:\<close>

lemma unify_eliminates:
  assumes "unify_dom (M, N)"
  assumes "unify M N = Some \<sigma>"
  shows "(\<exists>v\<in>vars_of M \<union> vars_of N. elim \<sigma> v) \<or> \<sigma> \<doteq> []"
  (is "?P M N \<sigma>")
using assms
proof (induct M N arbitrary:\<sigma>)
  case 1 thus ?case by simp
next
  case 2 thus ?case by simp
next
  case (3 c v)
  have no_occs: "\<not> Var v \<prec> Const c" by simp
  with 3 have "\<sigma> = [(v, Const c)]" by simp
  with occs_elim[OF no_occs]
  show ?case by auto
next
  case (4 M N v)
  hence no_occs: "\<not> Var v \<prec> M \<cdot> N" by auto
  with 4 have "\<sigma> = [(v, M\<cdot>N)]" by simp
  with occs_elim[OF no_occs]
  show ?case by auto
next
  case (5 v M)
  hence no_occs: "\<not> Var v \<prec> M" by auto
  with 5 have "\<sigma> = [(v, M)]" by simp
  with occs_elim[OF no_occs]
  show ?case by auto
next
  case (6 c d) thus ?case
    by (cases "c = d") auto
next
  case (7 M N M' N' \<sigma>)
  then obtain \<theta>1 \<theta>2
    where "unify M M' = Some \<theta>1"
    and "unify (N \<lhd> \<theta>1) (N' \<lhd> \<theta>1) = Some \<theta>2"
    and \<sigma>: "\<sigma> = \<theta>1 \<lozenge> \<theta>2"
    and ih1: "?P M M' \<theta>1"
    and ih2: "?P (N\<lhd>\<theta>1) (N'\<lhd>\<theta>1) \<theta>2"
    by (auto split:option.split_asm)

  from \<open>unify_dom (M \<cdot> N, M' \<cdot> N')\<close>
  have "unify_dom (M, M')"
    by (rule accp_downward) (rule unify_rel.intros)
  hence no_new_vars:
    "\<And>t. vars_of (t \<lhd> \<theta>1) \<subseteq> vars_of M \<union> vars_of M' \<union> vars_of t"
    by (rule unify_vars) (rule \<open>unify M M' = Some \<theta>1\<close>)

  from ih2 show ?case
  proof
    assume "\<exists>v\<in>vars_of (N \<lhd> \<theta>1) \<union> vars_of (N' \<lhd> \<theta>1). elim \<theta>2 v"
    then obtain v
      where "v\<in>vars_of (N \<lhd> \<theta>1) \<union> vars_of (N' \<lhd> \<theta>1)"
      and el: "elim \<theta>2 v" by auto
    with no_new_vars show ?thesis unfolding \<sigma>
      by (auto simp:elim_def)
  next
    assume empty[simp]: "\<theta>2 \<doteq> []"

    have "\<sigma> \<doteq> (\<theta>1 \<lozenge> [])" unfolding \<sigma>
      by (rule subst_cong) auto
    also have "\<dots> \<doteq> \<theta>1" by auto
    finally have "\<sigma> \<doteq> \<theta>1" .

    from ih1 show ?thesis
    proof
      assume "\<exists>v\<in>vars_of M \<union> vars_of M'. elim \<theta>1 v"
      with elim_eq[OF \<open>\<sigma> \<doteq> \<theta>1\<close>]
      show ?thesis by auto
    next
      note \<open>\<sigma> \<doteq> \<theta>1\<close>
      also assume "\<theta>1 \<doteq> []"
      finally show ?thesis ..
    qed
  qed
qed

declare unify.psimps[simp del]

subsection \<open>Termination proof\<close>

termination unify
proof
  let ?R = "measures [\<lambda>(M,N). card (vars_of M \<union> vars_of N),
                           \<lambda>(M, N). size M]"
  show "wf ?R" by simp

  fix M N M' N' :: "'a trm"
  show "((M, M'), (M \<cdot> N, M' \<cdot> N')) \<in> ?R" \<comment> \<open>Inner call\<close>
    by (rule measures_lesseq) (auto intro: card_mono)

  fix \<theta>                                   \<comment> \<open>Outer call\<close>
  assume inner: "unify_dom (M, M')"
    "unify M M' = Some \<theta>"

  from unify_eliminates[OF inner]
  show "((N \<lhd> \<theta>, N' \<lhd> \<theta>), (M \<cdot> N, M' \<cdot> N')) \<in>?R"
  proof
    \<comment> \<open>Either a variable is eliminated \ldots\<close>
    assume "(\<exists>v\<in>vars_of M \<union> vars_of M'. elim \<theta> v)"
    then obtain v
      where "elim \<theta> v"
      and "v\<in>vars_of M \<union> vars_of M'" by auto
    with unify_vars[OF inner]
    have "vars_of (N\<lhd>\<theta>) \<union> vars_of (N'\<lhd>\<theta>)
      \<subset> vars_of (M\<cdot>N) \<union> vars_of (M'\<cdot>N')"
      by auto

    thus ?thesis
      by (auto intro!: measures_less intro: psubset_card_mono)
  next
    \<comment> \<open>Or the substitution is empty\<close>
    assume "\<theta> \<doteq> []"
    hence "N \<lhd> \<theta> = N"
      and "N' \<lhd> \<theta> = N'" by auto
    thus ?thesis
       by (auto intro!: measures_less intro: psubset_card_mono)
  qed
qed

subsection \<open>Unification returns a Most General Unifier\<close>

lemma unify_computes_MGU:
  "unify M N = Some \<sigma> \<Longrightarrow> MGU \<sigma> M N"
proof (induct M N arbitrary: \<sigma> rule: unify.induct)
  case (7 M N M' N' \<sigma>) \<comment> \<open>The interesting case\<close>

  then obtain \<theta>1 \<theta>2
    where "unify M M' = Some \<theta>1"
    and "unify (N \<lhd> \<theta>1) (N' \<lhd> \<theta>1) = Some \<theta>2"
    and \<sigma>: "\<sigma> = \<theta>1 \<lozenge> \<theta>2"
    and MGU_inner: "MGU \<theta>1 M M'"
    and MGU_outer: "MGU \<theta>2 (N \<lhd> \<theta>1) (N' \<lhd> \<theta>1)"
    by (auto split:option.split_asm)

  show ?case
  proof
    from MGU_inner and MGU_outer
    have "M \<lhd> \<theta>1 = M' \<lhd> \<theta>1"
      and "N \<lhd> \<theta>1 \<lhd> \<theta>2 = N' \<lhd> \<theta>1 \<lhd> \<theta>2"
      unfolding MGU_def Unifier_def
      by auto
    thus "M \<cdot> N \<lhd> \<sigma> = M' \<cdot> N' \<lhd> \<sigma>" unfolding \<sigma>
      by simp
  next
    fix \<sigma>' assume "M \<cdot> N \<lhd> \<sigma>' = M' \<cdot> N' \<lhd> \<sigma>'"
    hence "M \<lhd> \<sigma>' = M' \<lhd> \<sigma>'"
      and Ns: "N \<lhd> \<sigma>' = N' \<lhd> \<sigma>'" by auto

    with MGU_inner obtain \<delta>
      where eqv: "\<sigma>' \<doteq> \<theta>1 \<lozenge> \<delta>"
      unfolding MGU_def Unifier_def
      by auto

    from Ns have "N \<lhd> \<theta>1 \<lhd> \<delta> = N' \<lhd> \<theta>1 \<lhd> \<delta>"
      by (simp add:subst_eq_dest[OF eqv])

    with MGU_outer obtain \<rho>
      where eqv2: "\<delta> \<doteq> \<theta>2 \<lozenge> \<rho>"
      unfolding MGU_def Unifier_def
      by auto

    have "\<sigma>' \<doteq> \<sigma> \<lozenge> \<rho>" unfolding \<sigma>
      by (rule subst_eq_intro, auto simp:subst_eq_dest[OF eqv] subst_eq_dest[OF eqv2])
    thus "\<exists>\<gamma>. \<sigma>' \<doteq> \<sigma> \<lozenge> \<gamma>" ..
  qed
qed (auto simp: MGU_Const intro: MGU_Var MGU_Var[symmetric] split: if_split_asm)

subsection \<open>Unification returns Idempotent Substitution\<close>

definition Idem :: "'a subst \<Rightarrow> bool"
where "Idem s \<longleftrightarrow> (s \<lozenge> s) \<doteq> s"

lemma Idem_Nil [iff]: "Idem []"
  by (simp add: Idem_def)

lemma Var_Idem:
  assumes "~ (Var v \<prec> t)" shows "Idem [(v,t)]"
  unfolding Idem_def
proof
  from assms have [simp]: "t \<lhd> [(v, t)] = t"
    by (metis assoc.simps(2) subst.simps(1) subst_no_occs)

  fix s show "s \<lhd> [(v, t)] \<lozenge> [(v, t)] = s \<lhd> [(v, t)]"
    by (induct s) auto
qed

lemma Unifier_Idem_subst:
  "Idem(r) \<Longrightarrow> Unifier s (t \<lhd> r) (u \<lhd> r) \<Longrightarrow>
    Unifier (r \<lozenge> s) (t \<lhd> r) (u \<lhd> r)"
by (simp add: Idem_def Unifier_def subst_eq_def)

lemma Idem_comp:
  "Idem r \<Longrightarrow> Unifier s (t \<lhd> r) (u \<lhd> r) \<Longrightarrow>
      (!!q. Unifier q (t \<lhd> r) (u \<lhd> r) \<Longrightarrow> s \<lozenge> q \<doteq> q) \<Longrightarrow>
    Idem (r \<lozenge> s)"
  apply (frule Unifier_Idem_subst, blast)
  apply (force simp add: Idem_def subst_eq_def)
  done

theorem unify_gives_Idem:
  "unify M N  = Some \<sigma> \<Longrightarrow> Idem \<sigma>"
proof (induct M N arbitrary: \<sigma> rule: unify.induct)
  case (7 M M' N N' \<sigma>)

  then obtain \<theta>1 \<theta>2
    where "unify M N = Some \<theta>1"
    and \<theta>2: "unify (M' \<lhd> \<theta>1) (N' \<lhd> \<theta>1) = Some \<theta>2"
    and \<sigma>: "\<sigma> = \<theta>1 \<lozenge> \<theta>2"
    and "Idem \<theta>1"
    and "Idem \<theta>2"
    by (auto split: option.split_asm)

  from \<theta>2 have "Unifier \<theta>2 (M' \<lhd> \<theta>1) (N' \<lhd> \<theta>1)"
    by (rule unify_computes_MGU[THEN MGU_is_Unifier])

  with \<open>Idem \<theta>1\<close>
  show "Idem \<sigma>" unfolding \<sigma>
  proof (rule Idem_comp)
    fix \<sigma> assume "Unifier \<sigma> (M' \<lhd> \<theta>1) (N' \<lhd> \<theta>1)"
    with \<theta>2 obtain \<gamma> where \<sigma>: "\<sigma> \<doteq> \<theta>2 \<lozenge> \<gamma>"
      using unify_computes_MGU MGU_def by blast

    have "\<theta>2 \<lozenge> \<sigma> \<doteq> \<theta>2 \<lozenge> (\<theta>2 \<lozenge> \<gamma>)" by (rule subst_cong) (auto simp: \<sigma>)
    also have "... \<doteq> (\<theta>2 \<lozenge> \<theta>2) \<lozenge> \<gamma>" by (rule comp_assoc[symmetric])
    also have "... \<doteq> \<theta>2 \<lozenge> \<gamma>" by (rule subst_cong) (auto simp: \<open>Idem \<theta>2\<close>[unfolded Idem_def])
    also have "... \<doteq> \<sigma>" by (rule \<sigma>[symmetric])
    finally show "\<theta>2 \<lozenge> \<sigma> \<doteq> \<sigma>" .
  qed
qed (auto intro!: Var_Idem split: option.splits if_splits)

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_subst_SubstFreeNo
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Expr = Var "int" | Lam "int" "Expr" | App "Expr" "Expr"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun newmaximum :: "int => int list => int" where
  "newmaximum y (nil2) = y"
| "newmaximum y (cons2 z2 ys) =
     (if y <= z2 then newmaximum z2 ys else newmaximum y ys)"

fun new :: "int list => int" where
  "new y = (newmaximum 0 y) + 1"

fun filter :: "('a => bool) => 'a list => 'a list" where
  "filter p (nil2) = nil2"
| "filter p (cons2 z xs) =
     (if p z then cons2 z (filter p xs) else filter p xs)"

fun free :: "Expr => int list" where
  "free (Var z) = cons2 z (nil2)"
| "free (Lam z2 b) = filter (% (x2 :: int) => (z2 ~= x2)) (free b)"
| "free (App a2 b2) = x (free a2) (free b2)"

fun elem :: "'a => 'a list => bool" where
  "elem y (nil2) = False"
| "elem y (cons2 z2 xs) = ((z2 = y) | (elem y xs))"

(*fun did not finish the proof*)
function subst :: "int => Expr => Expr => Expr" where
  "subst y z (Var y2) = (if (y = y2) then z else Var y2)"
| "subst y z (Lam y3 a) =
     (let z22 :: int = new (x (free z) (free a))
     in (if (y = y3) then Lam y3 a else
           (if elem y3 (free z) then
              subst y z (Lam z22 (subst y3 (Var z22) a))
              else
              Lam y3 (subst y z a))))"
| "subst y z (App a2 b2) = App (subst y z a2) (subst y z b2)"
  by pat_completeness auto

theorem property0 :
  "((~ (elem y (free a))) ==>
      ((elem z (free a)) = (elem z (free (subst y e a)))))"
  oops

end


theory union
imports Main
        "../data/Natu"
        "../data/list"
        "../funcs/equal"
        "$HIPSTER_HOME/IsaHipster"

begin

datatype NList = NNil | NCons Nat NList

fun elemN :: "Nat => NList => bool" where
  "elemN x (NNil) = False"
| "elemN x (NCons z xs) = (if equal2 x z then True else elemN x xs)"

fun union :: "NList => NList => NList" where
  "union (NNil) y = y"
| "union (NCons z xs) y =
     (if elemN z y then union xs y else NCons z (union xs y))"

(*hipster union elemN equal2*)
lemma lemma_ad [thy_expl]: "union x1 NNil = x1"
by (hipster_induct_schemes union.simps elemN.simps equal2.simps)

(*hipster_cond elemN equal2 union elemN*)
lemma lemma_ae [thy_expl]: "elemN x9 z9 \<Longrightarrow> elemN x9 (union y9 z9) = True"
by (hipster_induct_schemes elemN.simps equal2.simps union.simps elemN.simps)

lemma lemma_af [thy_expl]: "elemN x1 z1 \<Longrightarrow> union (NCons x1 y1) (union z1 xa1) = union y1 (union z1 xa1)"
by (hipster_induct_schemes elemN.simps equal2.simps union.simps elemN.simps)

lemma lemma_ag [thy_expl]: "elemN x1 y1 \<Longrightarrow> union (NCons x1 NNil) (union y1 z1) = union y1 z1"
by (hipster_induct_schemes elemN.simps equal2.simps union.simps elemN.simps)

lemma unknown [thy_expl]: "union x x = x"
by (hipster_induct_schemes elemN.simps equal2.simps union.simps )

lemma unknown [thy_expl]: "elemN x (union y z) = elemN x (union z y)"
oops

lemma unknown [thy_expl]: "union (union x y) z = union x (union y z)"
oops

lemma unknown [thy_expl]: "union x (union x y) = union x y"
oops

lemma unknown [thy_expl]: "union x (union y x) = union y x"
oops

lemma unknown [thy_expl]: "union x (NCons y x) = NCons y x"
oops

lemma unknown [thy_expl]: "union (union x y) x = union y x"
oops

lemma unknown [thy_expl]: "union (union x y) y = union x y"
oops

lemma unknown [thy_expl]: "union (union x y) (union x z) =
union y (union x z)"
oops

lemma unknown [thy_expl]: "union (union x y) (union y z) =
union x (union y z)"
oops

lemma unknown [thy_expl]: "union (union x y) (union z x) =
union y (union z x)"
oops

lemma unknown [thy_expl]: "union (union x y) (union z y) =
union x (union z y)"
oops

lemma unknown [thy_expl]: "union (union x y) (NCons z x) = union y (NCons z x)"
oops

lemma unknown [thy_expl]: "union (union x y) (NCons z y) = union x (NCons z y)"
oops

lemma unknown [thy_expl]: "union (NCons x y) (union z y) =
union (NCons x z) (union z y)"
oops

lemma unknown [thy_expl]: "union (NCons x y) (union y z) =
union (NCons x z) (union y z)"
oops

lemma unknown [thy_expl]: "elemN (S x) (union y z) = elemN (S x) (union z y)"
oops

lemma unknown [thy_expl]: "elemN Z (union x y) = elemN Z (union y x)"
oops

lemma unknown [thy_expl]: "union (union x y) (union x y) = union x y"
oops

lemma unknown [thy_expl]: "union (union x y) (union y x) = union y x"
oops

lemma unknown [thy_expl]: "union (NCons x y) (NCons x y) = NCons x y"
oops

lemma unknown [thy_expl]: "union (NCons x NNil) y = union (NCons x y) y"
oops

lemma unknown [thy_expl]: "union x (NCons Z x) = NCons Z x"
oops

lemma unknown [thy_expl]: "union (NCons x NNil) (union y z) =
union (NCons x y) (union y z)"
oops

lemma unknown [thy_expl]: "union (NCons x NNil) (union y z) =
union (NCons x z) (union y z)"
oops

lemma unknown [thy_expl]: "union (NCons x NNil) (NCons y z) = union (NCons x z) (NCons y z)"
oops

lemma unknown [thy_expl]: "union (union x y) (NCons Z x) = union y (NCons Z x)"
oops

lemma unknown [thy_expl]: "union (union x y) (NCons Z y) = union x (NCons Z y)"
oops

lemma unknown [thy_expl]: "union (NCons Z x) (union y x) =
union (NCons Z y) (union y x)"
oops

lemma unknown [thy_expl]: "union (NCons Z x) (union x y) =
union (NCons Z y) (union x y)"
oops

lemma unknown [thy_expl]: "elemN (S Z) (union x y) = elemN (S Z) (union y x)"
oops

lemma unknown [thy_expl]: "union (NCons Z NNil) x = union (NCons Z x) x"
oops

lemma unknown [thy_expl]: "union (NCons x NNil) (NCons Z y) = union (NCons x y) (NCons Z y)"
oops

lemma unknown [thy_expl]: "union (NCons Z NNil) (union x y) =
union (NCons Z x) (union x y)"
oops

lemma unknown [thy_expl]: "union (NCons Z NNil) (union x y) =
union (NCons Z y) (union x y)"
oops

lemma unknown [thy_expl]: "union (NCons Z NNil) (NCons x y) = union (NCons Z y) (NCons x y)"
oops

lemma unknown [thy_expl]: "union (NCons Z x) (NCons Z x) = NCons Z x"
oops

lemma unknown [thy_expl]: "elemN x y \<Longrightarrow> union (NCons x y) y = y"
oops

lemma unknown [thy_expl]: "elemN x y \<Longrightarrow>
union (NCons x y) (union y z) = union y z"
oops

lemma unknown [thy_expl]: "elemN x y \<Longrightarrow>
union (NCons x y) (union z y) = union z y"
oops

lemma unknown [thy_expl]: "elemN x y \<Longrightarrow> union (NCons x y) (NCons z y) = NCons z y"
oops

lemma unknown [thy_expl]: "elemN x z \<Longrightarrow>
union (NCons x y) (union z y) = union z y"
oops

lemma unknown [thy_expl]: "elemN x z \<Longrightarrow>
union (NCons x y) (union y z) = union y z"
oops

lemma unknown [thy_expl]: "elemN x y \<Longrightarrow> union (NCons x y) (NCons Z y) = NCons Z y"
oops

hipster_cond equal2 elemN union equal2

lemma unknown [thy_expl]: "union x x = x"
by (hipster_induct_schemes union.simps elemN.simps equal2.simps Nat.exhaust NList.exhaust)

lemma unknown [thy_expl]: "elemN x (union y z) = elemN x (union z y)"
oops

lemma unknown [thy_expl]: "union (union x y) z = union x (union y z)"
oops

lemma unknown [thy_expl]: "union x (union x y) = union x y"
oops

lemma unknown [thy_expl]: "union x (union y x) = union y x"
oops

lemma unknown [thy_expl]: "union x (NCons y x) = NCons y x"
oops

lemma unknown [thy_expl]: "union (union x y) x = union y x"
oops

lemma unknown [thy_expl]: "union (union x y) y = union x y"
oops

lemma unknown [thy_expl]: "union (union x y) (union x z) = union y (union x z)"
oops

lemma unknown [thy_expl]: "union (union x y) (union y z) = union x (union y z)"
oops

lemma unknown [thy_expl]: "union (union x y) (union z x) = union y (union z x)"
oops

lemma unknown [thy_expl]: "union (union x y) (union z y) = union x (union z y)"
oops

lemma unknown [thy_expl]: "union (union x y) (NCons z x) = union y (NCons z x)"
oops

lemma unknown [thy_expl]: "union (union x y) (NCons z y) = union x (NCons z y)"
oops

lemma unknown [thy_expl]: "union (NCons x y) (union z y) = union (NCons x z) (union z y)"
oops

lemma unknown [thy_expl]: "union (NCons x y) (union y z) = union (NCons x z) (union y z)"
oops

lemma unknown [thy_expl]: "elemN (S x) (union y z) = elemN (S x) (union z y)"
oops

lemma unknown [thy_expl]: "elemN Z (union x y) = elemN Z (union y x)"
oops

lemma unknown [thy_expl]: "union (union x y) (union x y) = union x y"
oops

lemma unknown [thy_expl]: "union (union x y) (union y x) = union y x"
oops

lemma unknown [thy_expl]: "union (NCons x y) (NCons x y) = NCons x y"
oops

lemma unknown [thy_expl]: "union (NCons x NNil) y = union (NCons x y) y"
oops

lemma unknown [thy_expl]: "union x (NCons Z x) = NCons Z x"
oops

lemma unknown [thy_expl]: "union (NCons x NNil) (union y z) = union (NCons x y) (union y z)"
oops

lemma unknown [thy_expl]: "union (NCons x NNil) (union y z) = union (NCons x z) (union y z)"
oops

lemma unknown [thy_expl]: "union (NCons x NNil) (NCons y z) = union (NCons x z) (NCons y z)"
oops

lemma unknown [thy_expl]: "union (union x y) (NCons Z x) = union y (NCons Z x)"
oops

lemma unknown [thy_expl]: "union (union x y) (NCons Z y) = union x (NCons Z y)"
oops

lemma unknown [thy_expl]: "union (NCons Z x) (union y x) = union (NCons Z y) (union y x)"
oops

lemma unknown [thy_expl]: "union (NCons Z x) (union x y) = union (NCons Z y) (union x y)"
oops

lemma unknown [thy_expl]: "elemN (S Z) (union x y) = elemN (S Z) (union y x)"
oops

lemma unknown [thy_expl]: "union (NCons Z NNil) x = union (NCons Z x) x"
oops

lemma unknown [thy_expl]: "union (NCons x NNil) (NCons Z y) = union (NCons x y) (NCons Z y)"
oops

lemma unknown [thy_expl]: "union (NCons Z NNil) (union x y) = union (NCons Z x) (union x y)"
oops

lemma unknown [thy_expl]: "union (NCons Z NNil) (union x y) = union (NCons Z y) (union x y)"
oops

lemma unknown [thy_expl]: "union (NCons Z NNil) (NCons x y) = union (NCons Z y) (NCons x y)"
oops

lemma unknown [thy_expl]: "union (NCons Z x) (NCons Z x) = NCons Z x"
oops

lemma t: "\<not> equal2 u v \<Longrightarrow> elem u (Cons2 v x) = elem u x"
oops

lemma u : "union x (NCons a x) = NCons a x"
apply(induction x)
apply simp
oops

lemma unknown [thy_expl]: "union x x = x"
apply(induction x)
apply(simp_all)
apply rule
apply rule
apply(hipster_induct_schemes simps list.exhaust Nat.exhaust equal2.simps elem.simps lemma_a )
oops

end


(*  Title:      ZF/IMP/Denotation.thy
    Author:     Heiko Loetzbeyer and Robert Sandner, TU München
*)

section \<open>Denotational semantics of expressions and commands\<close>

theory Denotation imports Com begin

subsection \<open>Definitions\<close>

consts
  A     :: "i \<Rightarrow> i \<Rightarrow> i"
  B     :: "i \<Rightarrow> i \<Rightarrow> i"
  C     :: "i \<Rightarrow> i"

definition
  Gamma :: "[i,i,i] \<Rightarrow> i"  (\<open>\<Gamma>\<close>) where
  "\<Gamma>(b,cden) \<equiv>
    (\<lambda>phi. {io \<in> (phi O cden). B(b,fst(io))=1} \<union>
           {io \<in> id(loc->nat). B(b,fst(io))=0})"

primrec
  "A(N(n), sigma) = n"
  "A(X(x), sigma) = sigma`x"
  "A(Op1(f,a), sigma) = f`A(a,sigma)"
  "A(Op2(f,a0,a1), sigma) = f`<A(a0,sigma),A(a1,sigma)>"

primrec
  "B(true, sigma) = 1"
  "B(false, sigma) = 0"
  "B(ROp(f,a0,a1), sigma) = f`<A(a0,sigma),A(a1,sigma)>"
  "B(noti(b), sigma) = not(B(b,sigma))"
  "B(b0 andi b1, sigma) = B(b0,sigma) and B(b1,sigma)"
  "B(b0 ori b1, sigma) = B(b0,sigma) or B(b1,sigma)"

primrec
  "C(\<SKIP>) = id(loc->nat)"
  "C(x \<ASSN> a) =
    {io \<in> (loc->nat) \<times> (loc->nat). snd(io) = fst(io)(x := A(a,fst(io)))}"
  "C(c0\<SEQ> c1) = C(c1) O C(c0)"
  "C(\<IF> b \<THEN> c0 \<ELSE> c1) =
    {io \<in> C(c0). B(b,fst(io)) = 1} \<union> {io \<in> C(c1). B(b,fst(io)) = 0}"
  "C(\<WHILE> b \<DO> c) = lfp((loc->nat) \<times> (loc->nat), \<Gamma>(b,C(c)))"

subsection \<open>Misc lemmas\<close>

lemma A_type [TC]: "\<lbrakk>a \<in> aexp; sigma \<in> loc->nat\<rbrakk> \<Longrightarrow> A(a,sigma) \<in> nat"
  by (erule aexp.induct) simp_all

lemma B_type [TC]: "\<lbrakk>b \<in> bexp; sigma \<in> loc->nat\<rbrakk> \<Longrightarrow> B(b,sigma) \<in> bool"
by (erule bexp.induct, simp_all)

lemma C_subset: "c \<in> com \<Longrightarrow> C(c) \<subseteq> (loc->nat) \<times> (loc->nat)"
  apply (erule com.induct)
      apply simp_all
      apply (blast dest: lfp_subset [THEN subsetD])+
  done

lemma C_type_D [dest]:
    "\<lbrakk>\<langle>x,y\<rangle> \<in> C(c); c \<in> com\<rbrakk> \<Longrightarrow> x \<in> loc->nat \<and> y \<in> loc->nat"
  by (blast dest: C_subset [THEN subsetD])

lemma C_type_fst [dest]: "\<lbrakk>x \<in> C(c); c \<in> com\<rbrakk> \<Longrightarrow> fst(x) \<in> loc->nat"
  by (auto dest!: C_subset [THEN subsetD])

lemma Gamma_bnd_mono:
  "cden \<subseteq> (loc->nat) \<times> (loc->nat)
    \<Longrightarrow> bnd_mono ((loc->nat) \<times> (loc->nat), \<Gamma>(b,cden))"
  by (unfold bnd_mono_def Gamma_def) blast

end


section \<open> Physical Constants \<close>

theory SI_Constants
  imports SI_Units
begin

subsection \<open> Core Derived Units \<close>

abbreviation (input) "hertz \<equiv> second\<^sup>-\<^sup>\<one>"

abbreviation "radian \<equiv> metre \<^bold>\<cdot> metre\<^sup>-\<^sup>\<one>"

abbreviation "steradian \<equiv> metre\<^sup>\<two> \<^bold>\<cdot> metre\<^sup>-\<^sup>\<two>"

abbreviation "joule \<equiv> kilogram \<^bold>\<cdot> metre\<^sup>\<two> \<^bold>\<cdot>  second\<^sup>-\<^sup>\<two>"

type_synonym 'a joule = "'a[M \<cdot> L\<^sup>2 \<cdot> T\<^sup>-\<^sup>2, SI]"

abbreviation "watt \<equiv> kilogram \<^bold>\<cdot> metre\<^sup>\<two> \<^bold>\<cdot> second\<^sup>-\<^sup>\<three>"

type_synonym 'a watt = "'a[M \<cdot> L\<^sup>2 \<cdot> T\<^sup>-\<^sup>3, SI]"

abbreviation "coulomb \<equiv> ampere \<^bold>\<cdot> second"

type_synonym 'a coulomb = "'a[I \<cdot> T, SI]"

abbreviation "lumen \<equiv> candela \<^bold>\<cdot> steradian"

type_synonym 'a lumen = "'a[J \<cdot> (L\<^sup>2 \<cdot> L\<^sup>-\<^sup>2), SI]"

subsection \<open> Constants \<close>

text \<open> The most general types we support must form a field into which the natural numbers can
  be injected. \<close>

default_sort field_char_0

text \<open> Hyperfine transition frequency of frequency of Cs \<close>

abbreviation caesium_frequency:: "'a[T\<^sup>-\<^sup>1,SI]" ("\<Delta>v\<^sub>C\<^sub>s") where
  "caesium_frequency \<equiv> 9192631770 *\<^sub>Q hertz"

text \<open> Speed of light in vacuum \<close>

abbreviation speed_of_light :: "'a[L \<cdot> T\<^sup>-\<^sup>1,SI]" ("\<^bold>c") where
  "speed_of_light \<equiv> 299792458 *\<^sub>Q (metre\<^bold>\<cdot>second\<^sup>-\<^sup>\<one>)"

text \<open> Planck constant \<close>

abbreviation Planck :: "'a[M \<cdot> L\<^sup>2 \<cdot> T\<^sup>-\<^sup>2 \<cdot> T,SI]" ("\<^bold>h") where
  "Planck \<equiv> (6.62607015 \<cdot> 1/(10^34)) *\<^sub>Q (joule\<^bold>\<cdot>second)"

text \<open> Elementary charge \<close>

abbreviation elementary_charge :: "'a[I \<cdot> T,SI]" ("\<^bold>e") where
  "elementary_charge \<equiv> (1.602176634 \<cdot> 1/(10^19)) *\<^sub>Q coulomb"

text \<open> The Boltzmann constant \<close>

abbreviation Boltzmann :: "'a[M \<cdot> L\<^sup>2 \<cdot> T\<^sup>-\<^sup>2 \<cdot> \<Theta>\<^sup>-\<^sup>1,SI]" ("\<^bold>k") where
  "Boltzmann \<equiv> (1.380649\<cdot>1/(10^23)) *\<^sub>Q (joule \<^bold>/ kelvin)"

text \<open> The Avogadro number \<close>

abbreviation Avogadro :: "'a[N\<^sup>-\<^sup>1,SI]" ("N\<^sub>A") where
"Avogadro \<equiv> 6.02214076\<cdot>(10^23) *\<^sub>Q (mole\<^sup>-\<^sup>\<one>)"

abbreviation max_luminous_frequency :: "'a[T\<^sup>-\<^sup>1,SI]" where
"max_luminous_frequency \<equiv> (540\<cdot>10^12) *\<^sub>Q hertz"

text \<open> The luminous efficacy of monochromatic radiation of frequency \<^const>\<open>max_luminous_frequency\<close>. \<close>

abbreviation luminous_efficacy :: "'a[J \<cdot> (L\<^sup>2 \<cdot> L\<^sup>-\<^sup>2) \<cdot> (M \<cdot> L\<^sup>2 \<cdot> T\<^sup>-\<^sup>3)\<^sup>-\<^sup>1,SI]" ("K\<^sub>c\<^sub>d") where
"luminous_efficacy \<equiv> 683 *\<^sub>Q (lumen\<^bold>/watt)"

subsection \<open> Checking Foundational Equations of the SI System \<close>

theorem second_definition:
  "1 *\<^sub>Q second \<cong>\<^sub>Q (9192631770 *\<^sub>Q \<one>) \<^bold>/ \<Delta>v\<^sub>C\<^sub>s"
  by si_calc

theorem metre_definition:
  "1 *\<^sub>Q metre \<cong>\<^sub>Q (\<^bold>c \<^bold>/ (299792458 *\<^sub>Q \<one>))\<^bold>\<cdot>second"
  "1 *\<^sub>Q metre \<cong>\<^sub>Q (9192631770 / 299792458) *\<^sub>Q (\<^bold>c \<^bold>/ \<Delta>v\<^sub>C\<^sub>s)"
  by si_calc+

theorem kilogram_definition:
  "((1 *\<^sub>Q kilogram)::'a kilogram) \<cong>\<^sub>Q (\<^bold>h \<^bold>/ (6.62607015 \<cdot> 1/(10^34) *\<^sub>Q \<one>))\<^bold>\<cdot>metre\<^sup>-\<^sup>\<two>\<^bold>\<cdot>second"
  by si_calc

abbreviation "approx_ice_point \<equiv> 273.15 *\<^sub>Q kelvin"

default_sort type

end


theory Higher_Projective_Space_Axioms
  imports Main
begin

(* Author: Anthony Bordg, University of Cambridge, apdb3@cam.ac.uk .*)

text \<open>
Contents:
\<^item> We introduce the types of 'point and 'line and an incidence relation between them.
\<^item> A set of axioms for higher projective spaces, i.e. we allow models of dimension \<open>>\<close> 3.
\<close>

section \<open>The axioms for Higher Projective Geometry\<close>

lemma distinct4_def:
  "distinct [A,B,C,D] = ((A \<noteq> B) \<and> (A \<noteq> C) \<and> (A \<noteq> D) \<and> (B \<noteq> C) \<and> (B \<noteq> D) \<and> (C \<noteq> D))"
  by auto

lemma distinct3_def:
  "distinct [A,B,C] = ((A \<noteq> B) \<and> (A \<noteq> C) \<and> (B \<noteq> C))"
  by auto

locale higher_projective_space =
(* One has a type of 'point *)
(* One has a type of 'line *)
(* One has a relation of incidence between 'point and 'line *)
  fixes incid :: "'point \<Rightarrow> 'line \<Rightarrow> bool"

(* We have the following axioms *)

(* Ax1: Any two distinct 'point are incident with just one line *)
  assumes ax1_existence: "\<exists>l. (incid P l) \<and> (incid M l)"
  assumes ax1_uniqueness: "(incid P k) \<longrightarrow> (incid M k) \<longrightarrow> (incid P l) \<longrightarrow> (incid M l) \<longrightarrow> (P = M) \<or> (k = l)"

(* Ax2: If A B C D are four distinct 'point such that AB meets CD, then AC meets BD.
Sometimes this is called Pasch's axiom, but according to Wikipedia it is misleading
since Pasch's axiom refers to something else. *)
assumes ax2: "distinct [A,B,C,D] \<longrightarrow> (incid A lAB \<and> incid B lAB)
\<longrightarrow> (incid C lCD \<and> incid D lCD) \<longrightarrow> (incid A lAC \<and> incid C lAC) \<longrightarrow>
(incid B lBD \<and> incid D lBD) \<longrightarrow> (\<exists>I.(incid I lAB \<and> incid I lCD)) \<longrightarrow>
(\<exists>J.(incid J lAC \<and> incid J lBD))"

(** Dimension-related axioms **)
(* Ax3: Every line is incident with at least three 'point.
As I understand it, this axiom makes sure that 'line are not degenerated into 'point
and since it asks for three distinct 'point, not only 2, it captures the idea that
'line have unlimited extent, i.e. there is always a point between two distinct 'point. *)
assumes ax3: "\<exists>A B C. distinct [A,B,C] \<and> (incid A l) \<and> (incid B l) \<and> (incid C l)"

(* Ax4: There exists two 'line that do not meet, hence the geometry is at least 3-dimensional *)
assumes ax4: "\<exists>l m.\<forall>P. \<not>(incid P l \<and> incid P m)"

end


theory Prd_assoc
  imports Main  "~~/src/HOL/Library/BNF_Corec" "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer

codatatype (sset: 'a) Stream =
  SCons (shd: 'a) (stl: "'a Stream")

primcorec pls :: "nat Stream \<Rightarrow> nat Stream \<Rightarrow> nat Stream" where
  "pls s t = SCons (plus (shd s) (shd t)) (pls (stl s) (stl t))"

friend_of_corec pls where
  "pls s t = SCons (plus (shd s) (shd t)) (pls (stl s) (stl t))"
   apply (rule pls.code)
  by transfer_prover

corec (friend) prd :: "nat Stream \<Rightarrow> nat Stream \<Rightarrow> nat Stream" where
  "prd s t = SCons ((shd s) * (shd t)) (pls (prd (stl s) t) (prd s (stl t)))"

datatype 'a Lst =
  Emp
  | Cons "'a" "'a Lst"

fun obsStream :: "int \<Rightarrow> 'a Stream \<Rightarrow> 'a Lst" where
"obsStream n s = (if (n \<le> 0) then Emp else Cons (shd s) (obsStream (n - 1) (stl s)))"

(*hipster_obs Stream Lst obsStream prd
Proving: times_nat x 0 = 0
Undefined fact: "Nat.nat.coinduct_strong" *)

theorem prd_assoc: "prd s (prd t u) = prd (prd s t) u"
 (* by hipster_coinduct_sledgehammer
Failed to apply initial proof method *)
end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_int_add_assoc
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

datatype Integer = P "Nat" | N "Nat"

fun pred :: "Nat => Nat" where
"pred (S y) = y"

fun plus2 :: "Nat => Nat => Nat" where
"plus2 (Z) y = y"
| "plus2 (S z) y = S (plus2 z y)"

fun t2 :: "Nat => Nat => Integer" where
"t2 x y =
   (let fail :: Integer =
     (case y of
        Z => P x
        | S z =>
            (case x of
               Z => N y
               | S x2 => t2 x2 z))
   in (case x of
         Z =>
           (case y of
              Z => P Z
              | S x4 => fail)
         | S x3 => fail))"

fun plus :: "Integer => Integer => Integer" where
"plus (P m) (P n) = P (plus2 m n)"
| "plus (P m) (N o2) = t2 m (plus2 (S Z) o2)"
| "plus (N m2) (P n2) = t2 n2 (plus2 (S Z) m2)"
| "plus (N m2) (N n3) = N (plus2 (plus2 (S Z) m2) n3)"

theorem property0 :
  "((plus x (plus y z)) = (plus (plus x y) z))"
  oops

end


\<^marker>\<open>author Simon Wimmer\<close>
theory Chained_Facts
  imports Main
begin

text \<open>To better understand the way methods work in Isabelle,
it is important to understand the concept of \<open>chained facts\<close>.
This often causes confusion, particularly to the users of
the \<open>intro/elim\<close> and \<open>rule/erule\<close> methods.\<close>

section \<open>Basic Example and Explanation\<close>

text \<open>In the following examples, @{method rule} and @{method intro} behave the same way.\<close>

lemma
  "\<exists>x::nat. x > 0"
  apply (rule exI)
  apply (rule zero_less_one)
  done

lemma
  "\<exists>x::nat. x > 0"
  apply (intro exI)
  apply (rule zero_less_one)
  done

text \<open>We now \<^emph>\<open>chain\<close> in the fact @{thm zero_less_one} with \<open>using\<close>.\<close>
lemma
  "\<exists>x::nat. x > 0"
  using zero_less_one
  apply (rule exI)
  done

lemma
  "\<exists>x::nat. x > 0"
  using zero_less_one
  apply (intro exI)
  apply assumption
  done

text \<open>We note a slight difference. In the variant with intro, a trivial goal remains
that we need to solve by \<open>assumption\<close>.
The reason is that \<open>intro\<close> is a \<^emph>\<open>simple method\<close> in Isabelle jargon, while \<open>rule\<close> is \<^emph>\<open>proper\<close>.
Simple methods ignore chained facts and insert them into the goal state,
while proper methods will usually act on them in some way.

In the example, \<open>rule\<close> matches the chained fact @{thm zero_less_one} on the first premise
of @{thm exI}, and the conclusion of @{thm exI} on the goal.
As @{thm exI} only has one premise, no subgoals are left.
In contrast, \<open>intro\<close> simply ignores @{thm zero_less_one} and matches @{thm exI} only on
the conclusion. The fact is nevertheless inserted into the goal that arises, which
is why we can solve it by \<open>assumption\<close>.

Most older proof methods such as \<open>simp\<close>, \<open>auto\<close>, or \<open>blast\<close> are simple.
Two noteworthy proper methods are \<open>induction\<close> and \<open>cases\<close>.
\<close>

section \<open>Inserting Facts\<close>

text \<open>The behaviour of simple methods can be simulated by \<open>-\<close>, which will insert
any chained facts into the current goal state.\<close>
lemma
  "\<exists>x::nat. x > 0"
  using zero_less_one
  apply -
  apply (rule exI)
  apply assumption
  done

text \<open>Method insert will ignore any chained facts and insert its arguments in the goal state:\<close>
lemma
  "\<exists>x::nat. x > 0"
  using exI
  apply (insert zero_less_one)
  apply (rule exI)
  apply assumption
  done

section \<open>Chained Facts Are Chained\<close>

text \<open>Chained facts are chained through method combinators.\<close>
lemma \<comment> \<open>This works.\<close>
  "\<exists>x::nat. x > 0"
  apply (insert zero_less_one, rule exI)
  apply assumption
  done

lemma \<comment> \<open>This fails because \<open>0 \<noteq> 1\<close> does not match \<open>0 < 1\<close>.\<close>
  "\<exists>x::nat. x > 0"
  using zero_neq_one
  \<^cancel>\<open>apply (insert zero_less_one, rule exI)\<close>
  oops

lemma \<comment> \<open>This works again.\<close>
  "\<exists>x::nat. x > 0"
  using zero_neq_one
  apply (insert zero_less_one)
  apply (rule exI)
  apply assumption
  done

section \<open>More Examples\<close>

text \<open>The following examples outline some typical Isar proof patterns that come up when
chained facts are involved.\<close>

notepad
begin
  have fin_lt_5: "finite {x::nat. x < 5}"
    by auto
  moreover have subs: "{x::nat. x < 4} \<subseteq> {x::nat. x < 5}"
    by auto
  ultimately have "finite {x::nat. x < 4}" \<comment> \<open>Both previous facts are currently chained.\<close>
    \<^cancel>\<open>apply (rule finite_subset)\<close> \<comment> \<open>This fails. Both premises are given but in the wrong order.\<close>
    \<^cancel>\<open>apply (rule finite_subset[rotated])\<close> \<comment> \<open>Hence this works.\<close>
    \<^cancel>\<open>apply (erule finite_subset[rotated])\<close> \<comment> \<open>
      This fails because after matching the premises against the chained facts,
      there is no premise left for \<open>erule\<close> to match on.\<close>
    \<^cancel>\<open>apply (intro finite_subset)\<close> \<comment> \<open>This loops. Be careful! Better stop it quickly.\<close>
    apply (elim finite_subset) \<comment> \<open>
      This does not loop because \<open>elim\<close> matches any of the chained facts against the first premise.\<close>
    apply assumption
    \<^cancel>\<open>apply (elim finite_subset, assumption)\<close> \<comment> \<open>
      This does not work because \<open>assumption\<close> is not happy with chained facts.\<close>
    \<^cancel>\<open>apply (rule finite_subset[rotated])\<close> \<comment> \<open>Hence this works.\<close>
    done
end

lemma length_gt_0_E:
  assumes "length xs = n" "n > 0"
  obtains y ys where "xs = y # ys"
  using assms by (cases xs) auto

notepad
begin
  let ?xs = "[1::nat, 2, 3]"
  have three_gt_0: "(3 :: nat) > 0"
    by auto
  have len: "length ?xs = 3"
    by auto
  then obtain y ys where "?xs = y # ys"
    by (rule length_gt_0_E) simp
  from len obtain y ys where "?xs = y # ys"
    \<^cancel>\<open>apply (intro length_gt_0_E)\<close> \<comment> \<open>Loops. For this kind of \<open>elim\<close>-rules \<open>intro\<close> is useless.\<close>
    by (elim length_gt_0_E; simp)
  from len three_gt_0 obtain y ys where "?xs = y # ys"
    by (rule length_gt_0_E)
  \<comment> \<open>Facts in wrong order.\<close>
  from three_gt_0 len obtain y ys where "?xs = y # ys"
    \<^cancel>\<open>apply (rule length_gt_0_E)\<close> \<comment> \<open>Wrong fact order. Fails.\<close>
    by - (rule length_gt_0_E) \<comment> \<open>Insert facts first.\<close>
  from three_gt_0 len obtain y ys where "?xs = y # ys"
    by - (erule length_gt_0_E) \<comment> \<open>Matching the first fact explicitly.\<close>
  from three_gt_0 len obtain y ys where "?xs = y # ys"
    by (elim length_gt_0_E) \<comment> \<open>In this type of situation \<open>elim\<close> is cleaner.\<close>
  from three_gt_0 len obtain y ys where "?xs = y # ys"
    \<^cancel>\<open>apply (rule length_gt_0_E)\<close> \<comment> \<open>Wrong fact order. Fails.\<close>
    by (elim length_gt_0_E) \<comment> \<open>In this type of situation \<open>elim\<close> is cleaner.\<close>
  from len three_gt_0 obtain y ys where "?xs = y # ys"
    by (elim length_gt_0_E) \<comment> \<open>Because it works essentially uniformly w.r.t\ to fact order.\<close>
end

section \<open>Notes\<close>
text \<open>
\<^item> Eisbach methods are usually proper and can act on the chained facts in various ways.
You can find more information in the Eisbach user manual.
\<^item> In Isabelle/ML, the combinator @{ML SIMPLE_METHOD} is used to turn tactics into simple methods.
\<close>

end


theory neighborhood
  imports "../TBAs/closure_algebra"
begin

(**The following four conditions characterize a neighborhood relation/function
as a centered proper filter.*)
definition Nbhd_1::"('w,'w \<sigma>)\<rho> \<Rightarrow> bool" ("Nbhd_1")
  where "Nbhd_1 F \<equiv> \<forall>x. meet_closed (F x)" (**filter-base*)
definition Nbhd_2::"('w,'w \<sigma>)\<rho> \<Rightarrow> bool" ("Nbhd_2")
  where "Nbhd_2 F \<equiv> \<forall>x. upwards_closed (F x)" (**filter*)
definition Nbhd_3::"('w,'w \<sigma>)\<rho> \<Rightarrow> bool" ("Nbhd_3")
  where "Nbhd_3 F \<equiv> \<forall>x. nonEmpty (F x)" (**proper filter(-base)*)
definition Nbhd_4::"('w,'w \<sigma>)\<rho> \<Rightarrow> bool" ("Nbhd_4")
  where "Nbhd_4 F \<equiv> \<forall>x N. F x N \<longrightarrow> N x" (**centered*)

abbreviation Nbhd_all::"('w,'w \<sigma>)\<rho> \<Rightarrow> bool" ("\<NN>")
  where "\<NN> F \<equiv> Nbhd_1 F \<and> Nbhd_2 F \<and> Nbhd_3 F \<and> Nbhd_4 F"

(**Neighborhood functions are useful to introduce the notions of adherent (aka. closure)
 and accumulation (aka. limit) points of a set (wrt. a neighborhood function).*)
definition adherent_points::"('w,'w \<sigma>)\<rho> \<Rightarrow> ('w \<sigma> \<Rightarrow> 'w \<sigma>)" ("ADH[_]")
  where "ADH[F] A \<equiv> \<lambda>p. \<forall>N. F p N \<longrightarrow> \<not>Disj N A"
definition accumulation_points::"('w,'w \<sigma>)\<rho> \<Rightarrow> ('w \<sigma> \<Rightarrow> 'w \<sigma>)" ("ACC[_]")
  where "ACC[F] A \<equiv> \<lambda>p. \<forall>N. F p N \<longrightarrow> \<not>Disj N (A \<^bold>\<leftharpoonup> {p})"

(**We can in fact easily define a neighborhood function given a closure operator.*)
definition Nbhd_Cl::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> ('w,'w \<sigma>)\<rho>" ("\<N>[_]")
  where "\<N>[\<C>] \<equiv> \<I>[\<C>]\<Zcat>"

(**We prove below that in doing this the characterising neighborhood conditions are satisfied.*)
lemma nbhd_prop1: "Cl_1' \<C> \<Longrightarrow> Nbhd_1 \<N>[\<C>]" unfolding Nbhd_1_def Nbhd_Cl_def swap_def op_dual_def by (smt (z3) ADDI_a_def BA_deMorgan2 compl_def join_def meet_closed_def subset_def)
lemma nbhd_prop2: "MONO \<C> \<Longrightarrow> Nbhd_2 \<N>[\<C>]" unfolding Nbhd_2_def Nbhd_Cl_def swap_def op_dual_def MONO_def subset_def by (smt (z3) BA_deMorgan1 L9 compl_def meet_def setequ_equ upwards_closed_def)
lemma nbhd_prop3: "Cl_3 \<C> \<Longrightarrow> Nbhd_3 \<N>[\<C>]" by (metis DNRM_def NOR_dual1 Nbhd_Cl_def swap_def Nbhd_3_def setequ_equ top_def)
lemma nbhd_prop4: "Cl_2 \<C> \<Longrightarrow> Cl_4' \<C> \<Longrightarrow> Nbhd_4 \<N>[\<C>]" by (metis (mono_tags) CNTR_def EXPN_CNTR_dual2 Nbhd_Cl_def swap_def Nbhd_4_def subset_def)

(**Moreover, we can show under which (minimal) conditions the well-known characterisation of neighborhood
functions in terms of open sets obtains.*)
lemma nbhd_open1: "Cl_2 \<C> \<Longrightarrow> Cl_4' \<C> \<Longrightarrow> \<forall>p N. \<N>[\<C>] p N \<longrightarrow> (\<exists>E. Op[\<C>] E \<and> E \<preceq> N \<and> E p)" by (metis BA_cp BA_dn EXPN_def IDEM_a_def IDEM_char Int_Open Nbhd_Cl_def base.swap_def op_dual_def)
lemma nbhd_open2: "MONO \<C> \<Longrightarrow> \<forall>p N. (\<exists>E. Op[\<C>] E \<and> E \<preceq> N \<and> E p) \<longrightarrow> \<N>[\<C>] p N" unfolding Nbhd_Cl_def swap_def by (metis MONO_def MONO_dual fixpoint_pred_def setequ_equ subset_def)
lemma nbhd_open: "MONO \<C> \<Longrightarrow> Cl_2 \<C> \<Longrightarrow> Cl_4' \<C> \<Longrightarrow>
                 \<forall>p. \<N>[\<C>] p = (\<lambda>N. (\<exists>E. Op[\<C>] E \<and> E \<preceq> N \<and> E p))" by (meson nbhd_open1 nbhd_open2)

(**We can also verify (using minimal conditions) the characterization of open sets by neighborhoods.*)
(**Every open set is a neighborhood of all (and only) of its points.*)
lemma open_nbhd1: "\<forall>N. Op[\<C>] N \<longrightarrow> (\<forall>x. N x \<longleftrightarrow> \<N>[\<C>] x N)"  by (simp add: Nbhd_Cl_def swap_def fixpoint_pred_def setequ_equ)
(**If a set is a neighborhood of all of its points then it is open.*)
lemma open_nbhd2: "MONO \<C> \<Longrightarrow> Cl_2 \<C> \<Longrightarrow> \<forall>N. (\<forall>x. N x \<longrightarrow> \<N>[\<C>] x N) \<longrightarrow> Op[\<C>] N" by (metis (mono_tags) CNTR_def EXPN_CNTR_dual2 Nbhd_Cl_def base.swap_def fixpoint_pred_def setequ_def subset_def)
lemma open_nbhd: "MONO \<C> \<Longrightarrow> Cl_2 \<C> \<Longrightarrow> \<forall>N. Op[\<C>] N = (\<forall>x. N x \<longrightarrow> \<N>[\<C>] x N)" by (metis open_nbhd1 open_nbhd2)

(**Having a closure operator allows for an alternative characterization of the set of limit points*)
definition limit::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> ('w \<sigma> \<Rightarrow> 'w \<sigma>)" ("limit[_]")
  where "limit[\<C>] A \<equiv> \<lambda>w. \<C> (A \<^bold>\<leftharpoonup> {w}) w"

lemma "MONO \<C> \<Longrightarrow> limit[\<C>] = ACC[\<N>[\<C>]]"
  unfolding limit_def accumulation_points_def Nbhd_Cl_def swap_def
  by (simp add: CI_Disj_rel)

end


(*  Title:       Right group actions
    Author:      Tim Makarios <tjm1983 at gmail.com>, 2012
    Maintainer:  Tim Makarios <tjm1983 at gmail.com>
*)

(* After Isabelle 2012, this may be moved to ~~/src/HOL/Algebra *)

header "Right group actions"

theory Action
  imports "~~/src/HOL/Algebra/Group"
begin

locale action = group +
  fixes act :: "'b \<Rightarrow> 'a \<Rightarrow> 'b" (infixl "<o" 69)
  assumes id_act [simp]: "b <o \<one> = b"
  and act_act':
  "g \<in> carrier G \<and> h \<in> carrier G \<longrightarrow> (b <o g) <o h = b <o (g \<otimes> h)"
begin

lemma act_act:
  assumes "g \<in> carrier G" and "h \<in> carrier G"
  shows "(b <o g) <o h = b <o (g \<otimes> h)"
proof -
  from `g \<in> carrier G` and `h \<in> carrier G` and act_act'
  show "(b <o g) <o h = b <o (g \<otimes> h)" by simp
qed

lemma act_act_inv [simp]:
  assumes "g \<in> carrier G"
  shows "b <o g <o inv g = b"
proof -
  from `g \<in> carrier G` have "inv g \<in> carrier G" by (rule inv_closed)
  with `g \<in> carrier G` have "b <o g <o inv g = b <o g \<otimes> inv g" by (rule act_act)
  with `g \<in> carrier G` show "b <o g <o inv g = b" by simp
qed

lemma act_inv_act [simp]:
  assumes "g \<in> carrier G"
  shows "b <o inv g <o g = b"
  using `g \<in> carrier G` and act_act_inv [of "inv g"]
  by simp

lemma act_inv_iff:
  assumes "g \<in> carrier G"
  shows "b <o inv g = c \<longleftrightarrow> b = c <o g"
proof
  assume "b <o inv g = c"
  hence "b <o inv g <o g = c <o g" by simp
  with `g \<in> carrier G` show "b = c <o g" by simp
next
  assume "b = c <o g"
  hence "b <o inv g = c <o g <o inv g" by simp
  with `g \<in> carrier G` show "b <o inv g = c" by simp
qed

end

end


theory T2
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


(*  Title:      HOL/Algebra/Exponent.thy
    Author:     Florian Kammueller
    Author:     L C Paulson

exponent p s   yields the greatest power of p that divides s.
*)

theory Exponent
imports MainRLT "HOL-Computational_Algebra.Primes"
begin

section \<open>Sylow's Theorem\<close>

text \<open>The Combinatorial Argument Underlying the First Sylow Theorem\<close>

text\<open>needed in this form to prove Sylow's theorem\<close>
corollary (in algebraic_semidom) div_combine:
  "\<lbrakk>prime_elem p; \<not> p ^ Suc r dvd n; p ^ (a + r) dvd n * k\<rbrakk> \<Longrightarrow> p ^ a dvd k"
  by (metis add_Suc_right mult.commute prime_elem_power_dvd_cases)

lemma exponent_p_a_m_k_equation:
  fixes p :: nat
  assumes "0 < m" "0 < k" "p \<noteq> 0" "k < p^a"
    shows "multiplicity p (p^a * m - k) = multiplicity p (p^a - k)"
proof (rule multiplicity_cong [OF iffI])
  fix r
  assume *: "p ^ r dvd p ^ a * m - k"
  show "p ^ r dvd p ^ a - k"
  proof -
    have "k \<le> p ^ a * m" using assms
      by (meson nat_dvd_not_less dvd_triv_left leI mult_pos_pos order.strict_trans)
    then have "r \<le> a"
      by (meson "*" \<open>0 < k\<close> \<open>k < p^a\<close> dvd_diffD1 dvd_triv_left leI less_imp_le_nat nat_dvd_not_less power_le_dvd)
    then have "p^r dvd p^a * m" by (simp add: le_imp_power_dvd)
    thus ?thesis
      by (meson \<open>k \<le> p ^ a * m\<close> \<open>r \<le> a\<close> * dvd_diffD1 dvd_diff_nat le_imp_power_dvd)
  qed
next
  fix r
  assume *: "p ^ r dvd p ^ a - k"
  with assms have "r \<le> a"
    by (metis diff_diff_cancel less_imp_le_nat nat_dvd_not_less nat_le_linear power_le_dvd zero_less_diff)
  show "p ^ r dvd p ^ a * m - k"
  proof -
    have "p^r dvd p^a*m"
      by (simp add: \<open>r \<le> a\<close> le_imp_power_dvd)
    then show ?thesis
      by (meson assms * dvd_diffD1 dvd_diff_nat le_imp_power_dvd less_imp_le_nat \<open>r \<le> a\<close>)
  qed
qed

lemma p_not_div_choose_lemma:
  fixes p :: nat
  assumes eeq: "\<And>i. Suc i < K \<Longrightarrow> multiplicity p (Suc i) = multiplicity p (Suc (j + i))"
      and "k < K" and p: "prime p"
    shows "multiplicity p (j + k choose k) = 0"
  using \<open>k < K\<close>
proof (induction k)
  case 0 then show ?case by simp
next
  case (Suc k)
  then have *: "(Suc (j+k) choose Suc k) > 0" by simp
  then have "multiplicity p ((Suc (j+k) choose Suc k) * Suc k) = multiplicity p (Suc k)"
    by (subst Suc_times_binomial_eq [symmetric], subst prime_elem_multiplicity_mult_distrib)
       (insert p Suc.prems, simp_all add: eeq [symmetric] Suc.IH)
  with p * show ?case
    by (subst (asm) prime_elem_multiplicity_mult_distrib) simp_all
qed

text\<open>The lemma above, with two changes of variables\<close>
lemma p_not_div_choose:
  assumes "k < K" and "k \<le> n"
      and eeq: "\<And>j. \<lbrakk>0<j; j<K\<rbrakk> \<Longrightarrow> multiplicity p (n - k + (K - j)) = multiplicity p (K - j)" "prime p"
    shows "multiplicity p (n choose k) = 0"
apply (rule p_not_div_choose_lemma [of K p "n-k" k, simplified assms nat_minus_add_max max_absorb1])
apply (metis add_Suc_right eeq diff_diff_cancel order_less_imp_le zero_less_Suc zero_less_diff)
apply (rule TrueI)+
done

proposition const_p_fac:
  assumes "m>0" and prime: "prime p"
  shows "multiplicity p (p^a * m choose p^a) = multiplicity p m"
proof-
  from assms have p: "0 < p ^ a" "0 < p^a * m" "p^a \<le> p^a * m"
    by (auto simp: prime_gt_0_nat)
  have *: "multiplicity p ((p^a * m - 1) choose (p^a - 1)) = 0"
    apply (rule p_not_div_choose [where K = "p^a"])
    using p exponent_p_a_m_k_equation by (auto simp: diff_le_mono prime)
  have "multiplicity p ((p ^ a * m choose p ^ a) * p ^ a) = a + multiplicity p m"
  proof -
    have "(p ^ a * m choose p ^ a) * p ^ a = p ^ a * m * (p ^ a * m - 1 choose (p ^ a - 1))"
      (is "_ = ?rhs") using prime
      by (subst times_binomial_minus1_eq [symmetric]) (auto simp: prime_gt_0_nat)
    also from p have "p ^ a - Suc 0 \<le> p ^ a * m - Suc 0" by linarith
    with prime * p have "multiplicity p ?rhs = multiplicity p (p ^ a * m)"
      by (subst prime_elem_multiplicity_mult_distrib) auto
    also have "\<dots> = a + multiplicity p m"
      using prime p by (subst prime_elem_multiplicity_mult_distrib) simp_all
    finally show ?thesis .
  qed
  then show ?thesis
    using prime p by (subst (asm) prime_elem_multiplicity_mult_distrib) simp_all
qed

end


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

  Definition and cost analysis of randomised QuickSort (i.e. pivot chosen uniformly at random).
*)
section \<open>Randomised QuickSort\<close>
theory Randomised_Quick_Sort
  imports
    "HOL-Probability.Probability"
    "Landau_Symbols.Landau_More"
    Comparison_Sort_Lower_Bound.Linorder_Relations
begin

subsection \<open>Deletion by index\<close>

text \<open>
  The following function deletes the $n$-th element of a list.
\<close>

fun delete_index :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "delete_index _ [] = []"
| "delete_index 0 (x # xs) = xs"
| "delete_index (Suc n) (x # xs) = x # delete_index n xs"

lemma delete_index_altdef: "delete_index n xs = take n xs @ drop (Suc n) xs"
  by (induction n xs rule: delete_index.induct) simp_all

lemma delete_index_ge_length: "n \<ge> length xs \<Longrightarrow> delete_index n xs = xs"
  by (simp add: delete_index_altdef)

lemma length_delete_index [simp]: "n < length xs \<Longrightarrow> length (delete_index n xs) = length xs - 1"
  by (simp add: delete_index_altdef)

lemma delete_index_Cons:
  "delete_index n (x # xs) = (if n = 0 then xs else x # delete_index (n - 1) xs)"
  by (cases n) simp_all

lemma insert_set_delete_index:
  "n < length xs \<Longrightarrow> insert (xs ! n) (set (delete_index n xs)) = set xs"
  by (induction n xs rule: delete_index.induct) auto

lemma add_mset_delete_index:
  "i < length xs \<Longrightarrow> add_mset (xs ! i) (mset (delete_index i xs)) = mset xs"
  by (induction i xs rule: delete_index.induct) simp_all

lemma nth_delete_index:
  "i < length xs \<Longrightarrow> n < length xs \<Longrightarrow>
     delete_index n xs ! i = (if i < n then xs ! i else xs ! Suc i)"
  by (auto simp: delete_index_altdef nth_append min_def)

lemma set_delete_index_distinct:
  assumes "distinct xs" "n < length xs"
  shows   "set (delete_index n xs) = set xs - {xs ! n}"
  using assms by (induction n xs rule: delete_index.induct) fastforce+

lemma distinct_delete_index [simp, intro]:
  assumes "distinct xs"
  shows   "distinct (delete_index n xs)"
proof (cases "n < length xs")
  case True
  with assms show ?thesis
    by (induction n xs rule: delete_index.induct) (auto simp: set_delete_index_distinct)
qed (simp_all add: delete_index_ge_length assms)

lemma mset_delete_index [simp]:
  "i < length xs \<Longrightarrow> mset (delete_index i xs) = mset xs - {# xs!i #}"
  by (induction i xs rule: delete_index.induct) simp_all

subsection \<open>Definition\<close>

text \<open>
  The following is a functional randomised version of QuickSort that also records the number
  of comparisons that were made. The randomisation is in the selection of the pivot element:
  In each step, the next pivot is chosen uniformly at random from all remaining list elements.

  The function takes the ordering relation to use as a first argument in the form of a set of
  pairs.
\<close>

function rquicksort :: "('a \<times> 'a) set \<Rightarrow> 'a list \<Rightarrow> ('a list \<times> nat) pmf" where
  "rquicksort R xs =
     (if xs = [] then
        return_pmf ([], 0)
      else
        do {
          i \<leftarrow> pmf_of_set {..<length xs};
          let x = xs ! i;
          case partition (\<lambda>y. (y,x) \<in> R) (delete_index i xs) of
            (ls, rs) \<Rightarrow> do {
              (ls, n1) \<leftarrow> rquicksort R ls;
              (rs, n2) \<leftarrow> rquicksort R rs;
              return_pmf (ls @ [x] @ rs, length xs - 1 + n1 + n2)
            }
        })"
  by auto
termination proof (relation "Wellfounded.measure (length \<circ> snd)", goal_cases)
  show "wf (Wellfounded.measure (length \<circ> snd))" by simp
qed (subst (asm) set_pmf_of_set; force intro!: le_less_trans[OF length_filter_le])+

declare rquicksort.simps [simp del]

lemma rquicksort_Nil [simp]: "rquicksort R [] = return_pmf ([], 0)"
  by (simp add: rquicksort.simps)

subsection \<open>Correctness proof\<close>

lemma set_pmf_of_set_lessThan_length [simp]:
  "xs \<noteq> [] \<Longrightarrow> set_pmf (pmf_of_set {..<length xs}) = {..<length xs}"
  by (subst set_pmf_of_set) auto

text \<open>
  We can now prove that any list that can be returned by QuickSort is sorted w.\,r.\,t.\ the
  given relation. (as long as that relation is reflexive, transitive, and total)
\<close>

theorem rquicksort_correct:
  assumes "trans R" and "total_on (set xs) R" and "\<forall>x\<in>set xs. (x,x) \<in> R"
  assumes "(ys, n) \<in> set_pmf (rquicksort R xs)"
  shows   "sorted_wrt R ys \<and> mset ys = mset xs"
  using assms(2-)
proof (induction xs arbitrary: ys n rule: length_induct)
  case (1 xs)
  have IH: "sorted_wrt R zs" "mset zs = mset ys"
    if "(zs, n) \<in> set_pmf (rquicksort R ys)" "length ys < length xs" "set ys \<subseteq> set xs" for zs ys n
    using that "1.IH" total_on_subset[OF "1.prems"(1) that(3)] "1.prems"(2) by blast+
  show ?case
  proof (cases "xs = []")
    case False
    with "1.prems" obtain ls rs n1 n2 i where *:
       "i < length xs" "(ls, n1) \<in> set_pmf (rquicksort R [y\<leftarrow>delete_index i xs. (y, xs ! i) \<in> R])"
       "(rs, n2) \<in> set_pmf (rquicksort R [y\<leftarrow>delete_index i xs. (y, xs ! i) \<notin> R])"
       "ys = ls @ [xs ! i] @ rs"
      by (subst (asm) rquicksort.simps[of _ xs]) (auto simp: Let_def o_def)
    note ys = \<open>ys = ls @ [xs ! i] @ rs\<close>
    define ls' where "ls' = [y\<leftarrow>delete_index i xs. (y, xs ! i) \<in> R]"
    define rs' where "rs' = [y\<leftarrow>delete_index i xs. (y, xs ! i) \<notin> R]"
    from \<open>i < length xs\<close> have less: "length ls' < length xs" "length rs' < length xs"
      unfolding ls'_def rs'_def by (intro le_less_trans[OF length_filter_le]; force)+
    have ls: "(ls, n1) \<in> set_pmf (rquicksort R ls')" and rs: "(rs, n2) \<in> set_pmf (rquicksort R rs')"
      using * unfolding ls'_def rs'_def by blast+
    have subset: "set ls' \<subseteq> set xs" "set rs' \<subseteq> set xs"
      using insert_set_delete_index[of i xs] \<open>i < length xs\<close>
      by (auto simp: ls'_def rs'_def)
    have sorted: "sorted_wrt R ls" "sorted_wrt R rs"
     and mset: "mset ls = mset ls'" "mset rs = mset rs'"
      by (rule IH[of ls n1 ls'] IH[of rs n2 rs'] less ls rs subset)+

    have ls_le: "(x, xs ! i) \<in> R" if "x \<in> set ls" for x
    proof -
      from that have "x \<in># mset ls" by simp
      also note mset(1)
      finally show ?thesis by (simp add: ls'_def)
    qed
    have rs_ge: "(x, xs ! i) \<notin> R" "(xs ! i, x) \<in> R" if "x \<in> set rs" for x
    proof -
      from that have "x \<in># mset rs" by simp
      also note mset(2)
      finally have x: "x \<in> set rs'" by simp
      thus "(x, xs ! i) \<notin> R" by (simp_all add: rs'_def)
      from x and subset and \<open>i < length xs\<close> have "x \<in> set xs" "xs ! i \<in> set xs" by auto
      with "1.prems" and \<open>(x, xs ! i) \<notin> R\<close> show "(xs ! i, x) \<in> R"
        unfolding total_on_def by (cases "xs ! i = x") auto
    qed

    have "sorted_wrt R ys" unfolding ys
      by (intro sorted_wrt_append \<open>trans R\<close> sorted_wrt_singleton sorted)
         (auto intro: rs_ge ls_le transD[OF \<open>trans R\<close>, of _ "xs!i"])
    moreover have "mset ys = mset xs" unfolding ys using \<open>i < length xs\<close>
      by (simp add: mset ls'_def rs'_def add_mset_delete_index)
    ultimately show ?thesis ..
  qed (insert "1.prems", simp_all)
qed

subsection \<open>Cost analysis\<close>

text \<open>
  The following distribution describes the number of comparisons made by randomised
  QuickSort in terms of the list length. (This is only valid if all list elements are distinct)

  A succinct explanation of this cost analysis is given by Jacek Cicho\'{n}~\cite{cichon}.
\<close>
fun rqs_cost :: "nat \<Rightarrow> nat pmf" where
  "rqs_cost 0 = return_pmf 0"
| "rqs_cost (Suc n) =
     do {i \<leftarrow> pmf_of_set {..n}; a \<leftarrow> rqs_cost i; b \<leftarrow> rqs_cost (n - i); return_pmf (n + a + b)}"

lemma finite_set_pmf_rqs_cost [intro!]: "finite (set_pmf (rqs_cost n))"
  by (induction n rule: rqs_cost.induct) simp_all

text \<open>
  We connect the @{const rqs_cost} function to the @{const rquicksort} function by showing that
  projecting out the number of comparisons from a run of @{const rquicksort} on a list with distinct
  elements yields the same distribution as @{const rqs_cost} for the length of that list.
\<close>
theorem snd_rquicksort:
  assumes "linorder_on A R" and "set xs \<subseteq> A" and "distinct xs"
  shows   "map_pmf snd (rquicksort R xs) = rqs_cost (length xs)"
  using assms(2-)
proof (induction xs rule: length_induct)
  case (1 xs)
  have IH: "map_pmf snd (rquicksort R ys) = rqs_cost (length ys)"
    if "length ys < length xs" "mset ys \<subseteq># mset xs" for ys
  proof -
    from set_mset_mono[OF that(2)] have "set ys \<subseteq> set xs" by simp
    also note \<open>set xs \<subseteq> A\<close>
    finally have "set ys \<subseteq> A" .
    moreover from \<open>distinct xs\<close> and that(2) have "distinct ys"
      by (rule distinct_mset_mono)
    ultimately show ?thesis using that and "1.IH" by blast
  qed
  define n where "n = length xs"
  define cnt where "cnt = (\<lambda>i. length [y\<leftarrow>delete_index i xs. (y, xs ! i) \<in> R])"
  have cnt_altdef: "cnt i = linorder_rank R (set xs) (xs ! i)" if i: "i < n" for i
  proof -
    have "cnt i = length [y\<leftarrow>delete_index i xs. (y, xs ! i) \<in> R]" by (simp add: cnt_def)
    also have "\<dots> = card (set [y\<leftarrow>delete_index i xs. (y, xs ! i) \<in> R])"
      by (intro distinct_card [symmetric] distinct_filter distinct_delete_index "1.prems")
    also have "set [y\<leftarrow>delete_index i xs. (y, xs ! i) \<in> R] =
                      {x \<in> set xs-{xs!i}. (x, xs ! i) \<in> R}"
      using "1.prems" and i by (simp add: set_delete_index_distinct n_def)
    also have "card \<dots> = linorder_rank R (set xs) (xs ! i)" by (simp add: linorder_rank_def)
    finally show ?thesis .
  qed

  from "1.prems" have "bij_betw ((!) xs) {..<n} (set xs)"
    by (intro bij_betw_byWitness[where f' = "index xs"]) (auto simp: n_def index_nth_id)
  moreover have "bij_betw (linorder_rank R (set xs)) (set xs) {..<card (set xs)}"
    using assms(1) by (rule bij_betw_linorder_rank) (insert "1.prems", auto)
  ultimately have "bij_betw (linorder_rank R (set xs) \<circ> (\<lambda>i. xs ! i)) {..<n} {..<card (set xs)}"
    by (rule bij_betw_trans)
  hence bij: "bij_betw (\<lambda>i. linorder_rank R (set xs) (xs ! i)) {..<n} {..<n}"
    using "1.prems" by (simp add: n_def o_def distinct_card)

  show ?case
  proof (cases "xs = []")
    case False
    hence "n > 0" by (simp add: n_def)
    hence [simp]: "n \<noteq> 0" by (intro notI) auto
    from False have "map_pmf snd (rquicksort R xs) =
             pmf_of_set {..<length xs} \<bind>
               (\<lambda>i. map_pmf (\<lambda>z. length xs - 1 + fst z + snd z)
                  (pair_pmf (map_pmf snd (rquicksort R [y\<leftarrow>delete_index i xs. (y, xs ! i) \<in> R]))
                            (map_pmf snd (rquicksort R [y\<leftarrow>delete_index i xs. (y, xs ! i) \<notin> R]))))"
      by (subst rquicksort.simps)
         (simp add: map_bind_pmf bind_map_pmf Let_def case_prod_unfold o_def pair_pmf_def)
    also have "\<dots> = pmf_of_set {..<length xs} \<bind>
                      (\<lambda>i. map_pmf (\<lambda>z. n - 1 + fst z + snd z)
                         (pair_pmf (rqs_cost (cnt i)) (rqs_cost (n - 1 - cnt i))))"
    proof (intro bind_pmf_cong refl, goal_cases)
      case (1 i)
      with \<open>xs \<noteq> []\<close> have i: "i < length xs" by auto
      from i have "map_pmf snd (rquicksort R [y\<leftarrow>delete_index i xs. (y, xs ! i) \<notin> R]) =
                              rqs_cost (length [y\<leftarrow>delete_index i xs. (y, xs ! i) \<notin> R])"
        by (intro IH)
           (auto intro!: le_less_trans[OF length_filter_le] simp: mset_filter
                 intro: subset_mset.order.trans multiset_filter_subset diff_subset_eq_self)
      also have "length [y\<leftarrow>delete_index i xs. (y, xs ! i) \<notin> R] = n - 1 - cnt i"
        unfolding n_def cnt_def
        using sum_length_filter_compl[of "\<lambda>y. (y, xs ! i) \<in> R" "delete_index i xs"] i by simp
      finally have "map_pmf snd (rquicksort R [y\<leftarrow>delete_index i xs. (y, xs ! i) \<notin> R]) =
                      rqs_cost (n - 1 - cnt i)" .
      moreover have "map_pmf snd (rquicksort R [y\<leftarrow>delete_index i xs. (y, xs ! i) \<in> R]) =
                       rqs_cost (cnt i)" unfolding cnt_def using i
        by (intro IH)
           (auto intro!: le_less_trans[OF length_filter_le] simp: mset_filter
                 intro: subset_mset.order.trans multiset_filter_subset diff_subset_eq_self)
      ultimately show ?case by (simp only: n_def)
    qed
    also have "\<dots> = map_pmf cnt (pmf_of_set {..<n}) \<bind>
          (\<lambda>i. map_pmf (\<lambda>z. n - 1 + fst z + snd z) (pair_pmf (rqs_cost i) (rqs_cost (n - 1 - i))))"
      (is "_ = bind_pmf _ ?f") by (simp add: bind_map_pmf n_def)
    also have "map_pmf cnt (pmf_of_set {..<n}) =
                 map_pmf (\<lambda>i. linorder_rank R (set xs) (xs ! i)) (pmf_of_set {..<n})"
      using \<open>n > 0\<close> by (intro map_pmf_cong refl, subst (asm) set_pmf_of_set) (auto simp: cnt_altdef)
    also from \<open>n > 0\<close> have "\<dots> = pmf_of_set {..<n}" by (intro map_pmf_of_set_bij_betw bij) auto
    also have "pmf_of_set {..<n} \<bind> ?f = rqs_cost n"
      by (cases n) (simp_all add: lessThan_Suc_atMost bind_map_pmf map_bind_pmf pair_pmf_def)
    finally show ?thesis by (simp add: n_def)
  qed simp_all
qed

subsection \<open>Expected cost\<close>

text \<open>
  It is relatively straightforward to see that the following recursive function
  (sometimes called the `QuickSort equation') describes the expectation of @{const rqs_cost},
  i.e. the expected number of comparisons of QuickSort when run on a list with distinct elements.
\<close>
fun rqs_cost_exp :: "nat \<Rightarrow> real" where
  "rqs_cost_exp 0 = 0"
| "rqs_cost_exp (Suc n) = real n + (\<Sum>i\<le>n. rqs_cost_exp i + rqs_cost_exp (n - i)) / real (Suc n)"

lemmas rqs_cost_exp_0 = rqs_cost_exp.simps(1)
lemmas rqs_cost_exp_Suc [simp del] = rqs_cost_exp.simps(2)
lemma rqs_cost_exp_Suc_0 [simp]: "rqs_cost_exp (Suc 0) = 0" by (simp add: rqs_cost_exp_Suc)

text \<open>
  The following theorem shows that @{const rqs_cost_exp} is indeed the expectation of
  @{const rqs_cost}.
\<close>
theorem expectation_rqs_cost: "measure_pmf.expectation (rqs_cost n) real = rqs_cost_exp n"
proof (induction n rule: rqs_cost.induct)
  case (2 n)
  note IH = "2.IH"
  have "measure_pmf.expectation (rqs_cost (Suc n)) real =
          (\<Sum>a\<le>n. inverse (real (Suc n)) *
              measure_pmf.expectation (rqs_cost a \<bind> (\<lambda>aa. rqs_cost (n - a) \<bind>
                 (\<lambda>b. return_pmf (n + aa + b)))) real)"
    unfolding rqs_cost.simps by (subst pmf_expectation_bind_pmf_of_set) auto
  also have "\<dots> = (\<Sum>i\<le>n. inverse (real (Suc n)) * (real n + rqs_cost_exp i + rqs_cost_exp (n - i)))"
  proof (intro sum.cong refl, goal_cases)
    case (1 i)
    have "rqs_cost i \<bind> (\<lambda>a. rqs_cost (n - i) \<bind> (\<lambda>b. return_pmf (n + a + b))) =
            map_pmf (\<lambda>(a,b). n + a + b) (pair_pmf (rqs_cost i) (rqs_cost (n - i)))"
      by (simp add: pair_pmf_def map_bind_pmf)
    also have "measure_pmf.expectation \<dots> real =
                 measure_pmf.expectation (pair_pmf (rqs_cost i) (rqs_cost (n - i)))
                   (\<lambda>z. real n + (real (fst z) + real (snd z)))"
      by (subst integral_map_pmf) (simp add: case_prod_unfold add_ac)
    also have "\<dots> = real n + measure_pmf.expectation (pair_pmf (rqs_cost i) (rqs_cost (n - i)))
                      (\<lambda>z. real (fst z) + real (snd z))" (is "_ = _ + ?A")
      by (subst Bochner_Integration.integral_add) (auto intro!: integrable_measure_pmf_finite)
    also have "?A = measure_pmf.expectation (map_pmf fst (pair_pmf (rqs_cost i) (rqs_cost (n - i)))) real +
                    measure_pmf.expectation (map_pmf snd (pair_pmf (rqs_cost i) (rqs_cost (n - i)))) real"
      unfolding integral_map_pmf
      by (subst Bochner_Integration.integral_add) (auto intro!: integrable_measure_pmf_finite)
    also have "\<dots> = measure_pmf.expectation (rqs_cost i) real +
                    measure_pmf.expectation (rqs_cost (n - i)) real"
      unfolding map_fst_pair_pmf map_snd_pair_pmf ..
    also from 1 have "\<dots> = rqs_cost_exp i + rqs_cost_exp (n - i)" by (simp_all add: IH)
    finally show ?case by simp
  qed
  also have "\<dots> = (\<Sum>i\<le>n. inverse (real (Suc n)) * real n) +
                    (\<Sum>i\<le>n. rqs_cost_exp i + rqs_cost_exp (n - i)) / real (Suc n)"
    by (simp add: sum.distrib field_simps sum_distrib_left sum_distrib_right
          sum_divide_distrib [symmetric] del: of_nat_Suc)
  also have "(\<Sum>i\<le>n. inverse (real (Suc n)) * real n) = real n" by simp
  also have "\<dots> + (\<Sum>i\<le>n. rqs_cost_exp i + rqs_cost_exp (n - i)) / real (Suc n) = rqs_cost_exp (Suc n)"
    by (simp add: rqs_cost_exp_Suc)
  finally show ?case .
qed simp_all

text \<open>
  We will now obtain a closed-form solution for @{const rqs_cost_exp}. First of all, we can
  reindex the right-most sum in the recursion step and obtain:
\<close>
lemma rqs_cost_exp_Suc':
  "rqs_cost_exp (Suc n) = real n + 2 / real (Suc n) * (\<Sum>i\<le>n. rqs_cost_exp i)"
proof -
  have "rqs_cost_exp (Suc n) = real n + (\<Sum>i\<le>n. rqs_cost_exp i + rqs_cost_exp (n - i)) / real (Suc n)"
    by (rule rqs_cost_exp_Suc)
  also have "(\<Sum>i\<le>n. rqs_cost_exp i + rqs_cost_exp (n - i)) = (\<Sum>i\<le>n. rqs_cost_exp i) + (\<Sum>i\<le>n. rqs_cost_exp (n - i))"
    by (simp add: sum.distrib)
  also have "(\<Sum>i\<le>n. rqs_cost_exp (n - i)) = (\<Sum>i\<le>n. rqs_cost_exp i)"
    by (intro sum.reindex_bij_witness[of _ "\<lambda>i. n - i" "\<lambda>i. n - i"]) auto
  also have "\<dots> + \<dots> = 2 * \<dots>" by simp
  also have "\<dots> / real (Suc n) = 2 / real (Suc n) * (\<Sum>i\<le>n. rqs_cost_exp i)" by simp
  finally show ?thesis .
qed

text \<open>
  Next, we can apply some standard techniques to transform this equation into a simple
  linear recurrence, which we can then solve easily in terms of harmonic numbers:
\<close>
theorem rqs_cost_exp_eq [code]: "rqs_cost_exp n = 2 * real (n + 1) * harm n - 4 * real n"
proof -
  define F where "F = (\<lambda>n. rqs_cost_exp n / (real n + 1))"
  have [simp]: "F 0 = 0" "F (Suc 0) = 0" by (simp_all add: F_def)
  have F_Suc: "F (Suc m) = F m + real (2*m) / (real ((m+1)*(m+2)))" if "m > 0" for m
  proof (cases m)
    case (Suc n)
    have A: "rqs_cost_exp (Suc (Suc n)) * real (Suc (Suc n)) =
            real ((n+1)*(n+2)) + 2 * (\<Sum>i\<le>n. rqs_cost_exp i) + 2 * rqs_cost_exp (Suc n)"
      by (subst rqs_cost_exp_Suc') (simp_all add: field_simps)
    have B: "rqs_cost_exp (Suc n) * real (Suc n) = real (n*(n+1)) + 2 * (\<Sum>i\<le>n. rqs_cost_exp i)"
      by (subst rqs_cost_exp_Suc') (simp_all add: field_simps)
    have "rqs_cost_exp (Suc (Suc n)) * real (Suc (Suc n)) - rqs_cost_exp (Suc n) * real (Suc n) =
            real ((n+1)*(n+2)) - real (n*(n+1)) + 2 * rqs_cost_exp (Suc n)"
      by (subst A, subst B) simp_all
    also have "real ((n+1)*(n+2)) - real (n*(n+1)) = real (2*(n+1))" by simp
    finally have "rqs_cost_exp (Suc (Suc n)) * real (n+2) = rqs_cost_exp (Suc n) * real (n+3) + real (2*(n+1))"
      by (simp add: algebra_simps)
    hence "rqs_cost_exp (Suc (Suc n)) / real (n+3) =
             rqs_cost_exp (Suc n) / real (n+2) + real (2*(n+1)) / (real (n+2)*real (n+3))"
      by (simp add: divide_simps del: of_nat_Suc of_nat_add)
    thus ?thesis by (simp add: F_def algebra_simps Suc)
  qed simp_all

  have F_eq: "F n = 2 * (\<Sum>k=1..n. real (k - 1) / real (k * (k + 1)))" for n
  proof (cases "n \<ge> 1")
    case True
    thus ?thesis by (induction n rule: dec_induct) (simp_all add: F_Suc algebra_simps)
  qed (simp_all add: not_le)

  have "F n = 2 * (\<Sum>k=1..n. real (k - 1) / real (k * (k + 1)))" (is "_ = 2 * ?S") by (fact F_eq)
  also have "?S = (\<Sum>k=1..n. 2 / real (Suc k) - 1 / real k)"
    by (intro sum.cong) (simp_all add: field_simps of_nat_diff)
  also have "\<dots> = 2 * (\<Sum>k=1..n. inverse (real (Suc k))) - harm n"
    by (subst sum_subtractf) (simp add: harm_def sum.distrib sum_distrib_left divide_simps)
  also have "(\<Sum>k=1..n. inverse (real (Suc k))) = (\<Sum>k=Suc 1..Suc n. inverse (real k))"
    by (intro sum.reindex_bij_witness[of _ "\<lambda>x. x - 1" Suc]) auto
  also have "\<dots> = harm (Suc n) - 1" unfolding harm_def by (subst (2) sum.atLeast_Suc_atMost) simp_all
  finally have "F n = 2 * harm n + 4 * (1 / (n + 1) - 1)" by (simp add: harm_Suc field_simps)
  also have "\<dots> * real (n + 1) = 2 * real (n + 1) * harm n - 4 * real n"
    by (simp add: field_simps)
  also have "F n * real (n + 1) = rqs_cost_exp n" by (simp add: F_def add_ac)
  finally show ?thesis .
qed

(* TODO Move *)
lemma asymp_equiv_harm [asymp_equiv_intros]: "harm \<sim>[at_top] (\<lambda>n. ln (real n))"
proof -
  have "(\<lambda>n. harm n - ln (real n)) \<in> O(\<lambda>_. 1)" using euler_mascheroni_LIMSEQ
    by (intro bigoI_tendsto[where c = euler_mascheroni]) simp_all
  also have "(\<lambda>_. 1) \<in> o(\<lambda>n. ln (real n))" by auto
  finally have "(\<lambda>n. ln (real n) + (harm n - ln (real n))) \<sim>[at_top] (\<lambda>n. ln (real n))"
    by (subst asymp_equiv_add_right) simp_all
  thus ?thesis by simp
qed

corollary rqs_cost_exp_asymp_equiv: "rqs_cost_exp \<sim>[at_top] (\<lambda>n. 2 * n * ln n)"
proof -
  have "rqs_cost_exp = (\<lambda>n. 2 * real (n + 1) * harm n - 4 * real n)" using rqs_cost_exp_eq ..
  also have "\<dots> = (\<lambda>n. 2 * real n * harm n + (2 * harm n - 4 * real n))"
    by (simp add: algebra_simps)
  finally have "rqs_cost_exp \<sim>[at_top] \<dots>" by simp
  also have "\<dots> \<sim>[at_top] (\<lambda>n. 2 * real n * harm n)"
  proof (subst asymp_equiv_add_right)
    have "(\<lambda>x. 1 * harm x) \<in> o(\<lambda>x. real x * harm x)"
      by (intro landau_o.small_big_mult smallo_real_nat_transfer) simp_all
    moreover have "harm \<in> \<omega>(\<lambda>_. 1 :: real)"
      by (intro smallomegaI_filterlim_at_top_norm) (auto simp: harm_at_top)
    hence "(\<lambda>x. real x * 1) \<in> o(\<lambda>x. real x * harm x)"
      by (intro landau_o.big_small_mult) (simp_all add: smallomega_iff_smallo)
    ultimately show "(\<lambda>n. 2 * harm n - 4 * real n) \<in> o(\<lambda>n. 2 * real n * harm n)"
      by (intro sum_in_smallo) simp_all
  qed simp_all
  also have "\<dots> \<sim>[at_top] (\<lambda>n. 2 * real n * ln (real n))" by (intro asymp_equiv_intros)
  finally show ?thesis .
qed

lemma harm_mono: "m \<le> n \<Longrightarrow> harm m \<le> (harm n :: real)"
  unfolding harm_def by (intro sum_mono2) auto

lemma harm_Suc_0 [simp]: "harm (Suc 0) = 1"
  by (simp add: harm_def)

lemma harm_ge_1: "n > 0 \<Longrightarrow> harm n \<ge> (1::real)"
  using harm_mono[of 1 n] by simp

lemma mono_rqs_cost_exp: "mono rqs_cost_exp"
proof (rule incseq_SucI)
  fix n show "rqs_cost_exp n \<le> rqs_cost_exp (Suc n)"
  proof (cases "n = 0")
    case False
    have "0 < (1 * 2 * (real n + 1) - 2 * real n) / (real n + 1)" by simp
    also have "\<dots> \<le> (harm n * 2 * (real n + 1) - 2 * real n) / (real n + 1)" using False
      by (intro divide_right_mono diff_right_mono mult_right_mono) (auto simp: harm_ge_1)
    also have "\<dots> = rqs_cost_exp (Suc n) - rqs_cost_exp n"
      by (simp add: rqs_cost_exp_eq harm_Suc field_simps)
    finally show ?thesis by simp
  qed auto
qed

lemma rqs_cost_exp_leI: "m \<le> n \<Longrightarrow> rqs_cost_exp m \<le> rqs_cost_exp n"
  using mono_rqs_cost_exp by (simp add: mono_def)

subsection \<open>Version for lists with repeated elements\<close>

definition threeway_partition where
  "threeway_partition x R xs =
     (filter (\<lambda>y. (y,x) \<in> R \<and> (x,y) \<notin> R) xs,
      filter (\<lambda>y. (x,y) \<in> R \<and> (y,x) \<in> R) xs,
      filter (\<lambda>y. (x,y) \<in> R \<and> (y,x) \<notin> R) xs)"

text \<open>
  The following version of randomised Quicksort uses a three-way partitioning function
  in order to also achieve expected logarithmic running time on lists with repeated elements.
\<close>
function rquicksort' :: "('a \<times> 'a) set \<Rightarrow> 'a list \<Rightarrow> ('a list \<times> nat) pmf" where
  "rquicksort' R xs =
     (if xs = [] then
        return_pmf ([], 0)
      else
        do {
          i \<leftarrow> pmf_of_set {..<length xs};
          let x = xs ! i;
          case threeway_partition x R (delete_index i xs) of
            (ls, es, rs) \<Rightarrow> do {
              (ls, n1) \<leftarrow> rquicksort' R ls;
              (rs, n2) \<leftarrow> rquicksort' R rs;
              return_pmf (ls @ x # es @ rs, length xs - 1 + n1 + n2)
            }
        })"
  by auto
termination proof (relation "Wellfounded.measure (length \<circ> snd)", goal_cases)
  show "wf (Wellfounded.measure (length \<circ> snd))" by simp
qed (subst (asm) set_pmf_of_set;
     force intro!: le_less_trans[OF length_filter_le] simp: threeway_partition_def)+

declare rquicksort'.simps [simp del]

lemma rquicksort'_Nil [simp]: "rquicksort' R [] = return_pmf ([], 0)"
  by (simp add: rquicksort'.simps)

context
begin

qualified definition lesss :: "('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "lesss R x xs = filter (\<lambda>y. (y, x) \<in> R \<and> (x, y) \<notin> R) xs"

qualified definition greaters :: "('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "greaters R x xs = filter (\<lambda>y. (x, y) \<in> R \<and> (y, x) \<notin> R) xs"

qualified lemma lesss_Cons:
  "lesss R x (y # ys) =
     (if (y, x) \<in> R \<and> (x, y) \<notin> R then y # lesss R x ys else lesss R x ys)"
  by (simp add: lesss_def)

qualified lemma length_lesss_le [intro]: "length (lesss R x xs) \<le> length xs"
  by (simp add: lesss_def)

qualified lemma length_lesss_less [intro]:
  assumes "x \<in> set xs"
  shows   "length (lesss R x xs) < length xs"
  using assms by (induction xs) (auto simp: lesss_Cons intro: le_less_trans)

qualified lemma greaters_Cons:
  "greaters R x (y # ys) =
     (if (x, y) \<in> R \<and> (y, x) \<notin> R then y # greaters R x ys else greaters R x ys)"
  by (simp add: greaters_def)

qualified lemma length_greaters_le [intro]: "length (greaters R x xs) \<le> length xs"
  by (simp add: greaters_def)

qualified lemma length_greaters_less [intro]:
  assumes "x \<in> set xs"
  shows   "length (greaters R x xs) < length xs"
  using assms by (induction xs) (auto simp: greaters_Cons intro: le_less_trans)

text \<open>
  The following function counts the comparisons made by the modified randomised Quicksort.
\<close>
function rqs'_cost :: "('a \<times> 'a) set \<Rightarrow> 'a list \<Rightarrow> nat pmf" where
  "rqs'_cost R xs =
     (if xs = [] then
        return_pmf 0
      else
        do {
          i \<leftarrow> pmf_of_set {..<length xs};
          let x = xs ! i;
          map_pmf (\<lambda>(n1,n2). length xs - 1 + n1 + n2)
            (pair_pmf (rqs'_cost R (lesss R x xs)) (rqs'_cost R (greaters R x xs)))
        })"
  by auto
termination by (relation "Wellfounded.measure (length \<circ> snd)") auto

declare rqs'_cost.simps [simp del]

lemma rqs'_cost_nonempty:
  "xs \<noteq> [] \<Longrightarrow> rqs'_cost R xs =
     do {
       i \<leftarrow> pmf_of_set {..<length xs};
       let x = xs ! i;
       n1 \<leftarrow> rqs'_cost R (lesss R x xs);
       n2 \<leftarrow> rqs'_cost R (greaters R x xs);
       return_pmf (length xs - 1 + n1 + n2)
     }"
  by (subst rqs'_cost.simps) (auto simp: pair_pmf_def Let_def map_bind_pmf)

lemma finite_set_pmf_rqs'_cost [simp, intro]:
  "finite (set_pmf (rqs'_cost R xs))"
  by (induction R xs rule: rqs'_cost.induct) (auto simp: rqs'_cost.simps Let_def)

(* TODO: Move? *)
lemma expectation_pair_pmf_fst [simp]:
  fixes f :: "'a \<Rightarrow> 'b::{banach, second_countable_topology}"
  shows "measure_pmf.expectation (pair_pmf p q) (\<lambda>x. f (fst x)) = measure_pmf.expectation p f"
proof -
  have "measure_pmf.expectation (pair_pmf p q) (\<lambda>x. f (fst x)) =
          measure_pmf.expectation (map_pmf fst (pair_pmf p q)) f" by simp
  also have "map_pmf fst (pair_pmf p q) = p"
    by (simp add: map_fst_pair_pmf)
  finally show ?thesis .
qed

lemma expectation_pair_pmf_snd [simp]:
  fixes f :: "'a \<Rightarrow> 'b::{banach, second_countable_topology}"
  shows "measure_pmf.expectation (pair_pmf p q) (\<lambda>x. f (snd x)) = measure_pmf.expectation q f"
proof -
  have "measure_pmf.expectation (pair_pmf p q) (\<lambda>x. f (snd x)) =
          measure_pmf.expectation (map_pmf snd (pair_pmf p q)) f" by simp
  also have "map_pmf snd (pair_pmf p q) = q"
    by (simp add: map_snd_pair_pmf)
  finally show ?thesis .
qed

qualified lemma length_lesss_le_sorted:
  assumes "sorted_wrt R xs" "i < length xs"
  shows   "length (lesss R (xs ! i) xs) \<le> i"
  using assms by (induction arbitrary: i rule: sorted_wrt.induct)
                 (force simp: lesss_def nth_Cons le_Suc_eq split: nat.splits)+

qualified lemma length_greaters_le_sorted:
  assumes "sorted_wrt R xs" "i < length xs"
  shows   "length (greaters R (xs ! i) xs) \<le> length xs - i - 1"
  using assms
  by (induction arbitrary: i rule: sorted_wrt.induct)
     (force simp: greaters_def nth_Cons le_Suc_eq split: nat.splits)+

qualified lemma length_lesss_le':
  assumes "i < length xs" "linorder_on A R" "set xs \<subseteq> A"
  shows   "length (lesss R (insort_wrt R xs ! i) xs) \<le> i"
proof -
  define x where "x = insort_wrt R xs ! i"
  define less where "less = (\<lambda>x y. (x,y) \<in> R \<and> (y,x) \<notin> R)"
  have "length (lesss R x xs) = size {# y \<in># mset xs. less y x #}"
    by (simp add: lesss_def size_mset [symmetric] less_def mset_filter del: size_mset)
  also have "mset xs = mset (insort_wrt R xs)" by simp
  also have "size {#y \<in># mset (insort_wrt R xs). less y x#} =
               length (lesss R x (insort_wrt R xs))"
    by (simp only: mset_filter [symmetric] size_mset lesss_def less_def)
  also have "\<dots> \<le> i" unfolding x_def by (rule length_lesss_le_sorted) (use assms in auto)
  finally show ?thesis unfolding x_def .
qed

qualified lemma length_greaters_le':
  assumes "i < length xs" "linorder_on A R" "set xs \<subseteq> A"
  shows   "length (greaters R (insort_wrt R xs ! i) xs) \<le> length xs - i - 1"
proof -
  define x where "x = insort_wrt R xs ! i"
  define less where "less = (\<lambda>x y. (x,y) \<in> R \<and> (y,x) \<notin> R)"
  have "length (greaters R x xs) = size {# y \<in># mset xs. less x y #}"
    by (simp add: greaters_def size_mset [symmetric] less_def mset_filter del: size_mset)
  also have "mset xs = mset (insort_wrt R xs)" by simp
  also have "size {#y \<in># mset (insort_wrt R xs). less x y#} =
               length (greaters R x (insort_wrt R xs))"
    by (simp only: mset_filter [symmetric] size_mset greaters_def less_def)
  also have "\<dots> \<le> length (insort_wrt R xs) - i - 1" unfolding x_def
    by (rule length_greaters_le_sorted) (use assms in auto)
  finally show ?thesis unfolding x_def by simp
qed

text \<open>
  We can show quite easily that the expected number of comparisons in this modified
  QuickSort is bounded above by the expected number of comparisons on a list of the same length
  with no repeated elements.
\<close>
theorem rqs'_cost_expectation_le:
  assumes "linorder_on A R" "set xs \<subseteq> A"
  shows   "measure_pmf.expectation (rqs'_cost R xs) real \<le> rqs_cost_exp (length xs)"
  using assms
proof (induction R xs rule: rqs'_cost.induct)
  case (1 R xs)
  show ?case
  proof (cases "xs = []")
    case False
    define n where "n = length xs - 1"
    have length_eq: "length xs = Suc n" using False by (simp add: n_def)
    define E where "E = (\<lambda>xs. measure_pmf.expectation (rqs'_cost R xs) real)"
    define f where "f = (\<lambda>x. rqs_cost_exp (length (lesss R x xs)) +
                                rqs_cost_exp (length (greaters R x xs)))"
    have "rqs'_cost R xs =
            do {
              i \<leftarrow> pmf_of_set {..<length xs};
              map_pmf (\<lambda>(n1, y). length xs - Suc 0 + n1 + y)
                (pair_pmf (rqs'_cost R (lesss R (xs ! i) xs))
                          (rqs'_cost R (greaters R (xs ! i) xs)))
            }"
      using False by (subst rqs'_cost.simps) (simp_all add: Let_def)
    also have "measure_pmf.expectation \<dots> real = real n +
           (\<Sum>k<length xs. E (lesss R (xs ! k) xs) + E (greaters R (xs ! k) xs)) / real (length xs)"
      using False
      by (subst pmf_expectation_bind_pmf_of_set)
         (auto intro!: finite_imageI finite_cartesian_product simp: case_prod_unfold
            integrable_measure_pmf_finite sum_divide_distrib [symmetric] field_simps
            length_eq sum.distrib E_def)
    also have "\<dots> \<le> real n + (\<Sum>k<length xs. f (xs ! k)) / real (length xs)"
      unfolding E_def f_def using False "1.prems"
      by (intro add_mono order.refl divide_right_mono sum_mono "1.IH"[OF _ _ refl] False)
         (auto simp: lesss_def greaters_def)
    also have "(\<Sum>k<length xs. f (xs ! k)) = (\<Sum>x\<in>#mset xs. f x)"
      by (simp only: mset_map [symmetric] sum_mset_sum_list sum_list_sum_nth)
         (simp_all add: atLeast0LessThan)
    also have "mset xs = mset (insort_wrt R xs)"
      by simp
    also have "(\<Sum>x\<in>#\<dots>. f x) = (\<Sum>i<length xs. f (insort_wrt R xs ! i))"
      by (simp only: mset_map [symmetric] sum_mset_sum_list sum_list_sum_nth)
         (simp_all add: atLeast0LessThan)
    also have "\<dots> \<le> (\<Sum>i<length xs. rqs_cost_exp i + rqs_cost_exp (length xs - i - 1))"
      unfolding f_def
    proof (intro sum_mono add_mono rqs_cost_exp_leI)
      fix i assume i: "i \<in> {..<length xs}"
      show "length (lesss R (insort_wrt R xs ! i) xs) \<le> i"
        using i "1.prems" by (intro length_lesss_le'[where A = A]) auto
      show "length (greaters R (insort_wrt R xs ! i) xs) \<le> length xs - i - 1"
        using i "1.prems" by (intro length_greaters_le'[where A = A]) auto
    qed
    also have "\<dots> = (\<Sum>i\<le>n. rqs_cost_exp i + rqs_cost_exp (n - i))"
      by (intro sum.cong) (auto simp: length_eq)
    also have "real n + \<dots> / real (length xs) = rqs_cost_exp (length xs)"
      by (simp add: length_eq rqs_cost_exp.simps(2))
    finally show ?thesis by (simp add: divide_right_mono)
  qed (auto simp: rqs'_cost.simps)
qed

end
end