theory Calculus
  imports Main
begin

(* locale  exos*)
locale partial_order =
  fixes
    le :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "\<sqsubseteq>" 50)
  assumes
    refl [intro, simp] : "\<And>x. x \<sqsubseteq> x" and
    anti_sym [intro] : "\<And>x y. \<lbrakk> x \<sqsubseteq> y; y \<sqsubseteq> x \<rbrakk> \<Longrightarrow> x = y" and
    trans [trans] : "\<And>x y z. \<lbrakk> x \<sqsubseteq> y; y \<sqsubseteq> z \<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"

  (*print_locales: lists the names of all locales of the currnet theory *)
print_locales
  (*print_locale n : prints the parameters and assumptions of locale n *)
print_locale partial_order
  (*print_locale! n : additionally outputs the conclusions that are stored in the locale *)
print_locale! partial_order
  (* partial_order_def : predicate introduicd by the locale declaration *)
thm partial_order_def
  (* each conclusion has a foundational theorem as counterpart in the theory*)
thm partial_order.trans
  (**)

definition (in partial_order) less :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "\<sqsubset>" 50) where
  "(x \<sqsubset> y) = (x \<sqsubseteq> y \<and> x \<noteq> y)"

print_locale partial_order
print_locale! partial_order
thm partial_order_def
thm partial_order.less_def

lemma (in partial_order) less_le_trans [trans]: "\<lbrakk> x \<sqsubset> y; y \<sqsubseteq> z \<rbrakk> \<Longrightarrow> x \<sqsubset> z"
  unfolding less_def by (blast intro : trans)

context partial_order
begin

definition is_inf where
  "is_inf x y i = ( i \<sqsubseteq> x \<and> i \<sqsubseteq> y \<and> (\<forall>z. z \<sqsubseteq> x \<and> z \<sqsubseteq> y \<longrightarrow> z \<sqsubseteq> i ))"

definition is_sup where
  "is_sup x y s = (   x \<sqsubseteq> s \<and> y \<sqsubseteq> s \<and> (\<forall>z. x \<sqsubseteq> z \<and> y \<sqsubseteq> z \<longrightarrow> s \<sqsubseteq> z ))"

theorem is_inf_uniq : " \<lbrakk> is_inf x y a; is_inf x y b \<rbrakk> \<Longrightarrow> a = b "
proof-
  assume "is_inf x y a" "is_inf x y b"
  show "a = b"
  proof-
    from `is_inf x y a` have H1 : "a \<sqsubseteq> x \<and> a \<sqsubseteq> y \<and> (\<forall>z. z \<sqsubseteq> x \<and> z \<sqsubseteq> y \<longrightarrow> z \<sqsubseteq> a)"
      by (simp add : is_inf_def)
    from `is_inf x y b` have H2 : "b \<sqsubseteq> x \<and> b \<sqsubseteq> y \<and> (\<forall>z. z \<sqsubseteq> x \<and> z \<sqsubseteq> y \<longrightarrow> z \<sqsubseteq> b)"
      by (simp add : is_inf_def)
    from H1 H2 have "b \<sqsubseteq> a" by simp
    from H1 H2 have "a \<sqsubseteq> b" by simp
    from `a \<sqsubseteq> b` `b \<sqsubseteq> a` show "a = b" by (rule anti_sym)
  qed
qed

theorem is_sup_uniq : " \<lbrakk> is_sup x y a; is_sup x y b \<rbrakk> \<Longrightarrow> a = b "
  by (simp add : is_sup_def anti_sym)
end

(* Section 3 *)

locale lattice = partial_order +
  assumes
    ex_inf : "\<exists>inf. is_inf x y inf" and
    ex_sup : "\<exists>sup. is_sup x y sup"
begin
  definition meet (infixl "\<sqinter>" 70) where "x \<sqinter> y = (THE z. is_inf x y z)"
definition join (infixl "\<squnion>" 70) where "x \<squnion> y = (THE z. is_sup x y z)"

(**************************************
***************************************
  ***************************************)

lemma meet_left_1 : "x \<sqinter> y \<sqsubseteq> x"
  (* sledgehammer *)
  by (metis ex_inf is_inf_uniq meet_def partial_order.is_inf_def partial_order_axioms the_equality)

find_theorems name: the_equality

lemma meet_left_2: "x \<sqinter> y \<sqsubseteq> x "
  unfolding meet_def is_inf_def
proof -
  fix x y
  obtain i where ix: "i \<sqsubseteq> x \<and> i \<sqsubseteq> y \<and> (\<forall>z. z \<sqsubseteq> x \<and> z \<sqsubseteq> y \<longrightarrow> z \<sqsubseteq> i)"
    using ex_inf unfolding is_inf_def by blast
  then have "\<And>z. ((z \<sqsubseteq> x) \<and> (z \<sqsubseteq> y) \<and> (\<forall>w. (w \<sqsubseteq> x) \<and> (w \<sqsubseteq> y) \<longrightarrow> w \<sqsubseteq> z)) \<Longrightarrow> z = i"
    using is_inf_uniq unfolding is_inf_def by blast
  then have "i = (THE i. i \<sqsubseteq> x \<and> i \<sqsubseteq> y \<and> (\<forall>z. z \<sqsubseteq> x \<and> z \<sqsubseteq> y \<longrightarrow> z \<sqsubseteq> i))"
    using the_equality[of _ i] is_inf_uniq ix unfolding is_inf_def by (smt (verit,best))
  then show \<open>(THE i. i \<sqsubseteq> x \<and> i \<sqsubseteq> y \<and> (\<forall>z. z \<sqsubseteq> x \<and> z \<sqsubseteq> y \<longrightarrow> z \<sqsubseteq> i)) \<sqsubseteq> x\<close>
    using ix by blast
qed

(**************************************
***************************************
***************************************)

end

locale total_order = partial_order +
  assumes total : "x \<sqsubseteq> y \<or> y \<sqsubseteq> x"

lemma (in total_order) less_total : "x \<sqsubset> y \<or> x = y \<or> y \<sqsubset> x"
proof(rule ccontr)
  assume H0 : "\<not>(x \<sqsubset> y \<or> x = y \<or> y \<sqsubset> x)"
  from H0 have H1 : "\<not>(x \<sqsubset> y) \<and> x \<noteq> y \<and> \<not>(y \<sqsubset> x)" by blast
  from H1 have "x \<noteq> y" by simp
  from H1 have H2 : "\<not>(x \<sqsubset> y) \<and> \<not>(y \<sqsubset> x)" by simp
  from H2 have H3 : "\<not>(x \<sqsubseteq> y \<and> x \<noteq> y) \<and> \<not>(y \<sqsubseteq> x \<and> y \<noteq> x)" by (simp add : less_def)
  from H3 have H4 : "(\<not>(x \<sqsubseteq> y) \<and> \<not>(y \<sqsubseteq> x)) \<or> \<not>(x \<noteq> y)" by blast
  from H4 show False
  proof (rule disjE)
    assume "\<not> x \<noteq> y"
    from `\<not>(x\<noteq>y)` have "x = y" by simp
    from `x \<noteq> y` `x = y` show False by (rule notE)
  next
    assume H : "\<not> x \<sqsubseteq> y \<and> \<not> y \<sqsubseteq> x"
    from total have H' : "x \<sqsubseteq> y \<or> y \<sqsubseteq> x" by simp
    from H H' show False by blast
  qed
qed

lemma "x \<or> \<not>x"
proof (rule ccontr)
  assume "\<not>(x \<or> \<not>x)"
  then have "\<not>x \<and> x" by simp
  then have "x" by (rule conjE)
  then have "x \<or> \<not>x" by (rule disjI1)
  from `\<not>(x \<or> \<not>x)` this show False by (rule notE)
qed

lemma "x \<or> \<not>x"
proof-
  have "\<not>(x \<or> \<not>x) \<Longrightarrow> False"
  proof-
    assume "\<not>(x \<or> \<not>x)"
    then have "\<not>x \<and> x" by simp
    then have "x" by (rule conjE)
    then have "x \<or> \<not>x" by (rule disjI1)
    from `\<not>(x \<or> \<not>x)` this show False by (rule notE)
  qed
  from this show "x \<or> \<not>x" by (rule ccontr)
qed

lemma (in total_order) "x \<sqsubset> y \<or> x = y \<or> y \<sqsubset> x"
proof-
  have "\<not>(x \<sqsubset> y \<or> x = y \<or> y \<sqsubset> x) \<Longrightarrow> False"
  proof-
    assume H0 : "\<not>(x \<sqsubset> y \<or> x = y \<or> y \<sqsubset> x)"
    from H0 have H1 : "\<not>(x \<sqsubset> y) \<and> x \<noteq> y \<and> \<not>(y \<sqsubset> x)" by blast
    from H1 have "x \<noteq> y" by simp
    from H1 have H2 : "\<not>(x \<sqsubset> y) \<and> \<not>(y \<sqsubset> x)" by simp
    from H2 have H3 : "\<not>(x \<sqsubseteq> y \<and> x \<noteq> y) \<and> \<not>(y \<sqsubseteq> x \<and> y \<noteq> x)" by (simp add : less_def)
    from H3 have H4 : "(\<not>(x \<sqsubseteq> y) \<and> \<not>(y \<sqsubseteq> x)) \<or> \<not>(x \<noteq> y)" by blast
    from H4 show False
    proof (rule disjE)
      assume "\<not> x \<noteq> y"
      from `\<not>(x\<noteq>y)` have "x = y" by simp
      from `x \<noteq> y` `x = y` show False by (rule notE)
    next
      assume H : "\<not> x \<sqsubseteq> y \<and> \<not> y \<sqsubseteq> x"
      from total have H' : "x \<sqsubseteq> y \<or> y \<sqsubseteq> x" by simp
      from H H' show False by blast
    qed
  qed
  from `\<not> (x \<sqsubset> y \<or> x = y \<or> y \<sqsubset> x) \<Longrightarrow> False`
  show "x \<sqsubset> y \<or> x = y \<or> y \<sqsubset> x" by (rule ccontr)
qed

locale distrib_lattice = lattice +
  assumes
    meet_distr : "x \<sqinter> (y \<sqinter> z) = (x \<sqinter> y) \<squnion> (x \<sqinter> z)"

lemma (in distrib_lattice) join_distr:
  "x \<squnion> (y \<sqinter> z) = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
  sorry

sublocale total_order \<subseteq> lattice
proof unfold_locales
  fix x y
  from total have "is_inf x y (if x \<sqsubseteq> y then x else y)" by (auto simp add : is_inf_def)
  then show "\<exists>inf. is_inf x y inf" by (rule exI)
next
  fix x y
  from total have "is_sup x y (if x \<sqsubseteq> y then y else x)" by (auto simp add : is_sup_def)
  then show "\<exists>sup. is_sup x y sup" by (rule exI)
qed

sublocale total_order \<subseteq> distrib_lattice
  sorry

lemma "\<And>x::nat. x \<le> x"
  by (metis Orderings.order_class.order.refl)

lemma "\<And>x::nat. x \<le> x"
  apply (auto simp add : Orderings.order_class.order.refl)
  sorry

lemma "(x::nat) \<le> x"
proof-
  from le_refl[of x] show "x \<le> x" by simp
qed

(* question pourquoi cette preuve ne marche pas*)
lemma "\<And>x::nat. x \<le> x"
proof-
  fix x
  from le_refl[of x] have "x \<le> x" by auto
(*
Failed to apply initial proof method\<^here>:
using this:
  x \<le> x
goal (1 subgoal):
 1. x \<le> x
*)
  then show ?thesis by auto
  oops

  print_locale partial_order

(* section 5.1 *)
interpretation int : partial_order "(\<le>) :: int \<Rightarrow> int \<Rightarrow> bool"
  by unfold_locales auto

(* section 5.2 *)
interpretation int : partial_order "(\<le>) :: int \<Rightarrow> int \<Rightarrow> bool"
  rewrites "int.less x y = (x < y)"
