Require Import Coq.QArith.QArith_base.
Require Import Coq.QArith.QArith.
Require Import Coq.QArith.Qfield.
Require Import Coq.PArith.BinPos.
Require Import Coq.Arith.Arith.
Require Import Coq.Lists.List.
Require Import NPeano.

Require Import Shorthand.
Require Import Prefix.
Require Import Combi.

Local Open Scope nat.

Fixpoint e2 (x : nat) : positive :=
  match x with
      | 0 => xH
      | S m => xO (e2 m)
  end.

Local Open Scope positive_scope.

Theorem e2_mul : forall (a : nat) (b : nat), (e2 a) * (e2 b) = e2 (a + b).
Proof.
  intros.
  induction a.
  replace (e2 0) with BinNums.xH.
  replace (0 + b)%nat with b.
  apply Pos.mul_1_l.
  auto.
  auto.
  replace (S a + b)%nat with (S (a + b))%nat.
  replace (e2 (S a)) with (BinPos.Pos.mul 2 (e2 (a))).
  replace (e2 (S (a + b))) with (BinPos.Pos.mul 2 (e2 (a + b))).
  apply eq_sym.
  replace (e2 (a + b)) with (BinPos.Pos.mul (e2 a) (e2 b)).
  apply BinPos.Pos.mul_assoc.
  auto.
  auto.
  auto.
Defined.

(* todo: gibts vmtl woanders *)
Definition kraft_f_1 : forall (m n : nat), (m - n = 0 -> m <= n)%nat.
Proof.
  intros.
  omega.
Defined.

Local Open Scope Q_scope.

