theory predicate_logic_examples_isar
imports Main
begin

(* lemma ex1: "A \<Rightarrow>(B \<Rightarrow> (A \<and> B)))" *)

thm conjI (* \<lbrakk>?P; ?Q\<rbrakk> \<Longrightarrow> ?P \<and> ?Q *)
lemma
  shows "\<lbrakk>A;B\<rbrakk> \<Longrightarrow> (A \<and> B)"
proof -
  assume A: A
  assume B: B
  from A B show "A \<and> B" by (rule conjI)
qed

(* Your turn 1 *)

lemma
  shows "A \<longrightarrow> (A \<or> B)"
proof (rule impI)
  show "A \<Longrightarrow> (A \<or> B)" by (rule disjI1)
qed

lemma
  shows "A \<longrightarrow> (A \<or> B)"
proof (rule impI)
  assume A: A
  from A show "(A \<or> B)" by (rule disjI1)
qed

(* Example 4: (A \<Rightarrow> B) \<Rightarrow> ((B \<Rightarrow> C) \<Rightarrow> (A \<Rightarrow> C)) *)

thm impI (* (?P \<Longrightarrow> ?Q) \<Longrightarrow> ?P \<longrightarrow> ?Q *)
thm impE (* \<lbrakk>?P \<longrightarrow> ?Q; ?P; ?Q \<Longrightarrow> ?R\<rbrakk> \<Longrightarrow> ?R *)
lemma
  shows "(A \<Longrightarrow> B) \<Longrightarrow> ((B \<Longrightarrow> C) \<Longrightarrow> (A \<Longrightarrow> C))"
proof -
  assume A2B: "A\<Longrightarrow>B"
  assume B2C: "B\<Longrightarrow>C"
  assume A: "A"
  from A2B have A22B: "A\<longrightarrow>B" by (rule impI)
  from B2C have A22C: "B\<longrightarrow>C" by (rule impI)
  have B: "B" proof -
    from A22B A show "B" by (rule impE) qed
  show "C" proof -
    from A22C B show "C" by (rule impE) qed
qed

(* Your turn 2:  (A \<and> B) \<Rightarrow> (A \<or> B) *)

thm conjE (* \<lbrakk>?P \<and> ?Q; \<lbrakk>?P; ?Q\<rbrakk> \<Longrightarrow> ?R\<rbrakk> \<Longrightarrow> ?R *)
lemma
  shows "A \<and> B \<longrightarrow> A \<or> B"
proof (rule impI)
  assume AnB: "A \<and> B"
  have AB2ArB: "A \<Longrightarrow> B \<Longrightarrow> A \<or> B" by (rule disjI1)
  from AnB AB2ArB show "A \<or> B" by (rule conjE)
qed

end


theory "Set-Cpo"
imports "~~/src/HOL/HOLCF/HOLCF"
begin

default_sort type

instantiation set :: (type) below
begin
  definition below_set where "op \<sqsubseteq> = op \<subseteq>"
instance..
end

instance set :: (type) po
  by standard (auto simp add: below_set_def)

lemma is_lub_set:
  "S <<| \<Union>S"
  by(auto simp add: is_lub_def below_set_def is_ub_def)

lemma lub_set: "lub S = \<Union>S"
  by (metis is_lub_set lub_eqI)

instance set  :: (type) cpo
  by standard (rule exI, rule is_lub_set)

lemma minimal_set: "{} \<sqsubseteq> S"
  unfolding below_set_def by simp

instance set  :: (type) pcpo
  by standard (rule+, rule minimal_set)

lemma set_contI:
  assumes  "\<And> Y. chain Y \<Longrightarrow> f (\<Squnion> i. Y i) = \<Union> (f ` range Y)"
  shows "cont f"
proof(rule contI)
  fix Y :: "nat \<Rightarrow> 'a"
  assume "chain Y"
  hence "f (\<Squnion> i. Y i) = \<Union> (f ` range Y)" by (rule assms)
  also have "\<dots> = \<Union> (range (\<lambda>i. f (Y i)))" by simp
  finally
  show "range (\<lambda>i. f (Y i)) <<| f (\<Squnion> i. Y i)" using is_lub_set by metis
qed

lemma set_set_contI:
  assumes  "\<And> S. f (\<Union>S) = \<Union> (f ` S)"
  shows "cont f"
  by (metis set_contI assms is_lub_set  lub_eqI)