proof -
  show "partial_order ((\<le>) :: int \<Rightarrow> int \<Rightarrow> bool)"
    by unfold_locales auto
  show "partial_order.less ((\<le>) :: int \<Rightarrow> int \<Rightarrow> bool) x y = (x < y)"
    unfolding partial_order.less_def [OF \<open>partial_order (\<le>)\<close>]
    by auto
qed

(* section 5.3 *)
interpretation int : partial_order "(\<le>) :: int \<Rightarrow> int \<Rightarrow> bool"
  rewrites "int.less x y = (x < y)"
proof -
  show "partial_order ((\<le>) :: int \<Rightarrow> int \<Rightarrow> bool)"
    by unfold_locales auto
  then interpret int : partial_order "(\<le>) :: [int, int] \<Rightarrow> bool" by assumption
  show "int.less x y = (x < y)"
    unfolding int.less_def
    by auto
qed

(* section 5.4 *)
interpretation int : lattice "(\<le>) :: int \<Rightarrow> int \<Rightarrow> bool"
  rewrites int_min_eq : "int.meet x y = min x y"
  and int_max_eq : "int.join x y = max x y"
proof -
  show "lattice ((\<le>) :: int \<Rightarrow> int \<Rightarrow> bool)"
    apply unfold_locales
     apply (unfold int.is_inf_def int.is_sup_def)
    by arith+
  then interpret int : lattice "(\<le>) :: int \<Rightarrow> int \<Rightarrow> bool" by assumption
  show "int.meet x y =  min x y"
    by (bestsimp simp : int.meet_def int.is_inf_def)
  show "int.join x y =  max x y"
    by (bestsimp simp : int.join_def int.is_sup_def)
qed

locale order_preserving =
  po_le : partial_order le  + po_le' : partial_order le'
  for le (infixl "\<sqsubseteq>" 50) and le' (infixl "\<lesssim>" 50) +
  fixes \<phi>
  assumes hom_le : "x \<sqsubseteq> y \<Longrightarrow> \<phi> x \<lesssim> \<phi> y"

print_locale order_preserving
print_locale! order_preserving

notation (in order_preserving) po_le'.less (infixl "<" 50)
print_locale! order_preserving

(* section 6.1  default instantiations *)

(* section 6.2 implicit  parameters *)
(* in a locale declarationm the expression partial_order is short for
    partial_order le for le (infixl "\<sqsubseteq>" 50)   *)

locale lattice_hom =
  le : lattice + le' : lattice le' for le' (infixl "\<lesssim>" 50) +
fixes \<phi>
assumes
  hom_meet : "\<phi> (x \<sqinter> y) = le'.meet (\<phi> x) (\<phi> y)"
  and
  hom_join : "\<phi> (x \<squnion> y) = le'.join (\<phi> x) (\<phi> y)"

context lattice_hom
begin
  notation le'.meet (infixl "\<sqinter>''" 50)
  notation le'.join (infixl "\<squnion>''" 50)
end

locale lattice_hom_2 =
  le : lattice le + le' : lattice le'
  for le (infixl "\<sqsubseteq>" 50) and le' (infixl "\<lesssim>" 50) +
fixes \<phi>
assumes
  hom_meet : "\<phi> (x \<sqinter> y) = le'.meet (\<phi> x) (\<phi> y)"
  and
  hom_join : "\<phi> (x \<squnion> y) = le'.join (\<phi> x) (\<phi> y)"

(* section 7 Conditional interpretation*)

locale non_negative =
  fixes n :: int
  assumes non_neg : "0 \<le> n"

sublocale non_negative \<subseteq> order_preserving "(\<le>)" "(\<le>)" "\<lambda>i. n * i"

end


(*<*)theory Advanced imports Even begin(*>*)

text \<open>
The premises of introduction rules may contain universal quantifiers and
monotone functions.  A universal quantifier lets the rule
refer to any number of instances of
the inductively defined set.  A monotone function lets the rule refer
to existing constructions (such as ``list of'') over the inductively defined
set.  The examples below show how to use the additional expressiveness
and how to reason from the resulting definitions.
\<close>

subsection\<open>Universal Quantifiers in Introduction Rules \label{sec:gterm-datatype}\<close>

text \<open>
\index{ground terms example|(}%
\index{quantifiers!and inductive definitions|(}%
As a running example, this section develops the theory of \textbf{ground
terms}: terms constructed from constant and function
symbols but not variables. To simplify matters further, we regard a
constant as a function applied to the null argument  list.  Let us declare a
datatype \<open>gterm\<close> for the type of ground  terms. It is a type constructor
whose argument is a type of  function symbols.
\<close>

datatype 'f gterm = Apply 'f "'f gterm list"

text \<open>
To try it out, we declare a datatype of some integer operations:
integer constants, the unary minus operator and the addition
operator.
\<close>

datatype integer_op = Number int | UnaryMinus | Plus

text \<open>
Now the type \<^typ>\<open>integer_op gterm\<close> denotes the ground
terms built over those symbols.

The type constructor \<open>gterm\<close> can be generalized to a function
over sets.  It returns
the set of ground terms that can be formed over a set \<open>F\<close> of function symbols. For
example,  we could consider the set of ground terms formed from the finite
set \<open>{Number 2, UnaryMinus, Plus}\<close>.

This concept is inductive. If we have a list \<open>args\<close> of ground terms
over~\<open>F\<close> and a function symbol \<open>f\<close> in \<open>F\<close>, then we
can apply \<open>f\<close> to \<open>args\<close> to obtain another ground term.
The only difficulty is that the argument list may be of any length. Hitherto,
each rule in an inductive definition referred to the inductively
defined set a fixed number of times, typically once or twice.
A universal quantifier in the premise of the introduction rule
expresses that every element of \<open>args\<close> belongs
to our inductively defined set: is a ground term
over~\<open>F\<close>.  The function \<^term>\<open>set\<close> denotes the set of elements in a given
list.
\<close>

inductive_set
  gterms :: "'f set \<Rightarrow> 'f gterm set"
  for F :: "'f set"
where
step[intro!]: "\<lbrakk>\<forall>t \<in> set args. t \<in> gterms F;  f \<in> F\<rbrakk>
               \<Longrightarrow> (Apply f args) \<in> gterms F"

text \<open>
To demonstrate a proof from this definition, let us
show that the function \<^term>\<open>gterms\<close>
is \textbf{monotone}.  We shall need this concept shortly.
\<close>

lemma gterms_mono: "F\<subseteq>G \<Longrightarrow> gterms F \<subseteq> gterms G"
apply clarify
apply (erule gterms.induct)
apply blast
done
(*<*)
lemma gterms_mono: "F\<subseteq>G \<Longrightarrow> gterms F \<subseteq> gterms G"
apply clarify
apply (erule gterms.induct)
(*>*)
txt\<open>
Intuitively, this theorem says that
enlarging the set of function symbols enlarges the set of ground
terms. The proof is a trivial rule induction.
First we use the \<open>clarify\<close> method to assume the existence of an element of
\<^term>\<open>gterms F\<close>.  (We could have used \<open>intro subsetI\<close>.)  We then
apply rule induction. Here is the resulting subgoal:
@{subgoals[display,indent=0]}
The assumptions state that \<open>f\<close> belongs
to~\<open>F\<close>, which is included in~\<open>G\<close>, and that every element of the list \<open>args\<close> is
a ground term over~\<open>G\<close>.  The \<open>blast\<close> method finds this chain of reasoning easily.
\<close>
(*<*)oops(*>*)
text \<open>
\begin{warn}
Why do we call this function \<open>gterms\<close> instead
of \<open>gterm\<close>?  A constant may have the same name as a type.  However,
name  clashes could arise in the theorems that Isabelle generates.
Our choice of names keeps \<open>gterms.induct\<close> separate from
\<open>gterm.induct\<close>.
\end{warn}

Call a term \textbf{well-formed} if each symbol occurring in it is applied
to the correct number of arguments.  (This number is called the symbol's
\textbf{arity}.)  We can express well-formedness by
generalizing the inductive definition of
\isa{gterms}.
Suppose we are given a function called \<open>arity\<close>, specifying the arities
of all symbols.  In the inductive step, we have a list \<open>args\<close> of such
terms and a function  symbol~\<open>f\<close>. If the length of the list matches the
function's arity  then applying \<open>f\<close> to \<open>args\<close> yields a well-formed
term.
\<close>

inductive_set
  well_formed_gterm :: "('f \<Rightarrow> nat) \<Rightarrow> 'f gterm set"
  for arity :: "'f \<Rightarrow> nat"
where
step[intro!]: "\<lbrakk>\<forall>t \<in> set args. t \<in> well_formed_gterm arity;
                length args = arity f\<rbrakk>
               \<Longrightarrow> (Apply f args) \<in> well_formed_gterm arity"

text \<open>
The inductive definition neatly captures the reasoning above.
The universal quantification over the
\<open>set\<close> of arguments expresses that all of them are well-formed.%
\index{quantifiers!and inductive definitions|)}
\<close>

subsection\<open>Alternative Definition Using a Monotone Function\<close>

text \<open>
\index{monotone functions!and inductive definitions|(}%
An inductive definition may refer to the
inductively defined  set through an arbitrary monotone function.  To
demonstrate this powerful feature, let us
change the  inductive definition above, replacing the
quantifier by a use of the function \<^term>\<open>lists\<close>. This
function, from the Isabelle theory of lists, is analogous to the
function \<^term>\<open>gterms\<close> declared above: if \<open>A\<close> is a set then
\<^term>\<open>lists A\<close> is the set of lists whose elements belong to
\<^term>\<open>A\<close>.

In the inductive definition of well-formed terms, examine the one
introduction rule.  The first premise states that \<open>args\<close> belongs to
the \<open>lists\<close> of well-formed terms.  This formulation is more
direct, if more obscure, than using a universal quantifier.
\<close>

inductive_set
  well_formed_gterm' :: "('f \<Rightarrow> nat) \<Rightarrow> 'f gterm set"
  for arity :: "'f \<Rightarrow> nat"
where
step[intro!]: "\<lbrakk>args \<in> lists (well_formed_gterm' arity);
                length args = arity f\<rbrakk>
               \<Longrightarrow> (Apply f args) \<in> well_formed_gterm' arity"
monos lists_mono

text \<open>
We cite the theorem \<open>lists_mono\<close> to justify
using the function \<^term>\<open>lists\<close>.%
\footnote{This particular theorem is installed by default already, but we
include the \isakeyword{monos} declaration in order to illustrate its syntax.}
@{named_thms [display,indent=0] lists_mono [no_vars] (lists_mono)}
Why must the function be monotone?  An inductive definition describes
an iterative construction: each element of the set is constructed by a
finite number of introduction rule applications.  For example, the
elements of \isa{even} are constructed by finitely many applications of
the rules
@{thm [display,indent=0] even.intros [no_vars]}
All references to a set in its
inductive definition must be positive.  Applications of an
introduction rule cannot invalidate previous applications, allowing the
construction process to converge.
The following pair of rules do not constitute an inductive definition:
\begin{trivlist}
\item \<^term>\<open>0 \<in> even\<close>
\item \<^term>\<open>n \<notin> even \<Longrightarrow> (Suc n) \<in> even\<close>
\end{trivlist}
Showing that 4 is even using these rules requires showing that 3 is not
even.  It is far from trivial to show that this set of rules
characterizes the even numbers.

Even with its use of the function \isa{lists}, the premise of our
introduction rule is positive:
@{thm [display,indent=0] (prem 1) step [no_vars]}
To apply the rule we construct a list \<^term>\<open>args\<close> of previously
constructed well-formed terms.  We obtain a
new term, \<^term>\<open>Apply f args\<close>.  Because \<^term>\<open>lists\<close> is monotone,
applications of the rule remain valid as new terms are constructed.
Further lists of well-formed
terms become available and none are taken away.%
\index{monotone functions!and inductive definitions|)}
\<close>

subsection\<open>A Proof of Equivalence\<close>

text \<open>
We naturally hope that these two inductive definitions of ``well-formed''
coincide.  The equality can be proved by separate inclusions in
each direction.  Each is a trivial rule induction.
\<close>

