Require Import
        Coq.QArith.Qabs
        CoRN.util.Qdlog
        CoRN.algebra.RSetoid
        CoRN.model.totalorder.QposMinMax
        CoRN.model.metric2.Qmetric
        CoRN.model.reals.CRreal
        CoRN.metric2.Metric
        CoRN.metric2.UniformContinuity
        CoRN.reals.fast.CRAlternatingSum
        CoRN.reals.fast.CRstreams
        CoRN.reals.faster.ApproximateRationals
        CoRN.reals.faster.ARArith.

(**
The goal of this section is to compute the infinite alternating sum. Since
we do not have a precise division operation, we want to postpone divisions as
long as possible. Hence we parametrize our infinite sum by a stream [sN]
of numerators and a stream [sD] of denominators.

To compute an infinite series at precision epsilon, the finite number n of
terms to sum can be computed exactly, because sN n / sD n < epsilon/2 is
equivalent to sN n < (sD n) * epsilon/2, which does not involve the approximate
division. In the other epsilon/2, we can approximate the n divisions at
precision 2^k such as n*2^k < epsilon/2.
*)

Section RationalStreamSum.

  Context `{AppRationals AQ}.

  (* For exponential, f p n d := (n*a, d*p).
     We might need to generalize positive to a more complicated
     state type later. *)
  Variable f : positive*(AQ*AQ) -> AQ*AQ.
  Definition fS x : positive*(AQ*AQ) := (Pos.succ (fst x), f x).
  Definition fSsum (k:Z) (x : positive*(AQ*AQ)*AQ) : positive*(AQ*AQ)*AQ
    := let (y,s) := x in
       let (a,b) := fS y in
       (a, b, s + app_div (fst b) (snd b) k).

  Hypothesis denomPos : forall x, 0 < snd (snd x) -> 0 < snd (f x).

  Lemma denomPos_iter : forall p x,
      0 < snd (snd x) ->
      0 < snd (snd (CRstreams.iterate _ fS p x)).
  Proof.
    apply (Pos.peano_ind (fun p => forall x,
      0 < snd (snd x) ->
      0 < snd (snd (CRstreams.iterate _ fS p x)))).
    - intros. simpl. apply denomPos, H5.
    - intros. rewrite iterate_succ, iterate_shift.
      apply H5. simpl.
      apply denomPos, H6.
  Qed.

  (* Find first index where num/denom <= e. *)
  Definition IsStopIndex x (e : AQ) (candidate : positive) : Prop
    := let (_,v) := CRstreams.iterate _ fS candidate (xH,x) in
       le (abs (fst v)) (snd v * e).
  Definition StopIndex x (e : AQ) (candidate : positive) : positive
    := Pos.pred (fst (iterate_stop
              _ fS (fun y : positive*(AQ*AQ)
                    => bool_decide_rel le (abs (fst (snd y))) ((snd (snd y))*e))
              candidate (xH, x))).

  Lemma fS_fst : forall (p:positive) x,
      fst (CRstreams.iterate (positive and AQ and AQ) fS p (1%positive, x))
          ≡ Pos.succ p.
  Proof.
    apply (Pos.peano_ind (fun p => forall (x : AQ and AQ),
    fst (CRstreams.iterate (positive and AQ and AQ) fS p (1%positive, x)) ≡ Pos.succ p)).
    - reflexivity.
    - intros. rewrite iterate_succ. simpl.
      apply f_equal, H5.
  Qed.

  Lemma StopIndex_correct : forall x (e:AQ) (p r : positive),
      IsStopIndex x e p
      -> (forall q:positive, Pos.lt q p -> ~IsStopIndex x e q)
      -> Pos.le p r
      -> StopIndex x e r ≡ p.
  Proof.
    unfold IsStopIndex. intros.
    unfold StopIndex.
    destruct (iterate_stop_correct
                  _ fS (fun y : positive and AQ and AQ =>
                              bool_decide_rel
                                le (abs (fst (snd y))) (snd (snd y) * e0))
               r (xH,x)) as [s [req [H8 H9]]].
    rewrite req, fS_fst, Pos.pred_succ. clear req.
    destruct H9.
    - subst r. apply Pos.le_lteq in H7.
      destruct H7. 2: symmetry; exact H7.
      exfalso. specialize (H8 p H7).
      apply bool_decide_rel_false in H8.
      contradict H8.
      destruct (CRstreams.iterate _ fS p (1%positive, x)).
      exact H5.
    - destruct H9.
      apply bool_decide_rel_true in H10.
      clear H7 H9 r.
      destruct (Pos.lt_total s p).
      + exfalso. specialize (H6 s H7).
        contradict H6.
        destruct (CRstreams.iterate _ fS s (1%positive, x)).
        exact H10.
      + destruct H7. exact H7. exfalso.
        specialize (H8 p H7).
        apply bool_decide_rel_false in H8.
        contradict H8.
      destruct (CRstreams.iterate _ fS p (1%positive, x)).
      exact H5.
  Qed.

  Lemma StopIndex_stop_fuel : forall x (e:AQ) (candidate : positive),
      (forall p:positive, Pos.lt p candidate -> ~IsStopIndex x e p)
      -> StopIndex x e candidate ≡ candidate.
  Proof.
    intros. unfold StopIndex.
    destruct (iterate_stop_correct
                  _ fS (fun y : positive and AQ and AQ =>
                              bool_decide_rel
                                le (abs (fst (snd y))) (snd (snd y) * e0))
               candidate (xH,x)) as [r [req [H6 H7]]].
    rewrite req, fS_fst, Pos.pred_succ. clear req.
    destruct H7. symmetry. exact H7.
    destruct H7. exfalso. clear H6.
    specialize (H5 r H7).
    apply bool_decide_rel_true in H8.
    contradict H5.
    unfold IsStopIndex.
    destruct (CRstreams.iterate _ fS r (1%positive, x)).
    exact H8.
  Qed.

  (* Approximate the infinite series at precision e.
     The precision i:Z in fSum satisfies n*2^i <= e/2. *)
  Definition app_inverse_below (q : Qpos) : AQ
    := AppInverse0 ((3#4)*proj1_sig q) ((1#4)*q)%Qpos.

  Lemma app_inverse_below_pos : forall q:Qpos, 0 < app_inverse_below q.
  Proof.
    intros. unfold app_inverse_below.
    destruct aq_dense_embedding.
    specialize (dense_inverse ((3 # 4) * ` q)%Q ((1#4)*q)%Qpos).
    apply AbsSmall_Qabs, Qabs_Qle_condition in dense_inverse.
    destruct dense_inverse as [H5 _].
    simpl in H5.
    apply (Qplus_le_r _ _ ((3 # 4) * ` q)) in H5.
    ring_simplify in H5.
    destruct aq_strict_order_embed.
    apply strict_order_embedding_reflecting.
    refine (Qlt_le_trans _ ((8 # 16) * ` q) _ _ H5).
    rewrite rings.preserves_0.
    apply (Qpos_ispos ((8#16)*q)).
  Qed.

  Lemma app_inverse_below_correct : forall q:Qpos,
      AQtoQ (app_inverse_below q) <= proj1_sig q.
  Proof.
    intros. unfold app_inverse_below.
    destruct aq_dense_embedding.
    specialize (dense_inverse ((3 # 4) * ` q)%Q ((1#4)*q)%Qpos).
    apply AbsSmall_Qabs, Qabs_Qle_condition in dense_inverse.
    destruct dense_inverse as [_ H5].
    simpl in H5.
    apply (Qplus_le_r _ _ ((3 # 4) * ` q)) in H5.
    ring_simplify in H5. exact H5.
  Qed.

  (* cvmod : AQ->positive would not improve this definition, because an
     AQtoQ would be almost inevitable to produce a boxed positive.
     Besides, Q will allow an easier interaction with fast reals streams. *)
  Definition AltSeries_raw (x : AQ*AQ) (cvmod : Qpos -> positive) (e:QposInf) : AQ
    := match e with
       | Qpos2QposInf d
         => let ae := app_inverse_below (d*(1#2)) in
           let n := StopIndex x ae (cvmod (d * (1#2))%Qpos) in
           snd (CRstreams.iterate _ (fSsum (Qdlog2 (proj1_sig d * (1#2*n)))) n (xH,x,0))
       | QposInfinity => 0
       end.

  (* To prove the correctness of the limit, convert the stream f into
     a stream g of exact rationals. g could be defined as the zip of
     f with the exact divisions, but it's more flexible to take g from
     outside, so that in addition we prove the equality of series. *)
  Variable X : Type.
  Variable g : X*Q -> X*Q.
  Variable fInit : AQ*AQ.
  Variable gInit : X*Q.

  Hypothesis g_pth : forall p:positive,
      Str_pth _ g p gInit
      == let (y,r) := CRstreams.iterate _ fS p (xH, fInit) in
         AQtoQ (fst r) / AQtoQ (snd r).

  Lemma abs_div_aqtoq_shift : forall (q r s : AQ),
      0 < r ->
      (Qabs (AQtoQ q / AQtoQ r) <= AQtoQ s
       <-> le (abs q) (r * s)).
  Proof.
    assert (forall q:AQ, Qabs (AQtoQ q) == AQtoQ (abs q)) as preserves_abs.
    { intros. rewrite abs.preserves_abs. reflexivity. }
    assert (forall q r:AQ, AQtoQ (q*r) == AQtoQ q*AQtoQ r) as preserves_mult.
    { intros. rewrite rings.preserves_mult. reflexivity. }
    intros.
    assert (0 < AQtoQ r).
    { rewrite <- rings.preserves_0.
      destruct aq_strict_order_embed.
      apply strict_order_embedding_preserving. exact H5. }
    split.
    - intros. unfold Qdiv in H7.
      rewrite Qabs_Qmult, Q.Qabs_Qinv in H7.
      rewrite (Qabs_pos (AQtoQ r)) in H7.
      rewrite preserves_abs, Qmult_comm in H7.
      apply (Qmult_le_l _ _ (AQtoQ r)) in H7.
      2: exact H6.
      rewrite Qmult_assoc, Qmult_inv_r, Qmult_1_l in H7.
      rewrite <- preserves_mult in H7.
      destruct aq_order_embed, order_embedding_reflecting.
      apply order_reflecting in H7.
      exact H7.
      intro abs. rewrite abs in H6. exact (Qlt_irrefl 0 H6).
      apply Qlt_le_weak, H6.
    - intros. unfold Qdiv.
      rewrite Qabs_Qmult, Q.Qabs_Qinv.
      rewrite (Qabs_pos (AQtoQ r)).
      rewrite preserves_abs.
      rewrite Qmult_comm.
      apply (Qmult_le_l _ _ (AQtoQ r)).
      exact H6.
      rewrite Qmult_assoc, Qmult_inv_r, Qmult_1_l.
      rewrite <- preserves_mult.
      destruct aq_order_embed.
      apply order_embedding_preserving.
      exact H7.
      intro abs. rewrite abs in H6. exact (Qlt_irrefl 0 H6).
      apply Qlt_le_weak, H6.
  Qed.

  Lemma fSsum_fst : forall p k,
      fst (CRstreams.iterate _ (fSsum k) p (1%positive, fInit, 0))
          ≡ CRstreams.iterate _ fS p (xH,fInit).
  Proof.
    apply (Pos.peano_ind (fun p => forall k,
      fst (CRstreams.iterate _ (fSsum k) p (1%positive, fInit, 0))
          ≡ CRstreams.iterate _ fS p (xH,fInit))).
    - reflexivity.
    - intros. rewrite iterate_succ, iterate_succ.
      rewrite <- (H5 k). unfold fSsum at 1.
      destruct (CRstreams.iterate ((positive and AQ and AQ) and AQ)
                                  (fSsum k) p (1%positive, fInit, 0)).
      reflexivity.
  Qed.

  (* Sum p terms, the error between each is below e. *)
  Lemma div_approx_error : ∀ (p:positive) (e:Qpos),
    Qball (` e * inject_Z (Zpos p))
      (AQtoQ (snd (CRstreams.iterate
                     _ (fSsum (Qdlog2 (` e))) p (1%positive, fInit, 0))))
      (snd (CRstreams.iterate
              _ (fun y : X*Q*Q =>
                       let (z, r) := g (fst y) in (z, r, Qred (r + snd y))) p
              (gInit, 0))).
  Proof.
    apply (Pos.peano_ind (fun p => forall (e:Qpos),
    Qball (` e * inject_Z (Zpos p))
      (AQtoQ (snd (CRstreams.iterate
                     _ (fSsum (Qdlog2 (` e))) p (1%positive, fInit, 0))))
      (snd (CRstreams.iterate
              _ (fun y : X*Q*Q =>
                       let (z, r) := g (fst y) in (z, r, Qred (r + snd y))) p
              (gInit, 0))))).
    - intros. rewrite iterate_one, iterate_one.
      rewrite Qmult_1_r.
      unfold fSsum, fS.
      unfold snd at 1. unfold fst at 2.
      pose proof (g_pth 1).
      unfold Str_pth in H5. simpl in H5.
      unfold snd at 3.
      replace (snd (let (z, r) := g gInit in (z, r, Qred (r + zero))))
        with (Qred (snd (g gInit) + 0))
        by (destruct (g gInit); reflexivity).
      rewrite Qred_correct, Qplus_0_r, H5.
      clear H5.
      destruct (f (1%positive, fInit)) as [u v].
      unfold snd, fst.
      rewrite rings.plus_0_l.
      apply ball_weak_le with (e:= (2 ^ Qdlog2 (` e0))%Q).
      apply Qdlog2_spec, Qpos_ispos.
      apply aq_div.
    - intros.
      rewrite iterate_succ.
      unfold fSsum at 1.
      specialize (H5 e0).
      pose proof (fSsum_fst p (Qdlog2 (` e0))).
      destruct (CRstreams.iterate _ (fSsum (Qdlog2 (` e0))) p (1%positive, fInit, 0))
        as [u approx_sum].
      unfold snd in H5 at 1.
      unfold fst in H6.
      change (snd
          (let (a, b) := fS u in (a, b, approx_sum + app_div (fst b) (snd b) (Qdlog2 (` e0)))))
        with (approx_sum + app_div (fst (snd (fS u))) (snd (snd (fS u))) (Qdlog2 (` e0))).
      rewrite iterate_succ, SumStream_fst_red.
      unfold fst at 2.
      rewrite <- iterate_succ.
      pose proof (g_pth (Pos.succ p)) as H7.
      unfold Str_pth in H7.
      destruct (CRstreams.iterate (X and Q) g (Pos.succ p) gInit).
      unfold snd at 4. unfold snd in H7 at 1.
      rewrite Qred_correct, H7. clear H7 q x.
      rewrite iterate_succ.
      rewrite <- H6. clear H6.
      destruct (fS u) as [v w].
      change (snd (v,w)) with w.
      clear v.
      destruct (CRstreams.iterate _
          (fun y : (X and Q) and Q =>
             let (z, r) := g (fst y) in (z, r, Qred (r + snd y))) p
          (gInit, 0))
        as [v exact_sum].
      unfold snd in H5.
      unfold snd at 3. clear v.
      destruct w as [v w].
      unfold fst, snd.
      rewrite rings.preserves_plus.
      apply AbsSmall_Qabs.
      apply AbsSmall_Qabs in H5.
      setoid_replace ((AQtoQ approx_sum + AQtoQ (app_div v w (Qdlog2 (` e0)))) -
                      (AQtoQ v / AQtoQ w + exact_sum))%Q
        with (AQtoQ approx_sum - exact_sum
              + (AQtoQ (app_div v w (Qdlog2 (` e0))) - (AQtoQ v / AQtoQ w)))%Q
        by ring.
      apply (Qle_trans _ _ _ (Qabs_triangle _ _)).
      rewrite <- Pos.add_1_r, Pos2Z.inj_add, inject_Z_plus.
      rewrite Qmult_plus_distr_r, Qmult_1_r.
      apply Qplus_le_compat. exact H5.
      apply AbsSmall_Qabs.
      change (Qball (` e0) (AQtoQ (app_div v w (Qdlog2 (` e0)))) (AQtoQ v / AQtoQ w)).
      apply ball_weak_le with (e:= (2 ^ Qdlog2 (` e0))%Q).
      apply Qdlog2_spec, Qpos_ispos.
      apply aq_div.
  Qed.

  (* SumStream is the implementation of CRAlternatingSum.AltSeries_raw.
     Errors only come from approximate divisions here. *)
  Lemma AltSeries_raw_correct : forall (e:Qpos) (cvmod : Qpos -> positive),
      0 < snd fInit ->
      Qball (` e * (1 # 2))
            (AQtoQ (AltSeries_raw fInit cvmod (Qpos2QposInf e)))
            (SumStream
               _ g gInit
               (cvmod (e * (1 # 2))%Qpos) (* fuel *)
               (AQposAsQpos (exist _ _ (app_inverse_below_pos (e * (1 # 2))%Qpos)))).
  Proof.
    intros e0 cvmod xpos.
    unfold SumStream.
    change (` (AQposAsQpos
                 (app_inverse_below (e0 * (1 # 2))%Qpos
                            ↾ app_inverse_below_pos (e0 * (1 # 2))%Qpos)))
      with (AQtoQ (app_inverse_below (e0 * (1 # 2))%Qpos)).
    pose proof (iterate_stop_correct
                  _ (fun y : (X and Q) and Q =>
                           let (z, r) := g (fst y) in (z, r, Qred (r + snd y)))
                  (fun y : (X and Q) and Q =>
             Qle_bool (Qabs (snd (fst y)))
               (AQtoQ (app_inverse_below (e0 * (1 # 2) ↾ eq_refl))))
              (cvmod (e0 * (1 # 2))%Qpos) (gInit,0))
      as [p [qeq [H5 H6]]].
    rewrite qeq. clear qeq.
    unfold AltSeries_raw.
    replace (StopIndex fInit (app_inverse_below (e0 * (1 # 2) ↾ eq_refl))
                       (cvmod (e0 * (1 # 2))%Qpos))
      with p.
    setoid_replace (` e0 * (1 # 2))%Q
      with (` e0 * (1 # 2 * p) * inject_Z (Zpos p))%Q.
    apply (div_approx_error p (e0*(1#2*p))).
    rewrite <- Qmult_assoc. apply Qmult_comp. reflexivity.
    unfold Qmult, Qeq; simpl.
    rewrite Pos.mul_1_r, Pos.mul_comm. reflexivity.
    rewrite SumStream_fst_red in H6.
    destruct H6 as [fuel | predicate].
    - (* The sum consumes all the fuel. *)
      subst p.
      symmetry. apply StopIndex_stop_fuel.
      intros. specialize (H5 p H6).
      rewrite SumStream_fst_red in H5.
      unfold fst in H5.
      unfold IsStopIndex. intro abs.
      pose proof (g_pth p). unfold Str_pth in H7.
      rewrite H7 in H5. clear H7.
      pose proof (denomPos_iter p (xH,fInit) xpos).
      destruct (CRstreams.iterate _ fS p (1%positive, fInit))
        as [u v].
      apply abs_div_aqtoq_shift in abs.
      apply Qle_bool_iff in abs.
      rewrite abs in H5. discriminate.
      exact H7.
    - (* The sum stops before the fuel, because of the predicate. *)
      assert (IsStopIndex fInit (app_inverse_below (e0 * (1 # 2))%Qpos) p) as pstop.
      { destruct predicate as [_ predicate]. unfold IsStopIndex.
        apply Qle_bool_iff in predicate.
        simpl in predicate.
        pose proof (g_pth p).
        unfold Str_pth in H6. rewrite H6 in predicate. clear H6.
        pose proof (denomPos_iter p (xH,fInit) xpos).
        destruct (CRstreams.iterate _ fS p (1%positive, fInit)).
        apply abs_div_aqtoq_shift. exact H6.
        exact predicate. }
      symmetry. apply StopIndex_correct.
      exact pstop. intros.
      unfold IsStopIndex.
      specialize (H5 q H6).
      rewrite SumStream_fst_red in H5. unfold fst in H5.
      pose proof (g_pth q).
      unfold Str_pth in H7. rewrite H7 in H5. clear H7.
      pose proof (denomPos_iter q (xH,fInit) xpos).
      destruct (CRstreams.iterate _ fS q (1%positive, fInit)).
      intro abs.
      apply abs_div_aqtoq_shift in abs.
      apply Qle_bool_iff in abs.
      rewrite abs in H5. discriminate.
      exact H7. apply Pos.lt_le_incl, predicate.
  Qed.

  Lemma AltSeries_raw_prf : forall (cvmod : Qpos -> positive),
      Str_alt_decr _ g gInit
      -> 0 < snd fInit
      -> Limit_zero _ g gInit cvmod ->
      is_RegularFunction (@ball AQ_as_MetricSpace) (AltSeries_raw fInit cvmod).
  Proof.
    intros cvmod g_decr xpos lz e1 e2.
    setoid_replace (`e1 + `e2)%Q
      with (`e1*(1#2) + (`e1*(1#2) + `e2*(1#2) + `e2*(1#2)))%Q by ring.
    apply (ball_triangle Q_as_MetricSpace _ _ _
      (SumStream
                   _ g gInit
                   (cvmod (e1 * (1 # 2))%Qpos)
                   (AQposAsQpos (exist _ _ (app_inverse_below_pos (e1 * (1 # 2))%Qpos))))).
    2: apply (ball_triangle Q_as_MetricSpace _ _ _
      (SumStream
                   _ g gInit
                   (cvmod (e2 * (1 # 2))%Qpos)
                   (AQposAsQpos (exist _ _ (app_inverse_below_pos (e2 * (1 # 2))%Qpos))))).
    - exact (AltSeries_raw_correct _ _ xpos).
    - apply (AltSeries_further
               _ g gInit _ _ _ _
               (e1 * (1 # 2))%Qpos (e2 * (1 # 2))%Qpos g_decr).
      apply lz. apply lz.
      apply app_inverse_below_correct.
      apply app_inverse_below_correct.
    - apply ball_sym, (AltSeries_raw_correct _ _ xpos).
  Qed.

  Definition AltSeries (cvmod : Qpos -> positive)
      (decr : Str_alt_decr _ g gInit)
      (xpos : 0 < snd fInit)
      (lz : Limit_zero _ g gInit cvmod) : msp_car AR
    := Build_RegularFunction (AltSeries_raw_prf cvmod decr xpos lz).

  Lemma AltSeries_correct : forall (cvmod : Qpos -> positive)
      (decr : Str_alt_decr _ g gInit)
      (xpos : 0 < snd fInit)
      (lz : Limit_zero _ g gInit cvmod),
      (ARtoCR (AltSeries cvmod decr xpos lz)
       == CRAlternatingSum.AltSeries _ g gInit cvmod decr lz)%CR.
  Proof.
    intros.
    apply regFunEq_equiv, regFunEq_e.
    intro d.
    setoid_replace (` d + ` d)%Q with (`d*(1#2) + (`d*(1#2)+` d))%Q by ring.
    apply (ball_triangle _ _ _ _ _ _ (AltSeries_raw_correct d cvmod xpos)).
    apply (AltSeries_further
             _ g gInit
             (cvmod (d * (1 # 2))%Qpos) (cvmod d)
             _ _ (d*(1#2))%Qpos d decr).
    apply lz. apply lz.
    apply app_inverse_below_correct.
    apply Qle_refl.
  Qed.

End RationalStreamSum.


Require Import Coq.Structures.DecidableTypeEx.
Require Import Coq.FSets.FMapFacts.
Require Import Category.Lib.FMapExt.
Require Import Coq.Arith.PeanoNat.

(* Override ++> notation with the crelation-based version. *)
#[local] Set Warnings "-notation-overridden".
Require Import Category.Lib.
Require Import Category.Theory.Category.

Generalizable All Variables.

(* This module defines an "arrows-only" metacategory, and shows that such a
   metacategory is sufficient to define a category. The axioms defined by Mac
   Lane are used, with the "defined set of composable pairs" and "composite
   assignments" both encoded using a key-value map provided by FMap, since
   that provides just the structure we need. Natural numbers are used to
   differentiate arrows. *)

Module PNN := PairUsualDecidableType Nat_as_DT Nat_as_DT.

Module Metacategory (M : WSfun PNN).

Module Import FMapExt := FMapExt PNN M.
Module P := FMapExt.P.
Module F := P.F.

Definition defined x y := M.In (elt:=nat) (x, y).

(* Mac Lane: "Since the objects of a metacategory correspond exactly to its
   identity arrows, it is technically possible to dispense altogether with the
   objects and deal only with arrows." *)
Record Metacategory := {
  (* "The data for an arrows-only metacategory C consist of arrows," *)
  arr := nat;

  (* "certain ordered pairs ⟨g, f⟩, called the composable pairs of arrows," *)
  pairs : M.t arr;

  (* "and an operation assigning to each composable pair ⟨g, f⟩ an arrow g∙f,
     called their composite. We say 'g∙f is defined' for '⟨g, f⟩ is a
     composable pair'". *)
  composite (f g h : arr) := M.MapsTo (f, g) h pairs;

  (* "With these data one defines an identity of C to be an arrow u such that
     f∙u = f whenever the composite f∙u is defined and u∙g = g whenever u∙g is
     defined." *)
  identity (u : arr) :=
    (∀ (f : arr), composite f u f) ∧ (∀ (g : arr), composite u g g);

  (* "The data are then required to satisfy the following three axioms:" *)

  (* First axiom: *)

  (* "The composite (k∙g)∙f is defined if and only if the composite k∙(g∙f) is
     defined. When either is defined, they are equal (and this triple
     composite is written as k∙g∙f)." *)
  composition_law (k g f kg gf : arr) :
    composite k g kg ->
    composite g f gf ->
    ∀ kgf, composite kg f kgf ↔ composite k gf kgf;

  (* Second axiom: *)

  (* "The triple composite k∙g∙f is defined whenever both composites k∙g and
     g∙f are defined." *)
  triple_composition (k g f kg gf : arr) :
    composite k g kg ->
    composite g f gf → (exists kgf : arr, composite kg f kgf)%type;

  (* Third axiom: *)

  (* "For each arrow g of C there exist identity arrows u and u' of C such
     that u'∙g and g∙u are defined." *)
  identity_law (g : arr) :
    ∃ u,  identity u  ->
    ∃ u', identity u' ->
      defined g u pairs ∧ defined u' g pairs;
}.

Definition composite_defined (M : Metacategory) (f g h : arr M) :
  composite M f g h → defined f g (pairs M) := fun H =>
  proj2 (@in_mapsto_iff _ _ _) (ex_intro _ h H).

Program Definition defined_composite (M : Metacategory) (f g : arr M) :
  defined f g (pairs M) → ∃ h : arr M, composite M f g h.
Proof.
  intro H.
  unfold defined in H.
  destruct (M.find (f, g) (pairs M)) eqn:Heqe.
  - exists n.
    apply (M.find_2 Heqe).
  - apply F.in_find_iff in H.
    contradiction.
Defined.

Lemma identity_morphism (M : Metacategory) (i : arr M) :
  identity M i → composite M i i i.
Proof. intro H; apply H. Qed.

Lemma identity_composition_between (M : Metacategory) :
  ∀ f g u,
    identity M u ->
    defined f u (pairs M) ->
    defined u g (pairs M) ->
    defined f g (pairs M).
Proof.
  intros.
  destruct H as [c c0].
  pose proof (@triple_composition M f u g f g (c f) (c0 g)) as H3;
  simpl in H3.
  destruct H3.
  apply composite_defined with (h:=x).
  exact H.
Defined.

Lemma identity_composition_left (M : Metacategory) :
  ∀ f g fg u,
    identity M u ->
    composite M f g fg ->
    defined u f (pairs M) ->
    defined u fg (pairs M).
Proof.
  intros.
  destruct H as [_ c0].
  apply composite_defined with (h:=fg); auto;
  try solve [ apply c0 ].
Qed.

Lemma identity_composition_right (M : Metacategory) :
  ∀ f g fg u,
    identity M u ->
    composite M f g fg ->
    defined g u (pairs M) ->
    defined fg u (pairs M).
Proof.
  intros.
  destruct H as [c _].
  apply composite_defined with (h:=fg); auto;
  try solve [ apply c ].
Qed.

#[local] Obligation Tactic := intros.

Program Definition FromArrows (M : Metacategory) : Category := {|
  (* The objects of the category are given by all the identity arrows of the
     arrows-only metacategory. *)
  obj := ∃ i : arr M, identity M i;

  (* The morphisms of the category from id[x] to id[y] are given by those
     arrows whose domain composes with id[x], and whose codomain composes with
     id[y]. *)
  hom := fun x y =>
    ∃ f : arr M, defined f ``x (pairs M) ∧ defined ``y f (pairs M);

  homset := fun _ _ => {| Setoid.equiv := fun f g => `1 f = `1 g |}
|}.
Next Obligation.
  equivalence; simpl in *; subst; reflexivity.
Qed.
Next Obligation.                (* id *)
  destruct x as [i [Hil Hir]].
  exists i.
  split; apply composite_defined with (h:=i); auto;
  try solve [ apply Hil
            | apply Hir ].
Defined.
Next Obligation.                (* compose *)
  destruct x as [x x_id];
  destruct y as [y y_id];
  destruct z as [z z_id];
  destruct f as [f [fl fr]];
  destruct g as [g [gl gr]]; simpl in *.
  pose proof (identity_composition_between M f g y y_id fl gr).
  destruct (defined_composite _ _ _ H) as [fg Hfg].
  exists fg; split.
  - eapply identity_composition_right; eauto.
  - eapply identity_composition_left; eauto.
Defined.
Next Obligation.
  proper.
  unfold FromArrows_obligation_3; simpl in *; subst.
  destruct (defined_composite _ _ _); reflexivity.
Qed.
Next Obligation.
  unfold FromArrows_obligation_3; simpl.
  destruct x, y, f, i as [c c0], i0 as [c1 c2], p; simpl in *; subst.
  destruct (defined_composite _ _ _) as [x2 c3].
  pose proof (c2 x1).
  unfold composite in c3, H.
  apply (FMapExt.F.MapsTo_fun c3 H).
Qed.
Next Obligation.
  unfold FromArrows_obligation_3; simpl.
  destruct x, y, f, i as [c c0], i0 as [c1 c2], p; simpl in *; subst.
  destruct (defined_composite _ _ _) as [x2 c3].
  pose proof (c x1).
  unfold composite in c3, H.
  apply (FMapExt.F.MapsTo_fun c3 H).
Qed.
Next Obligation.
  unfold FromArrows_obligation_3; simpl.
  destruct x as [x [xl_id xr_id]];
  destruct y as [y [yl_id yr_id]];
  destruct z as [z [zl_id zr_id]];
  destruct w as [w [wl_id wr_id]];
  destruct f as [f [fl fr]];
  destruct g as [g [gl gr]];
  destruct h as [h [hl hr]];
  simpl in *.
  repeat destruct (defined_composite _ _ _).
  unfold composite in *.
  pose proof (fst (composition_law M f g h x2 x0 c1 c x3) c2).
  simpl in H.
  apply (FMapExt.F.MapsTo_fun c0 H).
Qed.
Next Obligation.
  symmetry.
  unfold FromArrows_obligation_3; simpl.
  destruct x as [x [xl_id xr_id]];
  destruct y as [y [yl_id yr_id]];
  destruct z as [z [zl_id zr_id]];
  destruct w as [w [wl_id wr_id]];
  destruct f as [f [fl fr]];
  destruct g as [g [gl gr]];
  destruct h as [h [hl hr]];
  simpl in *.
  repeat destruct (defined_composite _ _ _).
  unfold composite in *.
  pose proof (fst (composition_law M f g h x2 x0 c1 c x3) c2).
  simpl in H.
  apply (FMapExt.F.MapsTo_fun c0 H).
Qed.

Notation "[map ]" := (M.empty _) (at level 9, only parsing).
Notation "x +=> y" := (M.add x y) (at level 9, only parsing).
Notation "[map  a ; .. ; b ]" := (a .. (b [map]) ..) (only parsing).

Ltac structure :=
  simpl in *;
  repeat (
    match goal with
    | [ H : (_, _) = (_, _) |- _ ] => inversion H; clear H; subst
    | [ |- ?X = ?Y → False ] =>
      let H := fresh "H" in
      intro H; inversion H; tauto
    | [ H : M.MapsTo _ _ _ |- _ ] => simplify_maps
    | [ |- M.MapsTo _ _ _ ] => simplify_maps
    | [ |- _ ↔ _ ] => split; intros
    | [ |- _ /\ _ ] => split
    | [ |- _ \/ _ ] => solve [ left; structure | right; structure ]
    end; intuition idtac; try congruence).

Ltac check_structure :=
  first [ unfold defined;
          repeat (unshelve eexists; try assumption; intros []);
          split; apply in_mapsto_iff;
          eexists; intuition
        | unshelve (structure; eexists; structure); exact 0%nat
        | structure ].

#[local] Obligation Tactic := program_simpl; check_structure.

Program Definition ZeroArrows : Metacategory := {|
  pairs := [map]
|}.

Program Definition OneArrow : Metacategory := {|
  pairs := [map (0, 0) +=> 0 ]%nat
|}.

Program Definition TwoArrows : Metacategory := {|
  pairs := [map (0, 0) +=> 0
           ;    (1, 1) +=> 1

           ;    (0, 2) +=> 2
           ;    (2, 1) +=> 2 ]%nat
|}.

Program Definition ThreeArrows : Metacategory := {|
  pairs := [map (0, 0) +=> 0
           ;    (1, 1) +=> 1
           ;    (2, 2) +=> 2

           ;    (0, 3) +=> 3
           ;    (3, 1) +=> 3

           ;    (1, 4) +=> 4
           ;    (4, 2) +=> 4

           ;    (3, 4) +=> 5

           ;    (0, 5) +=> 5
           ;    (5, 2) +=> 5 ]%nat
|}.

Definition Three : Category := FromArrows ThreeArrows.

Definition cardinality (M : Metacategory) : nat :=
  M.cardinal (P.filter (fun '(dom, cod) v =>
                          ((dom =? v)%nat && (cod =? v)%nat)%bool)
                       (pairs M)).

Lemma elements_filter {elt} (m : M.t elt) (P : M.key → elt → bool) :
  M.elements (P.filter P m)
    = filter (fun p => P (fst p) (snd p)) (M.elements m).
Proof.
  unfold P.filter.
  apply P.fold_rec; intros.
  - rewrite (proj1 (P.elements_Empty m0) H); simpl.
    apply P.elements_empty.
  - destruct (P k e) eqn:Heqe.
    + apply add_equal_iff in H1.
Abort.

Lemma length_elements_filter {elt} (m : M.t elt) k v (P : M.key * elt → bool) :
  length (filter P (M.elements (M.add k v m)))
    = length (filter P ((k, v) :: M.elements m)).
Proof.
Abort.

Theorem elements_rect {elt} (P : list (M.key * elt) → Type) :
  (∀ m1 m2, M.Equal m1 m2 → P (M.elements m1) → P (M.elements m2))
  → ∀ m k v, P ((k, v) :: M.elements m) → P (M.elements (M.add k v m)).
Proof.
Abort.

(* jww (2017-06-10): This needs automation. A computational tactic that
   reflects on map structures would be valuable here, since we are computing
   on known results. *)
Lemma ThreeArrows_card_3 : cardinality ThreeArrows = 3%nat.
Proof.
  (* unfold cardinality; simpl. *)
  (* rewrite M.cardinal_1. *)
  (* rewrite elements_filter. *)
  (* apply elements_rect; simpl; intros. *)
  assert (P.transpose_neqkey
            M.Equal
            (λ (k : M.key) (e : nat) (m : M.t nat),
             if (let '(dom, cod) := k in
                 λ v : nat, (dom =? v)%nat && (cod =? v)%nat) e
             then k +=> e m
             else m)). {
    intros ??????.
    destruct k, k'.
    assert (n ≠ n1 \/ n0 ≠ n2). {
      destruct (Nat.eq_dec n n1); subst.
      - right; congruence.
      - left; assumption.
    }
    destruct ((n =? e)%nat && (n0 =? e)%nat) eqn:Heqe.
    - apply andb_true_iff in Heqe.
      destruct Heqe.
      apply Nat.eqb_eq in H1.
      apply Nat.eqb_eq in H2.
      subst.
      destruct ((n1 =? e')%nat && (n2 =? e')%nat) eqn:Heqe2.
      * apply andb_true_iff in Heqe2.
        destruct Heqe2.
        apply Nat.eqb_eq in H1.
        apply Nat.eqb_eq in H2.
        subst.
        apply add_associative.
        intros; congruence.
      * reflexivity.
    - destruct ((n1 =? e')%nat && (n2 =? e')%nat) eqn:Heqe2.
      * apply andb_true_iff in Heqe2.
        destruct Heqe2.
        apply Nat.eqb_eq in H1.
        apply Nat.eqb_eq in H2.
        subst.
        reflexivity.
      * reflexivity.
  }

  assert (Proper (eq ==> eq ==> M.Equal ==> M.Equal)
                 (λ (k : M.key) (e : nat) (m : M.t nat),
                  if (let '(dom, cod) := k in
                      λ v : nat, (dom =? v)%nat && (cod =? v)%nat) e
                  then k +=> e m
                  else m)). {
    intros ?????????.
    destruct x, y; subst.
    inversion H0; clear H0; subst.
    destruct ((n1 =? y0)%nat && (n2 =? y0)%nat) eqn:Heqe.
    - apply andb_true_iff in Heqe.
      destruct Heqe.
      apply Nat.eqb_eq in H0.
      apply Nat.eqb_eq in H1.
      subst.
      rewrite H2; reflexivity.
    - assumption.
  }

  unfold cardinality; simpl.
  unfold P.filter; simpl.
  repeat (rewrite P.fold_add; eauto; relational; simpl);
  try (apply not_in_mapsto_iff; intros;
       repeat (unfold not; intros; simplify_maps; try congruence)).
  rewrite P.fold_Empty; auto; [| apply M.empty_1 ].

  assert (P.transpose_neqkey eq (λ (_ : M.key) (_ : nat), S)) by proper.

  rewrite P.cardinal_fold.
  repeat (rewrite P.fold_add; eauto; relational; simpl);
  try (apply not_in_mapsto_iff; intros;
       repeat (unfold not; intros; simplify_maps; try congruence)).
  rewrite P.fold_Empty; auto; apply M.empty_1.
Qed.

(* Definition objects_of (M : Metacategory) : *)
(*   ∀ P : nat → Type, P 0%nat → (∀ n : nat, P n → P (S n)) → ∀ n : nat, P n *)

#[local] Obligation Tactic := program_simpl.

(*
Program Definition FromThree {C : Category} (c : C) : Three ⟶ C := {|
  fobj := fun x =>
   match x with
   | existT _ 0%nat _ => c
   | existT _ 1%nat _ => c
   | existT _ 2%nat _ => c
   | _ => False_rect _ _
   end
|}.
Next Obligation.
  destruct x. specialize (H1 X); contradiction.
  destruct x. specialize (H X); contradiction.
  destruct x. specialize (H0 X); contradiction.
  destruct X.
  pose proof (c0 0%nat).
  unfold composite in H2; simpl in H2.
  simplify_maps. structure.
  simplify_maps. structure.
  simplify_maps. structure.
  simplify_maps. discriminate.
  simplify_maps. structure.
  simplify_maps. structure.
  simplify_maps. structure.
  simplify_maps. structure.
  simplify_maps. discriminate.
  simplify_maps. structure.
Qed.
*)

End Metacategory.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2015   --   INRIA - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.Abs.

(* Why3 goal *)
Definition div: Z -> Z -> Z.
intros x y.
case (Z_le_dec 0 (Zmod x y)) ; intros H.
exact (Zdiv x y).
exact (Zdiv x y + 1)%Z.
Defined.

(* Why3 goal *)
Definition mod1: Z -> Z -> Z.
intros x y.
exact (x - y * div x y)%Z.
Defined.

(* Why3 goal *)
Lemma Div_mod : forall (x:Z) (y:Z), (~ (y = 0%Z)) -> (x = ((y * (div x
  y))%Z + (mod1 x y))%Z).
intros x y Zy.
unfold mod1, div.
case Z_le_dec ; intros H ; ring.
Qed.

(* Why3 goal *)
Lemma Mod_bound : forall (x:Z) (y:Z), (~ (y = 0%Z)) -> ((0%Z <= (mod1 x
  y))%Z /\ ((mod1 x y) < (ZArith.BinInt.Z.abs y))%Z).
intros x y Zy.
zify.
assert (H1 := Z_mod_neg x y).
assert (H2 := Z_mod_lt x y).
unfold mod1, div.
case Z_le_dec ; intros H0.
rewrite Zmult_comm, <- Zmod_eq_full with (1 := Zy).
omega.
replace (x - y * (x / y + 1))%Z with (x - x / y * y - y)%Z by ring.
rewrite <- Zmod_eq_full with (1 := Zy).
omega.
Qed.

(* Why3 goal *)
Lemma Div_unique : forall (x:Z) (y:Z) (q:Z), (0%Z < y)%Z ->
  ((((q * y)%Z <= x)%Z /\ (x < ((q * y)%Z + y)%Z)%Z) -> ((div x y) = q)).
intros x y q h1 (h2,h3).
assert (h:(~(y=0))%Z) by omega.
generalize (Mod_bound x y h); intro h0.
rewrite Z.abs_eq in h0; auto with zarith.
generalize (Div_mod x y h); clear h; intro h.
assert (cases:(div x y = q \/ (div x y <= q - 1 \/ div x y >= q+1))%Z) by omega.
destruct cases as [h4 | [h5 | h6]]; auto.
assert (y * div x y <= y * (q - 1))%Z.
 apply  Zmult_le_compat_l; auto with zarith.
replace (y*(q-1))%Z with (q*y - y)%Z in H by ring.
elimtype False.
omega.
assert (y * div x y >= y * (q + 1))%Z.
 apply  Zmult_ge_compat_l; auto with zarith.
replace (y*(q+1))%Z with (q*y + y)%Z in H by ring.
elimtype False.
omega.
Qed.

(* Why3 goal *)
Lemma Div_bound : forall (x:Z) (y:Z), ((0%Z <= x)%Z /\ (0%Z < y)%Z) ->
  ((0%Z <= (div x y))%Z /\ ((div x y) <= x)%Z).
intros x y (Hx,Hy).
unfold div.
case Z_le_dec ; intros H.
split.
apply Z_div_pos with (2 := Hx).
now apply Zlt_gt.
destruct (Z_eq_dec y 1) as [H'|H'].
rewrite H', Zdiv_1_r.
apply Zle_refl.
rewrite <- (Zdiv_1_r x) at 2.
apply Zdiv_le_compat_l with (1 := Hx).
omega.
elim H.
apply Z_mod_lt.
now apply Zlt_gt.
Qed.

(* Why3 goal *)
Lemma Mod_1 : forall (x:Z), ((mod1 x 1%Z) = 0%Z).
intros x.
unfold mod1, div.
rewrite Zmod_1_r, Zdiv_1_r, Zmult_1_l.
apply Zminus_diag.
Qed.

(* Why3 goal *)
Lemma Div_1 : forall (x:Z), ((div x 1%Z) = x).
intros x.
unfold div.
now rewrite Zmod_1_r, Zdiv_1_r.
Qed.

(* Why3 goal *)
Lemma Div_inf : forall (x:Z) (y:Z), ((0%Z <= x)%Z /\ (x < y)%Z) -> ((div x
  y) = 0%Z).
intros x y Hxy.
unfold div.
case Z_le_dec ; intros H.
now apply Zdiv_small.
elim H.
now rewrite Zmod_small.
Qed.

(* Why3 goal *)
Lemma Div_inf_neg : forall (x:Z) (y:Z), ((0%Z < x)%Z /\ (x <= y)%Z) ->
  ((div (-x)%Z y) = (-1%Z)%Z).
intros x y Hxy.
assert (h: (x < y \/ x = y)%Z) by omega.
destruct h.
(* case 0 < x < y *)
assert (h1: (x mod y = x)%Z).
  rewrite Zmod_small; auto with zarith.
assert (h2: ((-x) mod y = y - x)%Z).
  rewrite Z_mod_nz_opp_full.
  rewrite h1; auto.
rewrite h1; auto with zarith.
unfold div.
case Z_le_dec; auto with zarith.
intros h3.
rewrite Z_div_nz_opp_full; auto with zarith.
rewrite Zdiv_small; auto with zarith.

(* case x = y *)
subst.
assert (h1: (y mod y = 0)%Z).
  rewrite Z_mod_same_full; auto with zarith.
assert (h2: ((-y) mod y = 0)%Z).
  rewrite Z_mod_zero_opp_full; auto with zarith.
unfold div.
case Z_le_dec; rewrite h2; auto with zarith.
intro.
rewrite Z_div_zero_opp_full; auto with zarith.
rewrite Z_div_same_full; auto with zarith.
Qed.

(* Why3 goal *)
Lemma Mod_0 : forall (y:Z), (~ (y = 0%Z)) -> ((mod1 0%Z y) = 0%Z).
intros y Hy.
unfold mod1, div.
rewrite Zmod_0_l.
simpl.
now rewrite Zdiv_0_l, Zmult_0_r.
Qed.

(* Why3 goal *)
Lemma Div_1_left : forall (y:Z), (1%Z < y)%Z -> ((div 1%Z y) = 0%Z).
intros y Hy.
rewrite Div_inf; auto with zarith.
Qed.

(* Why3 goal *)
Lemma Div_minus1_left : forall (y:Z), (1%Z < y)%Z -> ((div (-1%Z)%Z
  y) = (-1%Z)%Z).
intros y Hy.
unfold div.
assert (h1: (1 mod y = 1)%Z).
apply Zmod_1_l; auto.
assert (h2: ((-(1)) mod y = y-1)%Z).
  rewrite Z_mod_nz_opp_full; auto with zarith.
case Z_le_dec; auto with zarith.
intro.
rewrite Z_div_nz_opp_full; auto with zarith.
rewrite Zdiv_small; auto with zarith.
Qed.

(* Why3 goal *)
Lemma Mod_1_left : forall (y:Z), (1%Z < y)%Z -> ((mod1 1%Z y) = 1%Z).
intros y Hy.
unfold mod1.
rewrite Div_1_left; auto with zarith.
Qed.

(* Why3 goal *)
Lemma Mod_minus1_left : forall (y:Z), (1%Z < y)%Z -> ((mod1 (-1%Z)%Z
  y) = (y - 1%Z)%Z).
intros y Hy.
unfold mod1.
rewrite Div_minus1_left; auto with zarith.
Qed.

Open Scope Z_scope.

(* Why3 goal *)
Lemma Div_mult : forall (x:Z) (y:Z) (z:Z), (0%Z < x)%Z ->
  ((div ((x * y)%Z + z)%Z x) = (y + (div z x))%Z).
intros x y z h.
unfold div.
destruct (Z_le_dec 0 (z mod x)).
destruct (Z_le_dec 0 ((x*y+z) mod x)).
rewrite Zmult_comm.
rewrite Z_div_plus_full_l; auto with zarith.
generalize (Z_mod_lt (x * y + z) x); auto with zarith.
generalize (Z_mod_lt z x); auto with zarith.
Qed.

(* Why3 goal *)
Lemma Mod_mult : forall (x:Z) (y:Z) (z:Z), (0%Z < x)%Z ->
  ((mod1 ((x * y)%Z + z)%Z x) = (mod1 z x)).
intros x y z h.
unfold mod1.
rewrite Div_mult.
ring.
auto with zarith.
Qed.


Require Import GeoCoq.Axioms.continuity_axioms.
Require Import GeoCoq.Meta_theory.Continuity.first_order.
Require Import GeoCoq.Meta_theory.Continuity.first_order_dedekind_circle_circle.
Require Import GeoCoq.Meta_theory.Continuity.elementary_continuity_props.
Require Import GeoCoq.Tarski_dev.Ch05_bet_le.

Section Tarski_continuous_to_TRC.

Context `{TC:Tarski_continuous}.

Instance TC_to_TRC : Tarski_ruler_and_compass TnEQD.
Proof.
  split.
  apply circle_circle_bis__circle_circle_axiom, circle_circle__circle_circle_bis, fod__circle_circle, dedekind__fod.
  unfold dedekind_s_axiom.
  exact continuity.
Defined.

End Tarski_continuous_to_TRC.


(**
# 第9回 タクティックの定義と利用/停止性証明 (2014/06/08)

http://qnighy.github.io/coqex2014/

## 課題44 (種別:C / 締め切り : 2014/06/29)

課題42で証明したlog関数に関する性質を証明せよ。
*)

Require Import ssreflect ssrbool ssrnat div eqtype.
Require Import Recdef.

(*
Require Import Arith.
Require Import Omega.
Require Import Recdef.
*)

Require Import Lt.

(*
 well_founded lt を示す定理が見つからない。
 これは、Coq'n art の一部
 *)
Theorem lt_Acc : forall n:nat, Acc lt n.
Proof.
 induction n.
 split; intros p H; inversion H.
 split.
 intros y H0.
 case (le_lt_or_eq _ _ H0).
 intro; apply Acc_inv with n; auto with arith.
 intro e; injection e; intro e1; rewrite e1; assumption.
Qed.

Function log (n:nat) {wf lt n} :=
  match n with
    | 0 => 0
    | 1 => 0
    | n => (log (n %/ 2)).+1
  end.
Proof.
  + move=> n2 n1 n Hn1 Hn2.
    rewrite -!Hn2.
    apply/leP.
    apply ltn_Pdiv.
      - by [].
      - by rewrite Hn2.
  + rewrite /well_founded.
    by apply lt_Acc.
Qed.

(* ここまでは課題42 *)

Fixpoint pow (n:nat) :=
  match n with
    | O => 1
    | n'.+1 => 2 * pow n'
  end.

Lemma pown1_2pown : forall n, pow n.+1 = 2 * pow n.
Proof.
  by [].
Qed.

Lemma mn2__2mn : forall n m, (m <= n %/ 2) = (2 * m <= n).
Proof.
  move=> n m.
  rewrite leq_divRL.
  + by rewrite -mulnC.
  + by [].
Qed.

Lemma mn2_2mn : forall n m, m <= n %/ 2 -> 2 * m <= n.
Proof.
  move=> n m H.
  have Hmn : forall n m, (m <= n %/ 2) = (2 * m <= n)
                         by apply mn2__2mn.
  case Hmn.
  by [].
Qed.

Lemma np2d2_nd2p1 : forall n, (n + 2) %/ 2 = (n %/ 2) + 1.
Proof.
  move=> n.
  rewrite divnDr.
  have H : 2 %/ 2 = 1 by rewrite //.
  + by rewrite H.
  + by [].
Qed.

Lemma log_pow_lb: forall n, 1 <= n -> pow (log n) <= n.
Proof.
  move=> n H.
  functional induction (log n).
  + by [].                                  (* pow 0 <= 0 *)
  + by [].                                  (* pow 0 <= 1 *)
  + rewrite pown1_2pown.
    apply mn2_2mn.
    apply IHn0.
    destruct n.
    - inversion H.
    - destruct n.
      * inversion y.
      * rewrite -addn2.
        rewrite np2d2_nd2p1.
        apply ltn_addl.
        by [].
Qed.

(**
ヒント

functional inductionタクティックを使うと、Functionで定義した計算の構造に従う帰納法を行うことができます。
*)

(* END *)


Require FSets.
Require FSetFacts.
Require Import Sumbool.

Module Make (F: FSetInterface.S).

  Module Facts  := FSetFacts.Facts F.
  Module Properties := FSetProperties.Properties F.
  Module Dep := FSetBridge.DepOfNodep F.

  Section Eq.
    Variable x: F.E.t.
    Variable x': F.E.t.
    Variable A: F.t.
    Variable A': F.t.
    Variable B: F.t.
    Variable B': F.t.

    (* added for Coq 8.2, I don't know why unfolding Add goes past E.eq *)
    Theorem Add_unfold : Properties.Add x A A' -> forall x', F.In x' A' <->  F.In x' A \/ F.E.eq x x'.
    Proof.
      intros.
      unfold Properties.Add in *.
      split; intros;
      generalize (H x'0);
      intros;
      destruct H1;
      tauto.
    Qed.

    Theorem FSetAdd_Eq:
      F.add x A = F.add x' A -> F.E.eq x x' \/ F.In x A.
    Proof.
      intros H.
      generalize (Properties.Add_add A x'); unfold Properties.Add; intros H0.
      generalize (H0 x); intro H1.
      destruct H1 as [H1 H2].
      rewrite <- H in H1.
      generalize (F.E.eq_refl x). intros H3.
      generalize (F.add_1 A H3). intros H4.
      generalize (H1 H4). intros H5.
      destruct H5;
        eauto with *.
    Qed.

    Theorem add_eq_edges:
      F.E.eq x x'-> F.Equal (F.add x A) (F.add x' A).
    Proof.
      intros.
      auto with *.
    Qed.

    Theorem Add_eq_complete: F.E.eq x x' -> F.Equal A A' -> F.Equal B B' -> Properties.Add x A B -> Properties.Add x' A' B'.
    Proof.
      intros H3 H H0 H1.
      unfold Properties.Add in *.
      split;
        unfold F.Equal in *;
          generalize (H y); generalize (H0 y); generalize (H1 y); intros H6 H7 H8;
            destruct H6; destruct H7; destruct H8;
              intros; intuition eauto.
    Qed.

    Theorem Add_eq_full: F.Equal A A' -> F.Equal B B' -> Properties.Add x A B -> Properties.Add x A' B'.
    Proof.
      intros H H0 H1.
      unfold Properties.Add in *.
      split;
        unfold F.Equal in *;
          generalize (H y); generalize (H0 y); generalize (H1 y); intros H6 H7 H8;
            destruct H6; destruct H7; destruct H8;
              intros; intuition auto.
    Qed.

    Theorem Add_eq: F.Equal B B' -> Properties.Add x A B -> Properties.Add x A B'.
    Proof.
      intros H H0.
      unfold Properties.Add in *.
      split;
        unfold F.Equal in *;
          generalize (H y); generalize (H0 y); intros H1 H2 H3;
            destruct H1; destruct H2; auto.
    Qed.

    Theorem Eq_Add_Add: F.Equal A A' -> Properties.Add x A B -> Properties.Add x A' B.
    Proof.
      intros.
      unfold Properties.Add in *.
      unfold F.Equal in *.
      intros.
      generalize (H0 y); intros H1; destruct H1.
      generalize (H y); intros H3; destruct H3.
      split; intuition eauto.
    Qed.

    Theorem Add_Add: F.E.eq x x' -> Properties.Add x A B -> Properties.Add x' B B' -> F.Equal B B'.
    Proof.
      intros.
      intro e.
      generalize (H0 e); intros H0'.
      eapply iff_trans; [eapply H0'| clear H0'].
      generalize (H1 e); intros H1'.
      eapply iff_sym; eapply iff_trans; [eapply H1'|clear H1'].
      unfold Properties.Add in H0.
      case (F.E.eq_dec e x); intros Heq; intuition; eauto; right;
      generalize (H0 e); intros H0'; intuition; eapply F.E.eq_sym in H2; contradiction.
    Qed.

    Theorem In_eq_full: F.Equal A A' -> F.In x A -> F.In x A'.
    Proof.
      intros H H0.
      unfold F.Equal in H.
      generalize (H x). intros H1.
      destruct H1 as [H1 H2].
      intuition.
    Qed.

    Theorem Eq_Add_complete: F.E.eq x x' -> F.Equal A A' -> Properties.Add x A B -> Properties.Add x' A' B' -> F.Equal B B'.
    Proof.
      intros H9 H H0 H1.
      unfold Properties.Add in *; unfold F.Equal in *.
      intros.
      split;
        generalize (H0 a); intro H2;
          generalize (H1 a); intro H3;
            generalize (H a); intro H4;
              destruct H2; destruct H3; destruct H4;
                intuition eauto.
    Qed.

    Theorem Eq_Add: F.Equal A A' -> Properties.Add x A B -> Properties.Add x A' B' -> F.Equal B B'.
    Proof.
      intros.
      unfold Properties.Add in *; unfold F.Equal in *.
      intros.
      split;
        generalize (H0 a); intro H2;
          generalize (H1 a); intro H3;
            generalize (H a); intro H4;
              destruct H2; destruct H3; destruct H4;
                intuition eauto.
    Qed.

    Theorem Add_equal: Properties.Add x A B -> Properties.Add x' A B -> F.E.eq x x' \/ F.In x' A.
    Proof.
      intros.
      unfold Properties.Add in *.
      generalize (H x'); intro H1.
      destruct H1 as [H1 H2].
      generalize (H0 x'); intro H3.
      destruct H3 as [H3 H4].
      eauto.
    Qed.

    Theorem Add_Eq_Add: Properties.Add x A B -> F.E.eq x x' -> Properties.Add x' A B.
    Proof.
      intros.
      unfold Properties.Add in *.
      intro y.
      generalize (H y).
      intro H1.
      destruct H1.
      split.

      intro H3.
      generalize (H1 H3). intro H4.
      destruct H4; eauto.

      intro H3.
      apply H2.
      destruct H3; eauto.
    Qed.

    Theorem In_Add: F.In x A -> F.Equal A B -> Properties.Add x A B.
    Proof.
      intros HinX Heq.
      unfold Properties.Add in *.
      intros y.
      unfold F.Equal in *.
      split.
      intros HinY.
      right.
      generalize (Heq y); intros Htmp; destruct Htmp as [HyA HyB]; eauto.

      intros Hand.
      destruct Hand as [HeqXY | HinYA];
        generalize (Heq y); intros Htmp; destruct Htmp as [HinYAi HinYBi]; eauto;
          apply HinYAi;
            generalize (Facts.In_eq_iff A HeqXY); intros Htmp; destruct Htmp; eauto.
    Qed.

    Theorem Add_Subset:
      forall a b e,
        Properties.Add e a b -> F.Subset a b.
    Proof.
      intros.
      unfold Properties.Add in *.
      unfold F.Subset.
      intro.
      generalize (H a0). intro.
      destruct H0.
      auto with sets.
    Qed.
    Hint Resolve Add_Subset.

    Theorem Subset_Add : F.Subset A B -> Properties.Add x A A' -> Properties.Add x B B' ->
      Properties.Add x' A A' -> Properties.Add x' B B'.
    Proof.
      intros H H0 H1 H2.
      unfold F.Subset in H.
      unfold Properties.Add in *. intros y.
      split; intros H3;
        generalize (H y); generalize (H0 y); generalize (H1 y); generalize (H2 y); intros H4 H5 H6 H7;
          destruct H6; destruct H5; destruct H4; intuition auto.
    Qed.

    Theorem Add_lub: Properties.Add x A A' -> Properties.Add x' A' B -> Properties.Add x' A B' ->
      Properties.Add x B' B.
    Proof.
      intros Haa' Ha'b Hab'.
      unfold Properties.Add in *; intros; split; intros;
        generalize (Haa' y) (Ha'b y) (Hab' y); intros H1 H2 H3;
          destruct H1; destruct H2; destruct H3;
            intuition eauto.
    Qed.

    Theorem DepAdd_iff_Add: Properties.Add x A B <-> Dep.Add x A B.
    Proof.
      intuition.
    Qed.

    Theorem Add_In : F.E.eq x x' -> Properties.Add x A B -> F.In x' B.
    Proof.
      intuition.
      generalize (H0 x').
      intros H1; destruct H1 as [H1 H2].
      apply H2; auto.
    Qed.

  End Eq.

    Theorem Add_add: forall x A A', Properties.Add x A A' <-> F.Equal (F.add x A) A'.
    Proof.
      intros; split; intros.

      unfold Properties.Add in *.
      unfold F.Equal.
      intros.
      generalize (H a). intros.
      destruct H0.
      split; Facts.set_iff; trivial.

      eapply Add_eq.
      apply H.
      apply Properties.Add_add.
    Qed.

  Section add_dec.
    Variable x: F.E.t.
    Variable x': F.E.t.
    Variable A: F.t.
    Variable A': F.t.

    Theorem Add_dec: { Properties.Add x A A' } + { ~ Properties.Add x A A' }.
    Proof.
      generalize (Dep.add x A).
      intros Hdep.
      case Hdep; clear Hdep; intros C Hdep.
      generalize (DepAdd_iff_Add x A C); intros Hadd; destruct Hadd as [Hadd1 Hadd2].
      generalize (Dep.equal C A'); intros Ha'.
      intuition.

      left.
      apply Add_eq with C; auto.

      right.
      intuition.
      apply b.
      apply Eq_Add with x A A; auto.
      apply F.eq_refl.
    Qed.

    Theorem compat_P_Add: SetoidList.compat_P F.E.eq (fun x => Properties.Add x A A').
    Proof.
      unfold SetoidList.compat_P; unfold Morphisms.Proper; unfold Morphisms.respectful; unfold Basics.impl; intros.
      eapply Add_Eq_Add; eauto.
    Qed.

    Theorem compat_op_add: SetoidList.compat_op F.E.eq F.eq F.add.
    Proof.
      unfold SetoidList.compat_op;unfold Morphisms.Proper; unfold Morphisms.respectful; intros.
      eapply Eq_Add_complete; eauto.
    Qed.

  End add_dec.

  Section add.

    Variable x: F.E.t.
    Variable x': F.E.t.
    Variable A: F.t.
    Variable A': F.t.
    Variable B : F.t.

    Theorem Addx_dec: let Addx := (fun x => Properties.Add x A A') in
      forall x:F.E.t, {Addx x} + {~ Addx x}.
    Proof.
      simpl; intros.
      apply Add_dec.
    Qed.

    Theorem exists_Add_dec: { F.Exists (fun x => Properties.Add x A A') A } +
      { ~ F.Exists (fun x => Properties.Add x A A') A }.
    Proof.
      generalize (compat_P_Add A A'); intros H.
      generalize (Dep.exists_ Addx_dec A); intros H2.
      destruct H2; intuition.
    Qed.

    Theorem add_equal_complete:
      F.Equal A A' -> F.E.eq x x' -> F.Equal (F.add x A) (F.add x' A').
    Proof.
      intros.
      generalize (Properties.Add_add A x); generalize (Properties.Add_add A' x'); intros.
      eapply Eq_Add_complete; eauto.
    Qed.

    Theorem elim_In_add: F.In x A -> F.In x (F.add x' A).
    Proof.
      intros Hin.
      Facts.set_iff.
      right.
      trivial.
    Qed.

    Theorem Add_Equal : F.E.eq x x' -> F.In x A -> Properties.Add x' A B -> F.Equal A B.
    Proof.
      intros.
      apply F.In_1 with (x:=x) (y:=x') in H0; auto.
      generalize (Properties.Add_add A x'); intros.
      apply Eq_Add with (A:=A) (B:=B) in H2;[|apply Properties.equal_refl|auto].
      generalize (Properties.add_equal H0); intros.
      eapply Properties.equal_sym.
      eapply Properties.equal_trans; [apply H2 | apply H3].
    Qed.

    (* push this over to FSetAddEq.v *)
    Theorem In_nIn_neq :
      F.In x A -> ~ F.In x' A -> ~ F.E.eq x x'.
    Proof.
      intros.
      red. intros. apply H0.
      apply F.In_1 with x; auto.
    Qed.

    (* push to FSetAddEq.v *)
    Theorem In_remove_neq :
      F.In x (F.remove x' A) -> ~ F.E.eq x x'.
    Proof.
      intros.
      red; intros.
      apply F.E.eq_sym in H0.
      eapply F.remove_1. apply H0. apply H.
    Qed.

  End add.

  Section remove.

    Theorem Add_remove_Equal: forall edge A A',
      Properties.Add edge A A' -> ~ F.In edge A -> F.Equal A (F.remove edge A').
    Proof.
      intros.
      split; intros.
      generalize (In_nIn_neq _ _ _ H1 H0); intros Hneq.
      apply F.remove_2; auto.
      generalize (H a); intros Hadd; destruct Hadd.
      apply H3; auto.
      (* converse *)
      intros.
      generalize (In_remove_neq _ _ _ H1); intros Hneq.
      generalize (F.remove_3 H1); intros HinA'.
      generalize (H a); intros Hadd; destruct Hadd.
      apply H2 in HinA'.
      destruct HinA'; auto.
      red in Hneq.
      generalize (F.E.eq_sym H4). intros; auto.
      apply Hneq in H5.
      contradiction.
    Qed.

  End remove.

  Section union.
   (* This might have been proved using AGAddEq.Subset_fold_add_Equal,
      instantiating (AG.fold AG.add B A) for (AG.union A (AG.diff B A)),
      but this would still require induction to prove *)

   Theorem subset_union_diff : forall A B, F.Subset A B ->
     F.Equal B ((fun A => (F.union A (F.diff B A))) A).
   Proof.
     intros.
     eapply F.eq_trans;[ eapply F.eq_sym;eapply Properties.diff_inter_all |].
     rewrite Properties.inter_sym;
       rewrite Properties.inter_subset_equal; [rewrite Properties.union_sym; apply F.eq_refl|eauto].
   Qed.

   Hint Resolve subset_union_diff.
 End union.

  Section Add_Eq_eq.

    Theorem Add_neq_iff x x' A B: ~ F.E.eq x x' -> Properties.Add x A B ->
      (F.In x' B <-> F.In x' A).
    Proof.
      intros.
      generalize (H0 x'); intros.
      intuition.
    Qed.

    Theorem Add_neq_iff2 x x' A A' B B' :
      ~ F.E.eq x x' ->
      F.Equal A A' -> F.Equal B B' ->
      Properties.Add x A B -> (F.In x' B' <-> F.In x' A).
    Proof.
      intros.
      generalize (H2 x'); intros.
      generalize (H0 x'); intros.
      generalize (H1 x'); intros.
      intuition.
    Qed.

    Theorem double_add_eq A A' B B' x x': ~ F.In x A ->
      F.Equal A A' -> F.Equal B B' ->
      Properties.Add x A B -> Properties.Add x' A' B' ->
        F.E.eq x x'.
    Proof.
      intros.
      case (F.E.eq_dec x x'); intros; auto.
      assert (~ F.E.eq x' x); auto.
      case (Properties.In_dec x B'); intros.
      (* In x B' *)
      generalize (Add_neq_iff _ _ _ _ H4 H3); intros.
      destruct H5.
      generalize (H0 x); intros H7; destruct H7.
      intuition.
      (* ~ In x B' *)
      generalize (Add_neq_iff _ _ _ _ H4 H3); intros.
      generalize (H1 x); intros.
      generalize (H2 x); intros.
      generalize (F.E.eq_refl x); intros.
      intuition.
    Qed.

  End Add_Eq_eq.

  Section fold.

    Theorem subset_fold_subset: forall A A',
      F.Subset A A' -> F.Subset (F.fold F.add A' A) A'.
    Proof.
      intros A A' Hsub.
      eapply Properties.fold_rec_bis with
        (P:= fun (s a :F.t) => (F.Subset a A'));
 intros.
      (* equiv *)
      eauto.
      (* base *)
      eauto.
      (* step *)
      eapply Properties.subset_add_3; auto.
    Qed.

    Hint Resolve subset_fold_subset.

  (* problem, that proof was not dependent *)

    Theorem subset_fold_add_subset_2: forall A A',
      F.Subset A A' -> F.Subset A' (F.fold F.add A' A).
    Proof.
      intros A A' Hsub.
      eapply Properties.fold_rec_bis with
        (P:= fun (s a :F.t) => F.Subset s a);
 intros.
      (* equiv *)
      eapply F.eq_sym in H.
      eapply Properties.subset_equal in H.
      eapply Properties.subset_trans; eauto.
      (* base *)
      eapply Properties.subset_empty.
      (* step *)
      intros y Hin.
      generalize (Properties.Add_add s' x y); intros [Hadd HAdd'].
      apply Hadd in Hin; clear Hadd HAdd'; destruct Hin as [Hin | Hin'];
      Facts.set_iff; eauto.
    Qed.

    Hint Resolve subset_fold_add_subset_2.

    Theorem subset_fold_add_Equal: forall A A',
      F.Subset A A' -> F.Equal (F.fold F.add A' A) A'.
    Proof.
      intros A A' Hsub.
      eapply Properties.subset_antisym; eauto.
    Qed.

  End fold.

  Theorem is_empty_add : forall x s,
    F.is_empty (F.add x s) = false.
  Proof.
    intros.
    case (sumbool_of_bool (F.is_empty (F.add x s))); intros Hnot; auto.
    eapply Facts.is_empty_iff in Hnot.
    unfold F.Empty in *.
    generalize (Properties.Add_add s x x); intros [_ Hadd].
    eapply Hnot in Hadd; try contradiction; try auto.
  Qed.

  Theorem double_add : forall x s,
    F.Equal (F.add x (F.add x s)) (F.add x s).
  Proof.
    intros.
    intro; split; intro.

    apply Facts.add_iff in H; destruct H; auto.
    apply Facts.add_iff; left; auto.

    apply Facts.add_iff; right; auto.
  Qed.

End Make.


(** * Poly: Polymorphism and Higher-Order Functions *)

(* Final reminder: Please do not put solutions to the exercises in
   publicly accessible places.  Thank you!! *)

(* Suppress some annoying warnings from Coq: *)
Set Warnings "-notation-overridden,-parsing".
Require Export Lists.

(*** Polymorphism *)

(** In this chapter we continue our development of basic
    concepts of functional programming.  The critical new ideas are
    _polymorphism_ (abstracting functions over the types of the data
    they manipulate) and _higher-order functions_ (treating functions
    as data).  We begin with polymorphism. *)

(* ================================================================= *)
(** ** Polymorphic Lists *)

(** For the last couple of chapters, we've been working just
    with lists of numbers.  Obviously, interesting programs also need
    to be able to manipulate lists with elements from other types --
    lists of strings, lists of booleans, lists of lists, etc.  We
    _could_ just define a new inductive datatype for each of these,
    for example... *)

Inductive boollist : Type :=
  | bool_nil : boollist
  | bool_cons : bool -> boollist -> boollist.

(** ... but this would quickly become tedious, partly because we
    have to make up different constructor names for each datatype, but
    mostly because we would also need to define new versions of all
    our list manipulating functions ([length], [rev], etc.) for each
    new datatype definition. *)

(** To avoid all this repetition, Coq supports _polymorphic_
    inductive type definitions.  For example, here is a _polymorphic
    list_ datatype. *)

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

(** This is exactly like the definition of [natlist] from the
    previous chapter, except that the [nat] argument to the [cons]
    constructor has been replaced by an arbitrary type [X], a binding
    for [X] has been added to the header, and the occurrences of
    [natlist] in the types of the constructors have been replaced by
    [list X].  (We can re-use the constructor names [nil] and [cons]
    because the earlier definition of [natlist] was inside of a
    [Module] definition that is now out of scope.)

    What sort of thing is [list] itself?  One good way to think
    about it is that [list] is a _function_ from [Type]s to
    [Inductive] definitions; or, to put it another way, [list] is a
    function from [Type]s to [Type]s.  For any particular type [X],
    the type [list X] is an [Inductive]ly defined set of lists whose
    elements are of type [X]. *)

Check list.
(* ===> list : Type -> Type *)

(** The parameter [X] in the definition of [list] becomes a parameter
    to the constructors [nil] and [cons] -- that is, [nil] and [cons]
    are now polymorphic constructors, that need to be supplied with
    the type of the list they are building. As an example, [nil nat]
    constructs the empty list of type [nat]. *)

Check (nil nat).
(* ===> nil nat : list nat *)

(** Similarly, [cons nat] adds an element of type [nat] to a list of
    type [list nat]. Here is an example of forming a list containing
    just the natural number 3.*)

Check (cons nat 3 (nil nat)).
(* ===> cons nat 3 (nil nat) : list nat *)

(** What might the type of [nil] be? We can read off the type [list X]
    from the definition, but this omits the binding for [X] which is
    the parameter to [list]. [Type -> list X] does not explain the
    meaning of [X]. [(X : Type) -> list X] comes closer. Coq's
    notation for this situation is [forall X : Type, list X]. *)

Check nil.
(* ===> nil : forall X : Type, list X *)

(** Similarly, the type of [cons] from the definition looks like
    [X -> list X -> list X], but using this convention to explain the
    meaning of [X] results in the type [forall X, X -> list X -> list
    X]. *)

Check cons.
(* ===> cons : forall X : Type, X -> list X -> list X *)

(** (Side note on notation: In .v files, the "forall" quantifier
    is spelled out in letters.  In the generated HTML files and in the
    way various IDEs show .v files (with certain settings of their
    display controls), [forall] is usually typeset as the usual
    mathematical "upside down A," but you'll still see the spelled-out
    "forall" in a few places.  This is just a quirk of typesetting:
    there is no difference in meaning.) *)

(** Having to supply a type argument for each use of a list
    constructor may seem an awkward burden, but we will soon see
    ways of reducing that burden. *)

Check (cons nat 2 (cons nat 1 (nil nat))).

(** (We've written [nil] and [cons] explicitly here because we haven't
    yet defined the [ [] ] and [::] notations for the new version of
    lists.  We'll do that in a bit.) *)

(** We can now go back and make polymorphic versions of all the
    list-processing functions that we wrote before.  Here is [repeat],
    for example: *)

Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat X x count')
  end.

(** As with [nil] and [cons], we can use [repeat] by applying it
    first to a type and then to an element of this type (and a number): *)

Example test_repeat1 :
  repeat nat 4 2 = cons nat 4 (cons nat 4 (nil nat)).
Proof. reflexivity.  Qed.

(** To use [repeat] to build other kinds of lists, we simply
    instantiate it with an appropriate type parameter: *)

Example test_repeat2 :
  repeat bool false 1 = cons bool false (nil bool).
Proof. reflexivity.  Qed.

Module MumbleGrumble.

(** **** Exercise: 2 stars (mumble_grumble)  *)
(** Consider the following two inductively defined types. *)

Inductive mumble : Type :=
  | a : mumble
  | b : mumble -> nat -> mumble
  | c : mumble.

Inductive grumble (X:Type) : Type :=
  | d : mumble -> grumble X
  | e : X -> grumble X.

(** Which of the following are well-typed elements of [grumble X] for
    some type [X]?
-     - [d (b a 5)]
+     - [d mumble (b a 5)]
+     - [d bool (b a 5)]
+     - [e bool true]
+     - [e mumble (b c 0)]
-     - [e bool (b c 0)]
+     - [c]
(* FILL IN HERE *)
*)
(** [] *)

End MumbleGrumble.

(* ----------------------------------------------------------------- *)
(** *** Type Annotation Inference *)

(** Let's write the definition of [repeat] again, but this time we
    won't specify the types of any of the arguments.  Will Coq still
    accept it? *)

Fixpoint repeat' X x count : list X :=
  match count with
  | 0        => nil X
  | S count' => cons X x (repeat' X x count')
  end.

(** Indeed it will.  Let's see what type Coq has assigned to [repeat']: *)

Check repeat'.
(* ===> forall X : Type, X -> nat -> list X *)
Check repeat.
(* ===> forall X : Type, X -> nat -> list X *)

(** It has exactly the same type type as [repeat].  Coq was able
    to use _type inference_ to deduce what the types of [X], [x], and
    [count] must be, based on how they are used.  For example, since
    [X] is used as an argument to [cons], it must be a [Type], since
    [cons] expects a [Type] as its first argument; matching [count]
    with [0] and [S] means it must be a [nat]; and so on.

    This powerful facility means we don't always have to write
    explicit type annotations everywhere, although explicit type
    annotations are still quite useful as documentation and sanity
    checks, so we will continue to use them most of the time.  You
    should try to find a balance in your own code between too many
    type annotations (which can clutter and distract) and too
    few (which forces readers to perform type inference in their heads
    in order to understand your code). *)

(* ----------------------------------------------------------------- *)
(** *** Type Argument Synthesis *)

(** To use a polymorphic function, we need to pass it one or
    more types in addition to its other arguments.  For example, the
    recursive call in the body of the [repeat] function above must
    pass along the type [X].  But since the second argument to
    [repeat] is an element of [X], it seems entirely obvious that the
    first argument can only be [X] -- why should we have to write it
    explicitly?

    Fortunately, Coq permits us to avoid this kind of redundancy.  In
    place of any type argument we can write the "implicit argument"
    [_], which can be read as "Please try to figure out for yourself
    what belongs here."  More precisely, when Coq encounters a [_], it
    will attempt to _unify_ all locally available information -- the
    type of the function being applied, the types of the other
    arguments, and the type expected by the context in which the
    application appears -- to determine what concrete type should
    replace the [_].

    This may sound similar to type annotation inference -- indeed, the
    two procedures rely on the same underlying mechanisms.  Instead of
    simply omitting the types of some arguments to a function, like

      repeat' X x count : list X :=

    we can also replace the types with [_]

      repeat' (X : _) (x : _) (count : _) : list X :=

    to tell Coq to attempt to infer the missing information.

    Using implicit arguments, the [repeat] function can be written like
    this: *)

Fixpoint repeat'' X x count : list X :=
  match count with
  | 0        => nil _
  | S count' => cons _ x (repeat'' _ x count')
  end.

(** In this instance, we don't save much by writing [_] instead of
    [X].  But in many cases the difference in both keystrokes and
    readability is nontrivial.  For example, suppose we want to write
    down a list containing the numbers [1], [2], and [3].  Instead of
    writing this... *)

Definition list123 :=
  cons nat 1 (cons nat 2 (cons nat 3 (nil nat))).

(** ...we can use argument synthesis to write this: *)

Definition list123' :=
  cons _ 1 (cons _ 2 (cons _ 3 (nil _))).

(* ----------------------------------------------------------------- *)
(** *** Implicit Arguments *)

(** We can go further and even avoid writing [_]'s in most cases by
    telling Coq _always_ to infer the type argument(s) of a given
    function.

    The [Arguments] directive specifies the name of the function (or
    constructor) and then lists its argument names, with curly braces
    around any arguments to be treated as implicit.  (If some
    arguments of a definition don't have a name, as is often the case
    for constructors, they can be marked with a wildcard pattern
    [_].) *)

Arguments nil {X}.
Arguments cons {X} _ _.
Arguments repeat {X} x count.

(** Now, we don't have to supply type arguments at all: *)

Definition list123'' := cons 1 (cons 2 (cons 3 nil)).

(** Alternatively, we can declare an argument to be implicit
    when defining the function itself, by surrounding it in curly
    braces instead of parens.  For example: *)

Fixpoint repeat''' {X : Type} (x : X) (count : nat) : list X :=
  match count with
  | 0        => nil
  | S count' => cons x (repeat''' x count')
  end.

(** (Note that we didn't even have to provide a type argument to the
    recursive call to [repeat''']; indeed, it would be invalid to
    provide one!)

    We will use the latter style whenever possible, but we will
    continue to use explicit [Argument] declarations for [Inductive]
    constructors.  The reason for this is that marking the parameter
    of an inductive type as implicit causes it to become implicit for
    the type itself, not just for its constructors.  For instance,
    consider the following alternative definition of the [list]
    type: *)

Inductive list' {X:Type} : Type :=
  | nil' : list'
  | cons' : X -> list' -> list'.

(** Because [X] is declared as implicit for the _entire_ inductive
    definition including [list'] itself, we now have to write just
    [list'] whether we are talking about lists of numbers or booleans
    or anything else, rather than [list' nat] or [list' bool] or
    whatever; this is a step too far. *)

(** Let's finish by re-implementing a few other standard list
    functions on our new polymorphic lists... *)

Fixpoint app {X : Type} (l1 l2 : list X)
             : (list X) :=
  match l1 with
  | nil      => l2
  | cons h t => cons h (app t l2)
  end.

Fixpoint rev {X:Type} (l:list X) : list X :=
  match l with
  | nil      => nil
  | cons h t => app (rev t) (cons h nil)
  end.

Fixpoint length {X : Type} (l : list X) : nat :=
  match l with
  | nil => 0
  | cons _ l' => S (length l')
  end.

Example test_rev1 :
  rev (cons 1 (cons 2 nil)) = (cons 2 (cons 1 nil)).
Proof. reflexivity.  Qed.

Example test_rev2:
  rev (cons true nil) = cons true nil.
Proof. reflexivity.  Qed.

Example test_length1: length (cons 1 (cons 2 (cons 3 nil))) = 3.
Proof. reflexivity.  Qed.

(* ----------------------------------------------------------------- *)
(** *** Supplying Type Arguments Explicitly *)

(** One small problem with declaring arguments [Implicit] is
    that, occasionally, Coq does not have enough local information to
    determine a type argument; in such cases, we need to tell Coq that
    we want to give the argument explicitly just this time.  For
    example, suppose we write this: *)

Fail Definition mynil := nil.

(** (The [Fail] qualifier that appears before [Definition] can be
    used with _any_ command, and is used to ensure that that command
    indeed fails when executed. If the command does fail, Coq prints
    the corresponding error message, but continues processing the rest
    of the file.)

    Here, Coq gives us an error because it doesn't know what type
    argument to supply to [nil].  We can help it by providing an
    explicit type declaration (so that Coq has more information
    available when it gets to the "application" of [nil]): *)

Definition mynil : list nat := nil.

(** Alternatively, we can force the implicit arguments to be explicit by
   prefixing the function name with [@]. *)

Check @nil.

Definition mynil' := @nil nat.

(** Using argument synthesis and implicit arguments, we can
    define convenient notation for lists, as before.  Since we have
    made the constructor type arguments implicit, Coq will know to
    automatically infer these when we use the notations. *)

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

(** Now lists can be written just the way we'd hope: *)

Definition list123''' := [1; 2; 3].

(* ----------------------------------------------------------------- *)
(** *** Exercises *)

(** **** Exercise: 2 stars, optional (poly_exercises)  *)
(** Here are a few simple exercises, just like ones in the [Lists]
    chapter, for practice with polymorphism.  Complete the proofs below. *)

Theorem app_nil_r : forall (X:Type), forall l:list X,
  l ++ [] = l.
Proof.
intros X.
induction l.
reflexivity.
simpl.
rewrite IHl.
reflexivity.
Qed.

Theorem app_assoc : forall A (l m n:list A),
  l ++ m ++ n = (l ++ m) ++ n.
Proof.
intros A l m n.
induction l.
-
simpl.
reflexivity.
-
simpl.
rewrite IHl.
reflexivity.
Qed.

Lemma app_length : forall (X:Type) (l1 l2 : list X),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
intros X l1 l2.
induction l1.
-
simpl. reflexivity.
-
simpl. rewrite IHl1. reflexivity.
Qed.

(** **** Exercise: 2 stars, optional (more_poly_exercises)  *)
(** Here are some slightly more interesting ones... *)

Theorem rev_app_distr: forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
intros X l1 l2.
induction l1.
-
simpl.
rewrite app_nil_r.
reflexivity.
-
simpl.
rewrite -> IHl1.
rewrite app_assoc.
reflexivity.
Qed.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
intros X l.
induction l.
-
simpl. reflexivity.
-
simpl.
rewrite rev_app_distr.
rewrite IHl.
simpl.
reflexivity.
Qed.

(* ================================================================= *)
(** ** Polymorphic Pairs *)

(** Following the same pattern, the type definition we gave in
    the last chapter for pairs of numbers can be generalized to
    _polymorphic pairs_, often called _products_: *)

Inductive prod (X Y : Type) : Type :=
| pair : X -> Y -> prod X Y.

Arguments pair {X} {Y} _ _.

(** As with lists, we make the type arguments implicit and define the
    familiar concrete notation. *)

Notation "( x , y )" := (pair x y).

(** We can also use the [Notation] mechanism to define the standard
    notation for product _types_: *)

Notation "X * Y" := (prod X Y) : type_scope.

(** (The annotation [: type_scope] tells Coq that this abbreviation
    should only be used when parsing types.  This avoids a clash with
    the multiplication symbol.) *)

(** It is easy at first to get [(x,y)] and [X*Y] confused.
    Remember that [(x,y)] is a _value_ built from two other values,
    while [X*Y] is a _type_ built from two other types.  If [x] has
    type [X] and [y] has type [Y], then [(x,y)] has type [X*Y]. *)

(** The first and second projection functions now look pretty
    much as they would in any functional programming language. *)

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with
  | (x, y) => x
  end.

Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with
  | (x, y) => y
  end.

(** The following function takes two lists and combines them
    into a list of pairs.  In other functional languages, it is often
    called [zip]; we call it [combine] for consistency with Coq's
    standard library. *)

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y)
           : list (X*Y) :=
  match lx, ly with
  | [], _ => []
  | _, [] => []
  | x :: tx, y :: ty => (x, y) :: (combine tx ty)
  end.

(** **** Exercise: 1 star, optional (combine_checks)  *)
(** Try answering the following questions on paper and
    checking your answers in coq:
    - What is the type of [combine] (i.e., what does [Check
      @combine] print?)
    - What does

        Compute (combine [1;2] [false;false;true;true]).

      print? *)

Check @combine.
Compute (combine [1;2] [false;false;true;true]).

(** **** Exercise: 2 stars, recommended (split)  *)
(** The function [split] is the right inverse of [combine]: it takes a
    list of pairs and returns a pair of lists.  In many functional
    languages, it is called [unzip].

    Fill in the definition of [split] below.  Make sure it passes the
    given unit test. *)

Fixpoint split {X Y : Type} (l : list (X*Y)): (list X) * (list Y) :=
  match l with
  | nil  => (nil,nil)
  | (h1, h2)::tl => (h1:: fst (split tl), h2:: snd (split tl))
  end.

Example test_split:
  split [(1,false);(2,false)] = ([1;2],[false;false]).
Proof.
  simpl. reflexivity.
Qed.

(* ================================================================= *)
(** ** Polymorphic Options *)

(** One last polymorphic type for now: _polymorphic options_,
    which generalize [natoption] from the previous chapter: *)

Inductive option (X:Type) : Type :=
  | Some : X -> option X
  | None : option X.

Arguments Some {X} _.
Arguments None {X}.

(** We can now rewrite the [nth_error] function so that it works
    with any type of lists. *)

Fixpoint nth_error {X : Type} (l : list X) (n : nat)
                   : option X :=
  match l with
  | [] => None
  | a :: l' => if beq_nat n O then Some a else nth_error l' (pred n)
  end.

Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.
Proof. reflexivity. Qed.
Example test_nth_error2 : nth_error [[1];[2]] 1 = Some [2].
Proof. reflexivity. Qed.
Example test_nth_error3 : nth_error [true] 2 = None.
Proof. reflexivity. Qed.

(** **** Exercise: 1 star, optional (hd_error_poly)  *)
(** Complete the definition of a polymorphic version of the
    [hd_error] function from the last chapter. Be sure that it
    passes the unit tests below. *)

Definition hd_error {X : Type} (l : list X) : option X :=
  match l with
  | [] => None
  | h::tl  => Some h
  end.

(** Once again, to force the implicit arguments to be explicit,
    we can use [@] before the name of the function. *)

Check @hd_error.

Example test_hd_error1 : hd_error [1;2] = Some 1.
Proof. simpl. reflexivity. Qed.
Example test_hd_error2 : hd_error  [[1];[2]]  = Some [1].
Proof. simpl. reflexivity. Qed.

(* ################################################################# *)
(** * Functions as Data *)

(** Like many other modern programming languages -- including
    all functional languages (ML, Haskell, Scheme, Scala, Clojure,
    etc.) -- Coq treats functions as first-class citizens, allowing
    them to be passed as arguments to other functions, returned as
    results, stored in data structures, etc.*)

(* ================================================================= *)
(** ** Higher-Order Functions *)

(** Functions that manipulate other functions are often called
    _higher-order_ functions.  Here's a simple one: *)

Definition doit3times {X:Type} (f:X->X) (n:X) : X :=
  f (f (f n)).

(** The argument [f] here is itself a function (from [X] to
    [X]); the body of [doit3times] applies [f] three times to some
    value [n]. *)

Check @doit3times.
(* ===> doit3times : forall X : Type, (X -> X) -> X -> X *)

Example test_doit3times: doit3times minustwo 9 = 3.
Proof. reflexivity.  Qed.

Example test_doit3times': doit3times negb true = false.
Proof. reflexivity.  Qed.

(* ================================================================= *)
(** ** Filter *)

(** Here is a more useful higher-order function, taking a list
    of [X]s and a _predicate_ on [X] (a function from [X] to [bool])
    and "filtering" the list, returning a new list containing just
    those elements for which the predicate returns [true]. *)

Fixpoint filter {X:Type} (test: X->bool) (l:list X)
                : (list X) :=
  match l with
  | []     => []
  | h :: t => if test h then h :: (filter test t)
                        else       filter test t
  end.

(** For example, if we apply [filter] to the predicate [evenb]
    and a list of numbers [l], it returns a list containing just the
    even members of [l]. *)

Example test_filter1: filter evenb [1;2;3;4] = [2;4].
Proof. reflexivity.  Qed.

Definition length_is_1 {X : Type} (l : list X) : bool :=
  beq_nat (length l) 1.

Example test_filter2:
    filter length_is_1
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity.  Qed.

(** We can use [filter] to give a concise version of the
    [countoddmembers] function from the [Lists] chapter. *)

Definition countoddmembers' (l:list nat) : nat :=
  length (filter oddb l).

Example test_countoddmembers'1:   countoddmembers' [1;0;3;1;4;5] = 4.
Proof. reflexivity.  Qed.
Example test_countoddmembers'2:   countoddmembers' [0;2;4] = 0.
Proof. reflexivity.  Qed.
Example test_countoddmembers'3:   countoddmembers' nil = 0.
Proof. reflexivity.  Qed.

(* ================================================================= *)
(** ** Anonymous Functions *)

(** It is arguably a little sad, in the example just above, to
    be forced to define the function [length_is_1] and give it a name
    just to be able to pass it as an argument to [filter], since we
    will probably never use it again.  Moreover, this is not an
    isolated example: when using higher-order functions, we often want
    to pass as arguments "one-off" functions that we will never use
    again; having to give each of these functions a name would be
    tedious.

    Fortunately, there is a better way.  We can construct a function
    "on the fly" without declaring it at the top level or giving it a
    name. *)

Example test_anon_fun':
  doit3times (fun n => n * n) 2 = 256.
Proof. reflexivity.  Qed.

(** The expression [(fun n => n * n)] can be read as "the function
    that, given a number [n], yields [n * n]." *)

(** Here is the [filter] example, rewritten to use an anonymous
    function. *)

Example test_filter2':
    filter (fun l => beq_nat (length l) 1)
           [ [1; 2]; [3]; [4]; [5;6;7]; []; [8] ]
  = [ [3]; [4]; [8] ].
Proof. reflexivity.  Qed.

(** **** Exercise: 2 stars (filter_even_gt7)  *)
(** Use [filter] (instead of [Fixpoint]) to write a Coq function
    [filter_even_gt7] that takes a list of natural numbers as input
    and returns a list of just those that are even and greater than
    7. *)
Definition gt (n m:nat) := m < n.

Definition filter_even_gt7 (l : list nat) : list nat :=
  filter (fun n => andb (evenb n) (ble_nat 7 n)) l.

Example test_filter_even_gt7_1 :
  filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8].
Proof. cbv. reflexivity. Qed.

Example test_filter_even_gt7_2 :
  filter_even_gt7 [5;2;6;19;129] = [].
Proof. cbv. reflexivity. Qed.

(** **** Exercise: 3 stars (partition)  *)
(** Use [filter] to write a Coq function [partition]:

      partition : forall X : Type,
                  (X -> bool) -> list X -> list X * list X

   Given a set [X], a test function of type [X -> bool] and a [list
   X], [partition] should return a pair of lists.  The first member of
   the pair is the sublist of the original list containing the
   elements that satisfy the test, and the second is the sublist
   containing those that fail the test.  The order of elements in the
   two sublists should be the same as their order in the original
   list. *)

Definition partition {X : Type}
                     (test : X -> bool)
                     (l : list X)
  : list X * list X := ((filter test l), (filter (fun n => negb (test n)) l)).

Example test_partition1: partition oddb [1;2;3;4;5] = ([1;3;5], [2;4]).
Proof. cbv. reflexivity. Qed.
Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
Proof. cbv. reflexivity. Qed.
(** [] *)

(* ================================================================= *)
(** ** Map *)

(** Another handy higher-order function is called [map]. *)

Fixpoint map {X Y:Type} (f:X->Y) (l:list X) : (list Y) :=
  match l with
  | []     => []
  | h :: t => (f h) :: (map f t)
  end.

(** It takes a function [f] and a list [ l = [n1, n2, n3, ...] ]
    and returns the list [ [f n1, f n2, f n3,...] ], where [f] has
    been applied to each element of [l] in turn.  For example: *)

Example test_map1: map (fun x => plus 3 x) [2;0;2] = [5;3;5].
Proof. reflexivity.  Qed.

(** The element types of the input and output lists need not be
    the same, since [map] takes _two_ type arguments, [X] and [Y]; it
    can thus be applied to a list of numbers and a function from
    numbers to booleans to yield a list of booleans: *)

Example test_map2:
  map oddb [2;1;2;5] = [false;true;false;true].
Proof. reflexivity.  Qed.

(** It can even be applied to a list of numbers and
    a function from numbers to _lists_ of booleans to
    yield a _list of lists_ of booleans: *)

Example test_map3:
    map (fun n => [evenb n;oddb n]) [2;1;2;5]
  = [[true;false];[false;true];[true;false];[false;true]].
Proof. reflexivity.  Qed.

(* ----------------------------------------------------------------- *)
(** *** Exercises *)

(** **** Exercise: 3 stars (map_rev)  *)
(** Show that [map] and [rev] commute.  You may need to define an
    auxiliary lemma. *)

Theorem map_d : forall (X Y : Type) (f:X->Y) (a b : list X),   map f (a ++ b) = map f a ++ map f b.
Proof.
intros X Y f a b.
induction a.
-
simpl. reflexivity.
-
simpl. rewrite IHa. reflexivity.
Qed.

Theorem map_rev : forall (X Y : Type) (f : X -> Y) (l : list X),
  map f (rev l) = rev (map f l).
Proof.
intros X Y f l.
induction l.
-
simpl. reflexivity.
-
simpl.
rewrite <- IHl.
Check (rev l ++ [x]).
rewrite  map_d.
reflexivity.
Qed.

(** **** Exercise: 2 stars, recommended (flat_map)  *)
(** The function [map] maps a [list X] to a [list Y] using a function
    of type [X -> Y].  We can define a similar function, [flat_map],
    which maps a [list X] to a [list Y] using a function [f] of type
    [X -> list Y].  Your definition should work by 'flattening' the
    results of [f], like so:

        flat_map (fun n => [n;n+1;n+2]) [1;5;10]
      = [1; 2; 3; 5; 6; 7; 10; 11; 12].
*)

Fixpoint flat_map {X Y:Type} (f:X -> list Y) (l:list X)
  : (list Y) :=
  match l with
  | [] => []
  | h::tl => (f h) ++ flat_map f tl
  end.

Example test_flat_map1:
  flat_map (fun n => [n;n;n]) [1;5;4]
  = [1; 1; 1; 5; 5; 5; 4; 4; 4].
 Proof. cbv. reflexivity. Qed.

(** Lists are not the only inductive type that we can write a
    [map] function for.  Here is the definition of [map] for the
    [option] type: *)

Definition option_map {X Y : Type} (f : X -> Y) (xo : option X)
                      : option Y :=
  match xo with
    | None => None
    | Some x => Some (f x)
  end.

(** **** Exercise: 2 stars, optional (implicit_args)  *)
(** The definitions and uses of [filter] and [map] use implicit
    arguments in many places.  Replace the curly braces around the
    implicit arguments with parentheses, and then fill in explicit
    type parameters where necessary and use Coq to check that you've
    done so correctly.  (This exercise is not to be turned in; it is
    probably easiest to do it on a _copy_ of this file that you can
    throw away afterwards.)
*)
(** [] *)

(* ================================================================= *)
(** ** Fold *)

(** An even more powerful higher-order function is called
    [fold].  This function is the inspiration for the "[reduce]"
    operation that lies at the heart of Google's map/reduce
    distributed programming framework. *)

Fixpoint fold {X Y:Type} (f: X->Y->Y) (l:list X) (b:Y)
                         : Y :=
  match l with
  | nil => b
  | h :: t => f h (fold f t b)
  end.

(** Intuitively, the behavior of the [fold] operation is to
    insert a given binary operator [f] between every pair of elements
    in a given list.  For example, [ fold plus [1;2;3;4] ] intuitively
    means [1+2+3+4].  To make this precise, we also need a "starting
    element" that serves as the initial second input to [f].  So, for
    example,

       fold plus [1;2;3;4] 0

    yields

       1 + (2 + (3 + (4 + 0))).

    Some more examples: *)

Check (fold andb).
(* ===> fold andb : list bool -> bool -> bool *)

Example fold_example1 :
  fold mult [1;2;3;4] 1 = 24.
Proof. reflexivity. Qed.

Example fold_example2 :
  fold andb [true;true;false;true] true = false.
Proof. reflexivity. Qed.

Example fold_example3 :
  fold app  [[1];[];[2;3];[4]] [] = [1;2;3;4].
Proof. reflexivity. Qed.

(** **** Exercise: 1 star, advanced (fold_types_different)  *)
(** Observe that the type of [fold] is parameterized by _two_ type
    variables, [X] and [Y], and the parameter [f] is a binary operator
    that takes an [X] and a [Y] and returns a [Y].  Can you think of a
    situation where it would be useful for [X] and [Y] to be
    different? *)

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

(* ================================================================= *)
(** ** Functions That Construct Functions *)

(** Most of the higher-order functions we have talked about so
    far take functions as arguments.  Let's look at some examples that
    involve _returning_ functions as the results of other functions.
    To begin, here is a function that takes a value [x] (drawn from
    some type [X]) and returns a function from [nat] to [X] that
    yields [x] whenever it is called, ignoring its [nat] argument. *)

Definition constfun {X: Type} (x: X) : nat->X :=
  fun (k:nat) => x.

Definition ftrue := constfun true.

Example constfun_example1 : ftrue 0 = true.
Proof. reflexivity. Qed.

Example constfun_example2 : (constfun 5) 99 = 5.
Proof. reflexivity. Qed.

(** In fact, the multiple-argument functions we have already
    seen are also examples of passing functions as data.  To see why,
    recall the type of [plus]. *)

Check plus.
(* ==> nat -> nat -> nat *)

(** Each [->] in this expression is actually a _binary_ operator
    on types.  This operator is _right-associative_, so the type of
    [plus] is really a shorthand for [nat -> (nat -> nat)] -- i.e., it
    can be read as saying that "[plus] is a one-argument function that
    takes a [nat] and returns a one-argument function that takes
    another [nat] and returns a [nat]."  In the examples above, we
    have always applied [plus] to both of its arguments at once, but
    if we like we can supply just the first.  This is called _partial
    application_. *)

Definition plus3 := plus 3.
Check plus3.

Example test_plus3 :    plus3 4 = 7.
Proof. reflexivity.  Qed.
Example test_plus3' :   doit3times plus3 0 = 9.
Proof. reflexivity.  Qed.
Example test_plus3'' :  doit3times (plus 3) 0 = 9.
Proof. reflexivity.  Qed.

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

Module Exercises.

(** **** Exercise: 2 stars (fold_length)  *)
(** Many common functions on lists can be implemented in terms of
   [fold].  For example, here is an alternative definition of [length]: *)

Definition fold_length {X : Type} (l : list X) : nat :=
  fold (fun _ n => S n) l 0.

Example test_fold_length1 : fold_length [4;7;0] = 3.
Proof. reflexivity. Qed.

(** Prove the correctness of [fold_length]. *)

Theorem fold_length_correct : forall X (l : list X),
  fold_length l = length l.
Proof.
intros X.
induction l.
-
trivial.
-
unfold fold_length.
unfold fold.
unfold fold_length in IHl.
unfold fold in IHl.
rewrite IHl.
cbn.
reflexivity.
Qed.

(** **** Exercise: 3 stars (fold_map)  *)
(** We can also define [map] in terms of [fold].  Finish [fold_map]
    below. *)

Definition fold_map {X Y:Type} (f : X -> Y) (l : list X) : list Y
:= fold (fun y l => f y :: l) l [].

(** Write down a theorem [fold_map_correct] in Coq stating that
   [fold_map] is correct, and prove it. *)

Theorem foldmap_eq_map: forall X Y (f: X->Y) (l : list X),
    fold_map f l = map f l.
Proof.
intros X Y f l.
induction l.
-
cbv. reflexivity.
-
simpl.
unfold fold_map.
unfold fold.
unfold map.
unfold map in IHl.
unfold fold_map in IHl.
unfold fold in IHl.
rewrite IHl.
reflexivity.
Qed.

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

(** **** Exercise: 2 stars, advanced (currying)  *)
(** In Coq, a function [f : A -> B -> C] really has the type [A
    -> (B -> C)].  That is, if you give [f] a value of type [A], it
    will give you function [f' : B -> C].  If you then give [f'] a
    value of type [B], it will return a value of type [C].  This
    allows for partial application, as in [plus3].  Processing a list
    of arguments with functions that return functions is called
    _currying_, in honor of the logician Haskell Curry.

    Conversely, we can reinterpret the type [A -> B -> C] as [(A *
    B) -> C].  This is called _uncurrying_.  With an uncurried binary
    function, both arguments must be given at once as a pair; there is
    no partial application. *)

(** We can define currying as follows: *)

Definition prod_curry {X Y Z : Type}
  (f : X * Y -> Z) (x : X) (y : Y) : Z := f (x, y).

(** As an exercise, define its inverse, [prod_uncurry].  Then prove
    the theorems below to show that the two are inverses. *)

Definition prod_uncurry {X Y Z : Type}
           (f : X -> Y -> Z) (p : X * Y) : Z := f (fst p) (snd p).

(** As a (trivial) example of the usefulness of currying, we can use it
    to shorten one of the examples that we saw above: *)

Example test_map1': map (plus 3) [2;0;2] = [5;3;5].
Proof. reflexivity.  Qed.

(** Thought exercise: before running the following commands, can you
    calculate the types of [prod_curry] and [prod_uncurry]? *)

Check @prod_curry.
Check @prod_uncurry.

Theorem uncurry_curry : forall (X Y Z : Type)
                        (f : X -> Y -> Z)
                        x y,
  prod_curry (prod_uncurry f) x y = f x y.
Proof.
reflexivity.
Qed.

Theorem curry_uncurry : forall (X Y Z : Type)
                        (f : (X * Y) -> Z) (p : X * Y),
  prod_uncurry (prod_curry f) p = f p.
Proof.
intros X Y Z f p.
unfold prod_curry.
unfold prod_uncurry.
destruct p.
simpl.
reflexivity.
Qed.

(** **** Exercise: 2 stars, advanced (nth_error_informal)  *)
(** Recall the definition of the [nth_error] function:

   Fixpoint nth_error {X : Type} (l : list X) (n : nat) : option X :=
     match l with
     | [] => None
     | a :: l' => if beq_nat n O then Some a else nth_error l' (pred n)
     end.

   Write an informal proof of the following theorem:

   forall X n l, length l = n -> @nth_error X l n = None

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

(** **** Exercise: 4 stars, advanced (church_numerals)  *)
(** This exercise explores an alternative way of defining natural
    numbers, using the so-called _Church numerals_, named after
    mathematician Alonzo Church.  We can represent a natural number
    [n] as a function that takes a function [f] as a parameter and
    returns [f] iterated [n] times. *)

Module Church.

Definition nat := forall X : Type, (X -> X) -> X -> X.

(** Let's see how to write some numbers with this notation. Iterating
    a function once should be the same as just applying it.  Thus: *)

Definition one : nat :=
  fun (X : Type) (f : X -> X) (x : X) => f x.

(** Similarly, [two] should apply [f] twice to its argument: *)

Definition two : nat :=
  fun (X : Type) (f : X -> X) (x : X) => f (f x).

(** Defining [zero] is somewhat trickier: how can we "apply a function
    zero times"?  The answer is actually simple: just return the
    argument untouched. *)

Definition zero : nat :=
  fun (X : Type) (f : X -> X) (x : X) => x.

(** More generally, a number [n] can be written as [fun X f x => f (f
    ... (f x) ...)], with [n] occurrences of [f].  Notice in
    particular how the [doit3times] function we've defined previously
    is actually just the Church representation of [3]. *)

Definition three : nat := @doit3times.

(** Complete the definitions of the following functions. Make sure
    that the corresponding unit tests pass by proving them with
    [reflexivity]. *)

(** Successor of a natural number: *)

Print doit3times.
Definition succ (n : nat) : nat :=
  fun (X : Type) (f : X -> X) (x : X)  => f (n X f x).

Example succ_1 : succ zero = one.
Proof. reflexivity. Qed.

Example succ_2 : succ one = two.
Proof. reflexivity. Qed.

Example succ_3 : succ two = three.
Proof. reflexivity. Qed.

(** Addition of two natural numbers: *)

Definition plus (n m : nat) : nat :=
  fun (X : Type) (f : X -> X) (x : X) => (n X f (m X f x)).

Example plus_1 : plus zero one = one.
Proof. reflexivity. Qed.

Example plus_2 : plus two three = plus three two.
Proof. reflexivity. Qed.

Example plus_3 :
  plus (plus two two) three = plus one (plus three three).
Proof. reflexivity. Qed.

(** Multiplication: *)

Definition mult (n m : nat) : nat :=
  fun (X : Type) (f : X -> X) (x : X) => (n X (m X f) x).

Example mult_1 : mult one one = one.
Proof. reflexivity. Qed.

Example mult_2 : mult zero (plus three three) = zero.
Proof. reflexivity. Qed.

Example mult_3 : mult two three = plus three three.
Proof. reflexivity. Qed.

(** Exponentiation: *)

(** (_Hint_: Polymorphism plays a crucial role here.  However,
    choosing the right type to iterate over can be tricky.  If you hit
    a "Universe inconsistency" error, try iterating over a different
    type: [nat] itself is usually problematic.) *)

Definition exp (n m : nat) : nat :=
  fun (X : Type) (f : X -> X) (x : X) =>  (m (X -> X) (n X) f) x.

Example exp_1 : exp two two = plus two two.
Proof. reflexivity. Qed.

Example exp_2 : exp three two = plus (mult two (mult two two)) one.
Proof. reflexivity. Qed.

Example exp_3 : exp three zero = one.
Proof. reflexivity. Qed.

End Church.
(** [] *)

End Exercises.

(** $Date: 2018-01-23 21:16:07 -0500 (Tue, 23 Jan 2018) $ *)


Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.Combinatorics.FiniteSets.
Require Import UniMath.CategoryTheory.Core.Categories.

Require Import prelude.
Require Import syntax.containers.
Require Import syntax.hit_signature.
Require Import syntax.W_types.
Require Import algebra.set_algebra.

Local Open Scope container_scope.

(**
Natural numbers modulo 2

Inductive ℕ₂ : Type :=
| 0 : ℕ₂
| S : ℕ₂ → ℕ₂
| mod : ∏ (n : ℕ₂), S(S n) = n
 *)
Definition mod2_sig_point_constr
  : container.
Proof.
  use make_container.
  - exact boolset.
  - intro b.
    destruct b.
    + exact emptyset.
    + exact unitset.
Defined.

Definition mod2_sig_path_arg
  : container.
Proof.
  use make_container.
  - exact unitset.
  - exact (λ _, unitset).
Defined.

Definition mod2_sig_lhs
  : W mod2_sig_point_constr unitset.
Proof.
  simple refine (sup _ (λ _, sup _ (λ _, var _))) ; cbn.
  - exact false.
  - exact false.
  - exact tt.
Defined.

Definition mod2_sig_rhs
  : W mod2_sig_point_constr unitset.
Proof.
  apply var.
  exact tt.
Defined.

Definition mod2_sig : hit_signature.
Proof.
  use make_hit_signature.
  - exact mod2_sig_point_constr.
  - exact mod2_sig_path_arg.
  - exact (λ _, mod2_sig_lhs).
  - exact (λ _, mod2_sig_rhs).
Defined.

Definition is_finitary_mod2_sig
  : is_finitary_hit mod2_sig.
Proof.
  split.
  - intro x.
    destruct x ; cbn -[isfinite].
    + apply isfiniteempty.
    + apply isfiniteunit.
  - intro.
    apply isfiniteunit.
Qed.

Section Mod2Algebra.
  Variable (X : hit_algebra mod2_sig).

  Definition mod2_carrier
    : hSet
    := pr11 X.

  Definition mod2_Z
    : mod2_carrier
    := pr21 X (true ,, fromempty).

  Definition mod2_S
    : mod2_carrier → mod2_carrier
    := λ x, pr21 X (false ,, (λ _, x)).

  Definition mod2_path
    : ∏ (n : mod2_carrier), mod2_S (mod2_S n) = n
    := λ n, pr2 X tt (λ _ , n).
End Mod2Algebra.

Definition make_mod2_algebra
           (X : hSet)
           (Z : X)
           (S : X → X)
           (p : ∏ (n : X), S(S n) = n)
  : hit_algebra mod2_sig.
Proof.
  simple refine ((X ,, _) ,, _) ; cbn.
  - intro x.
    induction x as [x arg].
    induction x ; cbn in *.
    + exact Z.
    + exact (S (arg tt)).
  - exact (λ _ n, p (n tt)).
Defined.

Definition bool_mod2_sig
  : hit_algebra mod2_sig.
Proof.
  use make_mod2_algebra.
  - exact boolset.
  - exact false.
  - exact negb.
  - intro b ; induction b ; cbn.
    + apply idpath.
    + apply idpath.
Defined.


From Coq Require Import Reals.
From Flocq Require Import Core.
From Gappa Require Import Gappa_tactic.
Open Scope R_scope.

Definition floor := rounding_fixed rndDN 0.

Goal forall x y,
  floor x = floor y ->
  2 <= sqrt (4 + Rsqr (x - y)) <= 9/4.
Proof.
unfold floor, Rsqr.
gappa.
Qed.