lemma adm_subseteq[simp]:
  assumes "cont f"
  shows "adm (\<lambda>a. f a \<subseteq> S)"
by (rule admI)(auto simp add: cont2contlubE[OF assms] lub_set)

lemma adm_Ball[simp]: "adm (\<lambda>S. \<forall>x\<in>S. P x)"
  by (auto intro!: admI  simp add: lub_set)

lemma finite_subset_chain:
  fixes Y :: "nat \<Rightarrow> 'a set"
  assumes "chain Y"
  assumes "S \<subseteq> UNION UNIV Y"
  assumes "finite S"
  shows "\<exists>i. S \<subseteq> Y i"
proof-
  from assms(2)
  have "\<forall>x \<in> S. \<exists> i. x \<in> Y i" by auto
  then obtain f where f: "\<forall> x\<in> S. x \<in> Y (f x)" by metis

  def i \<equiv> "Max (f ` S)"
  from `finite S`
  have "finite (f ` S)" by simp
  hence "\<forall> x\<in>S. f x \<le> i" unfolding i_def by auto
  with chain_mono[OF `chain Y`]
  have "\<forall> x\<in>S. Y (f x) \<subseteq> Y i" by (auto simp add: below_set_def)
  with f
  have "S \<subseteq> Y i" by auto
  thus ?thesis..
qed

lemma diff_cont[THEN cont_compose, simp, cont2cont]:
  fixes S' :: "'a set"
  shows  "cont (\<lambda>S. S - S')"
by (rule set_set_contI) simp

end


(*<*)
theory Nested imports ABexpr begin
(*>*)

text{*
\index{datatypes!and nested recursion}%
So far, all datatypes had the property that on the right-hand side of their
definition they occurred only at the top-level: directly below a
constructor. Now we consider \emph{nested recursion}, where the recursive
datatype occurs nested in some other datatype (but not inside itself!).
Consider the following model of terms
where function symbols can be applied to a list of arguments:
*}
(*<*)hide_const Var(*>*)
datatype ('v,'f)"term" = Var 'v | App 'f "('v,'f)term list"

text{*\noindent
Note that we need to quote @{text term} on the left to avoid confusion with
the Isabelle command \isacommand{term}.
Parameter @{typ"'v"} is the type of variables and @{typ"'f"} the type of
function symbols.
A mathematical term like $f(x,g(y))$ becomes @{term"App f [Var x, App g
  [Var y]]"}, where @{term f}, @{term g}, @{term x}, @{term y} are
suitable values, e.g.\ numbers or strings.

What complicates the definition of @{text term} is the nested occurrence of
@{text term} inside @{text list} on the right-hand side. In principle,
nested recursion can be eliminated in favour of mutual recursion by unfolding
the offending datatypes, here @{text list}. The result for @{text term}
would be something like
\medskip

\input{unfoldnested.tex}
\medskip

\noindent
Although we do not recommend this unfolding to the user, it shows how to
simulate nested recursion by mutual recursion.
Now we return to the initial definition of @{text term} using
nested recursion.

Let us define a substitution function on terms. Because terms involve term
lists, we need to define two substitution functions simultaneously:
*}

primrec
subst :: "('v\<Rightarrow>('v,'f)term) \<Rightarrow> ('v,'f)term      \<Rightarrow> ('v,'f)term" and
substs:: "('v\<Rightarrow>('v,'f)term) \<Rightarrow> ('v,'f)term list \<Rightarrow> ('v,'f)term list"
where
"subst s (Var x) = s x" |
  subst_App:
"subst s (App f ts) = App f (substs s ts)" |

"substs s [] = []" |
"substs s (t # ts) = subst s t # substs s ts"

text{*\noindent
Individual equations in a \commdx{primrec} definition may be
named as shown for @{thm[source]subst_App}.
The significance of this device will become apparent below.

Similarly, when proving a statement about terms inductively, we need
to prove a related statement about term lists simultaneously. For example,
the fact that the identity substitution does not change a term needs to be
strengthened and proved as follows:
*}

lemma subst_id(*<*)(*referred to from ABexpr*)(*>*): "subst  Var t  = (t ::('v,'f)term)  \<and>
                  substs Var ts = (ts::('v,'f)term list)"
apply(induct_tac t and ts rule: subst.induct substs.induct, simp_all)
done