lemma "well_formed_gterm arity \<subseteq> well_formed_gterm' arity"
apply clarify
apply (erule well_formed_gterm.induct)
apply auto
done
(*<*)
lemma "well_formed_gterm arity \<subseteq> well_formed_gterm' arity"
apply clarify
apply (erule well_formed_gterm.induct)
(*>*)
txt \<open>
The \<open>clarify\<close> method gives
us an element of \<^term>\<open>well_formed_gterm arity\<close> on which to perform
induction.  The resulting subgoal can be proved automatically:
@{subgoals[display,indent=0]}
This proof resembles the one given in
{\S}\ref{sec:gterm-datatype} above, especially in the form of the
induction hypothesis.  Next, we consider the opposite inclusion:
\<close>
(*<*)oops(*>*)
lemma "well_formed_gterm' arity \<subseteq> well_formed_gterm arity"
apply clarify
apply (erule well_formed_gterm'.induct)
apply auto
done
(*<*)
lemma "well_formed_gterm' arity \<subseteq> well_formed_gterm arity"
apply clarify
apply (erule well_formed_gterm'.induct)
(*>*)
txt \<open>
The proof script is virtually identical,
but the subgoal after applying induction may be surprising:
@{subgoals[display,indent=0,margin=65]}
The induction hypothesis contains an application of \<^term>\<open>lists\<close>.  Using a
monotone function in the inductive definition always has this effect.  The
subgoal may look uninviting, but fortunately
\<^term>\<open>lists\<close> distributes over intersection:
@{named_thms [display,indent=0] lists_Int_eq [no_vars] (lists_Int_eq)}
Thanks to this default simplification rule, the induction hypothesis
is quickly replaced by its two parts:
\begin{trivlist}
\item \<^term>\<open>args \<in> lists (well_formed_gterm' arity)\<close>
\item \<^term>\<open>args \<in> lists (well_formed_gterm arity)\<close>
\end{trivlist}
Invoking the rule \<open>well_formed_gterm.step\<close> completes the proof.  The
call to \<open>auto\<close> does all this work.

This example is typical of how monotone functions
\index{monotone functions} can be used.  In particular, many of them
distribute over intersection.  Monotonicity implies one direction of
this set equality; we have this theorem:
@{named_thms [display,indent=0] mono_Int [no_vars] (mono_Int)}
\<close>
(*<*)oops(*>*)

subsection\<open>Another Example of Rule Inversion\<close>

text \<open>
\index{rule inversion|(}%
Does \<^term>\<open>gterms\<close> distribute over intersection?  We have proved that this
function is monotone, so \<open>mono_Int\<close> gives one of the inclusions.  The
opposite inclusion asserts that if \<^term>\<open>t\<close> is a ground term over both of the
sets
\<^term>\<open>F\<close> and~\<^term>\<open>G\<close> then it is also a ground term over their intersection,
\<^term>\<open>F \<inter> G\<close>.
\<close>

lemma gterms_IntI:
     "t \<in> gterms F \<Longrightarrow> t \<in> gterms G \<longrightarrow> t \<in> gterms (F\<inter>G)"
(*<*)oops(*>*)
text \<open>
Attempting this proof, we get the assumption
\<^term>\<open>Apply f args \<in> gterms G\<close>, which cannot be broken down.
It looks like a job for rule inversion:\cmmdx{inductive\protect\_cases}
\<close>

inductive_cases gterm_Apply_elim [elim!]: "Apply f args \<in> gterms F"

text \<open>
Here is the result.
@{named_thms [display,indent=0,margin=50] gterm_Apply_elim [no_vars] (gterm_Apply_elim)}
This rule replaces an assumption about \<^term>\<open>Apply f args\<close> by
assumptions about \<^term>\<open>f\<close> and~\<^term>\<open>args\<close>.
No cases are discarded (there was only one to begin
with) but the rule applies specifically to the pattern \<^term>\<open>Apply f args\<close>.
It can be applied repeatedly as an elimination rule without looping, so we
have given the \<open>elim!\<close> attribute.

Now we can prove the other half of that distributive law.
\<close>

lemma gterms_IntI [rule_format, intro!]:
     "t \<in> gterms F \<Longrightarrow> t \<in> gterms G \<longrightarrow> t \<in> gterms (F\<inter>G)"
apply (erule gterms.induct)
apply blast
done
(*<*)
lemma "t \<in> gterms F \<Longrightarrow> t \<in> gterms G \<longrightarrow> t \<in> gterms (F\<inter>G)"
apply (erule gterms.induct)
(*>*)
txt \<open>
The proof begins with rule induction over the definition of
\<^term>\<open>gterms\<close>, which leaves a single subgoal:
@{subgoals[display,indent=0,margin=65]}
To prove this, we assume \<^term>\<open>Apply f args \<in> gterms G\<close>.  Rule inversion,
in the form of \<open>gterm_Apply_elim\<close>, infers
that every element of \<^term>\<open>args\<close> belongs to
\<^term>\<open>gterms G\<close>; hence (by the induction hypothesis) it belongs
to \<^term>\<open>gterms (F \<inter> G)\<close>.  Rule inversion also yields
\<^term>\<open>f \<in> G\<close> and hence \<^term>\<open>f \<in> F \<inter> G\<close>.
All of this reasoning is done by \<open>blast\<close>.

\smallskip
Our distributive law is a trivial consequence of previously-proved results:
\<close>
(*<*)oops(*>*)
lemma gterms_Int_eq [simp]:
     "gterms (F \<inter> G) = gterms F \<inter> gterms G"
by (blast intro!: mono_Int monoI gterms_mono)

text_raw \<open>
\index{rule inversion|)}%
\index{ground terms example|)}

\begin{isamarkuptext}
\begin{exercise}
A function mapping function symbols to their
types is called a \textbf{signature}.  Given a type
ranging over type symbols, we can represent a function's type by a
list of argument types paired with the result type.
Complete this inductive definition:
\begin{isabelle}
\<close>

inductive_set
  well_typed_gterm :: "('f \<Rightarrow> 't list * 't) \<Rightarrow> ('f gterm * 't)set"
  for sig :: "'f \<Rightarrow> 't list * 't"
(*<*)
where
step[intro!]:
    "\<lbrakk>\<forall>pair \<in> set args. pair \<in> well_typed_gterm sig;
      sig f = (map snd args, rtype)\<rbrakk>
     \<Longrightarrow> (Apply f (map fst args), rtype)
         \<in> well_typed_gterm sig"
(*>*)
text_raw \<open>
\end{isabelle}
\end{exercise}
\end{isamarkuptext}
\<close>

(*<*)

text\<open>the following declaration isn't actually used\<close>
primrec
  integer_arity :: "integer_op \<Rightarrow> nat"
where
  "integer_arity (Number n)        = 0"
| "integer_arity UnaryMinus        = 1"
| "integer_arity Plus              = 2"

text\<open>the rest isn't used: too complicated.  OK for an exercise though.\<close>

inductive_set
  integer_signature :: "(integer_op * (unit list * unit)) set"
where
  Number:     "(Number n,   ([], ())) \<in> integer_signature"
| UnaryMinus: "(UnaryMinus, ([()], ())) \<in> integer_signature"
| Plus:       "(Plus,       ([(),()], ())) \<in> integer_signature"

inductive_set
  well_typed_gterm' :: "('f \<Rightarrow> 't list * 't) \<Rightarrow> ('f gterm * 't)set"
  for sig :: "'f \<Rightarrow> 't list * 't"
where
step[intro!]:
    "\<lbrakk>args \<in> lists(well_typed_gterm' sig);
      sig f = (map snd args, rtype)\<rbrakk>
     \<Longrightarrow> (Apply f (map fst args), rtype)
         \<in> well_typed_gterm' sig"
monos lists_mono

lemma "well_typed_gterm sig \<subseteq> well_typed_gterm' sig"
apply clarify
apply (erule well_typed_gterm.induct)
apply auto
done

lemma "well_typed_gterm' sig \<subseteq> well_typed_gterm sig"
apply clarify
apply (erule well_typed_gterm'.induct)
apply auto
done

end
(*>*)


section \<open>Sum of Vector Sets\<close>

text \<open>We use Isabelle's Set-Algebra theory to be able to write V + W for sets of vectors V and W,
 and prove some obvious properties about them.\<close>
theory Sum_Vec_Set
  imports
    Missing_Matrix
    "HOL-Library.Set_Algebras"
begin

lemma add_0_right_vecset:
  assumes "(A :: 'a :: monoid_add vec set) \<subseteq> carrier_vec n"
  shows "A + {0\<^sub>v n} = A"
  unfolding set_plus_def using assms by force

lemma add_0_left_vecset:
  assumes "(A :: 'a :: monoid_add vec set) \<subseteq> carrier_vec n"
  shows "{0\<^sub>v n} + A = A"
  unfolding set_plus_def using assms by force

lemma assoc_add_vecset:
  assumes "(A :: 'a :: semigroup_add vec set) \<subseteq> carrier_vec n"
    and "B \<subseteq> carrier_vec n"
    and "C \<subseteq> carrier_vec n"
  shows "A + (B + C) = (A + B) + C"
proof -
  {
    fix x
    assume "x \<in> A + (B + C)"
    then obtain a b c where "x = a + (b + c)" and *: "a \<in> A" "b \<in> B" "c \<in> C"
      unfolding set_plus_def by auto
    with assms have "x = (a + b) + c" using assoc_add_vec[of a n b c] by force
    with * have "x \<in> (A + B) + C" by auto
  }
  moreover
  {
    fix x
    assume "x \<in> (A + B) + C"
    then obtain a b c where "x = (a + b) + c" and *: "a \<in> A" "b \<in> B" "c \<in> C"
      unfolding set_plus_def by auto
    with assms have "x = a + (b + c)" using assoc_add_vec[of a n b c] by force
    with * have "x \<in> A + (B + C)" by auto
  }
  ultimately show ?thesis by blast
qed

lemma comm_add_vecset:
  assumes "(A :: 'a :: ab_semigroup_add vec set) \<subseteq> carrier_vec n"
    and "B \<subseteq> carrier_vec n"
  shows "A + B = B + A"
  unfolding set_plus_def using comm_add_vec assms by blast

end


theory hw04
  imports Main  "~~/src/HOL/Library/Tree"
begin

declare Let_def [simp]

datatype 'a rtree = Leaf | Node "'a rtree" nat 'a "'a rtree"

fun num_nodes:: "'a rtree \<Rightarrow> nat" where
  "num_nodes Leaf = 0"
| "num_nodes (Node l n b r) = 1 + num_nodes l + num_nodes r"

fun rbst:: "'a::linorder rtree \<Rightarrow> bool" where
  "rbst Leaf = True"
| "rbst (Node l a b r) = (rbst l \<and> (\<forall>x\<in>set_rtree l. (b > x)) \<and> (\<forall>x\<in>set_rtree r. (b < x)) \<and> (a = num_nodes l) \<and> rbst r)"

value "rbst (Node (Node Leaf (0::nat) (1::nat) Leaf) (1::nat) 2 (Node Leaf (0::nat) 3 Leaf))"

fun rins:: "'a::linorder \<Rightarrow> 'a rtree \<Rightarrow> 'a rtree" where
  "rins x Leaf = (Node Leaf 0 x Leaf)"
| "rins x (Node l n b r) =
  (if (x < b) then (Node (rins x l) (Suc n) b r) else (Node l n b (rins x r)))"

value "rins (4::nat) (Node (Node Leaf (0::nat) (1::nat) Leaf) (1::nat) 2 (Node Leaf (0::nat) 3 Leaf))"

lemma rins_set[simp]: "set_rtree (rins x t) = insert x (set_rtree t)"
  apply(induction t arbitrary:x)
   apply(auto)
  done

lemma aux1[simp]: "(x\<notin>set_rtree t) \<Longrightarrow> num_nodes (rins x t) = Suc(num_nodes t)"
  apply(induction t arbitrary: x)
   apply(auto)
  done

lemma aux2[simp]: "rbst(Node l a b r) \<Longrightarrow> (num_nodes l = a) "
   apply(auto)
  done

value "rbst  (rtree.Node rtree.Leaf 0 (1::nat) (rtree.Node rtree.Leaf 0 (1::nat) rtree.Leaf))"

lemma "x\<notin>set_rtree t \<Longrightarrow> rbst t \<Longrightarrow> rbst (rins x t)"
  apply(induction t arbitrary: x rule:rbst.induct)
   apply(auto)
  done

fun risin :: "'a::linorder \<Rightarrow> 'a rtree \<Rightarrow> bool" where
  "risin x Leaf = False"
| "risin x (Node l a b r) =
  (
    if (b < x) then
      (risin x r)
    else if (b > x) then
      (risin x l)
    else
      True
  )"

value "risin (3::nat) (Node (Node Leaf (0::nat) (1::nat) Leaf) (1::nat) 2 (Node Leaf (0::nat) 3 Leaf))"

lemma "rbst t \<Longrightarrow> risin x t \<longleftrightarrow> x\<in>set_rtree t"
  apply(induction t)
   apply(auto)
  done

fun inorder:: "'a rtree \<Rightarrow> 'a list" where
  "inorder Leaf = []"
| "inorder (Node l a b r) = inorder l @ [b] @ inorder r"

fun rank::"'a::linorder \<Rightarrow> _" where
  "rank x Leaf = undefined"
| "rank x (Node l a b r) = (if (x = b) then a else if (x < b) then (rank x l) else (a + 1 + rank x r))"

definition "at_index i l x \<equiv> i<length l \<and> l!i=x"

lemma aux3[simp]:"rbst t \<Longrightarrow> num_nodes t = length (inorder t)"
  apply(induction t)
   apply(auto)
  done

lemma "rbst t \<Longrightarrow> x\<in>set_rtree t \<Longrightarrow> at_index (rank x t) (inorder t) x"
  unfolding at_index_def
  apply(induction t rule:inorder.induct)
   apply(auto)
  sorry

fun select :: "nat \<Rightarrow> 'a::linorder rtree \<Rightarrow> 'a" where
  "select n Leaf = undefined"
| "select n (Node l a b r) = (if (n = a) then b else if n < a then select n l else select (n-a-1) r)"

lemma select_correct: "rbst t \<Longrightarrow> i<length (inorder t) \<Longrightarrow> select i t = inorder t ! i"
  apply(induction i t rule:select.induct)
   apply(auto)
  sorry

end


theory Ch5
  imports Main
begin

(*
then = from this
thus = then show
hence = then have
*)

(*

see of and OF 4.4.4

f.simps refers to the whole list of recursion equations defining
f. Individual facts can be selected by writing f.simps(2), whole sublists by
writing f.simps(2−4).

*)

(*
show "P (n)"
proof (induction n)
  case 0            // let ?case = "P (0)"
  ..
  show ?case <proof>
next
  case (Suc n)      // fix n assume Suc: "P(n)"
                    // let ?case = "P (Suc n)"
  ..
  show ?case <proof>
qed

That is, if in the above proof we replace show "P (n)" by
show "A(n) \<Longrightarrow> P (n)" then case 0 stands for

  assume 0: "A(0)"
  let ?case = "P (0)"

and case (Suc n) stands for

  fix n
  assume Suc: "A(n) \<Longrightarrow> P (n)"
              "A(Suc n)"
  let ?case = "P (Suc n)"

page 64 induction trickery

*)

lemma "\<not> surj (f :: 'a \<Rightarrow> 'a set )"
proof
assume 0: "surj f"
from 0 have 1: "\<forall> A. \<exists> a. A = f a" by(simp add: surj_def)
from 1 have 2: "\<exists> a. {x . x \<notin> f x } = f a" by blast
from 2 show "False" by blast
qed

lemma "\<not> surj (f :: 'a \<Rightarrow> 'a set )"
proof
assume "surj f"
  hence "\<exists> a. {x . x \<notin> f x } = f a" by(auto simp: surj_def)
  thus "False" by blast
qed

(* 5.1 *)

lemma
  assumes TT: "\<forall> x y. T x y \<or> T y x"
    and A:    "\<forall> x y. A x y \<and> A y x \<longrightarrow> x = y"
    and TA:   "\<forall> x y. T x y \<longrightarrow> A x y"
    and A2:   "A x y"
  shows       "T x y"
proof (rule ccontr)
  assume Z: "\<not> T x y"
  from TT and this have "T y x" by auto
  from TA and this have "A y x" by auto
  from this and A2 have "A x y \<and> A y x" by auto
  from this and A have "x = y" by auto
  from this and TT and Z show "False" by auto
qed

(* 5.2 *)

lemma "\<exists> ys zs. xs = ys @ zs \<and> (length ys = length zs \<or> length ys = length zs + 1)"
proof -
  obtain n where nd: "n = (length xs) div 2" by auto
  obtain m where md: "m = (length xs) - n" by auto
  from md have mmin: "m \<le> length xs" by auto
  from nd and md have mneq: "m = n \<or> m = n + 1" by auto
  obtain ys where yd: "ys = take m xs" by auto
  obtain zs where zd: "zs = drop m xs" by auto
  from nd and yd and mmin have L1: "length ys = m" by auto
  from nd and md and zd have L2: "length zs = n" by auto
  from L1 and L2 and mneq have Lconj: "length ys = length zs \<or> length ys = length zs + 1" by auto
  from yd and zd have Conc: "xs = ys @ zs" by auto
  from Conc and Lconj show ?thesis by auto
qed

(* 5.3 *)

inductive ev :: "nat \<Rightarrow> bool" where
ev0: "ev 0" |
evSS: "ev n \<Longrightarrow> ev(Suc(Suc n))"

fun evn :: "nat \<Rightarrow> bool" where
"evn 0 = True" |
"evn (Suc 0) = False" |
"evn (Suc (Suc n)) = evn n"

lemma "ev n \<Longrightarrow> ev (n - 2)"
proof -
  assume "ev n"
  from this have "ev (n - 2)"
  proof cases
    case ev0 thus "ev(n - 2)" by (simp add: ev.ev0)
  next
    case (evSS k) thus "ev (n - 2)" by (simp add: ev.evSS)
  qed
  thus ?thesis by auto
qed

lemma assumes a: "ev (Suc (Suc n))" shows "ev n"
proof -
  show ?thesis using a
  proof cases
    case evSS thus ?thesis by auto
  qed
qed

lemma assumes a: "ev (Suc (Suc n))" shows "ev n"
  using a ev.cases by blast

(* 5.4 *)

lemma "\<not> ev (Suc 0)"
proof
  assume "ev (Suc 0)" then show False by cases
qed

lemma "\<not> ev (Suc (Suc (Suc 0)))"
proof
  assume "ev (Suc (Suc (Suc 0)))"
  hence "ev (Suc 0)" by cases
  thus False by cases
qed

lemma "\<not> ev (Suc (Suc (Suc 0)))"
  using ev.cases by auto

(*
Exercise 5.5. Recall predicate star from Section 4.5.2 and iter from Exer-
cise 4.4. Prove iter r n x y =\<Rightarrow> star r x y in a structured style; do not just
sledgehammer each case of the required induction.
*)

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl: "star r x x" |
step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
iter0: "iter r 0 x x" |
itern: "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (Suc n) x z"

lemma "iter r n x y \<Longrightarrow> star r x y"
proof (induction rule: iter.induct)
  case iter0
  show ?case by (auto intro: refl)
next
  case itern
  thus ?case by (auto intro: step)
qed

(* 5.6 *)

fun elems :: "'a list \<Rightarrow> 'a set" where
"elems [] = {}" |
"elems (x#xs) = {x} \<union> elems xs"

value "elems ([1, 2, 5, 6]::nat list)"
value "elems ([]::nat list)"

lemma "x \<in> elems xs \<Longrightarrow> \<exists> ys zs. xs = ys @ x # zs \<and> x \<notin> elems ys"
proof (induction xs)
  case Nil thus ?case by auto
next
  case (Cons h xs0) show ?case
  proof cases
    assume hx: "h = x" then
    obtain ys where yd: "ys = ([]::'a list)" by auto
    hence "h \<notin> elems ys" by auto
    thus ?thesis using yd hx by blast
  next
    assume hnx: "h \<noteq> x"
    from hnx Cons.prems have inxs: "x \<in> elems xs0" by auto
    obtain ys0 zs where iyzs: "xs0 = ys0 @ x # zs \<and> x \<notin> elems ys0" using Cons.IH inxs by blast
    obtain ys where yd: "ys = h # ys0" by auto
    obtain xs where xd: "xs = h # xs0" by auto
    from hnx xd yd iyzs have wtf: "xs = ys @ x # zs \<and> x \<notin> elems ys" by auto
    from wtf xd show ?thesis by auto
  qed
qed

(* 5.7 *)

datatype alpha = a | b

inductive S :: "alpha list \<Rightarrow> bool" where
S0:  "S Nil" |
aSb: "S s \<Longrightarrow> S (a # s @ [b])" |
SS:  "S x \<Longrightarrow> S y \<Longrightarrow> S (x @ y)"

inductive T :: "alpha list \<Rightarrow> bool" where
T0:   "T Nil" |
TaTb: "T x \<Longrightarrow> T y \<Longrightarrow> T (x @ a # y @ [b])"

lemma TS: "T w \<Longrightarrow> S w"
  apply(induction rule: T.induct)
  apply(rule S0)
  apply(rule SS)
  apply(simp)
  apply(rule aSb)
  apply(simp)
  (* apply(auto intro: S0 aSb SS) *)
  done

lemma aTb: "T x \<Longrightarrow> T (a # x @ [b])"
  (* try found it *)
  by (metis Cons_eq_appendI T.simps self_append_conv2)

lemma TT: "T y \<Longrightarrow> T x \<Longrightarrow> T (x @ y)"
  apply(induction rule: T.induct)
  apply(auto intro: TaTb T0)
  by (metis T.simps append_eq_appendI)

lemma ST: "S w \<Longrightarrow> T w"
  apply(induction rule: S.induct)
  apply(rule T0)
  apply(rule aTb)
  apply(simp)
  apply(rule TT)
  apply(simp)
  apply(simp)
  done

fun balanced :: "nat \<Rightarrow> alpha list \<Rightarrow> bool" where
"balanced n Nil = (n = 0)" |
"balanced n (a#xs) = balanced (n + 1) xs" |
"balanced 0 (b#xs) = False" |
"balanced n (b#xs) = balanced (n - 1) xs"

value "balanced 0 [a, a, b, a, b, b, a, b]"

lemma "balanced n w = S (replicate n a @ w)"
  sorry

end


section \<open>Specification\<close>

theory Goodstein_Lambda
  imports Main
begin

subsection \<open>Hereditary base representation\<close>

text \<open>We define a data type of trees and an evaluation function that sums siblings and
  exponentiates with respect to the given base on nesting.\<close>

datatype C = C (unC: "C list")

fun evalC where
  "evalC b (C []) = 0"
| "evalC b (C (x # xs)) = b^evalC b x + evalC b (C xs)"

value "evalC 2 (C [])" \<comment> \<open>$0$\<close>
value "evalC 2 (C [C []])" \<comment> \<open>$2^0 = 1$\<close>
value "evalC 2 (C [C [C []]])" \<comment> \<open>$2^1 = 2$\<close>
value "evalC 2 (C [C [], C []])" \<comment> \<open>$2^0 + 2^0 = 2^0 \cdot 2 = 2$; not in hereditary base $2$\<close>

text \<open>The hereditary base representation is characterized as trees (i.e., nested lists) whose
  lists have monotonically increasing evaluations, with fewer than @{term "b"} repetitions for
  each value. We will show later that this representation is unique.\<close>

inductive_set hbase for b where
  "C [] \<in> hbase b"
| "i \<noteq> 0 \<Longrightarrow> i < b \<Longrightarrow> n \<in> hbase b \<Longrightarrow>
   C ms \<in> hbase b \<Longrightarrow> (\<And>m'. m' \<in> set ms \<Longrightarrow> evalC b n < evalC b m') \<Longrightarrow>
   C (replicate i n @ ms) \<in> hbase b"

text \<open>We can convert to and from natural numbers as follows.\<close>

definition H2N where
  "H2N b n = evalC b n"

text \<open>As we will show later, @{term "H2N b"} restricted to @{term "hbase n"} is bijective
  if @{prop "b \<ge> (2 :: nat)"}, so we can convert from natural numbers by taking the inverse.\<close>

definition N2H where
  "N2H b n = inv_into (hbase b) (H2N b) n"

subsection \<open>The Goodstein function\<close>

text \<open>We define a function that computes the length of the Goodstein sequence whose $c$-th element
  is $g_c = n$. Termination will be shown later, thereby establishing Goodstein's theorem.\<close>

function (sequential) goodstein :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "goodstein 0 n = 0"
  \<comment> \<open>we start counting at 1; also note that the initial base is @{term "c+1 :: nat"} and\<close>
  \<comment> \<open>hereditary base 1 makes no sense, so we have to avoid this case\<close>
| "goodstein c 0 = c"
| "goodstein c n = goodstein (c+1) (H2N (c+2) (N2H (c+1) n) - 1)"
  by pat_completeness auto

abbreviation \<G> where
  "\<G> n \<equiv> goodstein (Suc 0) n"

section \<open>Ordinals\<close>

text \<open>The following type contains countable ordinals, by the usual case distinction into 0,
  successor ordinal, or limit ordinal; limit ordinals are given by their fundamental sequence.
  Hereditary base @{term "b"} representations carry over to such ordinals by replacing each
  occurrence of the base by @{term "\<omega>"}.\<close>

datatype Ord = Z | S Ord | L "nat \<Rightarrow> Ord"

text \<open>Note that the following arithmetic operations are not correct for all ordinals. However, they
  will only be used in cases where they actually correspond to the ordinal arithmetic operations.\<close>

primrec addO where
  "addO n Z = n"
| "addO n (S m) = S (addO n m)"
| "addO n (L f) = L (\<lambda>i. addO n (f i))"

primrec mulO where
  "mulO n Z = Z"
| "mulO n (S m) = addO (mulO n m) n"
| "mulO n (L f) = L (\<lambda>i. mulO n (f i))"

definition \<omega> where
  "\<omega> = L (\<lambda>n. (S ^^ n) Z)"

primrec exp\<omega> where
  "exp\<omega> Z = S Z"
| "exp\<omega> (S n) = mulO (exp\<omega> n) \<omega>"
| "exp\<omega> (L f) = L (\<lambda>i. exp\<omega> (f i))"

subsection \<open>Evaluation\<close>

text \<open>Evaluating an ordinal number at base $b$ is accomplished by taking the $b$-th element of
  all fundamental sequences and interpreting zero and successor over the natural numbers.\<close>

primrec evalO where
  "evalO b Z = 0"
| "evalO b (S n) = Suc (evalO b n)"
| "evalO b (L f) = evalO b (f b)"

subsection \<open>Goodstein function and sequence\<close>

text \<open>We can define the Goodstein function very easily, but proving correctness will take a while.\<close>

primrec goodsteinO where
  "goodsteinO c Z = c"
| "goodsteinO c (S n) = goodsteinO (c+1) n"
| "goodsteinO c (L f) = goodsteinO c (f (c+2))"

primrec stepO where
  "stepO c Z = Z"
| "stepO c (S n) = n"
| "stepO c (L f) = stepO c (f (c+2))"

text \<open>We can compute a few values of the Goodstein sequence starting at $4$.\<close>

definition g4O where
  "g4O n = fold stepO [1..<Suc n] ((exp\<omega> ^^ 3) Z)"

value "map (\<lambda>n. evalO (n+2) (g4O n)) [0..<10]"
\<comment> \<open>@{value "[4, 26, 41, 60, 83, 109, 139, 173, 211, 253] :: nat list"}\<close>

subsection \<open>Properties of evaluation\<close>

lemma evalO_addO [simp]:
  "evalO b (addO n m) = evalO b n + evalO b m"
  by (induct m) auto

lemma evalO_mulO [simp]:
  "evalO b (mulO n m) = evalO b n * evalO b m"
  by (induct m) auto

lemma evalO_n [simp]:
  "evalO b ((S ^^ n) Z) = n"
  by (induct n) auto

lemma evalO_\<omega> [simp]:
  "evalO b \<omega> = b"
  by (auto simp: \<omega>_def)

lemma evalO_exp\<omega> [simp]:
  "evalO b (exp\<omega> n) = b^(evalO b n)"
  by (induct n) auto

text \<open>Note that evaluation is useful for proving that @{type "Ord"} values are distinct:\<close>
notepad begin
  have "addO n (exp\<omega> m) \<noteq> n" for n m by (auto dest: arg_cong[of _ _ "evalO 1"])
end

subsection \<open>Arithmetic properties\<close>

lemma addO_Z [simp]:
  "addO Z n = n"
  by (induct n) auto

lemma addO_assoc [simp]:
  "addO n (addO m p) = addO (addO n m) p"
  by (induct p) auto

lemma mul0_distrib [simp]:
  "mulO n (addO p q) = addO (mulO n p) (mulO n q)"
  by (induct q) auto

lemma mulO_assoc [simp]:
  "mulO n (mulO m p) = mulO (mulO n m) p"
  by (induct p) auto

section \<open>Cantor normal form\<close>

text \<open>The previously introduced tree type @{type C} can be used to represent Cantor normal forms;
  they are trees (evaluated at base @{term \<omega>}) such that siblings are in non-decreasing order.
  One can think of this as hereditary base @{term \<omega>}. The plan is to mirror selected operations on
  ordinals in Cantor normal forms.\<close>

subsection \<open>Conversion to and from the ordinal type @{type Ord}\<close>

fun C2O where
  "C2O (C []) = Z"
| "C2O (C (n # ns)) = addO (C2O (C ns)) (exp\<omega> (C2O n))"

definition O2C where
  "O2C = inv C2O"

text \<open>We show that @{term C2O} is injective, meaning the inverse is unique.\<close>

lemma addO_exp\<omega>_inj:
  assumes "addO n (exp\<omega> m) = addO n' (exp\<omega> m')"
  shows "n = n'" and "m = m'"
proof -
  have "addO n (exp\<omega> m) = addO n' (exp\<omega> m') \<Longrightarrow> n = n'"
    by (induct m arbitrary: m'; case_tac m';
      force simp: \<omega>_def dest!: fun_cong[of _ _ 1])
  moreover have "addO n (exp\<omega> m) = addO n (exp\<omega> m') \<Longrightarrow> m = m'"
    apply (induct m arbitrary: n m'; case_tac m')
    apply (auto 0 3 simp: \<omega>_def intro: rangeI
      dest: arg_cong[of _ _ "evalO 1"] fun_cong[of _ _ 0] fun_cong[of _ _ 1])[8] (* 1 left *)
    by simp (meson ext rangeI)
  ultimately show "n = n'" and "m = m'" using assms by simp_all
qed

lemma C2O_inj:
  "C2O n = C2O m \<Longrightarrow> n = m"
  by (induct n arbitrary: m rule: C2O.induct; case_tac m rule: C2O.cases)
    (auto dest: addO_exp\<omega>_inj arg_cong[of _ _ "evalO 1"])

lemma O2C_C2O [simp]:
  "O2C (C2O n) = n"
  by (auto intro!: inv_f_f simp: O2C_def inj_def C2O_inj)

lemma O2C_Z [simp]:
  "O2C Z = C []"
  using O2C_C2O[of "C []", unfolded C2O.simps] .

lemma C2O_replicate:
  "C2O (C (replicate i n)) = mulO (exp\<omega> (C2O n)) ((S ^^ i) Z)"
  by (induct i) auto

lemma C2O_app:
  "C2O (C (xs @ ys)) = addO (C2O (C ys)) (C2O (C xs))"
  by (induct xs arbitrary: ys) auto

subsection \<open>Evaluation\<close>

lemma evalC_def':
  "evalC b n = evalO b (C2O n)"
  by (induct n rule: C2O.induct) auto

lemma evalC_app [simp]:
  "evalC b (C (ns @ ms)) = evalC b (C ns) + evalC b (C ms)"
  by (induct ns) auto

lemma evalC_replicate [simp]:
  "evalC b (C (replicate c n)) = c * evalC b (C [n])"
  by (induct c) auto

subsection \<open>Transfer of the @{type Ord} induction principle to @{type C}\<close>

fun funC where \<comment> \<open>@{term funC} computes the fundamental sequence on @{type C}\<close>
  "funC (C []) = (\<lambda>i. [C []])"
| "funC (C (C [] # ns)) = (\<lambda>i. replicate i (C ns))"
| "funC (C (n # ns)) = (\<lambda>i. [C (funC n i @ ns)])"

lemma C2O_cons:
  "C2O (C (n # ns)) =
    (if n = C [] then S (C2O (C ns)) else L (\<lambda>i. C2O (C (funC n i @ ns))))"
  by (induct n arbitrary: ns rule: funC.induct)
    (simp_all add: \<omega>_def C2O_replicate C2O_app flip: exp\<omega>_addO)

lemma C_Ord_induct:
  assumes "P (C [])"
  and "\<And>ns. P (C ns) \<Longrightarrow> P (C (C [] # ns))"
  and "\<And>n ns ms. (\<And>i. P (C (funC (C (n # ns)) i @ ms))) \<Longrightarrow>
    P (C (C (n # ns) # ms))"
  shows "P n"
proof -
  have "\<forall>n. C2O n = m \<longrightarrow> P n" for m
    by (induct m; intro allI; case_tac n rule: funC.cases)
      (auto simp: C2O_cons simp del: C2O.simps(2) intro: assms)
  then show ?thesis by simp
qed

subsection \<open>Goodstein function and sequence on @{type C}\<close>

function (domintros) goodsteinC where
  "goodsteinC c (C []) = c"
| "goodsteinC c (C (C [] # ns)) = goodsteinC (c+1) (C ns)"
| "goodsteinC c (C (C (n # ns) # ms)) =
    goodsteinC c (C (funC (C (n # ns)) (c+2) @ ms))"
  by pat_completeness auto

termination
proof -
  have "goodsteinC_dom (c, n)" for c n
    by (induct n arbitrary: c rule: C_Ord_induct) (auto intro: goodsteinC.domintros)
  then show ?thesis by simp
qed

lemma goodsteinC_def':
  "goodsteinC c n = goodsteinO c (C2O n)"
  by (induct c n rule: goodsteinC.induct) (simp_all add: C2O_cons del: C2O.simps(2))

function (domintros) stepC where
  "stepC c (C []) = C []"
| "stepC c (C (C [] # ns)) = C ns"
| "stepC c (C (C (n # ns) # ms)) =
    stepC c (C (funC (C (n # ns)) (Suc (Suc c)) @ ms))"
  by pat_completeness auto

termination
proof -
  have "stepC_dom (c, n)" for c n
    by (induct n arbitrary: c rule: C_Ord_induct) (auto intro: stepC.domintros)
  then show ?thesis by simp
qed

definition g4C where
  "g4C n = fold stepC [1..<Suc n] (C [C [C [C []]]])"

value "map (\<lambda>n. evalC (n+2) (g4C n)) [0..<10]"
\<comment> \<open>@{value "[4, 26, 41, 60, 83, 109, 139, 173, 211, 253] :: nat list"}\<close>

subsection \<open>Properties\<close>

lemma stepC_def':
  "stepC c n = O2C (stepO c (C2O n))"
  by (induct c n rule: stepC.induct) (simp_all add: C2O_cons del: C2O.simps(2))

lemma funC_ne [simp]:
  "funC m (Suc n) \<noteq> []"
  by (cases m rule: funC.cases) simp_all

lemma evalC_funC [simp]:
  "evalC b (C (funC n b)) = evalC b (C [n])"
  by (induct n rule: funC.induct) simp_all

lemma stepC_app [simp]:
  "n \<noteq> C [] \<Longrightarrow> stepC c (C (unC n @ ns)) = C (unC (stepC c n) @ ns)"
  by (induct n arbitrary: ns rule: stepC.induct) simp_all

lemma stepC_cons [simp]:
  "ns \<noteq> [] \<Longrightarrow> stepC c (C (n # ns)) = C (unC (stepC c (C [n])) @ ns)"
  using stepC_app[of "C[n]" c ns] by simp

lemma stepC_dec:
  "n \<noteq> C [] \<Longrightarrow> Suc (evalC (Suc (Suc c)) (stepC c n)) = evalC (Suc (Suc c)) n"
  by (induct c n rule: stepC.induct) simp_all

lemma stepC_dec':
  "n \<noteq> C [] \<Longrightarrow> evalC (c+3) (stepC c n) < evalC (c+3) n"
proof (induct c n rule: stepC.induct)
  case (3 c n ns ms)
  have "evalC (c+3) (C (funC (C (n # ns)) (Suc (Suc c)))) \<le>
      (c+3) ^ ((c+3) ^ evalC (c+3) n + evalC (c+3) (C ns))"
    by (induct n rule: funC.induct) (simp_all add: distrib_right)
  then show ?case using 3 by simp
qed simp_all

section \<open>Hereditary base @{term b} representation\<close>

text \<open>We now turn to properties of the @{term "hbase b"} subset of trees.\<close>

subsection \<open>Uniqueness\<close>

text \<open>We show uniqueness of the hereditary base representation by showing that @{term "evalC b"}
  restricted to @{term "hbase b"} is injective.\<close>

lemma hbaseI2:
  "i < b \<Longrightarrow> n \<in> hbase b \<Longrightarrow> C m \<in> hbase b \<Longrightarrow>
    (\<And>m'. m' \<in> set m \<Longrightarrow> evalC b n < evalC b m') \<Longrightarrow>
    C (replicate i n @ m) \<in> hbase b"
  by (cases i) (auto intro: hbase.intros simp del: replicate.simps(2))

lemmas hbase_singletonI =
  hbase.intros(2)[of 1 "Suc (Suc b)" for b, OF _ _ _ hbase.intros(1), simplified]

lemma hbase_hd:
  "C ns \<in> hbase b \<Longrightarrow> ns \<noteq> [] \<Longrightarrow> hd ns \<in> hbase b"
  by (cases rule: hbase.cases) auto

lemmas hbase_hd' [dest] = hbase_hd[of "n # ns" for n ns, simplified]

lemma hbase_tl:
  "C ns \<in> hbase b \<Longrightarrow> ns \<noteq> [] \<Longrightarrow> C (tl ns) \<in> hbase b"
  by (cases "C ns" b rule: hbase.cases) (auto intro: hbaseI2)

lemmas hbase_tl' [dest] = hbase_tl[of "n # ns" for n ns, simplified]

lemma hbase_elt [dest]:
  "C ns \<in> hbase b \<Longrightarrow> n \<in> set ns \<Longrightarrow> n \<in> hbase b"
  by (induct ns) auto

lemma evalC_sum_list:
  "evalC b (C ns) = sum_list (map (\<lambda>n. b^evalC b n) ns)"
  by (induct ns) auto

lemma sum_list_replicate:
  "sum_list (replicate n x) = n * x"
  by (induct n) auto

lemma base_red:
  fixes b :: nat
  assumes n: "\<And>n'. n' \<in> set ns \<Longrightarrow> n < n'" "i < b" "i \<noteq> 0"
  and m: "\<And>m'. m' \<in> set ms \<Longrightarrow> m < m'" "j < b" "j \<noteq> 0"
  and s: "i * b^n + sum_list (map (\<lambda>n. b^n) ns) = j * b^m + sum_list (map (\<lambda>n. b^n) ms)"
  shows "i = j \<and> n = m"
  using n(1) m(1) s
proof (induct n arbitrary: m ns ms)
  { fix ns ms :: "nat list" and i j m :: nat
    assume n': "\<And>n'. n' \<in> set ns \<Longrightarrow> 0 < n'" "i < b" "i \<noteq> 0"
    assume m': "\<And>m'. m' \<in> set ms \<Longrightarrow> m < m'" "j < b" "j \<noteq> 0"
    assume s': "i * b^0 + sum_list (map (\<lambda>n. b^n) ns) = j * b^m + sum_list (map (\<lambda>n. b^n) ms)"
    obtain x where [simp]: "sum_list (map ((^) b) ns) = x*b"
      using n'(1)
      by (intro that[of "sum_list (map (\<lambda>n. b^(n-1)) ns)"])
        (simp add: ac_simps flip: sum_list_const_mult power_Suc cong: map_cong)
    obtain y where [simp]: "sum_list (map ((^) b) ms) = y*b"
      using order.strict_trans1[OF le0 m'(1)]
      by (intro that[of "sum_list (map (\<lambda>n. b^(n-1)) ms)"])
        (simp add: ac_simps flip: sum_list_const_mult power_Suc cong: map_cong)
    have [simp]: "m = 0"
      using s' n'(2,3)
      by (cases m, simp_all)
        (metis Groups.mult_ac(2) Groups.mult_ac(3) Suc_pred div_less mod_div_mult_eq
          mod_mult_self2 mod_mult_self2_is_0 mult_zero_right nat.simps(3))
    have "i = j \<and> 0 = m" using s' n'(2,3) m'(2,3)
      by simp (metis div_less mod_div_mult_eq mod_mult_self1)
  } note BASE = this
  {
    case 0 show ?case by (rule BASE; fact)
  next
    case (Suc n m')
    have "j = i \<and> 0 = Suc n" if "m' = 0" using Suc(2-4)
      by (intro BASE[of ms j ns "Suc n" i]) (simp_all add: ac_simps that n(2,3) m(2,3))
    then obtain m where m' [simp]: "m' = Suc m"
      by (cases m') auto
    obtain ns' where [simp]: "ns = map Suc ns'" "\<And>n'. n' \<in> set ns' \<Longrightarrow> n < n'"
      using Suc(2) less_trans[OF zero_less_Suc Suc(2)]
      by (intro that[of "map (\<lambda>n. n-1) ns"]; force cong: map_cong)
    obtain ms' where [simp]: "ms = map Suc ms'" "\<And>m'. m' \<in> set ms' \<Longrightarrow> m < m'"
      using Suc(3)[unfolded m'] less_trans[OF zero_less_Suc Suc(3)[unfolded m']]
      by (intro that[of "map (\<lambda>n. n-1) ms"]; force cong: map_cong)
    have *: "b * x = b * y \<Longrightarrow> x = y" for x y using n(2) by simp
    have "i = j \<and> n = m"
    proof (rule Suc(1)[of "map (\<lambda>n. n-1) ns" "map (\<lambda>n. n-1) ms" m, OF _ _ *], goal_cases)
      case 3 show ?case using Suc(4) unfolding add_mult_distrib2
        by (simp add: comp_def ac_simps flip: sum_list_const_mult)
    qed simp_all
    then show ?case by simp
  }
qed

lemma evalC_inj_on_hbase:
  "n \<in> hbase b \<Longrightarrow> m \<in> hbase b \<Longrightarrow> evalC b n = evalC b m \<Longrightarrow> n = m"
proof (induct n arbitrary: m rule: hbase.induct)
  case 1
  then show ?case by (cases m rule: hbase.cases) simp_all
next
  case (2 i n ns m')
  obtain j m ms where [simp]: "m' = C (replicate j m @ ms)" and
    m: "j \<noteq> 0" "j < b" "m \<in> hbase b" "C ms \<in> hbase b" "\<And>m'. m' \<in> set ms \<Longrightarrow> evalC b m < evalC b m'"
    using 2(8,1,2,9) by (cases m' rule: hbase.cases) simp_all
  have "i = j \<and> evalC b n = evalC b m" using 2(1,2,7,9) m(1,2,5)
    by (intro base_red[of "map (evalC b) ns" _ _ b "map (evalC b) ms"])
      (auto simp: comp_def evalC_sum_list sum_list_replicate)
  then show ?case
    using 2(4)[OF m(3)] 2(6)[OF m(4)] 2(9) by simp
qed

subsection \<open>Correctness of @{const stepC}\<close>

text \<open>We show that @{term "stepC c"} preserves hereditary base @{term "c + 2 :: nat"}
  representations. In order to cover intermediate results produced by @{const stepC}, we extend
  the hereditary base representation to allow the least significant digit to be equal to @{term b},
  which essentially means that we may have an extra sibling in front on every level.\<close>

inductive_set hbase_ext for b where
  "n \<in> hbase b \<Longrightarrow> n \<in> hbase_ext b"
| "n \<in> hbase_ext b \<Longrightarrow>
   C m \<in> hbase b \<Longrightarrow> (\<And>m'. m' \<in> set m \<Longrightarrow> evalC b n \<le> evalC b m') \<Longrightarrow>
   C (n # m) \<in> hbase_ext b"

lemma hbase_ext_hd' [dest]:
  "C (n # ns) \<in> hbase_ext b \<Longrightarrow> n \<in> hbase_ext b"
  by (cases rule: hbase_ext.cases) (auto intro: hbase_ext.intros(1))

lemma hbase_ext_tl:
  "C ns \<in> hbase_ext b \<Longrightarrow> ns \<noteq> [] \<Longrightarrow> C (tl ns) \<in> hbase b"
  by (cases "C ns" b rule: hbase_ext.cases; cases ns) (simp_all add: hbase_tl')

lemmas hbase_ext_tl' [dest] = hbase_ext_tl[of "n # ns" for n ns, simplified]

lemma hbase_funC:
  "c \<noteq> 0 \<Longrightarrow> C (n # ns) \<in> hbase_ext (Suc c) \<Longrightarrow>
    C (funC n (Suc c) @ ns) \<in> hbase_ext (Suc c)"
proof (induct n arbitrary: ns rule: funC.induct)
  case (2 ms)
  have [simp]: "evalC (Suc c) (C ms) < evalC (Suc c) m'" if "m' \<in> set ns" for m'
    using 2(2)
  proof (cases rule: hbase_ext.cases)
    case 1 then show ?thesis using that
      by (cases rule: hbase.cases, case_tac i) (auto intro: Suc_lessD)
  qed (auto simp: Suc_le_eq that)
  show ?case using 2
    by (auto 0 4 intro: hbase_ext.intros hbase.intros(2) order.strict_implies_order)
next
  case (3 m ms ms')
  show ?case
    unfolding funC.simps append_Cons append_Nil
  proof (rule hbase_ext.intros(2), goal_cases 31 32 33)
    case (33 m')
    show ?case using 3(3)
    proof (cases rule: hbase_ext.cases)
      case 1 show ?thesis using 1 3(1,2) 33
        by (cases rule: hbase.cases, case_tac i) (auto intro: less_or_eq_imp_le)
    qed (insert 33, simp)
  qed (insert 3, blast+)
qed auto

lemma stepC_sound:
  "n \<in> hbase_ext (Suc (Suc c)) \<Longrightarrow> stepC c n \<in> hbase (Suc (Suc c))"
proof (induct c n rule: stepC.induct)
  case (3 c n ns ms)
  show ?case using 3(2,1)
    by (cases rule: hbase_ext.cases; unfold stepC.simps) (auto intro: hbase_funC)
qed (auto intro: hbase.intros)

subsection \<open>Surjectivity of @{const evalC}\<close>

text \<open>Note that the base must be at least @{term "2 :: nat"}.\<close>

lemma evalC_surjective:
  "\<exists>n' \<in> hbase (Suc (Suc b)). evalC (Suc (Suc b)) n' = n"
proof (induct n)
  case 0 then show ?case by (auto intro: bexI[of _ "C []"] hbase.intros)
next
  have [simp]: "Suc x \<le> Suc (Suc b)^x" for x by (induct x) auto
  case (Suc n)
  then obtain n' where "n' \<in> hbase (Suc (Suc b))" "evalC (Suc (Suc b)) n' = n" by blast
  then obtain n' j where n': "Suc n \<le> j" "j = evalC (Suc (Suc b)) n'" "n' \<in> hbase (Suc (Suc b))"
    by (intro that[of _ "C [n']"])
      (auto intro!: intro: hbase.intros(1) dest!: hbaseI2[of 1 "b+2" n' "[]", simplified])
  then show ?case
  proof (induct rule: inc_induct)
    case (step m)
    obtain n' where "n' \<in> hbase (Suc (Suc b))" "evalC (Suc (Suc b)) n' = Suc m"
      using step(3)[OF step(4,5)] by blast
    then show ?case using stepC_dec[of n' "b"]
      by (cases n' rule: C2O.cases) (auto intro: stepC_sound hbase_ext.intros(1))
  qed blast
qed

subsection \<open>Monotonicity of @{const hbase}\<close>

text \<open>Here we show that every hereditary base @{term "b :: nat"} number is also a valid hereditary
  base @{term "b+1 :: nat"} number. This is not immediate because we have to show that monotonicity
  of siblings is preserved.\<close>

lemma hbase_evalC_mono:
  assumes "n \<in> hbase b" "m \<in> hbase b" "evalC b n < evalC b m"
  shows "evalC (Suc b) n < evalC (Suc b) m"
proof (cases "b < 2")
  case True show ?thesis using assms(2,3) True by (cases rule: hbase.cases) simp_all
next
  case False
  then obtain b' where [simp]: "b = Suc (Suc b')"
    by (auto simp: numeral_2_eq_2 not_less_eq dest: less_imp_Suc_add)
  show ?thesis using assms(3,1,2)
  proof (induct "evalC b n" "evalC b m" arbitrary: n m rule: less_Suc_induct)
    case 1 then show ?case using stepC_sound[of m b', OF hbase_ext.intros(1)]
      stepC_dec[of m b'] stepC_dec'[of m b'] evalC_inj_on_hbase
      by (cases m rule: C2O.cases) (fastforce simp: eval_nat_numeral)+
  next
    case (2 j) then show ?case
      using evalC_surjective[of b' j] less_trans by fastforce
  qed
qed

lemma hbase_mono:
  "n \<in> hbase b \<Longrightarrow> n \<in> hbase (Suc b)"
  by (induct n rule: hbase.induct) (auto 0 3 intro: hbase.intros hbase_evalC_mono)

subsection \<open>Conversion to and from @{type nat}\<close>

text \<open>We have previously defined @{term "H2N b = evalC b"} and @{term "N2H b"} as its inverse.
  So we can use the injectivity and surjectivity of @{term "evalC b"} for simplification.\<close>

lemma N2H_inv:
  "n \<in> hbase b \<Longrightarrow> N2H b (H2N b n) = n"
  using evalC_inj_on_hbase
  by (auto simp: N2H_def H2N_def[abs_def] inj_on_def intro!: inv_into_f_f)

lemma N2H_eqI:
  "n \<in> hbase (Suc (Suc b)) \<Longrightarrow>
   H2N (Suc (Suc b)) n = m \<Longrightarrow> N2H (Suc (Suc b)) m = n"
  using N2H_inv by blast

lemma N2H_neI:
  "n \<in> hbase (Suc (Suc b)) \<Longrightarrow>
   H2N (Suc (Suc b)) n \<noteq> m \<Longrightarrow> N2H (Suc (Suc b)) m \<noteq> n"
  using H2N_inv by blast

lemma N2H_0 [simp]:
  "N2H (Suc (Suc c)) 0 = C []"
  using H2N_def N2H_inv hbase.intros(1) by fastforce

lemma N2H_nz [simp]:
  "0 < n \<Longrightarrow> N2H (Suc (Suc c)) n \<noteq> C []"
  by (metis N2H_0 H2N_inv neq0_conv)

section \<open>The Goodstein function revisited\<close>

text \<open>We are now ready to prove termination of the Goodstein function @{const goodstein} as well
  as its relation to @{const goodsteinC} and @{const goodsteinO}.\<close>

lemma goodstein_aux:
  "goodsteinC (Suc c) (N2H (Suc (Suc c)) (Suc n)) =
    goodsteinC (c+2) (N2H (c+3) (H2N (c+3) (N2H (c+2) (n+1)) - 1))"
proof -
  have [simp]: "n \<noteq> C [] \<Longrightarrow> goodsteinC c n = goodsteinC (c+1) (stepC c n)" for c n
    by (induct c n rule: stepC.induct) simp_all
  have [simp]: "stepC (Suc c) (N2H (Suc (Suc c)) (Suc n)) \<in> hbase (Suc (Suc (Suc c)))"
    by (metis H2N_def N2H_inv evalC_surjective hbase_ext.intros(1) hbase_mono stepC_sound)
  show ?thesis
    using arg_cong[OF stepC_dec[of "N2H (c+2) (n+1)" "c+1", folded H2N_def], of "\<lambda>n. N2H (c+3) (n-1)"]
    by (simp add: eval_nat_numeral N2H_inv)
qed

termination goodstein
proof (relation "measure (\<lambda>(c, n). goodsteinC c (N2H (c+1) n) - c)", goal_cases _ 1)
  case (1 c n)
  have *: "goodsteinC c n \<ge> c" for c n
    by (induct c n rule: goodsteinC.induct) simp_all
  show ?case by (simp add: goodstein_aux eval_nat_numeral) (meson Suc_le_eq diff_less_mono2 lessI *)
qed simp

lemma goodstein_def':
  "c \<noteq> 0 \<Longrightarrow> goodstein c n = goodsteinC c (N2H (c+1) n)"
  by (induct c n rule: goodstein.induct) (simp_all add: goodstein_aux eval_nat_numeral)

lemma goodstein_impl:
  "c \<noteq> 0 \<Longrightarrow> goodstein c n = goodsteinO c (C2O (N2H (c+1) n))"
  \<comment> \<open>but note that @{term N2H} is not executable as currently defined\<close>
  using goodstein_def'[unfolded goodsteinC_def'] .

lemma goodstein_16:
  "\<G> 16 = goodsteinO 1 (exp\<omega> (exp\<omega> (exp\<omega> (exp\<omega> Z))))"
proof -
  have "N2H (Suc (Suc 0)) 16 = C [C [C [C [C []]]]]"
    by (auto simp: H2N_def intro!: N2H_eqI hbase_singletonI hbase.intros(1))
  then show ?thesis by (simp add: goodstein_impl)
qed

section \<open>Translation to $\lambda$-calculus\<close>

text \<open>We define Church encodings for @{type nat} and @{type Ord}. Note that we are basically in a
  Hindley-Milner type system, so we cannot use a proper polymorphic type. We can still express
  Church encodings as folds over values of the original type.\<close>

abbreviation Z\<^sub>N where "Z\<^sub>N \<equiv> (\<lambda>s z. z)"
abbreviation S\<^sub>N where "S\<^sub>N \<equiv> (\<lambda>n s z. s (n s z))"

primrec fold_nat ("\<langle>_\<rangle>\<^sub>N") where
  "\<langle>0\<rangle>\<^sub>N = Z\<^sub>N"
| "\<langle>Suc n\<rangle>\<^sub>N = S\<^sub>N \<langle>n\<rangle>\<^sub>N"

lemma one\<^sub>N:
  "\<langle>1\<rangle>\<^sub>N = (\<lambda>x. x)"
  by simp

abbreviation Z\<^sub>O where "Z\<^sub>O \<equiv> (\<lambda>z s l. z)"
abbreviation S\<^sub>O where "S\<^sub>O \<equiv> (\<lambda>n z s l. s (n z s l))"
abbreviation L\<^sub>O where "L\<^sub>O \<equiv> (\<lambda>f z s l. l (\<lambda>i. f i z s l))"

primrec fold_Ord ("\<langle>_\<rangle>\<^sub>O") where
  "\<langle>Z\<rangle>\<^sub>O = Z\<^sub>O"
| "\<langle>S n\<rangle>\<^sub>O = S\<^sub>O \<langle>n\<rangle>\<^sub>O"
| "\<langle>L f\<rangle>\<^sub>O = L\<^sub>O (\<lambda>i. \<langle>f i\<rangle>\<^sub>O)"

text \<open>The following abbreviations and lemmas show how to implement the arithmetic functions and
  the Goodstein function on a Church-encoded @{type Ord} in lambda calculus.\<close>

abbreviation (input) add\<^sub>O where
  "add\<^sub>O n m \<equiv> (\<lambda>z s l. m (n z s l) s l)"

lemma add\<^sub>O:
  "\<langle>addO n m\<rangle>\<^sub>O = add\<^sub>O \<langle>n\<rangle>\<^sub>O \<langle>m\<rangle>\<^sub>O"
  by (induct m) simp_all

abbreviation (input) mul\<^sub>O where
  "mul\<^sub>O n m \<equiv> (\<lambda>z s l. m z (\<lambda>m. n m s l) l)"

lemma mul\<^sub>O:
  "\<langle>mulO n m\<rangle>\<^sub>O = mul\<^sub>O \<langle>n\<rangle>\<^sub>O \<langle>m\<rangle>\<^sub>O"
  by (induct m) (simp_all add: add\<^sub>O)

abbreviation (input) \<omega>\<^sub>O where
  "\<omega>\<^sub>O \<equiv> (\<lambda>z s l. l (\<lambda>n. \<langle>n\<rangle>\<^sub>N s z))"

lemma \<omega>\<^sub>O:
  "\<langle>\<omega>\<rangle>\<^sub>O = \<omega>\<^sub>O"
proof -
  have [simp]: "\<langle>(S ^^ i) Z\<rangle>\<^sub>O z s l = \<langle>i\<rangle>\<^sub>N s z" for i z s l by (induct i) simp_all
  show ?thesis by (simp add: \<omega>_def)
qed

abbreviation (input) exp\<omega>\<^sub>O where
  "exp\<omega>\<^sub>O n \<equiv> (\<lambda>z s l. n s (\<lambda>x z. l (\<lambda>n. \<langle>n\<rangle>\<^sub>N x z)) (\<lambda>f z. l (\<lambda>n. f n z)) z)"

lemma exp\<omega>\<^sub>O:
  "\<langle>exp\<omega> n\<rangle>\<^sub>O = exp\<omega>\<^sub>O \<langle>n\<rangle>\<^sub>O"
  by (induct n) (simp_all add: mul\<^sub>O \<omega>\<^sub>O)

abbreviation (input) goodstein\<^sub>O where
  "goodstein\<^sub>O \<equiv> (\<lambda>c n. n (\<lambda>x. x) (\<lambda>n m. n (m + 1)) (\<lambda>f m. f (m + 2) m) c)"

lemma goodstein\<^sub>O:
  "goodsteinO c n = goodstein\<^sub>O c \<langle>n\<rangle>\<^sub>O"
  by (induct n arbitrary: c) simp_all

text \<open>Note that modeling Church encodings with folds is still limited. For example, the meaningful
  expression @{text "\<langle>n\<rangle>\<^sub>N exp\<omega>\<^sub>O Z\<^sub>O"} cannot be typed in Isabelle/HOL, as that would require rank-2
  polymorphism.\<close>

subsection \<open>Alternative: free theorems\<close>

text \<open>The following is essentially the free theorem for Church-encoded @{type Ord} values.\<close>

lemma freeOrd:
  assumes "\<And>n. h (s n) = s' (h n)" and "\<And>f. h (l f) = l' (\<lambda>i. h (f i))"
  shows "h (\<langle>n\<rangle>\<^sub>O z s l) = \<langle>n\<rangle>\<^sub>O (h z) s' l'"
  by (induct n) (simp_all add: assms)

text \<open>Each of the following proofs first states a naive definition of the corresponding function
  (which is proved correct by induction), from which we then derive the optimized version using
  the free theorem, by (conditional) rewriting (without induction).\<close>

lemma add\<^sub>O':
  "\<langle>addO n m\<rangle>\<^sub>O = add\<^sub>O \<langle>n\<rangle>\<^sub>O \<langle>m\<rangle>\<^sub>O"
proof -
  have [simp]: "\<langle>addO n m\<rangle>\<^sub>O = \<langle>m\<rangle>\<^sub>O \<langle>n\<rangle>\<^sub>O S\<^sub>O L\<^sub>O"
    by (induct m) simp_all
  show ?thesis
    by (intro ext) (simp add: freeOrd[where h = "\<lambda>n. n _ _ _"])
qed

lemma mul\<^sub>O':
  "\<langle>mulO n m\<rangle>\<^sub>O = mul\<^sub>O \<langle>n\<rangle>\<^sub>O \<langle>m\<rangle>\<^sub>O"
proof -
  have [simp]: "\<langle>mulO n m\<rangle>\<^sub>O = \<langle>m\<rangle>\<^sub>O Z\<^sub>O (\<lambda>m. add\<^sub>O m \<langle>n\<rangle>\<^sub>O) L\<^sub>O"
    by (induct m) (simp_all add: add\<^sub>O)
  show ?thesis
    by (intro ext) (simp add: freeOrd[where h = "\<lambda>n. n _ _ _"])
qed

lemma exp\<omega>\<^sub>O':
  "\<langle>exp\<omega> n\<rangle>\<^sub>O = exp\<omega>\<^sub>O \<langle>n\<rangle>\<^sub>O"
proof -
  have [simp]: "\<langle>exp\<omega> n\<rangle>\<^sub>O = \<langle>n\<rangle>\<^sub>O (S\<^sub>O Z\<^sub>O) (\<lambda>m. mul\<^sub>O m \<omega>\<^sub>O) L\<^sub>O"
    by (induct n) (simp_all add: mul\<^sub>O \<omega>\<^sub>O)
  show ?thesis
    by (intro ext) (simp add: fun_cong[OF freeOrd[where h = "\<lambda>n z. n z _ _"]])
qed

end


(*  Title:      HOL/Analysis/Euclidean_Space.thy
    Author:     Johannes Hölzl, TU München
    Author:     Brian Huffman, Portland State University
*)

section \<open>Finite-Dimensional Inner Product Spaces\<close>

theory Euclidean_Space
imports
  L2_Norm Product_Vector
begin

subsection \<open>Type class of Euclidean spaces\<close>

class euclidean_space = real_inner +
  fixes Basis :: "'a set"
  assumes nonempty_Basis [simp]: "Basis \<noteq> {}"
  assumes finite_Basis [simp]: "finite Basis"
  assumes inner_Basis:
    "\<lbrakk>u \<in> Basis; v \<in> Basis\<rbrakk> \<Longrightarrow> inner u v = (if u = v then 1 else 0)"
  assumes euclidean_all_zero_iff:
    "(\<forall>u\<in>Basis. inner x u = 0) \<longleftrightarrow> (x = 0)"

syntax "_type_dimension" :: "type \<Rightarrow> nat"  ("(1DIM/(1'(_')))")
translations "DIM('a)" \<rightharpoonup> "CONST card (CONST Basis :: 'a set)"
typed_print_translation \<open>
  [(@{const_syntax card},
    fn ctxt => fn _ => fn [Const (@{const_syntax Basis}, Type (@{type_name set}, [T]))] =>
      Syntax.const @{syntax_const "_type_dimension"} $ Syntax_Phases.term_of_typ ctxt T)]
\<close>

lemma (in euclidean_space) norm_Basis[simp]: "u \<in> Basis \<Longrightarrow> norm u = 1"
  unfolding norm_eq_sqrt_inner by (simp add: inner_Basis)

lemma (in euclidean_space) inner_same_Basis[simp]: "u \<in> Basis \<Longrightarrow> inner u u = 1"
  by (simp add: inner_Basis)

lemma (in euclidean_space) inner_not_same_Basis: "u \<in> Basis \<Longrightarrow> v \<in> Basis \<Longrightarrow> u \<noteq> v \<Longrightarrow> inner u v = 0"
  by (simp add: inner_Basis)

lemma (in euclidean_space) sgn_Basis: "u \<in> Basis \<Longrightarrow> sgn u = u"
  unfolding sgn_div_norm by (simp add: scaleR_one)

lemma (in euclidean_space) Basis_zero [simp]: "0 \<notin> Basis"
proof
  assume "0 \<in> Basis" thus "False"
    using inner_Basis [of 0 0] by simp
qed

lemma (in euclidean_space) nonzero_Basis: "u \<in> Basis \<Longrightarrow> u \<noteq> 0"
  by clarsimp

lemma (in euclidean_space) SOME_Basis: "(SOME i. i \<in> Basis) \<in> Basis"
  by (metis ex_in_conv nonempty_Basis someI_ex)

lemma (in euclidean_space) inner_sum_left_Basis[simp]:
    "b \<in> Basis \<Longrightarrow> inner (\<Sum>i\<in>Basis. f i *\<^sub>R i) b = f b"
  by (simp add: inner_sum_left inner_Basis if_distrib comm_monoid_add_class.sum.If_cases)

lemma (in euclidean_space) euclidean_eqI:
  assumes b: "\<And>b. b \<in> Basis \<Longrightarrow> inner x b = inner y b" shows "x = y"
proof -
  from b have "\<forall>b\<in>Basis. inner (x - y) b = 0"
    by (simp add: inner_diff_left)
  then show "x = y"
    by (simp add: euclidean_all_zero_iff)
qed

lemma (in euclidean_space) euclidean_eq_iff:
  "x = y \<longleftrightarrow> (\<forall>b\<in>Basis. inner x b = inner y b)"
  by (auto intro: euclidean_eqI)

lemma (in euclidean_space) euclidean_representation_sum:
  "(\<Sum>i\<in>Basis. f i *\<^sub>R i) = b \<longleftrightarrow> (\<forall>i\<in>Basis. f i = inner b i)"
  by (subst euclidean_eq_iff) simp

lemma (in euclidean_space) euclidean_representation_sum':
  "b = (\<Sum>i\<in>Basis. f i *\<^sub>R i) \<longleftrightarrow> (\<forall>i\<in>Basis. f i = inner b i)"
  by (auto simp add: euclidean_representation_sum[symmetric])

lemma (in euclidean_space) euclidean_representation: "(\<Sum>b\<in>Basis. inner x b *\<^sub>R b) = x"
  unfolding euclidean_representation_sum by simp

lemma (in euclidean_space) choice_Basis_iff:
  fixes P :: "'a \<Rightarrow> real \<Rightarrow> bool"
  shows "(\<forall>i\<in>Basis. \<exists>x. P i x) \<longleftrightarrow> (\<exists>x. \<forall>i\<in>Basis. P i (inner x i))"
  unfolding bchoice_iff
proof safe
  fix f assume "\<forall>i\<in>Basis. P i (f i)"
  then show "\<exists>x. \<forall>i\<in>Basis. P i (inner x i)"
    by (auto intro!: exI[of _ "\<Sum>i\<in>Basis. f i *\<^sub>R i"])
qed auto

lemma (in euclidean_space) bchoice_Basis_iff:
  fixes P :: "'a \<Rightarrow> real \<Rightarrow> bool"
  shows "(\<forall>i\<in>Basis. \<exists>x\<in>A. P i x) \<longleftrightarrow> (\<exists>x. \<forall>i\<in>Basis. inner x i \<in> A \<and> P i (inner x i))"
by (simp add: choice_Basis_iff Bex_def)

lemma (in euclidean_space) euclidean_representation_sum_fun:
    "(\<lambda>x. \<Sum>b\<in>Basis. inner (f x) b *\<^sub>R b) = f"
  by (rule ext) (simp add: euclidean_representation_sum)

lemma euclidean_isCont:
  assumes "\<And>b. b \<in> Basis \<Longrightarrow> isCont (\<lambda>x. (inner (f x) b) *\<^sub>R b) x"
    shows "isCont f x"
  apply (subst euclidean_representation_sum_fun [symmetric])
  apply (rule isCont_sum)
  apply (blast intro: assms)
  done

lemma DIM_positive [simp]: "0 < DIM('a::euclidean_space)"
  by (simp add: card_gt_0_iff)

lemma DIM_ge_Suc0 [simp]: "Suc 0 \<le> card Basis"
  by (meson DIM_positive Suc_leI)

lemma sum_inner_Basis_scaleR [simp]:
  fixes f :: "'a::euclidean_space \<Rightarrow> 'b::real_vector"
  assumes "b \<in> Basis" shows "(\<Sum>i\<in>Basis. (inner i b) *\<^sub>R f i) = f b"
  by (simp add: comm_monoid_add_class.sum.remove [OF finite_Basis assms]
         assms inner_not_same_Basis comm_monoid_add_class.sum.neutral)

lemma sum_inner_Basis_eq [simp]:
  assumes "b \<in> Basis" shows "(\<Sum>i\<in>Basis. (inner i b) * f i) = f b"
  by (simp add: comm_monoid_add_class.sum.remove [OF finite_Basis assms]
         assms inner_not_same_Basis comm_monoid_add_class.sum.neutral)

subsection \<open>Subclass relationships\<close>

instance euclidean_space \<subseteq> perfect_space
proof
  fix x :: 'a show "\<not> open {x}"
  proof
    assume "open {x}"
    then obtain e where "0 < e" and e: "\<forall>y. dist y x < e \<longrightarrow> y = x"
      unfolding open_dist by fast
    define y where "y = x + scaleR (e/2) (SOME b. b \<in> Basis)"
    have [simp]: "(SOME b. b \<in> Basis) \<in> Basis"
      by (rule someI_ex) (auto simp: ex_in_conv)
    from \<open>0 < e\<close> have "y \<noteq> x"
      unfolding y_def by (auto intro!: nonzero_Basis)
    from \<open>0 < e\<close> have "dist y x < e"
      unfolding y_def by (simp add: dist_norm)
    from \<open>y \<noteq> x\<close> and \<open>dist y x < e\<close> show "False"
      using e by simp
  qed
qed

subsection \<open>Class instances\<close>

subsubsection \<open>Type @{typ real}\<close>

instantiation real :: euclidean_space
begin

definition
  [simp]: "Basis = {1::real}"

instance
  by standard auto

end

lemma DIM_real[simp]: "DIM(real) = 1"
  by simp

subsubsection \<open>Type @{typ complex}\<close>

instantiation complex :: euclidean_space
begin

definition Basis_complex_def: "Basis = {1, \<i>}"

instance
  by standard (auto simp add: Basis_complex_def intro: complex_eqI split: if_split_asm)

end

lemma DIM_complex[simp]: "DIM(complex) = 2"
  unfolding Basis_complex_def by simp

subsubsection \<open>Type @{typ "'a \<times> 'b"}\<close>

instantiation prod :: (euclidean_space, euclidean_space) euclidean_space
begin

definition
  "Basis = (\<lambda>u. (u, 0)) ` Basis \<union> (\<lambda>v. (0, v)) ` Basis"

lemma sum_Basis_prod_eq:
  fixes f::"('a*'b)\<Rightarrow>('a*'b)"
  shows "sum f Basis = sum (\<lambda>i. f (i, 0)) Basis + sum (\<lambda>i. f (0, i)) Basis"
proof -
  have "inj_on (\<lambda>u. (u::'a, 0::'b)) Basis" "inj_on (\<lambda>u. (0::'a, u::'b)) Basis"
    by (auto intro!: inj_onI Pair_inject)
  thus ?thesis
    unfolding Basis_prod_def
    by (subst sum.union_disjoint) (auto simp: Basis_prod_def sum.reindex)
qed

instance proof
  show "(Basis :: ('a \<times> 'b) set) \<noteq> {}"
    unfolding Basis_prod_def by simp
next
  show "finite (Basis :: ('a \<times> 'b) set)"
    unfolding Basis_prod_def by simp
next
  fix u v :: "'a \<times> 'b"
  assume "u \<in> Basis" and "v \<in> Basis"
  thus "inner u v = (if u = v then 1 else 0)"
    unfolding Basis_prod_def inner_prod_def
    by (auto simp add: inner_Basis split: if_split_asm)
next
  fix x :: "'a \<times> 'b"
  show "(\<forall>u\<in>Basis. inner x u = 0) \<longleftrightarrow> x = 0"
    unfolding Basis_prod_def ball_Un ball_simps
    by (simp add: inner_prod_def prod_eq_iff euclidean_all_zero_iff)
qed

lemma DIM_prod[simp]: "DIM('a \<times> 'b) = DIM('a) + DIM('b)"
  unfolding Basis_prod_def
  by (subst card_Un_disjoint) (auto intro!: card_image arg_cong2[where f="op +"] inj_onI)

end

end