Function kraft_list (l : list LB) : Q :=
  foldlist 0 (fun x y => Qplus (1 # (e2 (ll x))) y) l.

Lemma kraft_pflist_split : forall l, pflist l -> (In Bnil l +
  (kraft_list (splitlist true l) + kraft_list (splitlist false l) ==
  (2 # 1) * kraft_list l))%type.
Proof.
  intros l pfl.
  induction l.
  apply inr.
  reflexivity.
  induction a.
  apply inl.
  apply in_eq.
  assert (H:In Bnil l + (kraft_list (splitlist true l) + kraft_list (splitlist false l) ==
                       (2 # 1) * kraft_list l)).
  apply IHl.
  unfold pflist.
  intros x y z t u.
  apply pfl.
  apply in_cons.
  auto.
  apply in_cons.
  auto.
  auto.
  elim H.
  intros innil.
  apply inl.
  apply in_cons.
  auto.
  intros kraftind.
  apply inr.
  induction a.
  assert(tmp1:kraft_list (splitlist true ((true :: a0) :: l)) =
              (1 # (e2 (ll a0))) + kraft_list (splitlist true l)).
  reflexivity.
  rewrite -> tmp1.
  assert(tmp2: splitlist false ((true :: a0) :: l) = splitlist false l).
  reflexivity.
  rewrite -> tmp2.
  assert(tmp3:kraft_list ((true :: a0) :: l)=(1 # (e2 (ll (true :: a0))))+kraft_list l).
  reflexivity.
  rewrite -> tmp3.
  assert(tmp4:(2 # 1) * ((1 # e2 (ll (true :: a0))) + kraft_list l) ==
              (2 # 1) * (1 # e2 (ll (true :: a0))) + (2 # 1) * (kraft_list l)).
  ring.
  rewrite -> tmp4.
  assert (tmp5:(1 # e2 (ll a0)) + kraft_list (splitlist true l) +
               kraft_list (splitlist false l) ==
               (1 # e2 (ll a0)) + (kraft_list (splitlist true l) +
                                   kraft_list (splitlist false l))).
  ring.
  rewrite -> tmp5.
  rewrite -> kraftind.
  assert (tmp1337:(1 # e2 (ll (true :: a0))) = (1#2)*(1#e2(ll(a0)))).
  reflexivity.
  rewrite -> tmp1337.
  ring.
  assert(tmp1:kraft_list (splitlist false ((false :: a0) :: l)) =
              (1 # (e2 (ll a0))) + kraft_list (splitlist false l)).
  reflexivity.
  rewrite -> tmp1.
  assert(tmp2: splitlist true ((false :: a0) :: l) = splitlist true l).
  reflexivity.
  rewrite -> tmp2.
  assert(tmp3:kraft_list ((false :: a0) :: l)=(1 # (e2 (ll (false :: a0))))+kraft_list l).
  reflexivity.
  rewrite -> tmp3.
  assert(tmp4:(2 # 1) * ((1 # e2 (ll (false :: a0))) + kraft_list l) ==
              (2 # 1) * (1 # e2 (ll (false :: a0))) + (2 # 1) * (kraft_list l)).
  ring.
  rewrite -> tmp4.
  assert (tmp5:kraft_list (splitlist true l) + ((1 # e2 (ll a0)) +
               kraft_list (splitlist false l)) ==
               (1 # e2 (ll a0)) + (kraft_list (splitlist true l) +
                                   kraft_list (splitlist false l))).
  ring.
  rewrite -> tmp5.
  rewrite -> kraftind.
  assert (tmp1337:(1 # e2 (ll (false :: a0))) = (1#2)*(1#e2(ll(a0)))).
  reflexivity.
  rewrite -> tmp1337.
  ring.
Defined.

Lemma kraft_pflist : forall l, dflist l -> pflist l -> kraft_list l <= 1.
Proof.
  intros lq dfq pfq.
  refine ((fix f n l df pf (eq0 : (list_maxlen l <= n)%nat) :=
             match n as m return ((m = n) -> _) with
               | 0%nat => (fun eq => _)
               | (S n') => (fun eq => _)
             end eq_refl) (S (list_maxlen lq)) lq dfq pfq _).
  rewrite <- eq in eq0.
  inversion eq0.
  induction l.
  compute.
  intros Q.
  inversion Q.
  inversion H0.
  destruct a.
  destruct l.
  apply Qle_refl.
  destruct l.
  inversion df.
  contradict H4.
  apply in_eq.
  assert (H2:max (ll Bnil) (list_maxlen ((b :: l) :: l0))=(list_maxlen ((b :: l) :: l0))).
  apply Max.max_0_l.
  rewrite -> H2 in H1.
  inversion H1.
  destruct (list_maxlen l0).
  inversion H3.
  inversion H3.
  inversion H1.
  destruct (list_maxlen l).
  inversion H2.
  inversion H2.

  elim (kraft_pflist_split l pf).
  intros innil.
  destruct l.
  inversion innil.
  destruct l.
  destruct l0.
  compute.
  intros Q.
  inversion Q.
  assert (q1 : In l (Bnil :: l :: l0)).
  apply in_cons.
  apply in_eq.
  assert (q2 : Bnil <> l).
  inversion df.
  contradict H2.
  rewrite <- H2.
  apply in_eq.
  assert (ispref : prefix Bnil l).
  exists l.
  apply app_nil_l.
  contradict ispref.
  apply pf.
  apply innil.
  apply q1.
  apply q2.
  assert(q1:In(b :: l)((b :: l) :: l0)).
  apply in_eq.
  assert (ispref : prefix Bnil (b :: l)).
  exists (b :: l).
  apply app_nil_l.
  contradict ispref.
  apply pf.
  apply innil.
  apply q1.
  intros Q.
  inversion Q.
  intros rc.
  assert(tmp1:(1#2)*(kraft_list (splitlist true l)) + (1#2)*kraft_list (splitlist false l) ==
              kraft_list l).
  assert(tmp2:(1#2)*(kraft_list (splitlist true l)) + (1#2)*(kraft_list (splitlist false l)) ==
              (1#2)*(kraft_list (splitlist true l) + kraft_list (splitlist false l))).
  ring.
  rewrite -> tmp2.
  rewrite -> rc.
  ring.
  rewrite <- tmp1.
  assert (tmp2 : 1 == (1 # 2) + (1 # 2)).
  ring.
  rewrite -> tmp2.
  assert (rec : forall b, kraft_list (splitlist b l) <= 1).
  intros b.
  apply (f n').
  apply dflist_splittable.
  auto.
  apply pflist_splittable.
  auto.
  elim (eq_nat_dec (list_maxlen (splitlist b l)) 0).
  intros iseq.
  rewrite -> iseq.
  apply le_0_n.
  intros isneq.
  apply lt_n_Sm_le.
  rewrite -> eq.
  apply (lt_le_trans _ (list_maxlen l)).
  apply maxlen_split.
  contradict isneq.
  apply maxlen_split_3.
  apply isneq.
  auto.
  apply Qplus_le_compat.
  assert (tmp3 : 1 # 2 == (1 # 2) * 1).
  ring.
  rewrite -> tmp3.
  apply Qmult_le_l.
  reflexivity.
  apply rec.
  assert (tmp3 : 1 # 2 == (1 # 2) * 1).
  ring.
  rewrite -> tmp3.
  apply Qmult_le_l.
  reflexivity.
  apply rec.
  auto.
Defined.

Lemma kraft_pflist_sharp_2 : forall l, 0 <= kraft_list l.
Proof.
  induction l.
  compute.
  intros Q.
  inversion Q.
  assert (l' : kraft_list (a :: l) == (1 # (e2 (ll a))) + kraft_list l).
  reflexivity.
  rewrite -> l'.
  assert (l'' : 0 == 0 + 0).
  ring.
  rewrite l''.
  apply Qplus_le_compat.
  compute.
  intros Q.
  inversion Q.
  apply IHl.
Defined.

Lemma kraft_pflist_sharp_1 : forall l, dflist l -> pflist l ->
                                       (forall m, dflist (m :: l) -> pflist (m :: l) -> False)
                                       -> kraft_list l <> 0.
Proof.
  intros l H H0 H1 k0.
  destruct l.
  apply (H1 nil).
  apply dflist_cons.
  auto.
  auto.
  intros a b ina inb anb pf.
  inversion ina.
  inversion inb.
  contradict anb.
  rewrite <- H2.
  apply H3.
  inversion H3.
  inversion H2.
  destruct l.
  destruct l0.
  inversion k0.
  destruct l.
  inversion H.
  contradict H5.
  apply in_eq.
  assert (pref : prefix Bnil (b :: l)).
  exists (b :: l).
  apply app_nil_l.
  contradict pref.
  apply H0.
  apply in_eq.
  apply in_cons.
  apply in_eq.
  intros Q.
  inversion Q.
  assert (k1 : 0 == kraft_list ((b :: l) :: l0)).
  rewrite -> k0.
  reflexivity.
  contradict k1.
  apply Qlt_not_eq.
  assert (kg' : kraft_list ((b :: l) :: l0) == (1 # (e2 (S (ll l)))) + kraft_list l0).
  reflexivity.
  rewrite -> kg'.
  assert (kg'' : 0 == 0 + 0).
  ring.
  rewrite -> kg''.
  apply Qplus_lt_le_compat.
  reflexivity.
  apply kraft_pflist_sharp_2.
Defined.

Lemma kraft_pflist_sharp : forall l, dflist l -> pflist l ->
                                     (forall m, dflist (m :: l) -> pflist (m :: l) -> False)
                                     -> kraft_list l == 1.
Proof.
  intros lq dfq pfq fmq.
  refine ((fix f n l (le : (list_maxlen l <= n)%nat) df pf fm :=
             match n as m return (n = m -> _) with
               | 0%nat => fun eq => _
               | S n' => fun eq => _
             end eq_refl)
            (list_maxlen lq) lq (le_refl (list_maxlen lq)) dfq pfq fmq).
  rewrite -> eq in le.
  induction l.
  assert (Q:False).
  apply (fm nil).
  apply dflist_cons.
  auto.
  auto.
  unfold pflist.
  intros a b ina inb aneqb.
  inversion ina.
  inversion inb.
  contradict aneqb.
  rewrite <- H.
  auto.
  inversion H0.
  inversion H.
  contradict Q.
  destruct a.
  destruct l.
  reflexivity.
  destruct l.
  inversion df.
  match goal with E : _ |- _ => contradict E; apply in_eq end.
  assert (ispf : prefix Bnil (b :: l)).
  exists (b :: l).
  apply app_nil_l.
  contradict ispf.
  apply pf.
  apply in_eq.
  apply in_cons.
  apply in_eq.
  intros Q.
  inversion Q.

  inversion le.
  destruct (list_maxlen l).
  match goal with E : _ |- _ => inversion E end.
  match goal with E : _ |- _ => inversion E end.

  assert(indec : {In nil l}+{~ In nil l}).
  apply in_dec.
  apply list_eq_dec.
  apply bool_dec.
  elim indec.
  intros innil.
  destruct l.
  inversion innil.
  destruct l.
  destruct l0.
  reflexivity.
  destruct l.
  inversion df.
  contradict H2.
  apply in_eq.
  assert (pref : prefix Bnil (b :: l)).
  exists (b :: l).
  auto.
  contradict pref.
  apply pf.
  apply in_eq.
  apply in_cons.
  apply in_eq.
  intros Q.
  inversion Q.
  assert (pref : prefix Bnil (b :: l)).
  exists (b :: l).
  auto.
  contradict pref.
  apply pf.
  apply innil.
  apply in_eq.
  intros Q.
  inversion Q.
  intros nin.
  elim (kraft_pflist_split l pf).
  intros isin.
  contradict nin.
  auto.
  intros kl.
  apply (Qmult_inj_l _ _ (2 # 1)).
  compute.
  intros Q.
  inversion Q.
  rewrite <- kl.

  assert (H_bl : forall bl, kraft_list (splitlist bl l) == 1).
  intros bl.
  apply (f n').
  apply le_S_n.
  apply (le_trans _ (list_maxlen l)).
  apply maxlen_split.
  destruct l.
  intros _.
  apply (fm nil).
  apply dflist_cons.
  apply dflist_nil.
  apply nin.
  intros a b ina inb anb.
  inversion ina.
  inversion inb.
  contradict anb.
  rewrite <- H.
  apply H0.
  inversion H0.
  inversion H.

  destruct l.
  contradict nin.
  apply in_eq.
  intros Q.
  inversion Q.
  destruct(list_maxlen l0).
  inversion H0.
  inversion H0.
  rewrite <- eq.
  auto.
  apply dflist_splittable.
  auto.
  apply pflist_splittable.
  auto.
  intros m d p.
  apply (fm (bl :: m)).
  inversion d.
  apply dflist_cons.
  apply df.
  contradict H2.
  apply pflist_splittable_3.
  apply H2.
  intros a b ina inb anb.

  elim (list_eq_dec bool_dec a (bl :: m)).

  intros a_eq.
  rewrite a_eq.
  inversion inb.
  contradict H.
  rewrite <- a_eq.
  apply anb.
  destruct b.
  auto.
  intros ispref.
  inversion ispref.
  inversion H0.
  assert (ispref2 : prefix m b0).
  exists x.
  apply H3.
  contradict ispref2.
  apply p.
  apply in_eq.
  apply in_cons.
  apply pflist_splittable_3.
  rewrite -> H2.
  auto.
  rewrite -> a_eq in anb.
  rewrite <- H2 in anb.
  intros q.
  contradict anb.
  rewrite <- q.
  reflexivity.
  intros a_neq.
  destruct a.
  contradict nin.
  assert (ininv : (bl :: m) = Bnil \/ In Bnil l).
  apply in_inv.
  auto.
  elim ininv.
  intros Q.
  inversion Q.
  trivial.
  elim (list_eq_dec bool_dec b (bl :: m)).
  intros beq.
  rewrite -> beq.
  intros pref.
  inversion pref.
  inversion H.
  assert (pref2 : prefix a m).
  exists x.
  apply H2.
  contradict pref2.
  apply p.
  rewrite -> H1 in ina.
  inversion ina.
  contradict a_neq.
  rewrite -> H1.
  auto.
  apply in_cons.
  apply pflist_splittable_3.
  apply H0.
  apply in_eq.
  rewrite -> H1 in a_neq.
  contradict a_neq.
  rewrite <- a_neq.
  reflexivity.
  intros b_neq.
  assert (ininv : (bl :: m) = (b0 :: a) \/ In (b0 :: a) l).
  apply in_inv.
  auto.
  elim ininv.
  intros iseq.
  contradict a_neq.
  auto.
  intros isinl.
  assert (ininv2 : (bl :: m) = b \/ In b l).
  apply in_inv.
  auto.
  elim ininv2.
  intros iseq.
  contradict b_neq.
  auto.
  intros isinl2.
  apply pf.
  auto.
  auto.
  auto.

  rewrite -> H_bl.
  rewrite -> H_bl.
  reflexivity.
Defined.


(* Zhiwei Wu, Wenrui Meng 1 hour for each *)
(** * MoreInd: More on Induction *)

Require Export Logic.

(* ##################################################### *)
(** * Induction Principles *)

(** This is a good point to pause and take a deeper look at induction
    principles.

    Every time we declare a new [Inductive] datatype, Coq
    automatically generates an _induction principle_ for this type.

    The induction principle for a type [t] is called [t_ind].  Here is
    the one for natural numbers: *)

Check nat_ind.
(*  ===> nat_ind :
           forall P : nat -> Prop,
              P 0  ->
              (forall n : nat, P n -> P (S n))  ->
              forall n : nat, P n  *)

(** The [induction] tactic is a straightforward wrapper that, at
    its core, simply performs [apply t_ind].  To see this more
    clearly, let's experiment a little with using [apply nat_ind]
    directly, instead of the [induction] tactic, to carry out some
    proofs.  Here, for example, is an alternate proof of a theorem
    that we saw in the [Basics] chapter. *)

Theorem mult_0_r' : forall n:nat,
  n * 0 = 0.
Proof.
  apply nat_ind.
  Case "O". reflexivity.
  Case "S". simpl. intros n IHn. rewrite -> IHn.
    reflexivity.  Qed.

(** This proof is basically the same as the earlier one, but a
    few minor differences are worth noting.  First, in the induction
    step of the proof (the ["S"] case), we have to do a little
    bookkeeping manually (the [intros]) that [induction] does
    automatically.

    Second, we do not introduce [n] into the context before applying
    [nat_ind] -- the conclusion of [nat_ind] is a quantified formula,
    and [apply] needs this conclusion to exactly match the shape of
    the goal state, including the quantifier.  The [induction] tactic
    works either with a variable in the context or a quantified
    variable in the goal.

    Third, the [apply] tactic automatically chooses variable names for
    us (in the second subgoal, here), whereas [induction] lets us
    specify (with the [as...]  clause) what names should be used.  The
    automatic choice is actually a little unfortunate, since it
    re-uses the name [n] for a variable that is different from the [n]
    in the original theorem.  This is why the [Case] annotation is
    just [S] -- if we tried to write it out in the more explicit form
    that we've been using for most proofs, we'd have to write [n = S
    n], which doesn't make a lot of sense!  All of these conveniences
    make [induction] nicer to use in practice than applying induction
    principles like [nat_ind] directly.  But it is important to
    realize that, modulo this little bit of bookkeeping, applying
    [nat_ind] is what we are really doing. *)

(** **** Exercise: 2 stars, optional (plus_one_r') *)
(** Complete this proof as we did [mult_0_r'] above, without using
    the [induction] tactic. *)

Theorem plus_one_r' : forall n:nat,
  n + 1 = S n.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** The induction principles that Coq generates for other datatypes
    defined with [Inductive] follow a similar pattern. If we define a
    type [t] with constructors [c1] ... [cn], Coq generates a theorem
    with this shape:
    t_ind :
       forall P : t -> Prop,
            ... case for c1 ... ->
            ... case for c2 ... ->
            ...
            ... case for cn ... ->
            forall n : t, P n
    The specific shape of each case depends on the arguments to the
    corresponding constructor.  Before trying to write down a general
    rule, let's look at some more examples. First, an example where
    the constructors take no arguments: *)

Inductive yesno : Type :=
  | yes : yesno
  | no : yesno.

Check yesno_ind.
(* ===> yesno_ind : forall P : yesno -> Prop,
                      P yes  ->
                      P no  ->
                      forall y : yesno, P y *)

(** **** Exercise: 1 star, optional (rgb) *)
(** Write out the induction principle that Coq will generate for the
    following datatype.  Write down your answer on paper or type it
    into a comment, and then compare it with what Coq prints. *)

Inductive rgb : Type :=
  | red : rgb
  | green : rgb
  | blue : rgb.
Check rgb_ind.
(** [] *)

(** Here's another example, this time with one of the constructors
    taking some arguments. *)

Inductive natlist : Type :=
  | nnil : natlist
  | ncons : nat -> natlist -> natlist.

Check natlist_ind.
(* ===> (modulo a little tidying)
   natlist_ind :
      forall P : natlist -> Prop,
         P nnil  ->
         (forall (n : nat) (l : natlist), P l -> P (ncons n l)) ->
         forall n : natlist, P n *)

(** **** Exercise: 1 star, optional (natlist1) *)
(** Suppose we had written the above definition a little
   differently: *)

Inductive natlist1 : Type :=
  | nnil1 : natlist1
  | nsnoc1 : natlist1 -> nat -> natlist1.

(** Now what will the induction principle look like? *)
(** [] *)

(** From these examples, we can extract this general rule:

    - The type declaration gives several constructors; each
      corresponds to one clause of the induction principle.
    - Each constructor [c] takes argument types [a1]...[an].
    - Each [ai] can be either [t] (the datatype we are defining) or
      some other type [s].
    - The corresponding case of the induction principle
      says (in English):
        - "for all values [x1]...[xn] of types [a1]...[an], if [P]
           holds for each of the inductive arguments (each [xi] of
           type [t]), then [P] holds for [c x1 ... xn]".

*)

(** **** Exercise: 1 star, optional (False_ind_principle) *)
(** Can you predict the induction principle for falsehood? *)

(* Check False_ind. *)
(** [] *)

(** **** Exercise: 1 star, optional (byntree_ind) *)
(** Write out the induction principle that Coq will generate for the
    following datatype.  Write down your answer on paper or type it
    into a comment, and then compare it with what Coq prints. *)

Inductive byntree : Type :=
 | bempty : byntree
 | bleaf  : yesno -> byntree
 | nbranch : yesno -> byntree -> byntree -> byntree.
(** [] *)

(** **** Exercise: 1 star, optional (ex_set) *)
(** Here is an induction principle for an inductively defined
    set.
      ExSet_ind :
         forall P : ExSet -> Prop,
             (forall b : bool, P (con1 b)) ->
             (forall (n : nat) (e : ExSet), P e -> P (con2 n e)) ->
             forall e : ExSet, P e
    Give an [Inductive] definition of [ExSet]: *)

Inductive ExSet : Type :=
  (* FILL IN HERE *)
.
(** [] *)

(** What about polymorphic datatypes?

    The inductive definition of polymorphic lists
      Inductive list (X:Type) : Type :=
        | nil : list X
        | cons : X -> list X -> list X.
    is very similar to that of [natlist].  The main difference is
    that, here, the whole definition is _parameterized_ on a set [X]:
    that is, we are defining a _family_ of inductive types [list X],
    one for each [X].  (Note that, wherever [list] appears in the body
    of the declaration, it is always applied to the parameter [X].)
    The induction principle is likewise parameterized on [X]:
     list_ind :
       forall (X : Type) (P : list X -> Prop),
          P [] ->
          (forall (x : X) (l : list X), P l -> P (x :: l)) ->
          forall l : list X, P l
   Note the wording here (and, accordingly, the form of [list_ind]):
   The _whole_ induction principle is parameterized on [X].  That is,
   [list_ind] can be thought of as a polymorphic function that, when
   applied to a type [X], gives us back an induction principle
   specialized to the type [list X]. *)

(** **** Exercise: 1 star, optional (tree) *)
(** Write out the induction principle that Coq will generate for
   the following datatype.  Compare your answer with what Coq
   prints. *)

Inductive tree (X:Type) : Type :=
  | leaf : X -> tree X
  | node : tree X -> tree X -> tree X.
Check tree_ind.
(** [] *)

(** **** Exercise: 1 star, optional (mytype) *)
(** Find an inductive definition that gives rise to the
    following induction principle:
      mytype_ind :
        forall (X : Type) (P : mytype X -> Prop),
            (forall x : X, P (constr1 X x)) ->
            (forall n : nat, P (constr2 X n)) ->
            (forall m : mytype X, P m ->
               forall n : nat, P (constr3 X m n)) ->
            forall m : mytype X, P m
*)
(** [] *)

(** **** Exercise: 1 star, optional (foo) *)
(** Find an inductive definition that gives rise to the
    following induction principle:
      foo_ind :
        forall (X Y : Type) (P : foo X Y -> Prop),
             (forall x : X, P (bar X Y x)) ->
             (forall y : Y, P (baz X Y y)) ->
             (forall f1 : nat -> foo X Y,
               (forall n : nat, P (f1 n)) -> P (quux X Y f1)) ->
             forall f2 : foo X Y, P f2
*)
(** [] *)

(** **** Exercise: 1 star, optional (foo') *)
(** Consider the following inductive definition: *)

Inductive foo' (X:Type) : Type :=
  | C1 : list X -> foo' X -> foo' X
  | C2 : foo' X.

(** What induction principle will Coq generate for [foo']?  Fill
   in the blanks, then check your answer with Coq.)
     foo'_ind :
        forall (X : Type) (P : foo' X -> Prop),
              (forall (l : list X) (f : foo' X),
                    _______________________ ->
                    _______________________   ) ->
             ___________________________________________ ->
             forall f : foo' X, ________________________
*)

(** [] *)

(* ##################################################### *)
(** ** Induction Hypotheses *)

(** Where does the phrase "induction hypothesis" fit into this story?

    The induction principle for numbers
       forall P : nat -> Prop,
            P 0  ->
            (forall n : nat, P n -> P (S n))  ->
            forall n : nat, P n
   is a generic statement that holds for all propositions
   [P] (strictly speaking, for all families of propositions [P]
   indexed by a number [n]).  Each time we use this principle, we
   are choosing [P] to be a particular expression of type
   [nat->Prop].

   We can make the proof more explicit by giving this expression a
   name.  For example, instead of stating the theorem [mult_0_r] as
   "[forall n, n * 0 = 0]," we can write it as "[forall n, P_m0r
   n]", where [P_m0r] is defined as... *)

Definition P_m0r (n:nat) : Prop :=
  n * 0 = 0.

(** ... or equivalently... *)

Definition P_m0r' : nat->Prop :=
  fun n => n * 0 = 0.

(** Now when we do the proof it is easier to see where [P_m0r]
    appears. *)

Theorem mult_0_r'' : forall n:nat,
  P_m0r n.
Proof.
  apply nat_ind.
  Case "n = O". reflexivity.
  Case "n = S n'".
    (* Note the proof state at this point! *)
    unfold P_m0r. simpl. intros n' IHn'.
    apply IHn'.  Qed.

(** This extra naming step isn't something that we'll do in
    normal proofs, but it is useful to do it explicitly for an example
    or two, because it allows us to see exactly what the induction
    hypothesis is.  If we prove [forall n, P_m0r n] by induction on
    [n] (using either [induction] or [apply nat_ind]), we see that the
    first subgoal requires us to prove [P_m0r 0] ("[P] holds for
    zero"), while the second subgoal requires us to prove [forall n',
    P_m0r n' -> P_m0r n' (S n')] (that is "[P] holds of [S n'] if it
    holds of [n']" or, more elegantly, "[P] is preserved by [S]").
    The _induction hypothesis_ is the premise of this latter
    implication -- the assumption that [P] holds of [n'], which we are
    allowed to use in proving that [P] holds for [S n']. *)

(* ####################################################### *)
(** * Informal Proofs (Advanced) *)

(** Q: What is the relation between a formal proof of a proposition
       [P] and an informal proof of the same proposition [P]?

    A: The latter should _teach_ the reader how to produce the
       former.

    Q: How much detail is needed??

    Unfortunately, There is no single right answer; rather, there is a
    range of choices.

    At one end of the spectrum, we can essentially give the reader the
    whole formal proof (i.e., the informal proof amounts to just
    transcribing the formal one into words).  This gives the reader
    the _ability_ to reproduce the formal one for themselves, but it
    doesn't _teach_ them anything.

   At the other end of the spectrum, we can say "The theorem is true
   and you can figure out why for yourself if you think about it hard
   enough."  This is also not a good teaching strategy, because
   usually writing the proof requires some deep insights into the
   thing we're proving, and most readers will give up before they
   rediscover all the same insights as we did.

   In the middle is the golden mean -- a proof that includes all of
   the essential insights (saving the reader the hard part of work
   that we went through to find the proof in the first place) and
   clear high-level suggestions for the more routine parts to save the
   reader from spending too much time reconstructing these
   parts (e.g., what the IH says and what must be shown in each case
   of an inductive proof), but not so much detail that the main ideas
   are obscured.

   Another key point: if we're comparing a formal proof of a
   proposition [P] and an informal proof of [P], the proposition [P]
   doesn't change.  That is, formal and informal proofs are _talking
   about the same world_ and they _must play by the same rules_. *)
(** ** Informal Proofs by Induction *)

(** Since we've spent much of this chapter looking "under the hood" at
    formal proofs by induction, now is a good moment to talk a little
    about _informal_ proofs by induction.

    In the real world of mathematical communication, written proofs
    range from extremely longwinded and pedantic to extremely brief
    and telegraphic.  The ideal is somewhere in between, of course,
    but while you are getting used to the style it is better to start
    out at the pedantic end.  Also, during the learning phase, it is
    probably helpful to have a clear standard to compare against.
    With this in mind, we offer two templates below -- one for proofs
    by induction over _data_ (i.e., where the thing we're doing
    induction on lives in [Type]) and one for proofs by induction over
    _evidence_ (i.e., where the inductively defined thing lives in
    [Prop]).  In the rest of this course, please follow one of the two
    for _all_ of your inductive proofs. *)

(** *** Induction Over an Inductively Defined Set *)

(** _Template_:

       - _Theorem_: <Universally quantified proposition of the form
         "For all [n:S], [P(n)]," where [S] is some inductively defined
         set.>

         _Proof_: By induction on [n].

           <one case for each constructor [c] of [S]...>

           - Suppose [n = c a1 ... ak], where <...and here we state
             the IH for each of the [a]'s that has type [S], if any>.
             We must show <...and here we restate [P(c a1 ... ak)]>.

             <go on and prove [P(n)] to finish the case...>

           - <other cases similarly...>                        []

    _Example_:

      - _Theorem_: For all sets [X], lists [l : list X], and numbers
        [n], if [length l = n] then [index (S n) l = None].

        _Proof_: By induction on [l].

        - Suppose [l = []].  We must show, for all numbers [n],
          that, if length [[] = n], then [index (S n) [] =
          None].

          This follows immediately from the definition of index.

        - Suppose [l = x :: l'] for some [x] and [l'], where
          [length l' = n'] implies [index (S n') l' = None], for
          any number [n'].  We must show, for all [n], that, if
          [length (x::l') = n] then [index (S n) (x::l') =
          None].

          Let [n] be a number with [length l = n].  Since
            length l = length (x::l') = S (length l'),
          it suffices to show that
            index (S (length l')) l' = None.
]]
          But this follows directly from the induction hypothesis,
          picking [n'] to be length [l'].  [] *)

(** *** Induction Over an Inductively Defined Proposition *)

(** Since inductively defined proof objects are often called
    "derivation trees," this form of proof is also known as _induction
    on derivations_.

    _Template_:

       - _Theorem_: <Proposition of the form "[Q -> P]," where [Q] is
         some inductively defined proposition (more generally,
         "For all [x] [y] [z], [Q x y z -> P x y z]")>

         _Proof_: By induction on a derivation of [Q].  <Or, more
         generally, "Suppose we are given [x], [y], and [z].  We
         show that [Q x y z] implies [P x y z], by induction on a
         derivation of [Q x y z]"...>

           <one case for each constructor [c] of [Q]...>

           - Suppose the final rule used to show [Q] is [c].  Then
             <...and here we state the types of all of the [a]'s
             together with any equalities that follow from the
             definition of the constructor and the IH for each of
             the [a]'s that has type [Q], if there are any>.  We must
             show <...and here we restate [P]>.

             <go on and prove [P] to finish the case...>

           - <other cases similarly...>                        []

    _Example_

       - _Theorem_: The [<=] relation is transitive -- i.e., for all
         numbers [n], [m], and [o], if [n <= m] and [m <= o], then
         [n <= o].

         _Proof_: By induction on a derivation of [m <= o].

           - Suppose the final rule used to show [m <= o] is
             [le_n]. Then [m = o] and we must show that [n <= m],
             which is immediate by hypothesis.

           - Suppose the final rule used to show [m <= o] is
             [le_S].  Then [o = S o'] for some [o'] with [m <= o'].
             We must show that [n <= S o'].
             By induction hypothesis, [n <= o'].

             But then, by [le_S], [n <= S o'].  [] *)

(* ##################################################### *)
(** * Optional Material *)

(** This section offers some additional details on how induction works
    in Coq and the process of building proof trees.  It can safely be
    skimmed on a first reading.  (We recommend skimming rather than
    skipping over it outright: it answers some questions that occur to
    many Coq users at some point, so it is useful to have a rough idea
    of what's here.) *)

(* ##################################################### *)
(** * Induction Principles for [=] and [<=] *)

(** In [Logic] we have defined [eq] as: *)

(* Inductive eq (X:Type) : X -> X -> Prop :=
       refl_equal : forall x, eq X x x. *)

(** In the Coq standard library, the definition of equality is
    slightly different: *)

Inductive eq' (X:Type) (x:X) : X -> Prop :=
    refl_equal' : eq' X x x.

(** The advantage of this definition is that the induction
    principle that Coq derives for it is precisely the familiar
    principle of _Leibniz equality_: what we mean when we say "[x] and
    [y] are equal" is that every property on [P] that is true of [x]
    is also true of [y].  *)

Check eq'_ind.
(* ===>
     forall (X : Type) (x : X) (P : X -> Prop),
       P x -> forall y : X, x =' y -> P y

   ===>  (i.e., after a little reorganization)
     forall (X : Type) (x : X) forall y : X,
       x =' y ->
       forall P : X -> Prop, P x -> P y *)

(** Similarly, we have defined [<=] as: *)

(* Inductive le : nat -> nat -> Prop :=
     | le_n : forall n, le n n
     | le_S : forall n m, (le n m) -> (le n (S m)). *)

(** This definition can be streamlined a little by observing that the
    left-hand argument [n] is the same everywhere in the definition,
    so we can actually make it a "general parameter" to the whole
    definition, rather than an argument to each constructor. *)

Inductive le (n:nat) : nat -> Prop :=
  | le_n : le n n
  | le_S : forall m, (le n m) -> (le n (S m)).

Notation "m <= n" := (le m n).

(** The second one is better, even though it looks less symmetric.
    Why?  Because it gives us a simpler induction principle.
    (The same was true of our second version of [eq].) *)

Check le_ind.
(* ===>  forall (n : nat) (P : nat -> Prop),
           P n ->
           (forall m : nat, n <= m -> P m -> P (S m)) ->
           forall n0 : nat, n <= n0 -> P n0 *)

(** By contrast, the induction principle that Coq calculates for the
    first definition has a lot of extra quantifiers, which makes it
    messier to work with when proving things by induction.  Here is
    the induction principle for the first [le]: *)

(* le_ind :
     forall P : nat -> nat -> Prop,
     (forall n : nat, P n n) ->
     (forall n m : nat, le n m -> P n m -> P n (S m)) ->
     forall n n0 : nat, le n n0 -> P n n0 *)

(* ##################################################### *)
(** ** Induction Principles in [Prop] *)

(** Earlier, we looked in detail at the induction principles that Coq
    generates for inductively defined _sets_.  The induction
    principles for inductively defined _propositions_ like [gorgeous]
    are a tiny bit more complicated.  As with all induction
    principles, we want to use the induction principle on [gorgeous]
    to prove things by inductively considering the possible shapes
    that something in [gorgeous] can have -- either it is evidence
    that [0] is gorgeous, or it is evidence that, for some [n], [3+n]
    is gorgeous, or it is evidence that, for some [n], [5+n] is
    gorgeous and it includes evidence that [n] itself is.  Intuitively
    speaking, however, what we want to prove are not statements about
    _evidence_ but statements about _numbers_.  So we want an
    induction principle that lets us prove properties of numbers by
    induction on evidence.

    For example, from what we've said so far, you might expect the
    inductive definition of [gorgeous]...
    Inductive gorgeous : nat -> Prop :=
         g_0 : gorgeous 0
       | g_plus3 : forall n, gorgeous n -> gorgeous (3+m)
       | g_plus5 : forall n, gorgeous n -> gorgeous (5+m).
    ...to give rise to an induction principle that looks like this...
    gorgeous_ind_max :
       forall P : (forall n : nat, gorgeous n -> Prop),
            P O g_0 ->
            (forall (m : nat) (e : gorgeous m),
               P m e -> P (3+m) (g_plus3 m e) ->
            (forall (m : nat) (e : gorgeous m),
               P m e -> P (5+m) (g_plus5 m e) ->
            forall (n : nat) (e : gorgeous n), P n e
    ... because:

     - Since [gorgeous] is indexed by a number [n] (every [gorgeous]
       object [e] is a piece of evidence that some particular number
       [n] is gorgeous), the proposition [P] is parameterized by both
       [n] and [e] -- that is, the induction principle can be used to
       prove assertions involving both a gorgeous number and the
       evidence that it is gorgeous.

     - Since there are three ways of giving evidence of gorgeousness
       ([gorgeous] has three constructors), applying the induction
       principle generates three subgoals:

         - We must prove that [P] holds for [O] and [b_0].

         - We must prove that, whenever [n] is a gorgeous
           number and [e] is an evidence of its gorgeousness,
           if [P] holds of [n] and [e],
           then it also holds of [3+m] and [g_plus3 n e].

         - We must prove that, whenever [n] is a gorgeous
           number and [e] is an evidence of its gorgeousness,
           if [P] holds of [n] and [e],
           then it also holds of [5+m] and [g_plus5 n e].

     - If these subgoals can be proved, then the induction principle
       tells us that [P] is true for _all_ gorgeous numbers [n] and
       evidence [e] of their gorgeousness.

    But this is a little more flexibility than we actually need or
    want: it is giving us a way to prove logical assertions where the
    assertion involves properties of some piece of _evidence_ of
    gorgeousness, while all we really care about is proving
    properties of _numbers_ that are gorgeous -- we are interested in
    assertions about numbers, not about evidence.  It would therefore
    be more convenient to have an induction principle for proving
    propositions [P] that are parameterized just by [n] and whose
    conclusion establishes [P] for all gorgeous numbers [n]:
       forall P : nat -> Prop,
          ... ->
             forall n : nat, gorgeous n -> P n
    For this reason, Coq actually generates the following simplified
    induction principle for [gorgeous]: *)

Check gorgeous_ind.
(* ===>  gorgeous_ind
     : forall P : nat -> Prop,
       P 0 ->
       (forall n : nat, gorgeous n -> P n -> P (3 + n)) ->
       (forall n : nat, gorgeous n -> P n -> P (5 + n)) ->
       forall n : nat, gorgeous n -> P n *)

(** In particular, Coq has dropped the evidence term [e] as a
    parameter of the the proposition [P], and consequently has
    rewritten the assumption [forall (n : nat) (e: gorgeous n), ...]
    to be [forall (n : nat), gorgeous n -> ...]; i.e., we no longer
    require explicit evidence of the provability of [gorgeous n]. *)

(** In English, [gorgeous_ind] says:

    - Suppose, [P] is a property of natural numbers (that is, [P n] is
      a [Prop] for every [n]).  To show that [P n] holds whenever [n]
      is gorgeous, it suffices to show:

      - [P] holds for [0],

      - for any [n], if [n] is gorgeous and [P] holds for
        [n], then [P] holds for [3+n],

      - for any [n], if [n] is gorgeous and [P] holds for
        [n], then [P] holds for [5+n]. *)

(** We can apply [gorgeous_ind] directly instead of using [induction]. *)

Theorem gorgeous__beautiful' : forall n, gorgeous n -> beautiful n.
Proof.
   intros.
   apply gorgeous_ind.
   Case "g_0".
       apply b_0.
   Case "g_plus3".
       intros.
       apply b_sum. apply b_3.
       apply H1.
   Case "g_plus5".
       intros.
       apply b_sum. apply b_5.
       apply H1.
   apply H.
Qed.

Module P.

(** **** Exercise: 3 stars, optional (p_provability) *)
(** Consider the following inductively defined proposition: *)

Inductive p : (tree nat) -> nat -> Prop :=
   | c1 : forall n, p (leaf _ n) 1
   | c2 : forall t1 t2 n1 n2,
            p t1 n1 -> p t2 n2 -> p (node _ t1 t2) (n1 + n2)
   | c3 : forall t n, p t n -> p t (S n).

(** Describe, in English, the conditions under which the
   proposition [p t n] is provable.

   (* FILL IN HERE *)
*)
(** [] *)

End P.

(* ##################################################### *)
(** ** More on the [induction] Tactic *)

(** The [induction] tactic actually does even more low-level
    bookkeeping for us than we discussed above.

    Recall the informal statement of the induction principle for
    natural numbers:
      - If [P n] is some proposition involving a natural number n, and
        we want to show that P holds for _all_ numbers n, we can
        reason like this:
          - show that [P O] holds
          - show that, if [P n'] holds, then so does [P (S n')]
          - conclude that [P n] holds for all n.
    So, when we begin a proof with [intros n] and then [induction n],
    we are first telling Coq to consider a _particular_ [n] (by
    introducing it into the context) and then telling it to prove
    something about _all_ numbers (by using induction).

    What Coq actually does in this situation, internally, is to
    "re-generalize" the variable we perform induction on.  For
    example, in the proof above that [plus] is associative...
*)

Theorem plus_assoc' : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof.
  (* ...we first introduce all 3 variables into the context,
     which amounts to saying "Consider an arbitrary [n], [m], and
     [p]..." *)
  intros n m p.
  (* ...We now use the [induction] tactic to prove [P n] (that
     is, [n + (m + p) = (n + m) + p]) for _all_ [n],
     and hence also for the particular [n] that is in the context
     at the moment. *)
  induction n as [| n'].
  Case "n = O". reflexivity.
  Case "n = S n'".
    (* In the second subgoal generated by [induction] -- the
       "inductive step" -- we must prove that [P n'] implies
       [P (S n')] for all [n'].  The [induction] tactic
       automatically introduces [n'] and [P n'] into the context
       for us, leaving just [P (S n')] as the goal. *)
    simpl. rewrite -> IHn'. reflexivity.  Qed.

(** It also works to apply [induction] to a variable that is
   quantified in the goal. *)

Theorem plus_comm' : forall n m : nat,
  n + m = m + n.
Proof.
  induction n as [| n'].
  Case "n = O". intros m. rewrite -> plus_0_r. reflexivity.
  Case "n = S n'". intros m. simpl. rewrite -> IHn'.
    rewrite <- plus_n_Sm. reflexivity.  Qed.

(** Note that [induction n] leaves [m] still bound in the goal --
    i.e., what we are proving inductively is a statement beginning
    with [forall m].

    If we do [induction] on a variable that is quantified in the goal
    _after_ some other quantifiers, the [induction] tactic will
    automatically introduce the variables bound by these quantifiers
    into the context. *)

Theorem plus_comm'' : forall n m : nat,
  n + m = m + n.
Proof.
  (* Let's do induction on [m] this time, instead of [n]... *)
  induction m as [| m'].
  Case "m = O". simpl. rewrite -> plus_0_r. reflexivity.
  Case "m = S m'". simpl. rewrite <- IHm'.
    rewrite <- plus_n_Sm. reflexivity.  Qed.

(** **** Exercise: 1 star, optional (plus_explicit_prop) *)
(** Rewrite both [plus_assoc'] and [plus_comm'] and their proofs in
    the same style as [mult_0_r''] above -- that is, for each theorem,
    give an explicit [Definition] of the proposition being proved by
    induction, and state the theorem and proof in terms of this
    defined proposition.  *)

(* FILL IN HERE *)
(** [] *)

(* ##################################################### *)
(** * Additional Exercises *)

(** **** Exercise: 2 stars, optional (foo_ind_principle) *)
(** Suppose we make the following inductive definition:
   Inductive foo (X : Set) (Y : Set) : Set :=
     | foo1 : X -> foo X Y
     | foo2 : Y -> foo X Y
     | foo3 : foo X Y -> foo X Y.
   Fill in the blanks to complete the induction principle that will be
   generated by Coq.
   foo_ind
        : forall (X Y : Set) (P : foo X Y -> Prop),
          (forall x : X, __________________________________) ->
          (forall y : Y, __________________________________) ->
          (________________________________________________) ->
           ________________________________________________

*)
(** [] *)

(** **** Exercise: 2 stars, optional (bar_ind_principle) *)
(** Consider the following induction principle:
   bar_ind
        : forall P : bar -> Prop,
          (forall n : nat, P (bar1 n)) ->
          (forall b : bar, P b -> P (bar2 b)) ->
          (forall (b : bool) (b0 : bar), P b0 -> P (bar3 b b0)) ->
          forall b : bar, P b
   Write out the corresponding inductive set definition.
   Inductive bar : Set :=
     | bar1 : ________________________________________
     | bar2 : ________________________________________
     | bar3 : ________________________________________.

*)
(** [] *)

(** **** Exercise: 2 stars, optional (no_longer_than_ind) *)
(** Given the following inductively defined proposition:
  Inductive no_longer_than (X : Set) : (list X) -> nat -> Prop :=
    | nlt_nil  : forall n, no_longer_than X [] n
    | nlt_cons : forall x l n, no_longer_than X l n ->
                               no_longer_than X (x::l) (S n)
    | nlt_succ : forall l n, no_longer_than X l n ->
                             no_longer_than X l (S n).
  write the induction principle generated by Coq.
  no_longer_than_ind
       : forall (X : Set) (P : list X -> nat -> Prop),
         (forall n : nat, ____________________) ->
         (forall (x : X) (l : list X) (n : nat),
          no_longer_than X l n -> ____________________ ->
                                  _____________________________ ->
         (forall (l : list X) (n : nat),
          no_longer_than X l n -> ____________________ ->
                                  _____________________________ ->
         forall (l : list X) (n : nat), no_longer_than X l n ->
           ____________________

*)
(** [] *)

(* ##################################################### *)
(** * Optional Material *)

(* ################################################### *)
(** ** Induction Principles for [/\] and [\/] *)

(** The induction principles for conjunction and disjunction are a
    good illustration of Coq's way of generating simplified induction
    principles for [Inductive]ly defined propositions, which we
    discussed in the last chapter.  You try first: *)

(** **** Exercise: 1 star, optional (and_ind_principle) *)
(** See if you can predict the induction principle for conjunction. *)

(* Check and_ind. *)
(** [] *)

(** **** Exercise: 1 star, optional (or_ind_principle) *)
(** See if you can predict the induction principle for disjunction. *)

(* Check or_ind. *)
(** [] *)

Check and_ind.

(** From the inductive definition of the proposition [and P Q]
     Inductive and (P Q : Prop) : Prop :=
       conj : P -> Q -> (and P Q).
    we might expect Coq to generate this induction principle
     and_ind_max :
       forall (P Q : Prop) (P0 : P /\ Q -> Prop),
            (forall (a : P) (b : Q), P0 (conj P Q a b)) ->
            forall a : P /\ Q, P0 a
    but actually it generates this simpler and more useful one:
     and_ind :
       forall P Q P0 : Prop,
            (P -> Q -> P0) ->
            P /\ Q -> P0
    In the same way, when given the inductive definition of [or P Q]
     Inductive or (P Q : Prop) : Prop :=
       | or_introl : P -> or P Q
       | or_intror : Q -> or P Q.
    instead of the "maximal induction principle"
     or_ind_max :
       forall (P Q : Prop) (P0 : P \/ Q -> Prop),
            (forall a : P, P0 (or_introl P Q a)) ->
            (forall b : Q, P0 (or_intror P Q b)) ->
            forall o : P \/ Q, P0 o
    what Coq actually generates is this:
     or_ind :
       forall P Q P0 : Prop,
            (P -> P0) ->
            (Q -> P0) ->
            P \/ Q -> P0
]]
*)

(* ######################################################### *)
(** ** Explicit Proof Objects for Induction *)

(** Although tactic-based proofs are normally much easier to
    work with, the ability to write a proof term directly is sometimes
    very handy, particularly when we want Coq to do something slightly
    non-standard.  *)

(** Recall the induction principle on naturals that Coq generates for
    us automatically from the Inductive declation for [nat]. *)

(* Check nat_ind. *)
(* ===>
   nat_ind : forall P : nat -> Prop,
      P 0%nat ->
      (forall n : nat, P n -> P (S n)) ->
      forall n : nat, P n  *)

(** There's nothing magic about this induction lemma: it's just
   another Coq lemma that requires a proof.  Coq generates the proof
   automatically too...  *)

Print nat_ind.
(* ===> (after some manual tidying)
   nat_ind =
    fun (P : nat -> Type)
        (f : P 0)
        (f0 : forall n : nat, P n -> P (S n)) =>
          fix F (n : nat) : P n :=
             match n as n0 return (P n0) with
            | 0 => f
            | S n0 => f0 n0 (F n0)
            end.
*)

(** We can read this as follows:
     Suppose we have evidence [f] that [P] holds on 0,  and
     evidence [f0] that [forall n:nat, P n -> P (S n)].
     Then we can prove that [P] holds of an arbitrary nat [n] via
     a recursive function [F] (here defined using the expression
     form [Fix] rather than by a top-level [Fixpoint]
     declaration).  [F] pattern matches on [n]:
      - If it finds 0, [F] uses [f] to show that [P n] holds.
      - If it finds [S n0], [F] applies itself recursively on [n0]
         to obtain evidence that [P n0] holds; then it applies [f0]
         on that evidence to show that [P (S n)] holds.
    [F] is just an ordinary recursive function that happens to
    operate on evidence in [Prop] rather than on terms in [Set].

    Aside to those interested in functional programming: You may
    notice that the [match] in [F] requires an annotation [as n0
    return (P n0)] to help Coq's typechecker realize that the two arms
    of the [match] actually return the same type (namely [P n]).  This
    is essentially like matching over a GADT (generalized algebraic
    datatype) in Haskell.  In fact, [F] has a _dependent_ type: its
    result type depends on its argument; GADT's can be used to
    describe simple dependent types like this.

    We can adapt this approach to proving [nat_ind] to help prove
    _non-standard_ induction principles too.  Recall our desire to
    prove that

    [forall n : nat, even n -> ev n].

    Attempts to do this by standard induction on [n] fail, because the
    induction principle only lets us proceed when we can prove that
    [even n -> even (S n)] -- which is of course never provable.  What
    we did earlier in this chapter was a bit of a hack:

    [Theorem even__ev : forall n : nat,
     (even n -> ev n) /\ (even (S n) -> ev (S n))].

    We can make a much better proof by defining and proving a
    non-standard induction principle that goes "by twos":

 *)

 Definition nat_ind2 :
    forall (P : nat -> Prop),
    P 0 ->
    P 1 ->
    (forall n : nat, P n -> P (S(S n))) ->
    forall n : nat , P n :=
       fun P => fun P0 => fun P1 => fun PSS =>
          fix f (n:nat) := match n return P n with
                             0 => P0
                           | 1 => P1
                           | S (S n') => PSS n' (f n')
                          end.

 (** Once you get the hang of it, it is entirely straightforward to
     give an explicit proof term for induction principles like this.
     Proving this as a lemma using tactics is much less intuitive (try
     it!).

     The [induction ... using] tactic gives a convenient way to
     specify a non-standard induction principle like this. *)

Lemma even__ev' : forall n, even n -> ev n.
Proof.
 intros.
 induction n as [ | |n'] using nat_ind2.
  Case "even 0".
    apply ev_0.
  Case "even 1".
    inversion H.
  Case "even (S(S n'))".
    apply ev_SS.
    apply IHn'.  unfold even.  unfold even in H.  simpl in H. apply H.
Qed.

(* ######################################################### *)
(** ** The Coq Trusted Computing Base *)

(** One issue that arises with any automated proof assistant is "why
    trust it?": what if there is a bug in the implementation that
    renders all its reasoning suspect?

    While it is impossible to allay such concerns completely, the fact
    that Coq is based on the Curry-Howard correspondence gives it a
    strong foundation. Because propositions are just types and proofs
    are just terms, checking that an alleged proof of a proposition is
    valid just amounts to _type-checking_ the term.  Type checkers are
    relatively small and straightforward programs, so the "trusted
    computing base" for Coq -- the part of the code that we have to
    believe is operating correctly -- is small too.

    What must a typechecker do?  Its primary job is to make sure that
    in each function application the expected and actual argument
    types match, that the arms of a [match] expression are constructor
    patterns belonging to the inductive type being matched over and
    all arms of the [match] return the same type, and so on.

    There are a few additional wrinkles:

    - Since Coq types can themselves be expressions, the checker must
      normalize these (by using the conversion rules) before
      comparing them.

    - The checker must make sure that [match] expressions are
      _exhaustive_.  That is, there must be an arm for every possible
      constructor.  To see why, consider the following alleged proof
      object:
      Definition or_bogus : forall P Q, P \/ Q -> P :=
        fun (P Q : Prop) (A : P \/ Q) =>
           match A with
           | or_introl H => H
           end.
      All the types here match correctly, but the [match] only
      considers one of the possible constructors for [or].  Coq's
      exhaustiveness check will reject this definition.

    - The checker must make sure that each [fix] expression
      terminates.  It does this using a syntactic check to make sure
      that each recursive call is on a subexpression of the original
      argument.  To see why this is essential, consider this alleged
      proof:
          Definition nat_false : forall (n:nat), False :=
             fix f (n:nat) : False := f n.
      Again, this is perfectly well-typed, but (fortunately) Coq will
      reject it. *)

(** Note that the soundness of Coq depends only on the correctness of
    this typechecking engine, not on the tactic machinery.  If there
    is a bug in a tactic implementation (and this certainly does
    happen!), that tactic might construct an invalid proof term.  But
    when you type [Qed], Coq checks the term for validity from
    scratch.  Only lemmas whose proofs pass the type-checker can be
    used in further proof developments.  *)

(* $Date: 2013-02-06 20:55:20 -0500 (Wed, 06 Feb 2013) $ *)


(** Ordering functions (after Schutte) *)

(**   Pierre Casteran, LaBRI, University of Bordeaux

Every subset [A] of [Ord] can be enumerated in an unique way
 by a segment of [Ord].

Thus it makes sense to consider the [alpha]-th element of [A]

This module shows the construction of the _ordering function_  of [A], following
Schutte's definitions.

*)

From hydras Require Export Schutte_basics.
Import Ensembles  Well_Orders  Countable  PartialFun.
Import Classical  MoreEpsilonIota  Epsilon.

Set Implicit Arguments.

 (** ** Main definitions *)

(* begin snippet segmentDef *)

Definition segment (A: Ensemble Ord) :=
  forall alpha beta, In A alpha -> beta < alpha -> In A  beta.

Definition proper_segment (A: Ensemble Ord) :=
  segment A /\  ~ Same_set A ordinal.

(* end snippet segmentDef *)

(* begin snippet orderingFunctionDef *)

Class ordering_function (f : Ord -> Ord)
           (A B : Ensemble Ord) : Prop :=
  Build_OF {
      OF_segment : segment A;
      OF_total : forall a, In A a -> In B (f a);
      OF_onto : forall b, In B b -> exists a, In A a /\ f a = b;
      OF_mono : forall a b, In A a -> In A b -> a < b -> f a < f b
    }.

Definition ordering_segment (A B : Ensemble Ord) :=
  exists f : Ord -> Ord, ordering_function f A B.

(* end snippet orderingFunctionDef *)

(* begin snippet ordDef *)

Definition the_ordering_segment (B : Ensemble Ord) :=
  the  (fun x => ordering_segment x B).

Definition ord   (B : Ensemble Ord) :=
  some (fun f => ordering_function f (the_ordering_segment B) B).
(* end snippet ordDef *)

Definition proper_segment_of (B : Ensemble Ord)(beta : Ord): Ensemble Ord  :=
  fun alpha => In B alpha /\ alpha < beta /\ In B beta.

Definition  normal (f : Ord -> Ord)(B : Ensemble Ord): Prop :=
 ordering_function f ordinal B /\ continuous f ordinal B.

Definition fun_equiv (f g : Ord -> Ord)(A B : Ensemble Ord) :=
  Same_set A B /\ forall a, In A a -> f a = g a.

(**  **  Properties of  segments *)

Lemma ordinal_segment : segment ordinal.
Proof.
 split; eauto with schutte.
Qed.

Lemma members_proper (alpha : Ord) :
  proper_segment (members alpha).
Proof with eauto with schutte.
  split.
 -  intros a b H H0; apply lt_trans with a ...
 -  intros [H0 H1]; destruct (@le_not_gt alpha (succ alpha)) ...
   + apply  (H1 (succ alpha)) ...
Qed.

Lemma proper_members (A: Ensemble Ord) (H :  proper_segment A) :
   exists a: Ord,  Same_set A (members a).
Proof with eauto with schutte.
  case (not_all_not_ex _ (fun b => ordinal b /\ ~ A b)).
  - intro H1;  apply H;split.
    +  unfold Included; split; auto.
    +  intros x H2; apply NNPP; intro H3.
       apply (H1 x); split;auto.
  -  intros x H1; case (@well_order _  lt AX1 (fun x => ordinal x /\ ~ A x) x).
     + auto.
     +  intros y Hy.
        case Hy;intros H2 H3; destruct H2.
        exists y;split...
        * intros a H6; tricho a y T ...
          case H;auto.
          subst a; contradiction.
          red in Hy.
          destruct Hy.
          destruct H.
          red in H.
          specialize (H a y H6 T).
          contradiction.
        *  red; unfold In;intros; apply NNPP.
          case Hy;  intros H7 H8 H10.
          case (H8 x0 ).
          { red; split ... }
          { intro; subst. destruct (lt_irrefl H4). }
          intro; case (@lt_irrefl x0); apply lt_trans with y ...
Qed.

Lemma countable_segment_proper : forall A : Ensemble Ord,
           segment A -> countable A -> proper_segment A.
Proof.
 intros A H H0; split;[auto|idtac].
 intro H1; generalize (Extensionality_Ensembles _ _ _ H1).
 intros; subst A ; now case Non_denum.
Qed.

Lemma ordering_function_In f A B a :
   ordering_function f A B -> In A a -> In B (f a).
Proof. destruct 1; auto. Qed.

Lemma ordering_function_mono (f : Ord -> Ord) (A B: Ensemble Ord) :
  ordering_function f A B ->
  forall alpha beta,
    In A alpha -> In A beta -> alpha < beta -> f alpha < f beta.
Proof.  now destruct 1. Qed.

#[global] Hint Resolve ordering_function_mono : schutte.

Lemma  ordering_function_mono_weak (f : Ord -> Ord) (A B: Ensemble Ord) :
 ordering_function f A B ->
   forall a b, In A a -> In A b -> a <= b -> f a <= f b.
Proof.
 destruct 1 as [H H0 H1 H2].
 destruct 3.
 -  subst b; left; auto with schutte.
 -  right;auto.
Qed.

#[global] Hint Resolve ordering_function_mono_weak : schutte.

Lemma ordering_function_monoR : forall f A B, ordering_function f A B ->
   forall a b, In A a -> In A b -> f a < f b -> a < b.
Proof.
  destruct 1 as [H H0 H1 H2];
    intros a b H3 H4 H5; tricho a b Ht; auto.
  - subst b; now destruct (@lt_irrefl (f a)).
  - destruct (@lt_irrefl (f a)); apply lt_trans with (f b); auto.
Qed.

#[global] Hint Resolve ordering_function_monoR : schutte.

Lemma Ordering_bijection : forall f A B, ordering_function f A B ->
                                         fun_bijection A B f.
Proof.
  destruct 1 as [H H0 H1 H2].
  split;red;auto; intros.
  tricho a a' H7; trivial.
  -  specialize  (H2 _ _ H3 H4 H7); rewrite H5 in H2;
     destruct (lt_irrefl H2).
  - specialize  (H2 _ _ H4 H3 H7);  rewrite H5 in H2;
    destruct (lt_irrefl H2).
Qed.

Lemma  ordering_function_mono_weakR :
  forall f A B, ordering_function f A B ->
                forall a b, In A a -> In A b ->  f a <= f b -> a <= b.
Proof with auto with schutte.
  intros f A B H a b H0 H1 H2.
  case H; intros H3 H4 H5 H6.
  destruct H2 as [H2 | H2].
  case (Ordering_bijection H).
  intros H10 H11 H12 ; specialize (H12 a b H0 H1 )...
  -  right; eapply ordering_function_monoR; eauto.
Qed.

#[global] Hint Resolve ordering_function_mono_weakR : schutte.

Lemma ordering_function_seg : forall A B, ordering_segment A B ->
                                          segment A.
Proof. now destruct 1 as [f [H _]]. Qed.

Lemma empty_ordering : forall B, (forall b, ~ B b) ->
                                 ordering_function (fun o => o)
                                                   (members zero)
                                                   B.
Proof.
  intros B H; split.
  -  intros a b H0 H1;  destruct (not_lt_zero H0);auto.
  - intros b H0 ; now destruct (not_lt_zero H0).
  -  intros x Hx; now destruct (H x).
  -  intros a b Hb; case (@not_lt_zero a); assumption.
Qed.

Lemma segment_lt : forall A a b, segment A -> A a -> b < a -> A b.
Proof.
 intros A a b H0  H1 H2; now apply H0 with a.
Qed.

Theorem segment_unbounded : forall A:Ensemble Ord, segment A ->
                                        Unbounded A ->
                                        A = ordinal.
Proof with eauto with schutte.
 intros A H H0; red in H0; apply Extensionality_Ensembles; split.
 - intros; split.
 -  intros x Hx; destruct (H0 x) as [x0 H1]...
    destruct H1; now apply H with x0.
Qed.

(* begin snippet orderingLe *)

(*  Theorem 13.3 of Schutte's book *)

Theorem ordering_le : forall f A B,
    ordering_function f A B ->
    forall alpha, In A alpha -> alpha <= f alpha. (* .no-out *)
(*| .. coq:: none |*)
Proof with auto with schutte.
  intros f A B H alpha H0; generalize H0;
    pattern alpha; apply transfinite_induction.
  - clear alpha H0; destruct H as [H1 H2 H3 H4].
    unfold progressive;   intros alpha H6 H7 .
    tricho alpha (f alpha) H' ...
    +   assert (f (f alpha) < f alpha).
      {    apply H4.
           - eapply segment_lt;eauto with schutte.
           - unfold In;auto.
           - unfold In;auto.
      }
      case (le_not_gt (a:= f alpha)(b:=f (f alpha)));auto.
      apply H6;  eauto with schutte.
Qed.
(*||*)
(* end snippet orderingLe *)

(* begin hide *)
Section ordering_function_unicity_1.

 Variables B A1 A2 : Ensemble Ord.
 Variables f1 f2 : Ord -> Ord.
 Hypothesis O1 : ordering_function f1 A1 B.
 Hypothesis O2 : ordering_function f2 A2 B.

 Remark SA1 : segment A1.
 Proof.   case O1;intuition.  Qed.

 Remark SA2 : segment A2.
 Proof.  case O2;intuition.  Qed.

 #[local] Hint Resolve SA2 SA1 : schutte.

  Lemma A1_A2 :forall a, In A1 a -> A2 a /\ f1 a = f2 a.
 Proof with eauto with schutte.
   intros a Ha;  generalize Ha;pattern a; apply transfinite_induction.
   {
     clear a Ha ; intros a  H0 Ha ;   assert (A2 a).
     {
       assert (forall khi, khi < a -> A2 khi /\ f1 khi = f2 khi).
       {  intros;  apply H0...
       }
       apply NNPP; intro H2.
       assert (forall y, A2 y -> y < a).
       { intros y H3;  tricho y a H4 ...
         subst y; now case H2.
         destruct H2;  apply segment_lt with y;auto with schutte.
       }

       assert (forall y, A2 y -> f1 y < f1 a).
       {   intros y H4;  case O1;intros H5 H6 H7 H8.
           apply H8 ...
       }

       case O2;intros H5 H6 H7 H8;  case (H7 (f1 a)).
       - case O1;intros H9 H10 H11 H12.
         apply H10;  auto.
       -  destruct 1.   generalize (H3 x H4).
          intro;  case (H0 x)...
           + intros H13 H14. specialize (H6 _ H4).   rewrite <- H9 in H10.
            rewrite H14 in H10.
            case (@lt_irrefl (f2 x));auto.
     }
     {   split; trivial.
         assert (H01 : least_member  lt
                                        (fun x => B x /\
                                                  forall y, y < a ->
                                                            f1 y <> x)
                                        (f1 a)).

         {  split.
            +  case O1;intros;  unfold In; intuition.
               apply OF_total0; auto.
               specialize (OF_mono0  y a ).
               assert (In A1 y) by (eapply OF_segment0 with a ; auto).
               specialize (OF_mono0 H3  Ha H1).
               rewrite H2 in OF_mono0; now apply (@lt_irrefl (f1 a)).
            + destruct 1;   destruct O1 as [H3 H4 H5 H6].
              destruct (H5 x H1).
              destruct H7; subst x;  tricho a x0 H9.
              *  right.   apply H6;auto.
              *  subst x0; now left.
              * now destruct  (H2  _ H9).
         }

         assert (H02 : least_member  lt
                                     (fun x => B x /\ forall y, y < a ->
                                                                f2 y <> x)
                                     (f2 a)).
         {
           split.
           +  case O2;intros  H2 H3 H4 H5.   unfold In; intuition.
              apply H3; auto.
              specialize (H5 y a ).
              assert (In A2 y)  by ( eapply H2 with a ; auto).
              specialize (H5 H7 H H1).
              rewrite H6 in H5; now apply (@lt_irrefl (f2 a)).
           + destruct 1; case O2; intros  H3 H4 H5 H6.
            destruct (H5 x H1).
             destruct H7; subst x; tricho a x0 H9.
             *  right;   apply H6;auto.
             *  subst x0; now left.
             * specialize (H2 _ H9); now destruct H2.
         }
         refine (least_member_of_eq AX1 _ _ H01 H02).

         - intros x Hx; split.
           + red in Hx; tauto.
           + intros y H1; destruct (H0 _ H1).
             * case O1; intros  H2 H3 H4 H5.    apply H2 with a; auto.
             * rewrite <- H3;  destruct Hx;  auto.
         - intros x Hx;  split.
           + red in Hx; tauto.
           + intros y H1;   destruct (H0 _ H1).
             case O1;intros H2 H3 H4 H5.   apply H2 with a; auto.
             rewrite  H3;    destruct Hx;  auto.
     }
   }
 Qed.

End ordering_function_unicity_1.

(* end hide *)

Section ordering_function_unicity.

 Variables B A1 A2 : Ensemble Ord.

 Variables f1 f2 : Ord -> Ord.
 Hypothesis O1 : ordering_function f1 A1 B.
 Hypothesis O2 : ordering_function f2 A2 B.

 (* begin hide *)

 Lemma A2_A1 :forall a, A2 a -> A1 a /\ f2 a = f1 a.
 Proof.
  intros; eapply A1_A2.
  - eapply O2.
  - apply O1.
  - auto.
 Qed.

 (* end hide *)

Theorem ordering_function_unicity  : fun_equiv f1 f2 A1 A2.
Proof.
 split.
 - split.
   +  intros x Hx; case (A1_A2 O1 O2 _ Hx);auto.
   +  intros x Hx; destruct (A2_A1 Hx);auto.
 -  intros a Ha; destruct (A1_A2 O1 O2 a Ha);auto.
Qed.

End ordering_function_unicity.

Lemma ordering_function_seg_unicity : forall A1 A2 B,
           ordering_segment A1 B ->
           ordering_segment A2 B -> A1 = A2.
Proof.
 destruct 1 as [f1 Hf1];  destruct 1 as [f2 Hf2];
 apply Extensionality_Ensembles.
 assert (H : fun_equiv f1 f2 A1 A2)
   by (eapply ordering_function_unicity;eauto); now destruct H.
Qed.

(** Let us build now an ordering function, and the associated ordering segment
 of any subset B composed of ordinals *)

Lemma proper_of_proper : forall B beta beta',
                           ordinal beta -> In B beta ->
                           In (proper_segment_of B beta) beta' ->
                           proper_segment_of B beta' =
                           proper_segment_of (proper_segment_of B beta) beta'.
Proof with  eauto with schutte.
 intros; apply Extensionality_Ensembles; split.
 - red; destruct 1; split.
   + split;auto.
     destruct H3; split.
     * apply lt_trans with beta'...
       case H1;tauto.
     * auto.
   + decompose [and] H3;  split;auto.
 - red; destruct 1;auto.
   split.
   +  case H2;auto.
   +  split.
    * tauto.
    * destruct  H3, H4 ...
Qed.

Section building_ordering_function_1.
 Variable B : Ensemble Ord.

 Hypothesis H_B : forall beta, In B beta ->
                               exists! A : Ensemble Ord,
                                    ordering_segment A
                                             (proper_segment_of B beta).

 Section beta_fixed.

 Variable beta : Ord.
 Hypothesis beta_B : In B beta.

 (** Let us build an ordering function for (proper_segment_of B beta) *)

 Definition _A := the  (fun E =>
                          ordering_segment E  (proper_segment_of B beta)).

 Definition _f := some  (fun f =>
                           ordering_function f _A
			                     (proper_segment_of B beta)).

 Lemma of_beta' : ordering_function _f _A (proper_segment_of B beta).
 Proof.
   pattern _f; unfold _f; apply epsilon_spec;
     destruct (H_B  beta_B) as [x [H1 H2]].
   case H1; intros x0 H;  exists x0;auto.
   unfold _A; apply iota_ind.
   - exists x; split; auto.
   - intros a H0;  destruct H0;  replace a with x; auto.
 Qed.

 Remark Bbeta_denum : countable (proper_segment_of B beta).
 Proof.
  apply AX2; exists beta;  destruct 1;tauto.
 Qed.

 #[local] Hint Resolve of_beta': schutte.

Remark A_denum : countable _A.
Proof.
 eapply countable_bij_funR.
 - eapply Ordering_bijection;   eauto with schutte.
 - apply Bbeta_denum;eauto.
Qed.

Lemma Proper_A : proper_segment _A.
Proof.
 apply countable_segment_proper.
 - eapply SA1; eauto with schutte.
 - eapply A_denum.
Qed.

Lemma g_def1  : exists g_beta: Ord,  ordinal g_beta /\ _A = members g_beta.
Proof.
 generalize (proper_members Proper_A); intros (a,Ha);exists a;split.
 - now destruct Ha.
 - eapply Extensionality_Ensembles; tauto.
Qed.

Lemma g_unic : forall g_beta g_beta', ordinal g_beta ->
                                      ordinal g_beta' ->
                                      _A = members g_beta ->
                                      _A = members g_beta' ->
                                      g_beta = g_beta'.
Proof.
  intros g_beta g_beta' H H0 H1 H2;  rewrite H2 in H1;clear H2.
  assert (Same_set  (members g_beta') (members g_beta)).
  { rewrite H1; split;auto with schutte. }
  case H2; unfold Included, members; intros; apply le_antisym.
 - apply not_gt_le; auto with schutte.
   intro H5; generalize (H4 g_beta'); intros H6; unfold In in H6.
   case (@lt_irrefl g_beta');  now apply H6.
 - apply not_gt_le; auto with schutte.
   intro H5;  generalize (H3 g_beta);intros H6;
     destruct  (@lt_irrefl g_beta);  now apply H6.
Qed.

Definition g := iota inh_Ord (fun o => ordinal o /\ _A = members o).

End beta_fixed.

Lemma g_def : forall beta, In  B beta ->  _A beta = members (g beta ).
Proof.
  intros.
  pattern (g beta); unfold g; apply iota_ind.
  - case (g_def1 H);  intros a' [Ha' Ha'']; exists a'; split;auto.
    intros x (Hx,H'x);  eapply g_unic;eauto.
  -  now intros x ((Hx,H'x),U).
Qed.

Lemma g_lemma :
  forall beta, In B beta ->
       ordering_function (_f beta) (members (g beta))
                                       (proper_segment_of B beta).
Proof.
 intros beta H; rewrite <- g_def.
 - now   apply of_beta'.
 - assumption.
Qed.

Lemma g_mono : forall beta1 beta2, In B beta1 -> In B  beta2 ->
                                   beta1 < beta2 ->
                                   g beta1 < g beta2.
Proof with eauto with schutte.
 intros beta1 beta2 H H0 H1.
 assert( B2 : fun_bijection (members (g beta2))
                            (proper_segment_of B beta2)
                            (_f beta2)) .
 { apply Ordering_bijection, g_lemma ... }
 assert (B3 : In (proper_segment_of B beta2) beta1).
 { split.  apply H. split; assumption. }
  assert (B4 : exists alpha,  alpha < g beta2 /\ _f beta2 alpha= beta1).
 { destruct B2; case (H3 beta1) ... }

 case B4; intros alpha (Ha2,Ha3).
 assert (B5 : ordering_function (_f beta2) (members alpha)
                                (proper_segment_of B beta1)).
 { repeat split ...
   - red;  intros;   apply lt_trans with alpha0;eauto.
   -  case B2;intros;  clear H4 H5; red in H3.
      + generalize (H3 a); intros H4;  clear H3;  case H4.
        * red; apply lt_trans with alpha; auto.
        *  auto.
   -  case (g_lemma H0).
      intros H3 H4; decompose [and] H4; clear H4.
      replace beta1 with (_f beta2 alpha).
      intros.
      apply OF_mono0; auto.
      +   red;  apply lt_trans with alpha;auto.
   -  destruct 1;  case (g_lemma H0).
      intros H4 H5;  decompose [and] H4;  clear H4;  decompose [and] H5.
       intros. case (OF_onto0 b).
      + split;auto.
        split;auto.
        eapply lt_trans;eauto.
        case H3;auto.
       +  intros a (Ha,Ha');exists a;split;auto.
          red;  tricho  a alpha X.
         *  auto.
         * subst a; rewrite Ha3 in Ha'.
           subst b; case H3;intros H33 _.
           case (@lt_irrefl _ H33).
         *  assert (beta1 < b).
           { rewrite <- Ha3; rewrite <- Ha'.
             case (g_lemma H0); intros.
             apply OF_mono1; auto.
           }
           case (@lt_irrefl beta1);  apply lt_trans with b;auto.
           case H3;auto.
   - intros; case (g_lemma H0); intros.
     apply OF_mono0; auto.
     red;  apply lt_trans with alpha;auto.
    red;  red; apply lt_trans with alpha;auto.
 }
 generalize (g_lemma H);intro.
 generalize (ordering_function_unicity B5 H2).
 destruct 1.
 generalize (Extensionality_Ensembles _ _ _ H3).
 intros;  generalize (members_eq   H5).
 intro; subst alpha;auto.
Qed.

Lemma L3a : segment (image B g).
Proof.
  intros gbeta alpha  (beta,(H1,H2)) H3;  subst gbeta.
     generalize (g_lemma H1);intro.
     case H; intros  H2 H4 H5 H6.
     assert (exists beta0, In (proper_segment_of B beta) beta0
                      /\ _f beta alpha=beta0).
     {  exists (_f beta alpha); split;auto.
     }
     case H0;intros beta0 (H9,H10); clear H0.
     assert (B5 : ordering_function (_f beta) (members alpha)
                 (proper_segment_of B beta0)).
     {
       repeat split;  auto with schutte.
       - red;  red; intros.  apply lt_trans with alpha0;eauto.
       - assert( B2 : fun_bijection (members (g beta))
                                  (proper_segment_of B beta) (_f beta)) .
        { apply Ordering_bijection ;   apply g_lemma; auto. }
         case B2;intros H77 H11 H12;  generalize (H77 a).
         intros H13;  clear H77;  case H13.
         2:auto.
        red;  apply lt_trans with alpha; auto.

       -  case (g_lemma H1); intros.
          replace beta0 with (_f beta alpha).
        apply OF_mono0; auto.
        red;  red;  apply lt_trans with alpha;auto.
       -  case H9;  auto.
       - destruct 1; case (g_lemma H1); intros.
          case (OF_onto0 b).
         split;auto.
         split;auto.
         apply lt_trans with beta0;auto.
         case H7;auto.
         case H9;auto.
         destruct 2; auto.
         intros a (Ha,Ha');exists a;split;auto.
         red; tricho  a alpha X.
         + auto.
        + subst a; rewrite H10 in Ha'.
          subst b. case H7; intros H77 _.
          case (@lt_irrefl _ H77).
        + assert (beta0 < b) by (rewrite <- H10; rewrite <- Ha'; auto).
          case (@lt_irrefl beta0).
          apply lt_trans with b;auto.
          case H7;auto.
        - intros; case (g_lemma H1); intros.
          apply OF_mono0; auto.
          red;  apply lt_trans with alpha;auto.
          red; red;  apply lt_trans with alpha;auto.
       }
     generalize (g_lemma (beta:=beta0));intros.
     case H9;intros H7 H8.   generalize (H0 H7).
     intros H12; generalize (ordering_function_unicity B5 H12).
     destruct 1;  generalize (Extensionality_Ensembles _ _ _ H11).
     intros H14; generalize (members_eq (alpha:=alpha)(beta:=g beta0)   H14 ).
     exists beta0;split;auto.
Qed.

 Lemma g_bij : fun_bijection B (image B g) g.
 Proof.
 split.
 -  intros a H ; exists a;split;auto.
 -  red; destruct 1;  exists x;split;auto.
   +  case H;auto.
   +  case H;auto.
 - red;intros a b; tricho a b Hab; trivial.
   intros H H0 ; generalize (g_mono H H0 Hab); auto.
   + intros H1 H2.   rewrite H2 in H1;  case (@lt_irrefl _ H1); auto.
   + intros H H0 H1; generalize (g_mono H0 H Hab); intro; rewrite H1 in H2;
      case (@lt_irrefl _ H2).
 Qed.

 #[local] Hint Resolve g_bij : schutte.

Let g_1 := inv_fun inh_Ord B (image B g) g.

Lemma g_1_bij : fun_bijection (image B g) B g_1.
Proof.
 unfold  g_1; apply inv_fun_bij; auto with schutte.
Qed.

#[local] Hint Resolve g_1_bij : schutte.

Lemma g_1_of : ordering_function g_1 (image B g) B.
Proof.
 split.
 -  apply L3a.
 -
   destruct 1 as [x [H0 H1]]. rewrite <- H1.
      replace (g_1 (g x)) with x;  auto.
      symmetry;unfold g_1;eapply inv_compose;eauto.
      auto with schutte.
 - intros b H;  exists (g b);  split;auto.
   +  exists b;  split;auto.
   +  unfold g_1;eapply inv_compose;eauto.
      auto with schutte.
  -  intros;  tricho (g_1 a) (g_1 b) Hab; auto with schutte.
    + case g_1_bij; intros.
      generalize (H2 a H).
      case g_1_bij; intros.
      generalize (H2 b H0).
      replace a with (g (g_1 a)) in H1.
      replace b with (g (g_1 b)) in H1.
      rewrite Hab in H1.
      case (@lt_irrefl _ H1).
      unfold g_1;  apply inv_composeR;  auto with schutte.
      unfold g_1;  apply inv_composeR;  auto with schutte.
    +  case (le_not_gt (a:=a)(b:= b));  auto with schutte.
       replace a with (g (g_1 a));
         replace b with (g (g_1 b)) .
       apply g_mono;auto with schutte.
       case g_1_bij;auto with schutte.
       case g_1_bij;auto with schutte.
     all :  unfold g_1;  apply inv_composeR;  auto with schutte.
Qed.

Lemma image_B_g_seg  : ordering_segment (image B g) B.
Proof.
 exists g_1;  apply g_1_of.
Qed.

(** Corresponds to Lemma 3 of Schutte's chapter :
    It is used twice in the building of ordering function for any subset B of ordinal *)

Lemma L3_u : exists! S, ordering_segment S B.
Proof.
 exists (image B g);  split.
 - apply image_B_g_seg.
 - intros ;eapply ordering_function_seg_unicity;eauto.
   apply image_B_g_seg.
Qed.

End building_ordering_function_1.

(** For any set [B], we build by transfinite induction the ordering segment of
  [B] and the (unique upto extensionnality) ordering function of B
 *)

Section building_ordering_function_by_induction.

 Variable B : Ensemble Ord.

 Lemma ordering_segments_of_B (beta : Ord) :
  In B beta ->
  exists! A : Ensemble Ord,
    ordering_segment A  (proper_segment_of B beta).
  Proof with eauto with schutte.
    intros  Hbeta; pattern beta; apply transfinite_induction.
    -  intros a  H0;  apply L3_u.
    +   intros beta0 H1;
      rewrite <- (proper_of_proper (B:=B) (beta:=a) (beta':=beta0))...
      apply H0...
        *  destruct H1 ; tauto.
        *  destruct H1; tauto.
Qed.

 Theorem ordering_segment_ex_unique : exists! S, ordering_segment S B.
 Proof.
   apply L3_u,  ordering_segments_of_B.
 Qed.

Theorem ordering_function_ex : exists ! S, exists f, ordering_function f S B.
Proof with eauto.
 case ordering_segment_ex_unique;intros S (f,pi); exists S.
  split.
  -  case f;intros x H;  exists x;auto.
  -  intros x' H;  case H; intros;case f;intros.
     eapply ordering_function_seg_unicity...
Qed.

Lemma ord_ok :
  ordering_function (ord  B) (the_ordering_segment B) B.
Proof.
  pattern (ord  B);  apply epsilon_spec.
  pattern (the_ordering_segment B);
    apply iota_spec,  ordering_segment_ex_unique.
Qed.

Lemma segment_the_ordering_segment  :
  segment (the_ordering_segment B).
  unfold the_ordering_segment.
  apply iota_ind.
  apply ordering_segment_ex_unique.
  destruct 1.
  destruct H.
  now  destruct H.
Qed.

Lemma ord_eq (A : Ensemble Ord) (f : Ord -> Ord) :
  ordering_function f A B ->
  fun_equiv f (ord B) A (the_ordering_segment B).
 Proof with eauto with schutte.
   intros;eapply ordering_function_unicity...
   apply ord_ok.
 Qed.

End building_ordering_function_by_induction.

(* begin snippet orderingFunctionEx *)

About ordering_function_ex.
About ordering_function_unicity.

(* end snippet orderingFunctionEx *)

Lemma of_image : forall f A B, ordering_function f A B ->
                               ordering_function f A (image A f).
Proof.
 intros f A B O; case O; intros H H0;  decompose [and] H0.
 repeat split;auto.
 intros; exists a; auto.
Qed.

Section Th13_5.
 Variables (A B : Ensemble Ord).
 Variable f : Ord -> Ord.
 Hypothesis f_ord : ordering_function f A B.

 Section recto.

 Hypothesis f_cont : continuous f A B.
 (* begin hide *)

 Section M_fixed.
 Variable M : Ensemble Ord.
 Hypothesis inc : Included M B.
 Hypothesis ne : Inhabited _ M.
 Hypothesis den : countable M.

 Let U := fun u => In A u /\ In M ( f u).

 Remark fbij : fun_bijection A B f.
  apply Ordering_bijection; auto.
 Qed.

 Remark restrict : fun_bijection U M f.
 Proof.
   split.
   -  destruct 1;auto.
   - red; case fbij.
     intros  H H0 H1 b H2; case (H0 b).
     +   apply inc;auto.
     +  intros x (Hx,H'x); exists x;split;auto.
        red;unfold U; split;auto.
        subst b;auto.
   -  red; destruct 1.
      destruct 1.
      intros H3; case fbij;intros; now  apply H6.
Qed.

 Remark Inc_U_A : Included U A.
 Proof. now destruct 1. Qed.

 Remark den_U : countable U.
 eapply countable_bij_funR with Ord M f;auto.
 apply restrict.
 Qed.

 Remark inh_U : Inhabited _ U.
 Proof.
   case ne;intros.
   exists (inv_fun inh_Ord A B f x).
   red; unfold U; rewrite inv_composeR.
   -  split;auto.
      generalize (Ordering_bijection f_ord);
      intros;    generalize (inv_fun_bij inh_Ord H0).
      intros;  destruct H1.
      apply H1.
      apply inc;auto.
   -  apply fbij.
   -   apply inc;auto.
 Qed.

 Remark im_U_f : (image U f : Ensemble Ord)  = M.
 Proof.
   eapply Extensionality_Ensembles;    split.
   red;destruct 1;  unfold U in H;  case H.
   intros;   case H0;intros.
   subst x;auto.
   red;  intros.
   exists (inv_fun inh_Ord A B f x);  split.
   red;red;  generalize (Ordering_bijection f_ord).
   intros;   split.
   case (inv_fun_bij inh_Ord H0).
   auto.
   intros;   destruct H0.
   rewrite inv_composeR; auto with schutte.
   apply fbij.
   apply inc;auto.
   rewrite inv_composeR; auto with schutte.
   apply fbij.
   apply inc;auto.
 Qed.

 Lemma sup_M_in_B : In B (|_| M).
 Proof.
  rewrite <- im_U_f.   case f_cont.  intros H [H0 H1].
  rewrite H1; auto.
  -  apply H.
     apply H0.
     + apply Inc_U_A.
     + apply inh_U.
     + apply den_U.
  -  apply Inc_U_A.
  -  apply inh_U.
  - apply den_U.
Qed.

End M_fixed.

 (* end hide *)

 Lemma Th_13_5_1 : Closed B.
 Proof.
    red.
   intros;    apply sup_M_in_B; auto.
 Qed.

End recto.

Section verso.
 Hypothesis B_closed : Closed B.

 (* begin hide *)

 Section U_fixed.
 Variable U : Ensemble Ord.
 Hypothesis U_non_empty : Inhabited _ U.
 Hypothesis U_den : countable U.
 Hypothesis U_inc_A : Included U A.

 (* apply Virgile's technique ? *)

 Remark R1_aux : countable (image U f).
 Proof.
 apply countable_bij_fun with Ord U f.
 - case (Ordering_bijection f_ord); intros H H0 H1;  split.
  + intros u u_In_U;  exists u; auto.
  +  intros u u_In_img; case u_In_img;  intros x Hx.
      exists x; assumption.
  +  intros u1 u2 u1_In_U u2_In_U Heq; apply H1;
       try apply U_inc_A; assumption.
 -  assumption.
 Qed.

 Definition R1 := let foo := U_den in R1_aux.
 Opaque R1.

 Remark R2 : In B (|_| (image U f)).
 Proof.
   apply  B_closed.
   -  red;red;  destruct 1.
      case f_ord. intros H0 H1 H2 H3.
      case H;intros; subst x; destruct f_ord.
      decompose [and] H3.
      apply OF_total0. apply U_inc_A;auto.
   -  case U_non_empty;intros x H;  exists (f x);auto.
      exists x;auto.
   - apply R1_aux.
 Qed.

Remark R3: exists alpha, In A alpha /\ f alpha = |_|  (image U f).
Proof.
 case f_ord; intros H H0 H1 H2.
  case (H1 (|_|image U f)).
  -  apply R2.
  -  intros x; exists x;auto.
Qed.

Let alpha_ : Ord :=
  (epsilon inh_Ord (fun alpha =>  In A alpha /\ f alpha = sup(image U f))).

Lemma alpha_A :   In A alpha_.
Proof.
  unfold alpha_;  apply epsilon_ind.
  - apply R3.
  -  tauto.
Qed.

Lemma alpha_sup : f alpha_ = |_| (image U f).
Proof.
 pattern alpha_; epsilon_elim.
 - apply R3.
 - tauto.
Qed.

Remark R5 : forall khi, In U khi -> f khi <= f alpha_.
Proof.
 intros; rewrite alpha_sup;  apply sup_upper_bound.
 -  apply R1.
 -  exists khi; tauto.
Qed.

Remark R6 : forall khi, In U khi ->  khi <=  alpha_ .
Proof with eauto with schutte.
 intros khi H; case (R5 H).
 -  left.
   +  case (Ordering_bijection f_ord).
      intros H1 H2 H3; apply H3.
    *  apply U_inc_A;auto.
    * apply alpha_A.
    *  case H0;auto.
 -  right; case f_ord; intros _ H1 H2 H3.
    tricho khi alpha_ H7; auto.
   +    subst khi; case (@lt_irrefl _ H0).
   + case (@lt_irrefl (f alpha_));auto.
     apply lt_trans with (f khi); auto.
     * apply H3; auto.
      apply alpha_A;  auto.
Qed.

#[local] Hint Resolve  alpha_A : schutte.

Remark R7 : |_| U <= alpha_ .
Proof.
 apply sup_least_upper_bound; trivial.
 - intros;now apply R6.
Qed.

Remark R4 : forall khi, In U khi -> khi <= sup U.
Proof.
 intros;  apply sup_upper_bound;auto.
Qed.

 (* Schutte's remark "hence A is closed " is out of this section *)

Lemma A_closed : In A (sup U).
Proof.
  assert (H: segment A) by (eapply SA2;  eauto).
  case R7.
  - intros  H3; rewrite H3; apply alpha_A.
  - intros;red.  eapply H with alpha_ ;auto with schutte.
Qed.

Remark R4' : forall khi, In U khi -> f khi <= f (sup U).
Proof.
 intros khi H ; case f_ord;intros H0 H1 H2 H3 .
 case (R4 H).
 - intro;  subst khi;left;auto with schutte.
 -  right;auto.
    apply H3;auto with schutte.
    apply A_closed;auto.
Qed.

Remark R4'' : |_| (image U f) <= f (sup U).
Proof.
 apply sup_least_upper_bound.
 -  apply R1.
 - intros y H; destruct H; destruct H;subst y;
     apply ordering_function_mono_weak with A B; auto.
   +  apply  A_closed.
   +  apply sup_upper_bound;auto.
Qed.

Remark R42 : f (sup U) <= |_| (image U f).
Proof.
 apply le_trans with (f alpha_).
 -  case f_ord;intros H H0 H1 H2.
    case R7.
    +  intro H5; rewrite H5;auto with schutte.
    +  right;auto.
       apply H2;auto with schutte.
       apply A_closed;auto with schutte.
 -  unfold alpha_; apply epsilon_ind.
    + apply R3.
    + destruct 1; left;   auto.
Qed.

Lemma f_sup_commutes : f (|_| U) = |_| (image U f).
Proof.
 apply le_antisym.
 -  apply R42.
 -  apply R4''.
Qed.

End U_fixed.

 (* end hide *)

 Lemma Th_13_5_2 : continuous f A B.
 Proof.
   split.
   - red.
     case f_ord;tauto.
   - split. red. intros.
     eapply A_closed;auto.
     intros;symmetry;apply f_sup_commutes;auto.
 Qed.

End verso.

End Th13_5.

Theorem TH_13_6 (B : Ensemble Ord)(f : Ord -> Ord) :
  normal f B ->   Closed B /\ Unbounded B.
Proof with eauto with schutte.
 destruct 1.
 split.
 -  eapply Th_13_5_1;eauto.
 -  intros x;  generalize (Ordering_bijection H).
    destruct 1 as [H3 H4 H5].
    exists (f (succ x));  split.
    +  apply H3 ...
    +  apply le_lt_trans with (f x).
       * eapply ordering_le ...
       *  eapply ordering_function_mono ...
Qed.

Lemma ordering_unbounded_unbounded :
  forall A B f,  ordering_function f A B ->
                 (Unbounded B <-> Unbounded A).
Proof with auto with schutte.
  intros A B f  H0;split.
  - intro; apply not_countable_unbounded.
    intro H2;  assert (H3 : countable B).
    {  apply countable_bij_fun with Ord A  f ...
       apply Ordering_bijection;auto.
    }
    case (countable_not_Unbounded  H3);auto.
  - intro H1;  apply not_countable_unbounded ...
    intro H2;  assert (H3 : countable A).
    { apply countable_bij_funR with Ord   B  f;auto.
      apply Ordering_bijection;auto.
    }
 case (countable_not_Unbounded (X:= A));auto.
Qed.

Theorem TH_13_6R (A B : Ensemble Ord) (f : Ord -> Ord) :
  ordering_function f A B ->
  Closed B ->    Unbounded B ->   normal f B.
Proof with auto with schutte.
  intros  H0 H1 H2; assert (A = ordinal).
    {   apply segment_unbounded.
        - eapply SA1;  apply H0.
        - destruct (ordering_unbounded_unbounded H0); auto.
    }
    subst A; split; [trivial | now apply Th_13_5_2].
Qed.

(** If [f] is the ordering function of [B], then [f 0] is the least element of
   [B] *)

Lemma ordering_function_least_least :
 forall B f  , ordering_function f ordinal B ->
     least_member  lt B (f zero).
Proof with auto with schutte.
 intros b f H; case H; intros H0 H2 H3 H4 .
 split.
 -  apply H2 ...
 -  intros x  H55.
   case (H3 _ H55); intros x0 (Hx0,H'x0); subst x.
   generalize (ordering_function_mono_weak H (a:=zero) (b:=x0)).
   intro H6;  apply H6 ...
Qed.

Lemma segment_lt_closed : forall A a b, segment A ->
                                          In A b ->
                                          a < b ->
                                          In A a.
Proof.
 intros A a b H H0 H1; apply H with b;  auto.
Qed.

Lemma th_In A  alpha : In (the_ordering_segment A) alpha ->
                             In A (ord A alpha).
Proof.
  unfold ord;  intro H;   red;  unfold some;  apply epsilon_ind.
  - destruct   (ordering_function_ex A) as [X [[f Hf] H0]];  exists f.
   rewrite <-  (H0 (the_ordering_segment A) );  auto.
   exists (ord A); apply ord_ok.
  -   intros beta H0;  eapply ordering_function_In; [ eexact H0 | trivial].
Qed.

(* begin snippet Th1352 *)

(* Theorem 13.5.2 by Schutte *)

About Th_13_5_2.

(* end snippet Th1352 *)

Arguments ord  : clear implicits.
Arguments the_ordering_segment : clear implicits.


Theorem rev_app_distr: forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros.
  induction l1 as [| h1 t1 IH1].
  - simpl. rewrite -> app_nil_r. reflexivity.
  - simpl. rewrite -> IH1. rewrite <- app_assoc. reflexivity.
Qed.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  intros.
  induction l as [| h t IH].
  - simpl. reflexivity.
  - simpl. rewrite -> rev_app_distr.
    simpl. rewrite -> IH.
    reflexivity.
Qed.


Require Export Bool.
Require Export ZArith.

Open Scope Z_scope.

Inductive Z_inf_branch_tree : Set :=
  Z_inf_leaf : Z_inf_branch_tree
| Z_inf_node : Z->(nat->Z_inf_branch_tree)->Z_inf_branch_tree.

Fixpoint any_true (n:nat)(f:nat->bool){struct n}:bool :=
 match n with
   0%nat => f 0%nat
 | S p => orb (f (S p)) (any_true p f)
 end.

Fixpoint izero_present (n:nat)(t:Z_inf_branch_tree) {struct t} :bool :=
 match t with
 | Z_inf_leaf => false
 | Z_inf_node v f =>
   match v with
     0 => true
   | _ => any_true n (fun p => izero_present n (f p))
   end
 end.


Require Export Pullback Limits.
Require Import Common.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Section subobject_classifier.
  (** Quoting Wikipedia:

    For the general definition, we start with a category [C] that has
    a terminal object, which we denote by [1]. The object [Ω] of [C]
    is a subobject classifier for [C] if there exists a morphism [m :
    1 → Ω] with the following property: for each monomorphism [j : U →
    X] there is a unique morphism [χj : X → Ω] such that the following
    commutative diagram:

    [[
        U ----> 1
        |       |
      j |       | m
        ↓       ↓
        X ----> Ω
           χj
    ]]

    is a pullback diagram — that is, [U] is the limit of the diagram:

    [[
                1
                |
                | m
                ↓
        X ----> Ω
           χj
    ]]

    The morphism [χj] is then called the classifying morphism for the
    subobject represented by [j].
   *)

  (** Quoting nCatLab:

   Definition 1. In a category [C] with finite limits, a subobject
   classifier is a monomorphism [true : * → Ω] out of the terminal
   object, such that for every monomorphism [U → X] in [C] there is a unique
   morphism [χU : X → Ω] such that there is a pullback diagram

   [[
        U ----> *
        |       |
        |       | true
        ↓       ↓
        X ----> Ω
           χU
   ]]

   See for instance (MacLane-Moerdijk, p. 22).
   *)

  Context `(C : @SpecializedCategory objC).

  Local Reserved Notation "'Ω'".

  Record SubobjectClassifier :=
    {
      SubobjectClassifierOne : TerminalObject C where "1" := (TerminalObject_Object SubobjectClassifierOne);
      ObjectOfTruthValues : C where "'Ω'" := ObjectOfTruthValues;
      TrueValue : C.(Morphism) 1 Ω;
      TrueIsMonomorphism : IsMonomorphism TrueValue;
      SubobjectClassifyingMap : forall U X (j : C.(Morphism) U X),
                                  IsMonomorphism j
                                  -> { χj : Morphism C X Ω &
                                                     { H : Compose χj j =
                                                           Compose TrueValue (TerminalObject_Morphism SubobjectClassifierOne U)
                                                                   & IsPullbackGivenMorphisms
                                                                   X 1 Ω
                                                                   χj TrueValue
                                                                   U j
                                                                   (TerminalObject_Morphism SubobjectClassifierOne U)
                                                                   H } }
    }.
End subobject_classifier.