text{*\noindent
Note that @{term Var} is the identity substitution because by definition it
leaves variables unchanged: @{prop"subst Var (Var x) = Var x"}. Note also
that the type annotations are necessary because otherwise there is nothing in
the goal to enforce that both halves of the goal talk about the same type
parameters @{text"('v,'f)"}. As a result, induction would fail
because the two halves of the goal would be unrelated.

\begin{exercise}
The fact that substitution distributes over composition can be expressed
roughly as follows:
@{text[display]"subst (f \<circ> g) t = subst f (subst g t)"}
Correct this statement (you will find that it does not type-check),
strengthen it, and prove it. (Note: @{text"\<circ>"} is function composition;
its definition is found in theorem @{thm[source]o_def}).
\end{exercise}
\begin{exercise}\label{ex:trev-trev}
  Define a function @{term trev} of type @{typ"('v,'f)term => ('v,'f)term"}
that recursively reverses the order of arguments of all function symbols in a
  term. Prove that @{prop"trev(trev t) = t"}.
\end{exercise}

The experienced functional programmer may feel that our definition of
@{term subst} is too complicated in that @{const substs} is
unnecessary. The @{term App}-case can be defined directly as
@{term[display]"subst s (App f ts) = App f (map (subst s) ts)"}
where @{term"map"} is the standard list function such that
@{text"map f [x1,...,xn] = [f x1,...,f xn]"}. This is true, but Isabelle
insists on the conjunctive format. Fortunately, we can easily \emph{prove}
that the suggested equation holds:
*}
(*<*)
(* Exercise 1: *)
lemma "subst  ((subst f) \<circ> g) t  = subst  f (subst g t) \<and>
       substs ((subst f) \<circ> g) ts = substs f (substs g ts)"
apply (induct_tac t and ts rule: subst.induct substs.induct)
apply (simp_all)
done

(* Exercise 2: *)

primrec trev :: "('v,'f) term \<Rightarrow> ('v,'f) term"
  and trevs:: "('v,'f) term list \<Rightarrow> ('v,'f) term list"
where
  "trev (Var v)    = Var v"
| "trev (App f ts) = App f (trevs ts)"
| "trevs [] = []"
| "trevs (t#ts) = (trevs ts) @ [(trev t)]"

lemma "trev (trev t) = (t::('v,'f)term) \<and>
       trevs (trevs ts) = (ts::('v,'f)term list)"
apply (induct_tac t and ts rule: trev.induct trevs.induct, simp_all)
done
(*>*)

lemma [simp]: "subst s (App f ts) = App f (map (subst s) ts)"
apply(induct_tac ts, simp_all)
done

text{*\noindent
What is more, we can now disable the old defining equation as a
simplification rule:
*}

declare subst_App [simp del]

text{*\noindent The advantage is that now we have replaced @{const
substs} by @{const map}, we can profit from the large number of
pre-proved lemmas about @{const map}.  Unfortunately, inductive proofs
about type @{text term} are still awkward because they expect a
conjunction. One could derive a new induction principle as well (see
\S\ref{sec:derive-ind}), but simpler is to stop using
\isacommand{primrec} and to define functions with \isacommand{fun}
instead.  Simple uses of \isacommand{fun} are described in
\S\ref{sec:fun} below.  Advanced applications, including functions
over nested datatypes like @{text term}, are discussed in a
separate tutorial~@{cite "isabelle-function"}.

Of course, you may also combine mutual and nested recursion of datatypes. For example,
constructor @{text Sum} in \S\ref{sec:datatype-mut-rec} could take a list of
expressions as its argument: @{text Sum}~@{typ[quotes]"'a aexp list"}.
*}
(*<*)end(*>*)


(*  Title:      HOL/Statespace/DistinctTreeProver.thy
    Author:     Norbert Schirmer, TU Muenchen
*)

section \<open>Distinctness of Names in a Binary Tree \label{sec:DistinctTreeProver}\<close>

theory DistinctTreeProver
imports Main
begin

text \<open>A state space manages a set of (abstract) names and assumes
that the names are distinct. The names are stored as parameters of a
locale and distinctness as an assumption. The most common request is
to proof distinctness of two given names. We maintain the names in a
balanced binary tree and formulate a predicate that all nodes in the
tree have distinct names. This setup leads to logarithmic certificates.
\<close>

subsection \<open>The Binary Tree\<close>

datatype 'a tree = Node "'a tree" 'a bool "'a tree" | Tip

text \<open>The boolean flag in the node marks the content of the node as
deleted, without having to build a new tree. We prefer the boolean
flag to an option type, so that the ML-layer can still use the node
content to facilitate binary search in the tree. The ML code keeps the
nodes sorted using the term order. We do not have to push ordering to
the HOL level.\<close>

