(** * The Wainer hierarchy of rapidly growing functions (variant)

    After Wainer, Ketonen, Solovay, etc .
 *)

From hydras  Require Import  Iterates  Simple_LexProd Exp2.
From hydras Require Import  E0 Canon Paths primRec Hprime.
Import RelationClasses Relations.

From Coq Require Import ArithRing Lia.
Require Import Compat815.

From Equations Require Import Equations.

From hydras Require Import primRec.

(** For masking primRec's iterate *)

Import Prelude.Iterates.

(** ** Definition, using [coq-equations]

The following definition is not accepted by the [equations] plug-in.

 *)

#[global] Instance Olt : WellFounded E0lt := E0lt_wf.

(* begin snippet FailDemo *)
(*  Works with Dev
Fail Equations F_ (alpha: E0) (i:nat) :  nat  by wf  alpha E0lt :=
  F_ alpha  i with E0_eq_dec alpha E0zero :=
    { | left _zero =>  i ;
      | right _nonzero
          with Utils.dec (E0limit alpha) :=
          { | left _limit =>  F_ (Canon alpha i)  i ;
          | right _notlimit =>  iterate (F_ (E0pred alpha)) (S i) i}}.
*)
(* end snippet FailDemo *)

(**

    Indeed, we define the $n$-th iterate of [F_ alpha] by well-founded
    recursion  on the pair (alpha,n), then [F_ alpha] as the first iterate
    of the defined function.
 *)

(* begin snippet goodDefa:: no-out *)
Definition call_lt (c c' : E0 * nat) :=
  lexico E0lt (Peano.lt) c c'.

Lemma call_lt_wf : well_founded call_lt.
  unfold call_lt; apply Inverse_Image.wf_inverse_image,  wf_lexico.
  -  apply E0lt_wf.
  -  unfold Peano.lt; apply Nat.lt_wf_0.
Qed.

#[ global ] Instance WF : WellFounded call_lt := call_lt_wf.

(*  F_star (alpha,i) is intended to be the i-th iterate of F_ alpha *)

Equations  F_star (c: E0 * nat) (i:nat) :  nat by wf  c call_lt :=
  F_star (alpha, 0) i := i;
  F_star (alpha, 1) i
    with E0_eq_dec alpha E0zero :=
    { | left _zero => S i ;
      | right _nonzero
          with Utils.dec (E0limit alpha) :=
          { | left _limit => F_star (Canon alpha i,1) i ;
            | right _notlimit =>
              F_star (E0pred alpha, S i)  i}};
  F_star (alpha,(S (S n))) i :=
    F_star (alpha, 1) (F_star (alpha, (S n)) i).
(* end snippet goodDefa *)

Next Obligation.
  left; cbn ; auto with E0.
Defined.

Next Obligation.
  left; cbn; auto with E0.
Defined.

Next Obligation.
  right; cbn; auto with arith.
Defined.

Next Obligation.
  right; cbn; auto with arith.
Defined.

(* begin snippet goodDefb *)
Definition F_ alpha i := F_star (alpha, 1) i.
(* end snippet goodDefb *)

(** ** We get the "usual" equations for [F_]  *)

(** *** Relations between [F_star] and [F_] *)

Lemma F_star_zero_eqn : forall alpha i, F_star (alpha, 0) i = i.
Proof.
  intros; now rewrite F_star_equation_1.
Qed.

Lemma Fstar_S : forall alpha n i, F_star (alpha, S (S n)) i =
                                  F_ alpha  (F_star (alpha, S n) i).
Proof.
  unfold F_; intros; now rewrite F_star_equation_3.
Qed.

Lemma F_eq2 : forall alpha i,
    E0is_succ alpha ->
    F_ alpha i = F_star (E0pred alpha, S i) i.
Proof.
  unfold F_; intros; rewrite F_star_equation_2.
  destruct (E0_eq_dec alpha E0zero).
  - subst alpha; discriminate H.
  - cbn; destruct (Utils.dec (E0limit alpha)) .
    + assert (true=false) by
          ( now  destruct (Succ_not_T1limit _ H)).
      discriminate.
    + now cbn.
Qed.

Lemma F_star_Succ:  forall alpha n i,
    F_star (alpha, S n) i =
    F_ alpha (F_star (alpha, n) i).
Proof.
  destruct n.
  - intros; now rewrite F_star_zero_eqn.
  - intros i; unfold F_; now rewrite Fstar_S.
Qed.

Lemma F_star_iterate : forall alpha n i,
    F_star (alpha, n) i =  iterate (F_ alpha) n i.
Proof.
  induction n; intro i; simpl.
  - now rewrite F_star_zero_eqn.
  - specialize (IHn i); rewrite F_star_Succ in *;  now rewrite <- IHn.
Qed.

(** *** Usual equations for [F_] *)

(* begin snippet FEquations *)

Lemma F_zero_eqn : forall i, F_ E0zero i = S i.  (* .no-out *)
(*| .. coq:: none |*)
Proof.
  intro i. unfold F_; rewrite F_star_equation_2.
  destruct (E0_eq_dec E0zero E0zero).
  - now cbn.
  - now destruct n.
Qed.
(*||*)

Lemma F_lim_eqn : forall alpha i,
    E0limit alpha ->
    F_ alpha i = F_ (Canon alpha i) i. (* .no-out *)
(*| .. coq:: none |*)
Proof.
  unfold F_; intros. rewrite F_star_equation_2.
  destruct (E0_eq_dec alpha E0zero).
  - now  destruct (Limit_not_Zero  H).
  - cbn; destruct (Utils.dec (E0limit alpha)) .
    + cbn; auto.
    + red in H. rewrite e in H; discriminate.
Qed.
(*||*)

Lemma F_succ_eqn : forall alpha i,
    F_ (E0succ alpha) i = iterate (F_ alpha) (S i) i. (* .no-out *)
(*| .. coq:: none |*)
Proof with auto with E0.
  intros;rewrite F_eq2,  F_star_iterate ...
  -  now rewrite E0pred_of_Succ.
Qed.
(*||*)
(* end snippet FEquations *)

(** ** First steps of the hierarchy *)

(** performs an induction only on the occ1-th and occ2_th occurrences of n *)

Tactic Notation "undiag2" constr(n) integer(occ1) integer(occ2) :=
  let n' := fresh "n" in
  generalize n at occ1 occ2; intro n'; induction n'.

(* begin snippet FirstValues *)

Lemma LF1 : forall i,  F_ 1 i = S (2 * i). (* .no-out *)
(*| .. coq:: none |*)
Proof.
  intro i; unfold E0fin; rewrite FinS_Succ_eq, F_succ_eqn.
  rewrite iterate_rw, F_zero_eqn.
  simpl; rewrite iterate_ext with (g := S).
  - undiag2 i 1 3.
    + simpl; abstract lia.
    + simpl; auto.
  - intro; now rewrite F_zero_eqn.
Qed.
(*||*)

Lemma LF2 : forall i, exp2 i * i < F_ 2 i. (* .no-out *)
(*| .. coq:: none |*)
Proof.
  intro i; ochange (E0fin 2) (E0succ 1); rewrite F_succ_eqn.
  undiag2 i 1 3.
  -  intros. cbn;  intros; cbn.  repeat rewrite LF1. abstract lia.
  - intros; simpl exp2; ring_simplify. simpl (2+n)%nat.
    rewrite iterate_S_eqn, LF1; abstract lia.
Qed.
(*||*)
(* end snippet FirstValues *)

Corollary LF2' : forall i,  1 <= i -> exp2 i < F_ 2 i.
Proof.
  intros;  apply Nat.le_lt_trans with (exp2 i * i).
  - destruct (Compat815.mult_O_le (exp2 i) i).
    + lia.
    + now rewrite Nat.mul_comm.
  -  apply LF2.
Qed.

Lemma F_alpha_0_eq : forall alpha: E0, F_ alpha 0 = 1.
  intro alpha. pattern alpha; apply well_founded_induction with E0lt.
  - apply E0lt_wf.
  - clear alpha; intros alpha Halpha.
    destruct (Zero_Limit_Succ_dec alpha).
    destruct s.
    + subst alpha; now rewrite F_zero_eqn.
    +  rewrite F_lim_eqn;auto; unfold Canon. rewrite Halpha. auto.
       Search (Canon ?a _ o< ?a).
       apply  (@Canon_lt 0 alpha).
       intro Heq; subst. discriminate.
    +  destruct s; subst; rewrite F_succ_eqn; simpl; apply Halpha, Lt_Succ.
Qed.

(** Properties of [F_ alpha]  *)
(* begin hide *)

Section Properties.
  Record P (alpha:E0) : Prop :=
    mkP {
        PA : strict_mono (F_ alpha);
        PB : forall n, n < F_ alpha n;
        PC : F_ alpha <<= F_ (E0succ alpha);
        PD : dominates_from 1 (F_ (E0succ alpha)) (F_ alpha);
        PE : forall beta n, Canon_plus n alpha beta ->
                            F_ beta n <= F_ alpha n}.

  Section The_induction.

    (** Base step : (sequential) proof of (P 0) *)

    Lemma mono_F_Zero : strict_mono (F_ E0zero).
    Proof.
      intros n p H; repeat rewrite F_zero_eqn; auto with arith.
    Qed.

    Lemma Lt_n_F_Zero_n : forall n:nat, n < F_ E0zero n.
    Proof. intros n ; rewrite F_zero_eqn; auto with arith. Qed.

    Lemma F_One_Zero_dom : dominates_from 1 (F_ 1) (F_ E0zero).
    Proof.
      red;intros.
      rewrite F_zero_eqn. rewrite LF1; abstract lia.
    Qed.

    #[local] Hint Resolve F_One_Zero_dom mono_F_Zero Lt_n_F_Zero_n : T1.

    Lemma F_One_Zero_ge :  F_ E0zero <<= F_ 1.
    Proof.
      intro n; destruct n;
        rewrite F_zero_eqn, LF1; abstract lia.
    Qed.

    #[local] Hint Resolve  F_One_Zero_ge : T1.

    Lemma PZero : P E0zero.
    Proof.
      split; auto with T1; ord_eq  (E0succ E0zero) (E0fin 1).
      all: try (rewrite H;auto with T1).
      unfold Canon_plus; intros beta n H0;
        unfold E0zero in H0; simpl in H0.
      destruct n.
      - inversion H0.
      - destruct (const_pathS_zero  H0).
    Qed.

    Variable alpha : E0.
    Hypothesis Halpha : forall beta, E0lt beta alpha -> P beta.

    Ltac hdecomp := destruct Halpha.
    Section alpha_Succ.
      Variable beta: E0.
      Hypothesis alpha_def : alpha = E0succ beta.

      Remark R1 : strict_mono (F_ alpha).
      Proof.
        destruct (Halpha beta).
        subst alpha; apply Lt_Succ.
        red; intros.
        subst alpha.
        repeat rewrite F_succ_eqn.
        induction H.

        rewrite (iterate_S_eqn (F_ beta) (S n)).
        apply Nat.lt_le_trans with (F_ beta
                                      (iterate (F_ beta) (S n) n)).
        auto.
        apply mono_weak; auto.

        apply Nat.lt_le_incl.
        apply iterate_mono;auto.
        destruct (Halpha beta).
        apply Lt_Succ.

        transitivity (iterate (F_ beta) (S m) m);auto.
        rewrite (iterate_S_eqn (F_ beta) (S m)).
        apply Nat.lt_le_trans with (F_ beta (iterate (F_ beta) (S m) m)).
        auto.
        apply mono_weak; auto.
        apply Nat.lt_le_incl.
        apply iterate_mono;auto.
      Qed.

      Remark RB : forall n, n < F_ alpha n.
      Proof.
        subst  alpha.
        intro n.
        rewrite F_succ_eqn.
        destruct (Halpha beta).
        apply Lt_Succ.
        change n with (iterate (F_ beta) 0 n) at 1.
        apply iterate_lt;auto with arith.
      Qed.

      Remark RD : dominates_from 1 (F_ (E0succ alpha)) (F_ alpha).
        generalize RB; intro RB'.
        rewrite alpha_def .

        destruct (Halpha beta).
        rewrite alpha_def ;apply Lt_Succ.
        intros n Hn.
        rewrite (F_succ_eqn (E0succ beta)).
        apply Nat.lt_le_trans with (F_ (E0succ beta) (F_ (E0succ beta) n)).

        rewrite <- alpha_def.
        apply RB'.
        rewrite iterate_S_eqn2.
        change (F_ (E0succ beta) (F_ (E0succ beta) n)) with
            (iterate (F_ (E0succ beta)) 1 (F_ (E0succ beta) n)).
        apply iterate_le.

        generalize R1; intro R1'.
        rewrite <- alpha_def. auto.
        assumption.
      Qed.

      Remark RE : forall beta n, Canon_plus n alpha beta ->
                                 F_ beta n <= F_ alpha n.
      Proof.
        destruct n.
        repeat rewrite F_alpha_0_eq.
        reflexivity.
        intros.
        transitivity (F_ beta (S n)).
        rewrite alpha_def in H.
        - destruct (Canon_plus_first_step  H).
          subst beta0; reflexivity.
          destruct (Halpha beta).
          rewrite alpha_def.
          apply Lt_Succ.
          apply PE0.
          auto.
        - destruct (Halpha beta).
          rewrite alpha_def.
          apply Lt_Succ.
          rewrite alpha_def.
          apply Nat.lt_le_incl.
          apply PD0.
          auto with arith.
      Qed.

      Remark RC : F_ alpha <<= F_ (E0succ alpha).
      Proof.
        intro n; destruct n.
        repeat rewrite F_alpha_0_eq. auto with arith.
        apply Nat.lt_le_incl.
        apply RD. auto with arith.
      Qed.

      Remark RP : P alpha.
        split.
        apply R1.
        apply RB.
        apply RC.
        apply RD.
        apply RE.
      Qed.

    End alpha_Succ.

    Section alpha_limit.
      Hypothesis Hlim : E0limit alpha.

      Remark RBlim : forall n, n < F_ alpha n.
        intro n.
        rewrite F_lim_eqn.
        destruct (Halpha (Canon alpha n)).
        apply Canon_lt.
        now apply Limit_not_Zero.
        auto.
        auto.
      Qed.

      Remark RAlim : strict_mono (F_ alpha).
      Proof.
        red;intros m n H; destruct m.
        - rewrite (F_lim_eqn alpha n);auto.
          rewrite F_alpha_0_eq. (* bad name *)
          destruct n. inversion H.
          unfold Canon.
          apply Nat.le_lt_trans with (S n).
          auto with arith.
          destruct (Halpha (Canon alpha (S n))).
          apply CanonS_lt.
          now apply Limit_not_Zero.
          now apply PB0.

        - destruct n. inversion H.
          rewrite (F_lim_eqn alpha (S n));auto.
          rewrite (F_lim_eqn alpha (S m));auto.
          assert (Canon_plus 1 (Canon alpha (S n)) (Canon alpha (S m))).
          apply KS_thm_2_4_E0; auto.
          auto with arith.
          assert (Canon_plus (S n) (Canon alpha (S n)) (Canon alpha (S m))).
          eapply Cor12_E0 with 0; auto with arith.
          apply canonS_limit_mono; auto with T1.
          auto with arith.
          auto with E0.
          auto with arith.
          apply Nat.le_lt_trans with (F_ (Canon alpha (S n)) (S m) ).
          destruct (Halpha (Canon alpha (S n))).
          apply Canon_lt.
          now apply Limit_not_Zero.
          apply PE0. auto. auto.
          eapply Cor12_E0 with 0; auto with arith.
          apply canonS_limit_mono; auto with T1.
          auto with arith.
          destruct (Halpha (Canon alpha (S n))).
          apply Canon_lt.
          now apply Limit_not_Zero.
          auto with E0.
          auto with arith.
          apply PA.
          apply Halpha.
          apply CanonS_lt.
          auto with E0.
          auto with arith.
      Qed.

      Remark RClim : F_ alpha <<= F_ (E0succ alpha).
      Proof.
        intro n; destruct n.
        - repeat rewrite F_alpha_0_eq; auto with arith.
        -  apply Nat.lt_le_incl;  rewrite F_succ_eqn.
           change (F_ alpha (S n)) with (iterate (F_ alpha) 1 (S n)).
           apply iterate_lt.
           +  apply RAlim.
           +  red;intros; apply RBlim.
           +  auto with arith.
      Qed.

      Remark RDlim : dominates_from 1 (F_ (E0succ alpha)) (F_ alpha).
      Proof.
        red;intros; rewrite F_succ_eqn.
        change (F_ alpha p) with (iterate (F_ alpha) 1 p);
          apply iterate_lt.
        -   apply RAlim.
        -   red;intros; apply RBlim.
        -   auto with arith.
      Qed.

      Remark RElim : forall beta n, Canon_plus n alpha beta ->
                                    F_ beta n <= F_ alpha n.
      Proof.
        destruct n.
        - now  repeat rewrite F_alpha_0_eq.
        - intros H;  destruct (Canon_plus_first_step_lim  Hlim H).
          +  rewrite (F_lim_eqn alpha _).
             * now rewrite H0.
             * auto.
          +  rewrite (F_lim_eqn alpha _);auto.
             destruct (Halpha (Canon alpha (S n))); auto.
             apply CanonS_lt;  now apply Limit_not_Zero.
      Qed.

    End alpha_limit.

    Lemma LL : P alpha.
    Proof.
      destruct (Zero_Limit_Succ_dec alpha).
      destruct s.
      - subst; apply PZero.
      - split.
        apply RAlim; auto.
        apply RBlim; auto.
        apply RClim; auto.
        apply RDlim; auto.
        apply RElim; auto.
      - destruct s; split.
        eapply R1;eauto.
        eapply RB;eauto.
        eapply RC;eauto.
        eapply RD;eauto.
        eapply RE;eauto.
    Qed.

  End The_induction.

  Theorem TH_packed : forall alpha, P alpha.
  Proof.
    intro alpha; apply well_founded_induction with E0lt.
    - exact E0lt_wf.
    - apply LL.
  Qed.

End Properties.

(* end hide *)

(* begin snippet FalphaThms *)

Theorem F_alpha_mono alpha : strict_mono (F_ alpha). (* .no-out *)
(*| .. coq:: none |*)
Proof. now  destruct  (TH_packed alpha). Qed.
(*||*)

Theorem F_alpha_gt alpha : forall n, n < F_ alpha n. (* .no-out *)
(*| .. coq:: none |*)
Proof. now  destruct  (TH_packed alpha). Qed.
(*||*)

Corollary F_alpha_positive alpha :  forall n, 0 < F_ alpha n. (* .no-out *)
(*| .. coq:: none |*)
Proof.
  intro n; apply Nat.le_lt_trans with n; auto with arith.
  apply F_alpha_gt.
Qed.

Theorem F_alpha_Succ_le alpha : F_ alpha <<= F_ (E0succ alpha).
(*| .. coq:: none |*)
Proof. now  destruct  (TH_packed alpha). Qed.
(*||*)

Theorem F_alpha_dom alpha :
  dominates_from 1 (F_ (E0succ alpha)) (F_ alpha). (* .no-out *)
(*| .. coq:: none |*)
Proof. now  destruct  (TH_packed alpha). Qed.
(*||*)

Theorem F_restricted_mono_l alpha :
  forall beta n, Canon_plus n alpha beta ->
                 F_ beta n <= F_ alpha n. (* .no-out *)
(*| .. coq:: none |*)
Proof. now  destruct (TH_packed alpha). Qed.
(*||*)

(* end snippet FalphaThms *)
 #[deprecated(note="use F_alpha_gt")]
  Notation F_alpha_ge_S := StrictOrder_Transitive (only parsing).

Lemma LF2_0 : dominates_from 0 (F_ 2) (fun i => exp2 i * i).
Proof.
  red. intros ; apply LF2 ; auto.
Qed.

Lemma LF3_2  : dominates_from 2  (F_ 3) (fun  n => iterate exp2 (S n) n).
Proof.
  intros p H; assert (H0:= LF2_0).
  ochange (E0fin 3) (E0succ 2); rewrite F_succ_eqn.
  eapply iterate_dom_prop; eauto with arith.
  - apply exp2_ge_S.
  - apply exp2_mono.
  - apply F_alpha_mono.
  - red; intros; transitivity (exp2 p0 * p0)%nat; auto.
    {  rewrite <- Nat.mul_1_r at 1; apply Nat.mul_lt_mono_pos_l; auto.
       apply exp2_positive.
    }
    apply LF2_0; abstract lia.
Qed.

(** From Ketonen and Solovay, page 284, op. cit. *)

(* begin snippet FDomContext *)

Section F_monotony_l.

  Variables alpha beta : E0.
  Hypothesis H'_beta_alpha : E0lt beta alpha.

  (* end snippet FDomContext *)

  (* begin hide *)
  Section case_eq.
    Hypothesis Heq : alpha = E0succ beta.

    Fact F2 : forall i, (1 <= i ->  F_ beta i < F_ alpha i)%nat.
    Proof.
      subst alpha; intros i H; apply (F_alpha_dom beta i H).
    Qed.

  End case_eq.

  Section case_lt.
    Variable n: nat.
    Hypothesis Hlt :  E0lt (E0succ beta) alpha.

    Hypothesis Hd : Canon_plus (S n) alpha beta.

    Fact F5 : Canon_plus (S (S n)) alpha (E0succ beta).
    Proof.
      destruct alpha, beta; cbn;  now apply L2_6_2.
    Qed.

    Fact F6 : forall i, (S n < i)%nat ->  Canon_plus i alpha (E0succ beta).
    Proof.
      destruct alpha, beta; unfold lt, Canon_plus in *; simpl in *.
      intros i H; destruct i.
      - inversion H.
      - destruct i.
        + inversion H. lia.
        + apply Cor12_3 with (S (S n)); auto.
          apply L2_6_2; auto.
    Qed.

    Fact F7 : forall i, (S n < i -> F_ (E0succ beta) i <= F_ alpha i)%nat.
    Proof.
      intros; apply  F_restricted_mono_l; apply F6; auto.
    Qed.

    Fact F8 : forall i, (S n < i -> F_ beta i < F_ (E0succ beta) i)%nat.
    Proof.
      intros i H; apply  (F_alpha_dom beta i); abstract lia.
    Qed.

    Fact F9 : forall i, (S n < i -> F_ beta i < F_ alpha i)%nat.
    Proof.
      intros ? ?; eapply Nat.lt_le_trans.
      - eapply F8;eauto.
      - apply F7;auto.
    Qed.

  End case_lt.

  (* end hide *)

  Lemma F_mono_l_0 : forall n,
      Canon_plus (S n) alpha beta ->
      forall i, (S n < i -> F_ beta i < F_ alpha i)%nat.
  Proof.
    assert (H: E0le (E0succ beta) alpha) by (now apply Lt_Succ_Le).
    assert (H0: {alpha = E0succ beta} + {E0lt (E0succ  beta) alpha}).
    {
      rewrite <- lt_Succ_inv in H.
      apply Lt_Succ_Le in H; destruct (E0.le_lt_eq_dec  H); auto.
    }
    destruct H0.
    - intros; apply F2; [trivial | lia].
    - intros; eapply F9; eauto.
  Qed.

  (* begin snippet FDom *)

  Lemma F_mono_l: dominates (F_ alpha) (F_ beta). (* .no-out *)
  (*| .. coq:: none |*)
  Proof.
    destruct (Lemma2_6_1_E0  H'_beta_alpha) as [i Hi].
    exists (S (S i)); intros p Hp; apply F_mono_l_0 with i;  auto.
  Qed.
  (*||*)

End  F_monotony_l.
(* end snippet FDom *)

(** * Comparison with the Hardy hierarchy

      [(F_ alpha (S n) <= H'_ (Phi0 alpha) (S n))]
*)

Section H'_F.

  Let P (alpha: E0) :=
        forall n,  (F_ alpha (S n) <= H'_ (E0phi0 alpha) (S n))%nat.

 Variable alpha: E0.

 Hypothesis IHalpha : forall  beta, beta o< alpha -> P beta.

 Lemma HF0 : P E0zero.
 Proof.
   intro n; rewrite F_zero_eqn.
   replace (E0phi0 E0zero) with (E0fin 1).
   - now rewrite H'_Fin.
   - now apply E0_eq_intro.
 Qed.

 Lemma HFsucc : E0is_succ alpha -> P alpha.
 Proof.
   intro H; destruct (Succb_Succ _ H) as [beta Hbeta]; subst.
   intro n; rewrite H'_Phi0_succ.
   unfold H'_succ_fun; rewrite F_succ_eqn.
   specialize (IHalpha beta (Lt_Succ beta));  unfold P in IHalpha.
   - apply iterate_mono_1 with 1.
     + apply F_alpha_mono.
     + intro k; apply F_alpha_gt.
     + intros; destruct n0.
       * lia.
       * apply IHalpha.
     +lia.
 Qed.

  (** The following proof is far from being trivial.
      It uses some lemmas from the Ketonen-Solovay machinery *)

  Lemma HFLim : E0limit alpha -> P alpha.
  Proof.
    intros Halpha n; rewrite H'_eq3.
    - rewrite CanonS_phi0_lim; [| trivial].
      rewrite F_lim_eqn; auto.
      + transitivity (H'_ (E0phi0 (Canon alpha (S n))) (S n)).
        *  apply IHalpha.
           apply CanonS_lt.
           now apply Limit_not_Zero.
        * (** Not trivial, since [H'_ ] is not monotonous ! *)

          apply H'_restricted_mono_l.

          red; cbn; apply KS_thm_2_4_lemma5.
          -- apply Cor12_1 with 0.
           ++ apply nf_canon, cnf_ok.
           ++ apply canonS_limit_mono.
              ** apply cnf_ok.
              ** destruct alpha; cbn; assumption.
              ** auto with arith.
           ++ auto with arith.
           ++ apply KS_thm_2_4.
              ** apply cnf_ok.
              ** destruct alpha; auto.
              ** auto with arith.
          --  apply nf_canon, cnf_ok.
          --  apply T1limit_canonS_not_zero.
              ++ apply cnf_ok.
              ++ now destruct alpha.
    - apply T1limit_phi0.
      apply Limit_not_Zero; auto.
Qed.

End H'_F.

(* begin snippet HprimeF:: no-out  *)

Lemma H'_F alpha : forall n,  F_ alpha (S n) <= H'_ (E0phi0 alpha) (S n).
Proof.
  pattern alpha; apply well_founded_induction with E0lt.
(* end snippet HprimeF *)
  - apply E0lt_wf.
  -  clear alpha; intros alpha IHalpha.
     destruct (Zero_Limit_Succ_dec alpha) as [[Hzero | Hlim] | Hsucc].
    + subst; apply HF0.
    + apply HFLim; auto.
    + destruct Hsucc; subst; apply HFsucc.
      intros; apply IHalpha; auto.
      apply Succ_Succb.
  Qed.

(** * A variant (Lob-Wainer hierarchy)
***************************************)

Equations  f_star (c: E0 * nat) (i:nat) :  nat by wf c call_lt :=
  f_star (alpha, 0) i := i;
  f_star (alpha, 1) i
    with E0_eq_dec alpha E0zero :=
    { | left _zero => S i ;
      | right _nonzero
          with Utils.dec (E0limit alpha) :=
          { | left _limit => f_star (Canon alpha i,1) i ;
            | right _successor =>
              f_star (E0pred alpha, i)  i}};
  f_star (alpha,(S (S n))) i :=
    f_star (alpha, 1) (f_star (alpha, (S n)) i).

Next Obligation.
  left; cbn ; auto with E0.
Defined.

Next Obligation.
  left; cbn; auto with E0.
Defined.

Next Obligation.
  right; cbn; auto with arith.
Defined.

Next Obligation.
  right; cbn; auto with arith.
Defined.

(**  Finally, [f_ alpha] is defined as its first iterate  ! *)

Definition f_ alpha i := f_star (alpha, 1) i.

(** ** We get the "usual" equations for [F_]  *)

(** *** Relations between [F_star] and [F_] *)

Lemma f_star_zero_eqn : forall alpha i, f_star (alpha, 0) i = i.
Proof.
  intros; now rewrite f_star_equation_1.
Qed.

Lemma fstar_S : forall alpha n i, f_star (alpha, S (S n)) i =
                                  f_ alpha  (f_star (alpha,  S n) i).
Proof.
  unfold F_; intros; now rewrite f_star_equation_3.
Qed.

Lemma f_eq2 : forall alpha i,
    E0is_succ alpha ->
    f_ alpha i = f_star (E0pred alpha,  i) i.
Proof.
  unfold f_; intros; rewrite f_star_equation_2.
  destruct (E0_eq_dec alpha E0zero).
  - subst alpha; discriminate H.
  - cbn; destruct (Utils.dec (E0limit alpha)) .
    + assert (true=false) by
          ( now  destruct (Succ_not_T1limit _ H)).
      discriminate.
    + now cbn.
Qed.

Lemma f_star_Succ:  forall alpha n i,
    f_star (alpha, S n) i =
    f_ alpha (f_star (alpha, n) i).
Proof.
  destruct n.
  - intros; now rewrite f_star_zero_eqn.
  - intros i; unfold f_; now rewrite fstar_S.
Qed.

Lemma f_star_iterate : forall alpha n i,
    f_star (alpha, n) i =  iterate (f_ alpha) n i.
Proof.
  induction n; intro i; simpl.
  - now rewrite f_star_zero_eqn.
  - specialize (IHn i); rewrite f_star_Succ in *;  now rewrite <- IHn.
Qed.

(** *** Usual equations for [f_] *)

Lemma f_zero_eqn : forall i, f_ E0zero i = S i.
Proof.
  intro i. unfold f_; rewrite f_star_equation_2.
  destruct (E0_eq_dec E0zero E0zero).
  - now cbn.
  - now destruct n.
Qed.

Lemma f_lim_eqn : forall alpha i,  E0limit alpha ->
                                   f_ alpha i = f_ (Canon alpha i) i.
Proof.
  unfold f_; intros. rewrite f_star_equation_2.
  destruct (E0_eq_dec alpha E0zero).
  - now  destruct (Limit_not_Zero  H).
  - cbn; destruct (Utils.dec (E0limit alpha)) .
    + cbn; auto.
    + red in H; rewrite e in H; discriminate.
Qed.

Lemma f_succ_eqn : forall alpha i,
    f_ (E0succ alpha) i = iterate (f_ alpha) i i.
Proof with auto with E0.
  intros;rewrite f_eq2,  f_star_iterate ...
  -  now rewrite E0pred_of_Succ.
Qed.

Lemma id_le_f_alpha (alpha: E0) : forall i, i <= f_ alpha i.
Proof.
 pattern alpha; apply (well_founded_induction E0lt_wf);
   clear alpha; intros alpha IHalpha.
 destruct (Zero_Limit_Succ_dec alpha) as [[HZero | Hlim] | Hsucc].
   - subst; intros i ; rewrite !f_zero_eqn; auto with arith.
   - intros i.  rewrite !(f_lim_eqn alpha).
     + apply IHalpha,  Canon_lt; now apply Limit_not_Zero.
     + apply Hlim.
   - destruct Hsucc as [beta Hbeta]; subst; intro i; rewrite f_succ_eqn.
     generalize i at 1 3; induction i.
     + intros; cbn; auto with arith.
     + intros; cbn; transitivity (iterate (f_ beta) i i0); auto.
     apply (IHalpha beta (Lt_Succ beta)).
Qed.

Section Properties_of_f_alpha.

Record  Q (alpha:E0) : Prop :=
    mkQ {
        QA : strict_mono (f_ alpha);
        QD : dominates_from 2 (f_ (E0succ alpha)) (f_ alpha);
        QE : forall beta n, Canon_plus n alpha beta ->
                            f_ beta n <= f_ alpha n}.

Section The_induction.

  Lemma QA0 : strict_mono (f_ E0zero).
  Proof.
    intros n p H; repeat rewrite f_zero_eqn; auto with arith.
  Qed.

  Lemma QD0 : dominates_from 2 (f_ (E0succ E0zero)) (f_ E0zero).
  Proof.
    intros p Hp; rewrite f_succ_eqn, f_zero_eqn.
    apply Nat.lt_le_trans with (iterate S p p).
    - replace (iterate S p p) with (p + p).
      + lia.
      + clear Hp; generalize p at 2 4; induction p.
        * cbn; reflexivity.
        * intro p0; cbn; now rewrite IHp.
    -  apply Nat.eq_le_incl, iterate_ext. intros ?; now rewrite f_zero_eqn.
  Qed.

  (** TODO : Study the equality F_ alpha i = Nat.pred (f_ alpha (S i)) *)

End The_induction.

End Properties_of_f_alpha.

(* begin  snippet DemoAssumptions *)
Print Assumptions F_zero_eqn.

(* end snippet DemoAssumptions *)


(*|
#################################################
mutual recursion on an inductive type and ``nat``
#################################################

:Link: https://stackoverflow.com/q/50477918
|*)

(*|
Question
********

Consider this example:
|*)

Inductive T :=
| foo : T
| bar : nat -> T -> T.

Fail Fixpoint evalT (t : T) {struct t} : nat :=
  match t with
  | foo => 1
  | bar n x => evalBar x n
  end
with
evalBar (x : T) (n : nat) {struct n} : nat :=
  match n with
  | O => 0
  | S n' => evalT x + evalBar x n'
  end. (* .fails .unfold *)

(*|
Coq rejects it.

I understand that termination checker got confused by two unrelated
inductive types (``T`` and ``nat``). However, it looks like the
function I am trying to define will indeed terminate. How can I make
Coq accept it?
|*)

(*|
Answer (eponier)
****************

Another solution is to use a nested fixpoint.
|*)

Fixpoint evalT (t : T) {struct t} : nat :=
  match t with
  | foo => 1
  | bar n x => let fix evalBar n {struct n} :=
                   match n with
                   | 0 => 0
                   | S n' => evalT x + evalBar n'
                   end
               in evalBar n
  end.

(*|
The important point is to remove the argument ``x`` from ``evalBar``.
Thus the recursive call to ``evalT`` is done on the ``x`` from ``bar n
x``, not the ``x`` given as an argument to ``evalBar``, and thus the
termination checker can validate the definition of ``evalT``.

This is the same idea that makes the version with ``nat_rec`` proposed
in another answer work.
|*)

(*|
Answer (krokodil)
*****************

One solution I found is to use ``nat_rec`` instead of ``evalBar``:
|*)

Reset evalT. (* .none *)
Fixpoint evalT (t : T) {struct t} : nat :=
  match t with
  | foo => 1
  | bar n x => @nat_rec _ 0 (fun n' t' => evalT x + t') n
  end.

(*|
It works but I wish I could hide ``nat_rec`` under ``evalBar``
definition to hide details. In my real project, such construct is used
several times.
|*)


(* ###################################################################### *)
(* taken from http://www.cis.upenn.edu/~rrand/popl_2016/ *)
(** * Proofs and Programs *)

(** (We use [admit] and [Admitted] to hide solutions from exercises.) *)

Axiom admit : forall {T}, T.

(** Everything in Coq is built from scratch -- even booleans!
    Fortunately, they are already provided by the Coq standard
    library, but we'll review their definition here to get familiar
    with the basic features of the system. *)

(** [Inductive] is Coq's way of defining an algebraic datatype.  Its
    syntax is similar to OCaml's ([type]) or Haskell's ([data]). Here,
    we define [bool] as a simple algebraic datatype. *)

Module Bool.

Inductive bool : Type :=
| true : bool
| false : bool.

(** **** Exercise: 1 star (trivalue)  *)
(** Define a three-valued data type, representing ternary logic.  Here
    something can be true, false and unknown. *)

Inductive trivalue : Type :=
(* SOLUTION: *)
| tv_true
| tv_false
| tv_unknown
.
(** [] *)

(** We can write functions that operate on [bool]s by simple pattern
    matching, using the [match] keyword. *)

Definition negb (b:bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

(** We can pattern-match on multiple arguments simultaneously, and
    also use "_" as a wildcard pattern. *)

Definition orb (b1 b2: bool) : bool :=
  match b1, b2 with
  | false, false => false
  | _, _ => true
  end.

Print orb.

(** We can also use an [if] statement, which matches on the first
    constructor of any two-constructor datatype, in our definition. *)

Definition andb (b1 b2: bool) : bool :=
  if b1 then b2 else false.

(** Let's test our functions. The [Compute] command tells Coq to
    evaluate an expression and print the result on the screen.*)

Compute (negb true).
Compute (orb true false).
Compute (andb true false).

(** **** Exercise: 1 star (xor)  *)
(** Define xor (exclusive or). *)

Definition xorb (b1 b2 : bool) : bool :=
(* SOLUTION: *) if b1 then negb b2 else b2.
Compute (xorb true true).
(** [] *)

(** What makes Coq different from normal functional programming
    languages is that it allows us to formally _prove_ that our
    programs satisfy certain properties. The system mechanically
    verifies these proofs to ensure that they are correct.

    We use [Lemma], [Theorem] and [Example] to write logical
    statements. Coq requires us to prove these statements using
    _tactics_, which are commands that manipulate formulas using basic
    logic rules. Here's an example showing some basic tactics in
    action. *)

(** New tactics
    -----------

    - [intros]: Introduce variables into the context, giving them
      names.

    - [simpl]: Simplify the goal.

    - [reflexivity]: Prove that some expression [x] is equal to itself. *)

Example andb_false_l : forall b, andb false b = false.
Proof.
(* WORKED IN CLASS *)
  intros b. (* introduce the variable b *)
  simpl. (* simplify the expression *)
  reflexivity. (* solve for x = x *)
Qed.

(** **** Exercise: 1 star (orb_true_l)  *)
Theorem orb_true_l :
  forall b, orb true b = true.
Proof.
(* SOLUTION: *)
  reflexivity.
Qed.
(** [] *)

(** Some proofs require case analysis. In Coq, this is done with the
    [destruct] tactic. *)

(** New tactic
    ----------

    - [destruct]: Consider all possible constructors of an inductive
      data type, generating subgoals that need to be solved
      separately. *)

(*  FULL: Here's an example of [destruct] in action. *)

Lemma orb_true_r : forall b : bool, orb b true = true.
(* Here we explicitly annotate b with its type, even though Coq could infer it. *)
Proof.
(* WORKED IN CLASS *)
  intros b.
  simpl. (* This doesn't do anything, since orb pattern matches on the
  first variable first. *)
  destruct b. (* Do case analysis on b *)
  + (* We use the "bullets" '+' '-' and '*' to delimit subgoals *)
    (* true case *)
    simpl.
    reflexivity.
  + (* false case *)
    simpl.
    reflexivity.
Qed.

(** We can call [destruct] as many times as we want, generating deeper subgoals. *)

Theorem andb_commutative : forall b1 b2 : bool, andb b1 b2 = andb b2 b1.
Proof.
(* WORKED IN CLASS *)
  intros b1 b2.
  destruct b1.
  + destruct b2.
    - simpl. reflexivity.
    - simpl. reflexivity. (* bullets need to be consistent *)

(** Alternatively, if all the subgoals are solved the same way, we can
    use the [;] operator to execute a tactic on _all_ the generated
    subgoals, like this: *)

  + destruct b2; simpl; reflexivity.
Qed.

(** **** Exercise: 1 star (andb_false_r)  *)
(** Show that b AND false is always false  *)

Theorem andb_false_r :
(* SOLUTION: *)
  forall b, andb b false = false.
Proof.
(* SOLUTION: *)
  intros b. destruct b.
  + reflexivity.
  + reflexivity.
Qed.
(** [] *)

(** **** Exercise: 1 star (xorb_b_neg_b)  *)
(** Show that b xor (not b) is always true. *)

Theorem xorb_b_neg_b :
(* SOLUTION: *)
  forall b, xorb b (negb b) = true.
Proof.
(* SOLUTION: *)
  intros b. destruct b.
  + reflexivity.
  + reflexivity.
Qed.

(** Sometimes, we want to show a result that requires hypotheses. In
    Coq, [P -> Q] means that [P] implies [Q], or that [Q] is true
    whenever [P] is. We can use [->] multiple times to express that
    more than one hypothesis are needed; the syntax is similar to how
    we write multiple-argument functions in OCaml or Haskell. For
    example: *)

Theorem rewrite_example : forall b1 b2 b3 b4,
  b1 = b4 ->
  b2 = b3 ->
  andb b1 b2 = andb b3 b4.

(** We can use the [intros] tactic to give hypotheses names,
    bringing them into the proof context. *)

Proof.
  intros b1 b2 b3 b4 eq14 eq23.

(** Now, our context has two hypotheses: [eq14], which states
    that [b1 = b4], and [eq23], stating that [b2 = b3].

     Here are some tactics for using hypotheses and previously proved
    results: *)

(** New tactics
    -----------

    - [rewrite]: Replace one side of an equation by the other.

    - [apply]: Suppose that the current goal is [Q]. If [H : Q], then
      [apply H] solves the goal. If [H : P -> Q], then [apply H]
      replaces [Q] by [P] in the goal. If [H] has multiple hypotheses,
      [H : P1 -> P2 -> ... -> Pn -> Q], then [apply H] generates one
      subgoal for each [Pi]. *)

  rewrite eq14. (* replace b1 with b4 in the goal *)
  rewrite <- eq23. (* replace b3 with b2 in the goal. *)
  apply andb_commutative. (* solve using our earlier theorem *)
Qed.

(** **** Exercise: 1 star (xorb_same)  *)
(** Show that if [b1 = b2] then b1 xor b2 is false. *)

Theorem xorb_same :
(* SOLUTION: *)
  forall b1 b2, b1 = b2 -> xorb b1 b2 = false.
Proof.
(* SOLUTION: *)
  intros b1 b2 eq.
  rewrite eq.
  destruct b2.
  + reflexivity.
  + reflexivity.
Qed.

End Bool.

(* ###################################################################### *)

(** We will use the following option to make polymorphism more
    convenient. *)

Set Implicit Arguments.

(** * Lists *)

(** We will now shift gears and study more interesting functional
    programs; namely, programs that manipulate _lists_. *)

Module List.

(** Here's a polymorphic definition of a [list] type in Coq: *)

Inductive list (T : Type) :=
| nil : list T
| cons : T -> list T -> list T.

(** Here's how we define a function to append two lists.
    Note that we declare the type parameter T. *)

Fixpoint app T (l1 l2 : list T) : list T :=
  match l1 with
  | nil => l2
  | cons h t  => cons h (app t l2)
  end.

(** Coq comes with a syntax extension mechanism for defining custom
    notations. Without getting into details, here's how we can give
    familiar syntax for lists. *)

Notation "h :: t" := (cons h t) (at level 60, right associativity).
Notation "[ ]" := (nil _).
Notation "[ x ; .. ; y ]" := (cons x .. (cons y [] ) ..).
Notation "l1 ++ l2" := (app l1 l2) (at level 60, right associativity).

(** Since [nil] can potentially be of any type, we add an underscore
    to tell Coq to infer the type from the context. *)

(** We can now check the types of expressions involving lists. *)

Check [].
Check true :: [].
Check [true ; false].
Check [true ; false] ++ [false].

(** And compute the last. *)
Compute [true ; false] ++ [false].

(** Note that we can use define notations and functions
    simultaneously: *)

Reserved Notation "l1 @ l2" (at level 60).
Fixpoint app' T (l1 l2 : list T) : list T :=
  match l1 with
  | [] => l2
  | h :: t  => h :: (t @ l2)
  end

  where "l1 @ l2" := (app' l1 l2).

(** **** Exercise: 1 star (snoc)  *)
(** Define [snoc], which adds an element to the end of a list. *)

Fixpoint snoc T (l : list T) (x : T) : list T :=
(* SOLUTION: *)
  match l with
  | [] => [x]
  | h :: t => h :: snoc t x
  end.

(** It is easy to show that appending [nil] to the left of a list
    yields the original list.  *)

Lemma app_nil_l: forall T (l : list T), [] ++ l  = l.
Proof.
(* WORKED IN CLASS *)
  intros T l.
  simpl.
  reflexivity.
Qed.

(** Showing the symmetric result is more difficult
    since it doesn't follow by simplification alone. *)

Lemma app_nil_r: forall T (l : list T), l ++ []  = l.
Proof.
  intros T l.
  simpl. (* Does nothing *)
  destruct l as [| h t]. (* Notice the [as] clause, which allows us
                            to name constructor arguments. *)
  + simpl.
    reflexivity.
  + simpl. (* no way to proceed... *)

(** The problem is that we can only prove the result for [h::t]
    if we already know that it is valid for [t]. We need a bigger
    hammer here... *)

(** New tactic
    ----------

    - [induction]: Argue by induction. It works as [destruct], but
    additionally giving us an inductive hypothesis in the inductive
    case. *)
Restart.
  intros T l.
  induction l as [| h t IH]. (* Note the additional name [IH], given to our
                                inductive hypothesis *)
  + simpl.
    reflexivity.
  + simpl.
    rewrite IH.
    reflexivity.
Qed.

(** As a rule of thumb, when proving some property of a recursive
    function, it is a good idea to do induction on the recursive
    argument of the function. For instance, let's show that [app] is
    associative: *)

Lemma app_assoc :
  forall T (l1 l2 l3 : list T),
    l1 ++ (l2 ++ l3) = (l1 ++ l2) ++ l3.
Proof.
(* WORKED IN CLASS *)
  intros T l1 l2 l3.
  induction l1 as [|h1 t1 IH]. (* l1 is the right choice here, since [app] is defined
                                  by recursion on the first argument. *)
  - (* [] *)
    simpl.
    reflexivity.
  - (* h1 :: t1 *)
    simpl.
    rewrite IH.
    reflexivity.
Qed.

(** Exercise: Try to do induction on [l2] and [l3] in the
    above proof, and see where it fails. *)

(** **** Exercise: 2 stars (snoc_app)  *)
(** Prove that [snoc l x] is equivalent to appending [x] to the end of
    [l]. *)

Lemma snoc_app : forall T (l : list T) (x : T), snoc l x = l ++ [x].
Proof.
(* SOLUTION: *)
  intros T l x.
  induction l as [|h t IH].
  + reflexivity.
  + simpl. rewrite IH. reflexivity.
Qed.
(** [] *)

(** The natural numbers are defined in Coq's standard library as follows:

    Inductive nat : Type :=
      | O : nat
      | S : nat -> nat.

    where [S] stands for "Successor".

    Coq prints [S (S (S O))] as "3", as you might expect.

*)

Set Printing All.

Check 0.
Check 2.
Check 2 + 2.

Unset Printing All.

Check S (S (S O)).
Check 2 + 3.
Compute 2 + 3.

(** Now we can define the [length] function: *)

Fixpoint length T (l : list T) :=
  match l with
  | [] => 0
  | h :: t => 1 + length t
  end.

Compute length [1; 1; 1].

(** **** Exercise: 3 stars (app_length)  *)

Lemma app_length : forall T (l1 l2 : list T),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
(* SOLUTION: *)
  intros T l1 l2.
  induction l1 as [|h t IH].
  + reflexivity.
  + simpl. rewrite IH. reflexivity.
Qed.

(** Often we find ourselves needing to reason about _contradictory_
    hypotheses. Whenever we have a hypothesis that equates two
    expressions that start with different constructors, we can use the
    [discriminate] tactic to prune that subgoal.

    This is a particular case of what is known as _the principle of
    explosion_, which states that a contradiction implies anything. *)

(** New Tactic
    ----------

    - [discriminate]: Looks for an equation between terms starting
      with different constructors, and solves the current goal. *)

(* Let's try to prove that if [l1 ++ l2 = []] then [l1] is [[]] *)

Lemma app_eq_nil_l : forall T (l1 l2 : list T),
  l1 ++ l2 = [] -> l1 = [].
Proof.
(* WORKED IN CLASS *)
  intros T l1 l2 H.
  destruct l1 as [| h t].
  + (* [] *)
    reflexivity.
  + (* h :: t *)
    simpl in H.
    discriminate.
Qed.

(** **** Exercise: 2 stars (app_eq_nil_r)  *)
(** Prove the same about [l2]. *)

Lemma plus_nil_r : forall T (l1 l2 : list T),
  l1 ++ l2 = [] -> l2 = [].
Proof.
(* SOLUTION: *)
  intros T l1 l2 H.
  destruct l1 as [|h t].
  + apply H.
  + discriminate.
Qed.
(** [] *)

(** Coq, like many other proof assistants, requires functions to
    be _total_ and defined for all possible inputs; in particular,
    recursive functions are always required to terminate.

    Since there is no general algorithm for deciding whether a
    function is terminating or not, Coq needs to settle for an
    incomplete class of recursive functions that is easy to show
    terminating. This means that, although every recursive function
    accepted by Coq is terminating, there are many recursive functions
    that always terminate but are not accepted by Coq, because it
    isn't "smart enough" to realize that they indeed terminate.

    The criterion adopted by Coq for deciding whether to accept a
    definition or not is _structural recursion_: All recursive calls
    must be performed on _sub-terms_ of the original argument.

    Note that the definition of _sub-terms_ used in context is purely syntactic
    hence the following definition fails.

**)

Fail Fixpoint shuffle T (l1 l2 : list T) :=
  match l1 with
  | [] => l2
  | h :: t => h :: shuffle l2 t
  end.

(** The [Fail] keyword instructs Coq to ignore a command when it
    fails, but to fail if the command succeeds. It is useful for
    showing certain pieces of code that are not accepted by the
    language.

    In this case, we can rewrite [shuffle] so that it is accepted by
    Coq's termination checker: *)

Fixpoint shuffle T (l1 l2 : list T) :=
  match l1, l2 with
  | [], _ => l2
  | _, [] => l1
  | h1 :: t1, h2 :: t2 => h1 :: h2 :: shuffle t1 t2
  end.

Print shuffle.

(** Let's define list reversal function and prove some of its basic
    properties. *)

Fixpoint rev T (l : list T) :=
  match l with
  | [] => []
  | h :: t => (rev t) ++ [h]
  end.

Lemma rev_app : forall T (l1 l2 : list T), rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
(* WORKED IN CLASS *)
  intros T l1 l2.
  induction l1 as [|h t IH].
  + simpl.
    rewrite app_nil_r.
    reflexivity.
  + simpl.
    rewrite IH.
    rewrite app_assoc.
    reflexivity.
Qed.

(** **** Exercise: 2 stars (rev_app)  *)
(** Using [rev_app], prove that reversing a list twice results in the
    same list. *)

Lemma rev_involutive : forall T (l : list T), rev (rev l) = l.
Proof.
(* SOLUTION: *)
  intros T l. induction l as [|h t IH].
  + reflexivity.
  + simpl. rewrite rev_app. rewrite IH. reflexivity.
Qed.

(** Notice that the definition of list reversal given above runs in
    quadratic time. Here is a tail-recursive equivalent that runs in
    linear time. *)

Fixpoint tr_rev_aux T (l acc : list T) : list T :=
  match l with
  | [] => acc
  | x :: l => tr_rev_aux l (x :: acc)
  end.

Definition tr_rev T (l: list T) := tr_rev_aux l [].

(** Here, [acc] is an accumulator argument that holds the portion of
    the list that we have reversed so far. Let's prove that [tr_rev]
    is equivalent to [rev]. For this we will need another tactic: *)

(** New Tactic
    ----------

    - [unfold]: Calling [unfold foo] expands the definition of [foo]
      in the goal.
*)

Lemma tr_rev_eq_rev_try_one :
  forall T (l : list T),
    tr_rev l = rev l.
Proof.
  intros T l.
  unfold tr_rev.
  induction l as [| h t IH].
  + simpl.
    reflexivity.
  + simpl.
    (* and now we're stuck... *)
Abort.

(** The problem is that the result we are trying to prove is not
    general enough. We will need the following auxiliary lemma: *)

Lemma tr_rev_aux_eq_rev :
  forall T (l1 l2 : list T),
    tr_rev_aux l1 l2 = rev l1 ++ l2.
Proof.
  intros T l1 l2.
  induction l1 as [|x l1 IH].
  - simpl. reflexivity.
  - simpl.

(** Our inductive hypothesis is too weak to proceed. We want
    [tr_rev_aux l1 l2 = rev l1 ++ l2] for all [l2]. Let's try again
    from the start. *)

Restart.
  intros T l1. (* Now we don't introduce l2, leaving it general. *)
  induction l1 as [|x l1 IH].
  - intros l2. simpl. reflexivity.
  - intros l2. (* Behold our induction hypothesis! *)
    simpl.
    rewrite IH.

(** We can use the [SearchAbout] command to look up lemmas that can be
    used with certain expressions ([C-c C-a C-a] in Proof General). *)

    SearchAbout (_ ++ _ ++ _).
    rewrite <- app_assoc.
    simpl.
    reflexivity.
Qed.

(** Our result follows easily: *)

Lemma tr_rev_eq_rev :
  forall T (l : list T),
    tr_rev l = rev l.
Proof.
(* WORKED IN CLASS *)
  intros T l.
  unfold tr_rev.
  rewrite tr_rev_aux_eq_rev.
  SearchAbout (_ ++ []).
  apply app_nil_r.
Qed.

End List.

(** You may have noticed that several of the proofs in this section,
    particularly regarding the associativity of the append function,
    closely resemble proofs about arithmetic. You might also be interested
    in Coq for its ability to prove results in mathematics. The
    material in this section should be sufficient for you to start
    formulating theorems about the natural numbers, such as the
    commutativity, associativity and distributivity of addition and
    multiplication.

    As noted above, the natural numbers are defined as follows:

    Inductive nat : Type :=
      | O : nat
      | S : nat -> nat.

    From there you can define +, -, *, /, ^ etc. We encourage you to
    start on your own, but to help we've included a module on arithmetic
    We hope you enjoy.

*)


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf1 : natural) : natural := plus Zero (plus Zero lf1).


(* Additional definitions and lemmas on lists *)

Require Import Arith.
Require Import Max.
Require Import Min.
Require Import List.
Require Import Omega.
Require Import Ott.ott_list_support.
Require Import Ott.ott_list_base.
Require Import Ott.ott_list_nth.
Import List_lib_Arith.

Section Lists.

Variables A B C : Type.
Implicit Types x : A.
Implicit Types y : B.
Implicit Types z : C.
Implicit Types xs l : list A.
Implicit Types ys : list B.
Implicit Types zs : list C.
Implicit Types f : A -> B.
Implicit Types g : B -> C.
Implicit Types m n : nat.
Set Implicit Arguments.

(*** Prefix and suffix extraction ***)

Fixpoint take n l {struct l} : list A :=
  match n, l with
    | 0, _ => nil
    | _, nil => nil
    | S m, h::t => h :: (take m t)
  end.

Lemma take_0 : forall l, take 0 l = nil.
Proof. destruct l; reflexivity. Qed.
Lemma take_nil : forall n, take n nil = nil.
Proof. destruct n; reflexivity. Qed.

Lemma take_all :
  forall l n, length l <= n -> take n l = l.
Proof.
  induction l; destruct n; intros; try reflexivity.
  solve [inversion H].
  simpl in * . apply (f_equal2 (@cons A)). reflexivity. apply IHl. omega.
Qed.

Lemma take_length :
  forall l n, length (take n l) = min n (length l).
Proof.
  induction l; destruct n; intros; simpl; try rewrite IHl; reflexivity.
Qed.

Lemma take_some_length :
  forall l n, n <= length l -> length (take n l) = n.
Proof.
  intros. rewrite take_length. auto with arith.
Qed.

Lemma take_nth :
  forall l m n,
    nth_error (take m l) n = if le_lt_dec m n then error else nth_error l n.
Proof.
  intros until n. generalize dependent l. generalize dependent m.
  induction n; intros; simpl.
  destruct m; destruct l; reflexivity.
  destruct l; simpl.
  destruct (le_lt_dec m (S n)); destruct m; reflexivity.
  destruct m. reflexivity.
  rewrite IHn. symmetry. apply le_lt_dec_S.
Qed.

Lemma take_take :
  forall l m n, take m (take n l) = take (min m n) l.
Proof.
  induction l; intros; simpl.
  destruct (min m n); destruct n; repeat rewrite take_nil; reflexivity.
  destruct n; destruct m; try reflexivity.
  simpl. rewrite IHl. reflexivity.
Qed.

Fixpoint drop n l {struct l} : list A :=
  match n, l with
    | 0, _ => l
    | _, nil => nil
    | S m, h::t => drop m t
  end.

Lemma drop_0 : forall l, drop 0 l = l.
Proof. destruct l; reflexivity. Qed.
Lemma drop_nil : forall n, drop n nil = nil.
Proof. destruct n; reflexivity. Qed.

Lemma drop_all :
  forall l n, length l <= n -> drop n l = nil.
Proof.
  induction l; destruct n; intros; try reflexivity.
  solve [inversion H].
  simpl in * . apply IHl. omega.
Qed.

Lemma drop_length : forall l n, length (drop n l) = length l - n.
Proof.
  induction l; destruct n; intros; simpl; try rewrite IHl; reflexivity.
Qed.

Lemma match_drop :
  forall l n, match drop n l with
                | nil => length l <= n
                | _::_ => length l > n
              end.
Proof.
  intros. destruct (le_gt_dec (length l) n) as [Le | Gt].
  rewrite drop_all; assumption.
  generalize (conj (refl_equal (length (drop n l))) (refl_equal (drop n l))).
  pattern (drop n l) at 1 3.
  case (drop n l); intros; rewrite drop_length in H; destruct H; simpl in * .
  elimtype False; omega.
  rewrite <- H0. assumption.
Qed.

Lemma drop_nth :
  forall l m n, nth_error (drop m l) n = nth_error l (m + n).
Proof.
  induction l; intros.
  rewrite drop_nil. repeat rewrite nth_error_nil. reflexivity.
  destruct m; simpl; auto.
Qed.

Lemma drop_drop :
  forall l m n, drop m (drop n l) = drop (n + m) l.
Proof.
  intros; generalize dependent l. induction n; simpl; intros.
  rewrite drop_0. reflexivity.
  destruct l; simpl; [destruct m | rewrite IHn]; reflexivity.
Qed.

Lemma take_app_drop : forall l n, take n l ++ drop n l = l.
Proof.
  intros l n; generalize dependent l; induction n; intros.
  rewrite take_0; rewrite drop_0; reflexivity.
  induction l; simpl. reflexivity.
  rewrite IHn. reflexivity.
Qed.

Lemma take_app_exact :
  forall l l' n, length l = n -> take n (l ++ l') = l.
Proof.
  induction l; intros; subst n; simpl in * .
  rewrite take_0. reflexivity.
  rewrite IHl; reflexivity.
Qed.

Lemma drop_app_exact :
  forall l l' n, length l = n -> drop n (l ++ l') = l'.
Proof.
  induction l; intros; subst n; simpl in * .
  rewrite drop_0. reflexivity.
  rewrite IHl; reflexivity.
Qed.

Lemma take_app_long :
  forall l l' n, n <= length l -> take n (l ++ l') = take n l.
Proof.
  intros.
  set (tmp := l) in |- * at 2. rewrite <- (take_app_drop l n). subst tmp.
  rewrite app_ass. rewrite take_app_exact. reflexivity.
  apply take_some_length. assumption.
Qed.

Lemma drop_app_long :
  forall l l' n, n <= length l -> drop n (l ++ l') = drop n l ++ l'.
Proof.
  intros.
  set (tmp := l) in |- * at 2. rewrite <- (take_app_drop l n). subst tmp.
  rewrite app_ass. rewrite drop_app_exact. reflexivity.
  apply take_some_length. assumption.
Qed.

Lemma take_app_short :
  forall l l' n, take (length l + n) (l ++ l') = l ++ take n l'.
Proof. intros. induction l; simpl; congruence. Qed.

Lemma drop_app_short :
  forall l l' n, drop (length l + n) (l ++ l') = drop n l'.
Proof. intros. induction l; simpl; congruence. Qed.

Lemma take_from_app :
  forall l l', take (length l) (l ++ l') = l.
Proof.
  intros. replace (length l) with (length l + 0). 2: omega.
  rewrite take_app_short. rewrite take_0.
  symmetry. apply app_nil_end.
Qed.

Lemma drop_from_app :
  forall l l', drop (length l) (l ++ l') = l'.
Proof.
  intros. replace (length l) with (length l + 0). 2: omega.
  rewrite drop_app_short. apply drop_0.
Qed.

Lemma take_take_app :
  forall l l' n, n <= length l -> take n (take n l ++ l') = take n l.
Proof.
  intros. rewrite take_app_long. rewrite take_take.
  destruct (min_dec n n) as [Eq | Eq]; rewrite Eq; reflexivity.
  rewrite take_some_length; trivial.
Qed.

Lemma drop_take_app :
  forall l l' n, n <= length l -> drop n (take n l ++ l') = l'.
Proof.
  intros. rewrite drop_app_exact. reflexivity.
  apply take_some_length. assumption.
Qed.

(*** End of the Lists section ***)

End Lists.

Hint Rewrite take_0 take_nil take_length take_nth take_take : take_drop.
Hint Rewrite take_all : take_drop_short.
Hint Rewrite take_some_length : take_drop_long.
Hint Rewrite drop_0 drop_nil drop_length drop_nth drop_drop : take_drop.
Hint Rewrite drop_all : take_drop_short.
Hint Rewrite take_app_drop : take_drop.
Hint Rewrite take_app_exact drop_app_exact : take_drop_exact.
Hint Rewrite take_app_long drop_app_long : take_drop_long.
Hint Rewrite take_app_short drop_app_short : take_drop.
Hint Rewrite take_from_app drop_from_app : take_drop.
Hint Rewrite take_take_app drop_take_app : take_drop_long.

(* Break the list [original] into two pieces [prefix] and [suffix]
   at the location indicated by [cut_point]. [cut_point] indicates
   the number of elements to retain in [prefix]; it may also be
   a list whose length is used. This tactic leaves either one or two
   goals. The first goal has a hypothesis stating that the length of
   [prefix] is [cut_point]. The second goal has [original] left
   unchanged and an additional hypothesis stating that
   [length original < cut_point]; the tactic tries refuting this by
   calling omega. *)
Ltac cut_list original cut_point prefix suffix :=
  let l := fresh "whole" with Ineq := fresh "Ineq" with
      Eq := fresh "Decomposition" with Eql := fresh "Eqlen" with
      p := fresh "prefix" with s := fresh "suffix" with
      n := match type of cut_point with
             | nat => cut_point
             | list _ => constr:(length cut_point)
             | _ => fail "cut_list: unrecognised cut_point type"
           end in (
    destruct (le_lt_dec n (length original)) as [Ineq | Ineq]; [
      (**length original >= n, so length prefix = n**)
      assert (Eql := take_some_length original Ineq); clear Ineq;
      generalize dependent original; intro l;
      assert (Eq := take_app_drop l n);
      set (p := (take n l)) in *; set (s := (drop n l)) in *;
      clearbody p s; subst l;
      (*We've done the cutting, now we try to do some simplifications*)
      autorewrite with lists take_drop; intros;
      rename p into prefix; rename s into suffix
    | (**length original < n**)
      try (equate_list_lengths; elimtype False; omega) ]
  ).

(* Look for equations between lists that can be simplified.
   [?p ++ ?s = ?p' ++ ?s'] is simplified into [?p = ?p'] and [?s = ?s'] *)
Ltac parallel_split :=
  let eq' := fresh "eq" with tmp := fresh "tmp" with
      EqPrefix := fresh "Eql" with EqSuffix := fresh "Eql" in (
    pose (eq' := eq);
    repeat match goal with
             | H : app ?p ?s = app ?p' ?s' |- _ =>
               (
                 assert (tmp : length p = length p');
                   [equate_list_lengths; omega | idtac];
                 assert (EqPrefix := app_inj_prefix_length_prefix _ _ _ _ tmp H);
                 rewrite <- EqPrefix in H;
                 assert (EqSuffix := app_inj_prefix _ _ _ H);
                 clear tmp H
               ) || (
                 assert (tmp : length s = length s');
                   [equate_list_lengths; omega | idtac];
                 assert (EqSuffix := app_inj_prefix_length_suffix _ _ _ _ tmp H);
                 rewrite <- EqSuffix in H;
                 assert (EqPrefix := app_inj_suffix _ _ _ H);
                 clear tmp H
               ) || fold eq' in H
             | H : cons ?a ?l = cons ?a' ?l' |- _ =>
               injection H; intro; clear H; intro H
           end;
    unfold eq' in *; clear eq'
  ).
(* Ad-hoc obsolete tactic (superceded by [parallel_split]) *)
Ltac parallel_split_maps :=
  repeat match goal with
           | H : map ?f ?p ++ map ?f ?s = ?p' ++ ?s' |- _ =>
             assert (Eqlen' : length (map f p) = length p');
               [equate_list_lengths; omega | idtac];
             assert (EqPrefix := app_inj_prefix_length_prefix _ _ _ _ Eqlen' H);
             rewrite <- EqPrefix in H;
             assert (EqSuffix := app_inj_prefix _ _ _ H);
             clear Eqlen' H
           | H : _ ++ _ = map _ _ ++ map _ _ |- _ => symmetry in H
         end.

(*** The End. ***)