subsection \<open>Distinctness of Nodes\<close>

primrec set_of :: "'a tree \<Rightarrow> 'a set"
where
  "set_of Tip = {}"
| "set_of (Node l x d r) = (if d then {} else {x}) \<union> set_of l \<union> set_of r"

primrec all_distinct :: "'a tree \<Rightarrow> bool"
where
  "all_distinct Tip = True"
| "all_distinct (Node l x d r) =
    ((d \<or> (x \<notin> set_of l \<and> x \<notin> set_of r)) \<and>
      set_of l \<inter> set_of r = {} \<and>
      all_distinct l \<and> all_distinct r)"

text \<open>Given a binary tree @{term "t"} for which
@{const all_distinct} holds, given two different nodes contained in the tree,
we want to write a ML function that generates a logarithmic
certificate that the content of the nodes is distinct. We use the
following lemmas to achieve this.\<close>

lemma all_distinct_left: "all_distinct (Node l x b r) \<Longrightarrow> all_distinct l"
  by simp

lemma all_distinct_right: "all_distinct (Node l x b r) \<Longrightarrow> all_distinct r"
  by simp

lemma distinct_left: "all_distinct (Node l x False r) \<Longrightarrow> y \<in> set_of l \<Longrightarrow> x \<noteq> y"
  by auto

lemma distinct_right: "all_distinct (Node l x False r) \<Longrightarrow> y \<in> set_of r \<Longrightarrow> x \<noteq> y"
  by auto

lemma distinct_left_right:
    "all_distinct (Node l z b r) \<Longrightarrow> x \<in> set_of l \<Longrightarrow> y \<in> set_of r \<Longrightarrow> x \<noteq> y"
  by auto

lemma in_set_root: "x \<in> set_of (Node l x False r)"
  by simp

lemma in_set_left: "y \<in> set_of l \<Longrightarrow>  y \<in> set_of (Node l x False r)"
  by simp

lemma in_set_right: "y \<in> set_of r \<Longrightarrow>  y \<in> set_of (Node l x False r)"
  by simp

lemma swap_neq: "x \<noteq> y \<Longrightarrow> y \<noteq> x"
  by blast

lemma neq_to_eq_False: "x\<noteq>y \<Longrightarrow> (x=y)\<equiv>False"
  by simp

subsection \<open>Containment of Trees\<close>

text \<open>When deriving a state space from other ones, we create a new
name tree which contains all the names of the parent state spaces and
assume the predicate @{const all_distinct}. We then prove that the new
locale interprets all parent locales. Hence we have to show that the
new distinctness assumption on all names implies the distinctness
assumptions of the parent locales. This proof is implemented in ML. We
do this efficiently by defining a kind of containment check of trees
by ``subtraction''.  We subtract the parent tree from the new tree. If
this succeeds we know that @{const all_distinct} of the new tree
implies @{const all_distinct} of the parent tree.  The resulting
certificate is of the order @{term "n * log(m)"} where @{term "n"} is
the size of the (smaller) parent tree and @{term "m"} the size of the
(bigger) new tree.\<close>

primrec delete :: "'a \<Rightarrow> 'a tree \<Rightarrow> 'a tree option"
where
  "delete x Tip = None"
| "delete x (Node l y d r) = (case delete x l of
                                Some l' \<Rightarrow>
                                 (case delete x r of
                                    Some r' \<Rightarrow> Some (Node l' y (d \<or> (x=y)) r')
                                  | None \<Rightarrow> Some (Node l' y (d \<or> (x=y)) r))
                               | None \<Rightarrow>
                                  (case delete x r of
                                     Some r' \<Rightarrow> Some (Node l y (d \<or> (x=y)) r')
                                   | None \<Rightarrow> if x=y \<and> \<not>d then Some (Node l y True r)
                                             else None))"

lemma delete_Some_set_of: "delete x t = Some t' \<Longrightarrow> set_of t' \<subseteq> set_of t"
proof (induct t arbitrary: t')
  case Tip thus ?case by simp
next
  case (Node l y d r)
  have del: "delete x (Node l y d r) = Some t'" by fact
  show ?case
  proof (cases "delete x l")
    case (Some l')
    note x_l_Some = this
    with Node.hyps
    have l'_l: "set_of l' \<subseteq> set_of l"
      by simp
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      with Node.hyps
      have "set_of r' \<subseteq> set_of r"
        by simp
      with l'_l Some x_l_Some del
      show ?thesis
        by (auto split: if_split_asm)
    next
      case None
      with l'_l Some x_l_Some del
      show ?thesis
        by (fastforce split: if_split_asm)
    qed
  next
    case None
    note x_l_None = this
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      with Node.hyps
      have "set_of r' \<subseteq> set_of r"
        by simp
      with Some x_l_None del
      show ?thesis
        by (fastforce split: if_split_asm)
    next
      case None
      with x_l_None del
      show ?thesis
        by (fastforce split: if_split_asm)
    qed
  qed
qed

lemma delete_Some_all_distinct:
  "delete x t = Some t' \<Longrightarrow> all_distinct t \<Longrightarrow> all_distinct t'"
proof (induct t arbitrary: t')
  case Tip thus ?case by simp
next
  case (Node l y d r)
  have del: "delete x (Node l y d r) = Some t'" by fact
  have "all_distinct (Node l y d r)" by fact
  then obtain
    dist_l: "all_distinct l" and
    dist_r: "all_distinct r" and
    d: "d \<or> (y \<notin> set_of l \<and> y \<notin> set_of r)" and
    dist_l_r: "set_of l \<inter> set_of r = {}"
    by auto
  show ?case
  proof (cases "delete x l")
    case (Some l')
    note x_l_Some = this
    from Node.hyps (1) [OF Some dist_l]
    have dist_l': "all_distinct l'"
      by simp
    from delete_Some_set_of [OF x_l_Some]
    have l'_l: "set_of l' \<subseteq> set_of l".
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      from Node.hyps (2) [OF Some dist_r]
      have dist_r': "all_distinct r'"
        by simp
      from delete_Some_set_of [OF Some]
      have "set_of r' \<subseteq> set_of r".

      with dist_l' dist_r' l'_l Some x_l_Some del d dist_l_r
      show ?thesis
        by fastforce
    next
      case None
      with l'_l dist_l'  x_l_Some del d dist_l_r dist_r
      show ?thesis
        by fastforce
    qed
  next
    case None
    note x_l_None = this
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      with Node.hyps (2) [OF Some dist_r]
      have dist_r': "all_distinct r'"
        by simp
      from delete_Some_set_of [OF Some]
      have "set_of r' \<subseteq> set_of r".
      with Some dist_r' x_l_None del dist_l d dist_l_r
      show ?thesis
        by fastforce
    next
      case None
      with x_l_None del dist_l dist_r d dist_l_r
      show ?thesis
        by (fastforce split: if_split_asm)
    qed
  qed
qed

lemma delete_None_set_of_conv: "delete x t = None = (x \<notin> set_of t)"
proof (induct t)
  case Tip thus ?case by simp
next
  case (Node l y d r)
  thus ?case
    by (auto split: option.splits)
qed

lemma delete_Some_x_set_of:
  "delete x t = Some t' \<Longrightarrow> x \<in> set_of t \<and> x \<notin> set_of t'"
proof (induct t arbitrary: t')
  case Tip thus ?case by simp
next
  case (Node l y d r)
  have del: "delete x (Node l y d r) = Some t'" by fact
  show ?case
  proof (cases "delete x l")
    case (Some l')
    note x_l_Some = this
    from Node.hyps (1) [OF Some]
    obtain x_l: "x \<in> set_of l" "x \<notin> set_of l'"
      by simp
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      from Node.hyps (2) [OF Some]
      obtain x_r: "x \<in> set_of r" "x \<notin> set_of r'"
        by simp
      from x_r x_l Some x_l_Some del
      show ?thesis
        by (clarsimp split: if_split_asm)
    next
      case None
      then have "x \<notin> set_of r"
        by (simp add: delete_None_set_of_conv)
      with x_l None x_l_Some del
      show ?thesis
        by (clarsimp split: if_split_asm)
    qed
  next
    case None
    note x_l_None = this
    then have x_notin_l: "x \<notin> set_of l"
      by (simp add: delete_None_set_of_conv)
    show ?thesis
    proof (cases "delete x r")
      case (Some r')
      from Node.hyps (2) [OF Some]
      obtain x_r: "x \<in> set_of r" "x \<notin> set_of r'"
        by simp
      from x_r x_notin_l Some x_l_None del
      show ?thesis
        by (clarsimp split: if_split_asm)
    next
      case None
      then have "x \<notin> set_of r"
        by (simp add: delete_None_set_of_conv)
      with None x_l_None x_notin_l del
      show ?thesis
        by (clarsimp split: if_split_asm)
    qed
  qed
qed

primrec subtract :: "'a tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree option"
where
  "subtract Tip t = Some t"
| "subtract (Node l x b r) t =
     (case delete x t of
        Some t' \<Rightarrow> (case subtract l t' of
                     Some t'' \<Rightarrow> subtract r t''
                    | None \<Rightarrow> None)
       | None \<Rightarrow> None)"

lemma subtract_Some_set_of_res:
  "subtract t\<^sub>1 t\<^sub>2 = Some t \<Longrightarrow> set_of t \<subseteq> set_of t\<^sub>2"
proof (induct t\<^sub>1 arbitrary: t\<^sub>2 t)
  case Tip thus ?case by simp
next
  case (Node l x b r)
  have sub: "subtract (Node l x b r) t\<^sub>2 = Some t" by fact
  show ?case
  proof (cases "delete x t\<^sub>2")
    case (Some t\<^sub>2')
    note del_x_Some = this
    from delete_Some_set_of [OF Some]
    have t2'_t2: "set_of t\<^sub>2' \<subseteq> set_of t\<^sub>2" .
    show ?thesis
    proof (cases "subtract l t\<^sub>2'")
      case (Some t\<^sub>2'')
      note sub_l_Some = this
      from Node.hyps (1) [OF Some]
      have t2''_t2': "set_of t\<^sub>2'' \<subseteq> set_of t\<^sub>2'" .
      show ?thesis
      proof (cases "subtract r t\<^sub>2''")
        case (Some t\<^sub>2''')
        from Node.hyps (2) [OF Some ]
        have "set_of t\<^sub>2''' \<subseteq> set_of t\<^sub>2''" .
        with Some sub_l_Some del_x_Some sub t2''_t2' t2'_t2
        show ?thesis
          by simp
      next
        case None
        with del_x_Some sub_l_Some sub
        show ?thesis
          by simp
      qed
    next
      case None
      with del_x_Some sub
      show ?thesis
        by simp
    qed
  next
    case None
    with sub show ?thesis by simp
  qed
qed

lemma subtract_Some_set_of:
  "subtract t\<^sub>1 t\<^sub>2 = Some t \<Longrightarrow> set_of t\<^sub>1 \<subseteq> set_of t\<^sub>2"
proof (induct t\<^sub>1 arbitrary: t\<^sub>2 t)
  case Tip thus ?case by simp
next
  case (Node l x d r)
  have sub: "subtract (Node l x d r) t\<^sub>2 = Some t" by fact
  show ?case
  proof (cases "delete x t\<^sub>2")
    case (Some t\<^sub>2')
    note del_x_Some = this
    from delete_Some_set_of [OF Some]
    have t2'_t2: "set_of t\<^sub>2' \<subseteq> set_of t\<^sub>2" .
    from delete_None_set_of_conv [of x t\<^sub>2] Some
    have x_t2: "x \<in> set_of t\<^sub>2"
      by simp
    show ?thesis
    proof (cases "subtract l t\<^sub>2'")
      case (Some t\<^sub>2'')
      note sub_l_Some = this
      from Node.hyps (1) [OF Some]
      have l_t2': "set_of l \<subseteq> set_of t\<^sub>2'" .
      from subtract_Some_set_of_res [OF Some]
      have t2''_t2': "set_of t\<^sub>2'' \<subseteq> set_of t\<^sub>2'" .
      show ?thesis
      proof (cases "subtract r t\<^sub>2''")
        case (Some t\<^sub>2''')
        from Node.hyps (2) [OF Some ]
        have r_t\<^sub>2'': "set_of r \<subseteq> set_of t\<^sub>2''" .
        from Some sub_l_Some del_x_Some sub r_t\<^sub>2'' l_t2' t2'_t2 t2''_t2' x_t2
        show ?thesis
          by auto
      next
        case None
        with del_x_Some sub_l_Some sub
        show ?thesis
          by simp
      qed
    next
      case None
      with del_x_Some sub
      show ?thesis
        by simp
    qed
  next
    case None
    with sub show ?thesis by simp
  qed
qed

lemma subtract_Some_all_distinct_res:
  "subtract t\<^sub>1 t\<^sub>2 = Some t \<Longrightarrow> all_distinct t\<^sub>2 \<Longrightarrow> all_distinct t"
proof (induct t\<^sub>1 arbitrary: t\<^sub>2 t)
  case Tip thus ?case by simp
next
  case (Node l x d r)
  have sub: "subtract (Node l x d r) t\<^sub>2 = Some t" by fact
  have dist_t2: "all_distinct t\<^sub>2" by fact
  show ?case
  proof (cases "delete x t\<^sub>2")
    case (Some t\<^sub>2')
    note del_x_Some = this
    from delete_Some_all_distinct [OF Some dist_t2]
    have dist_t2': "all_distinct t\<^sub>2'" .
    show ?thesis
    proof (cases "subtract l t\<^sub>2'")
      case (Some t\<^sub>2'')
      note sub_l_Some = this
      from Node.hyps (1) [OF Some dist_t2']
      have dist_t2'': "all_distinct t\<^sub>2''" .
      show ?thesis
      proof (cases "subtract r t\<^sub>2''")
        case (Some t\<^sub>2''')
        from Node.hyps (2) [OF Some dist_t2'']
        have dist_t2''': "all_distinct t\<^sub>2'''" .
        from Some sub_l_Some del_x_Some sub
             dist_t2'''
        show ?thesis
          by simp
      next
        case None
        with del_x_Some sub_l_Some sub
        show ?thesis
          by simp
      qed
    next
      case None
      with del_x_Some sub
      show ?thesis
        by simp
    qed
  next
    case None
    with sub show ?thesis by simp
  qed
qed

lemma subtract_Some_dist_res:
  "subtract t\<^sub>1 t\<^sub>2 = Some t \<Longrightarrow> set_of t\<^sub>1 \<inter> set_of t = {}"
proof (induct t\<^sub>1 arbitrary: t\<^sub>2 t)
  case Tip thus ?case by simp
next
  case (Node l x d r)
  have sub: "subtract (Node l x d r) t\<^sub>2 = Some t" by fact
  show ?case
  proof (cases "delete x t\<^sub>2")
    case (Some t\<^sub>2')
    note del_x_Some = this
    from delete_Some_x_set_of [OF Some]
    obtain x_t2: "x \<in> set_of t\<^sub>2" and x_not_t2': "x \<notin> set_of t\<^sub>2'"
      by simp
    from delete_Some_set_of [OF Some]
    have t2'_t2: "set_of t\<^sub>2' \<subseteq> set_of t\<^sub>2" .
    show ?thesis
    proof (cases "subtract l t\<^sub>2'")
      case (Some t\<^sub>2'')
      note sub_l_Some = this
      from Node.hyps (1) [OF Some ]
      have dist_l_t2'': "set_of l \<inter> set_of t\<^sub>2'' = {}".
      from subtract_Some_set_of_res [OF Some]
      have t2''_t2': "set_of t\<^sub>2'' \<subseteq> set_of t\<^sub>2'" .
      show ?thesis
      proof (cases "subtract r t\<^sub>2''")
        case (Some t\<^sub>2''')
        from Node.hyps (2) [OF Some]
        have dist_r_t2''': "set_of r \<inter> set_of t\<^sub>2''' = {}" .
        from subtract_Some_set_of_res [OF Some]
        have t2'''_t2'': "set_of t\<^sub>2''' \<subseteq> set_of t\<^sub>2''".

        from Some sub_l_Some del_x_Some sub t2'''_t2'' dist_l_t2'' dist_r_t2'''
             t2''_t2' t2'_t2 x_not_t2'
        show ?thesis
          by auto
      next
        case None
        with del_x_Some sub_l_Some sub
        show ?thesis
          by simp
      qed
    next
      case None
      with del_x_Some sub
      show ?thesis
        by simp
    qed
  next
    case None
    with sub show ?thesis by simp
  qed
qed

lemma subtract_Some_all_distinct:
  "subtract t\<^sub>1 t\<^sub>2 = Some t \<Longrightarrow> all_distinct t\<^sub>2 \<Longrightarrow> all_distinct t\<^sub>1"
proof (induct t\<^sub>1 arbitrary: t\<^sub>2 t)
  case Tip thus ?case by simp
next
  case (Node l x d r)
  have sub: "subtract (Node l x d r) t\<^sub>2 = Some t" by fact
  have dist_t2: "all_distinct t\<^sub>2" by fact
  show ?case
  proof (cases "delete x t\<^sub>2")
    case (Some t\<^sub>2')
    note del_x_Some = this
    from delete_Some_all_distinct [OF Some dist_t2 ]
    have dist_t2': "all_distinct t\<^sub>2'" .
    from delete_Some_set_of [OF Some]
    have t2'_t2: "set_of t\<^sub>2' \<subseteq> set_of t\<^sub>2" .
    from delete_Some_x_set_of [OF Some]
    obtain x_t2: "x \<in> set_of t\<^sub>2" and x_not_t2': "x \<notin> set_of t\<^sub>2'"
      by simp

    show ?thesis
    proof (cases "subtract l t\<^sub>2'")
      case (Some t\<^sub>2'')
      note sub_l_Some = this
      from Node.hyps (1) [OF Some dist_t2' ]
      have dist_l: "all_distinct l" .
      from subtract_Some_all_distinct_res [OF Some dist_t2']
      have dist_t2'': "all_distinct t\<^sub>2''" .
      from subtract_Some_set_of [OF Some]
      have l_t2': "set_of l \<subseteq> set_of t\<^sub>2'" .
      from subtract_Some_set_of_res [OF Some]
      have t2''_t2': "set_of t\<^sub>2'' \<subseteq> set_of t\<^sub>2'" .
      from subtract_Some_dist_res [OF Some]
      have dist_l_t2'': "set_of l \<inter> set_of t\<^sub>2'' = {}".
      show ?thesis
      proof (cases "subtract r t\<^sub>2''")
        case (Some t\<^sub>2''')
        from Node.hyps (2) [OF Some dist_t2'']
        have dist_r: "all_distinct r" .
        from subtract_Some_set_of [OF Some]
        have r_t2'': "set_of r \<subseteq> set_of t\<^sub>2''" .
        from subtract_Some_dist_res [OF Some]
        have dist_r_t2''': "set_of r \<inter> set_of t\<^sub>2''' = {}".

        from dist_l dist_r Some sub_l_Some del_x_Some r_t2'' l_t2' x_t2 x_not_t2'
             t2''_t2' dist_l_t2'' dist_r_t2'''
        show ?thesis
          by auto
      next
        case None
        with del_x_Some sub_l_Some sub
        show ?thesis
          by simp
      qed
    next
      case None
      with del_x_Some sub
      show ?thesis
        by simp
    qed
  next
    case None
    with sub show ?thesis by simp
  qed
qed

lemma delete_left:
  assumes dist: "all_distinct (Node l y d r)"
  assumes del_l: "delete x l = Some l'"
  shows "delete x (Node l y d r) = Some (Node l' y d r)"
proof -
  from delete_Some_x_set_of [OF del_l]
  obtain x: "x \<in> set_of l"
    by simp
  with dist
  have "delete x r = None"
    by (cases "delete x r") (auto dest:delete_Some_x_set_of)

  with x
  show ?thesis
    using del_l dist
    by (auto split: option.splits)
qed

lemma delete_right:
  assumes dist: "all_distinct (Node l y d r)"
  assumes del_r: "delete x r = Some r'"
  shows "delete x (Node l y d r) = Some (Node l y d r')"
proof -
  from delete_Some_x_set_of [OF del_r]
  obtain x: "x \<in> set_of r"
    by simp
  with dist
  have "delete x l = None"
    by (cases "delete x l") (auto dest:delete_Some_x_set_of)

  with x
  show ?thesis
    using del_r dist
    by (auto split: option.splits)
qed

lemma delete_root:
  assumes dist: "all_distinct (Node l x False r)"
  shows "delete x (Node l x False r) = Some (Node l x True r)"
proof -
  from dist have "delete x r = None"
    by (cases "delete x r") (auto dest:delete_Some_x_set_of)
  moreover
  from dist have "delete x l = None"
    by (cases "delete x l") (auto dest:delete_Some_x_set_of)
  ultimately show ?thesis
    using dist
       by (auto split: option.splits)
qed

lemma subtract_Node:
 assumes del: "delete x t = Some t'"
 assumes sub_l: "subtract l t' = Some t''"
 assumes sub_r: "subtract r t'' = Some t'''"
 shows "subtract (Node l x False r) t = Some t'''"
using del sub_l sub_r
by simp

lemma subtract_Tip: "subtract Tip t = Some t"
  by simp

text \<open>Now we have all the theorems in place that are needed for the
certificate generating ML functions.\<close>

ML_file "distinct_tree_prover.ML"

end


header{*Sum of divisors function*}

theory Sigma
imports PerfectBasics "~~/src/HOL/Library/Infinite_Set"
begin

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end