Require Export ProductCategory Functor NaturalTransformation.
Require Import Common Notations.

Set Implicit Arguments.

Generalizable All Variables.

Local Ltac product_induced_functors_t :=
  intros; simpl; repeat (rewrite <- FCompositionOf || rewrite <- FIdentityOf);
  apply f_equal; expand; autorewrite with morphism;
  reflexivity.

Section ProductInducedFunctors.
  Context `(C : @Category objC).
  Context `(D : @Category objD).
  Context `(E : @Category objE).

  Variable F : Functor (C * D) E.

  Definition InducedProductFstFunctor (d : D) : Functor C E.
    refine {| ObjectOf := (fun c => F (c, d));
              MorphismOf := (fun _ _ m => MorphismOf F (s := (_, d)) (d := (_, d)) (m, Identity d))
           |};
    abstract product_induced_functors_t.
  Defined.

  Definition InducedProductSndFunctor (c : C) : Functor D E.
    refine {| ObjectOf := (fun d => F (c, d));
              MorphismOf := (fun _ _ m => MorphismOf F (s := (c, _)) (d := (c, _)) (Identity c, m))
           |};
    abstract product_induced_functors_t.
  Defined.
End ProductInducedFunctors.

Notation "F ⟨ c , - ⟩" := (InducedProductSndFunctor F c) : functor_scope.
Notation "F ⟨ - , d ⟩" := (InducedProductFstFunctor F d) : functor_scope.

Section ProductInducedNaturalTransformations.
  Context `(C : @Category objC).
  Context `(D : @Category objD).
  Context `(E : @Category objE).

  Variable F : Functor (C * D) E.

  Definition InducedProductFstNaturalTransformation {s d} (m : Morphism C s d) : NaturalTransformation (F ⟨ s, - ⟩) (F ⟨ d, - ⟩).
    match goal with
      | [ |- NaturalTransformation ?F0 ?G0 ] =>
        refine (Build_NaturalTransformation F0 G0
                                            (fun d => MorphismOf F (s := (_, d)) (d := (_, d)) (m, Identity (C := D) d))
                                            _
               )
    end;
    abstract product_induced_functors_t.
  Defined.

  Definition InducedProductSndNaturalTransformation {s d} (m : Morphism D s d) : NaturalTransformation (F ⟨ -, s ⟩) (F ⟨ - , d ⟩).
    match goal with
      | [ |- NaturalTransformation ?F0 ?G0 ] =>
        refine (Build_NaturalTransformation F0 G0
                                            (fun c => MorphismOf F (s := (c, _)) (d := (c, _)) (Identity (C := C) c, m))
                                            _
               )
    end;
    abstract product_induced_functors_t.
  Defined.
End ProductInducedNaturalTransformations.

Notation "F ⟨ f , - ⟩" := (InducedProductSndNaturalTransformation F f) : natural_transformation_scope.
Notation "F ⟨ - , f ⟩" := (InducedProductFstNaturalTransformation F f) : natural_transformation_scope.


(** * Finite types *)

(* [fin n : Type] is a type with [n] inhabitants. It is isomorphic to
   [Coq.Vector.Fin.t] from the standard library, but we found this formulation
   easier to reason about. *)

(* In this compiler, we use [fin n] as the type of "block labels" in [Asm]
   programs (program locations that can be jumped to). In an earlier version, labels
   could be any type, but this restriction makes [Asm] programs easier to introspect
   for defining optimizations (though the current development doesn't make use of it).
  *)

(* The instances at the end derive categorical operations for the subcategories of
   [Fun] and [ktree] on finite types (instead of arbitrary types). *)

(* begin hide *)
From Coq Require Import
     Arith
     Lia.
Import PeanoNat.Nat EqNotations.

From ITree Require Import
     ITree
     ITreeFacts
     Basics.Category
     Basics.CategorySub.

From TinyRAM.Utils Require Import
  Arith.
(* end hide *)

(* Type with [n] inhabitants. *)
Definition fin (n : nat) : Type := { x : nat | x < n }.

(* Hide proof terms. *)
(* N.B.: [x < n] unfolds to [S x < n], which is why we don't make the first
   field more precise. *)
Notation fi' i := (exist (fun j : nat => _) i _).

Program Definition f0 {n} : fin (S n) := fi' 0.
Next Obligation. lia. Defined.

Lemma unique_fin : forall n (i j : fin n),
    proj1_sig i = proj1_sig j -> i = j.
Proof.
  intros ? [] [] w. simpl in w; destruct w. f_equal; apply le_unique.
Qed.

Lemma unique_f0 : forall (a : fin 1), a = f0.
Proof.
  destruct a. apply unique_fin; simpl. lia.
Qed.

Program Definition fS {n} : fin n -> fin (S n) :=
  fun i => fi' (S (proj1_sig i)).
Next Obligation.
  destruct i; simpl; lia.
Defined.

Lemma fin_0 {A} : fin 0 -> A.
Proof.
  intros [].
  apply PeanoNat.Nat.nlt_0_r in l.
  contradiction.
Qed.

Instance FinInitial {E} : Initial (sub (ktree E) fin) 0 := fun _ => fin_0.

Lemma split_fin_helper:
  forall n m x : nat, x < n + m -> ~ x < n -> x - n < m.
Proof.
  intros n m x l n0.
  lia.
Defined.

Program Definition split_fin_sum (n m : nat)
  : fin (n + m) -> (fin n) + (fin m) := fun x =>
    match lt_dec (proj1_sig x) n with
    | left _ => inl (fi' (proj1_sig x))
    | right _ => inr (fi' (proj1_sig x - n))
    end.
Next Obligation.
  apply split_fin_helper. eapply proj2_sig. assumption.
Defined.

Program Definition L {n} (m : nat) (a : fin n) : fin (n + m) := _.
Next Obligation.
  destruct a.
  exists x. apply PeanoNat.Nat.lt_lt_add_r.  assumption.
Defined.

Program Definition R {m} (n:nat) (a:fin m) : fin (n + m) := _.
Next Obligation.
  destruct a.
  exists (n + x). lia.
Defined.

Lemma R_0_a : forall (n:nat) (a : fin n), R 0 a = a.
Proof.
  intros; destruct a; apply unique_fin; reflexivity.
Qed.

Lemma R_1_a : forall (n:nat) (a : fin n), R 1 a = fS a.
Proof.
  intros; destruct a; apply unique_fin; reflexivity.
Qed.

Lemma split_fin_sum_0_a : forall m (a : fin (0 + m)),
    (@split_fin_sum 0 m a) = inr a.
Proof.
  intros.
  unfold split_fin_sum, split_fin_sum_obligation_1.
  destruct (Compare_dec.lt_dec _ 0) as [H | H].
  - inversion H.
  - f_equal. destruct a; apply unique_fin. simpl; lia.
Qed.

Lemma split_fin_sum_FS_inr :
  (@split_fin_sum (S O) (S O) (fS f0) = inr f0).
Proof.
  cbn; f_equal; apply unique_f0.
Qed.

Lemma split_fin_sum_f1_inl :
  (@split_fin_sum 1 1 (@f0 1)) = inl f0.
Proof.
  cbn; f_equal; apply unique_f0.
Qed.

Lemma L_1_f1 : (L 1 (@f0 0)) = f0.
Proof.
  apply unique_fin; reflexivity.
Qed.

Lemma split_fin_sum_L_L_f1 :
  (@split_fin_sum _ _ (L 1 (L 1 (@f0 0)))) = inl f0.
Proof.
  cbn; f_equal; apply unique_fin; reflexivity.
Qed.

Lemma split_fin_sum_R_2 : split_fin_sum 2 1 (R 2 (@f0 0)) = inr f0.
Proof.
  cbn; f_equal; apply unique_fin; reflexivity.
Qed.

Lemma split_fin_sum_R n m (x : fin m) : split_fin_sum n m (R n x) = inr x.
Proof.
  destruct x; simpl. unfold split_fin_sum; simpl.
  destruct lt_dec.
  - exfalso. lia.
  - f_equal. apply unique_fin; simpl; lia.
Qed.

Lemma split_fin_sum_L n m (x : fin n) : split_fin_sum n m (L m x) = inl x.
Proof.
  destruct x; simpl. unfold split_fin_sum; simpl.
  destruct lt_dec.
  - f_equal. apply unique_fin; simpl; lia.
  - exfalso. lia.
Qed.

Definition merge_fin_sum (n m: nat) : fin n + fin m -> fin (n + m) :=
  fun v =>
    match v with
    | inl v => L m v
    | inr v => R n v
    end.

Lemma merge_fin_sum_inr : (merge_fin_sum 1 1 (inr f0)) = (fS f0).
Proof.
  apply unique_fin; reflexivity.
Qed.

Lemma merge_fin_sum_inl_1 f : (merge_fin_sum 1 1 (inl f)) = f0.
Proof.
  rewrite (unique_f0 f); apply unique_fin; reflexivity.
Qed.

Lemma merge_split:
  forall (n m : nat) (a : fin (n + m)), merge_fin_sum n m (split_fin_sum n m a) = a.
Proof.
  intros n m []. unfold split_fin_sum; simpl.
  destruct (lt_dec x n); apply unique_fin; simpl; reflexivity + lia.
Qed.

Lemma split_merge:
  forall (n m : nat) (a : fin n + fin m), split_fin_sum n m (merge_fin_sum n m a) = a.
Proof.
  intros n m [[] | []]; unfold split_fin_sum; simpl; destruct lt_dec; simpl;
    try (f_equal; apply unique_fin; simpl; reflexivity + lia);
    try contradiction + exfalso; lia.
Qed.

Definition fin_mod : forall n m,
  n <> 0 -> fin (m * n) -> fin n.
  intros n m meq f.
  destruct f as [f fprp].
  exists (f mod n).
  apply mod_upper_bound.
  assumption.
Defined.

Instance ToBifunctor_ktree_fin {E} : ToBifunctor (ktree E) fin sum Nat.add :=
  fun n m y => Ret (split_fin_sum n m y).

Instance FromBifunctor_ktree_fin {E} : FromBifunctor (ktree E) fin sum Nat.add :=
  fun n m y => Ret (merge_fin_sum n m y).

Instance IsoBif_ktree_fin {E}
  : forall a b, Iso (ktree E) (a := fin (Nat.add a b)) to_bif from_bif.
Proof.
  unfold to_bif, ToBifunctor_ktree_fin, from_bif, FromBifunctor_ktree_fin.
  constructor; intros x.
  - unfold cat, Cat_sub, Cat_Kleisli. cbn. rewrite bind_ret_l.
    apply eqit_Ret, merge_split.
  - unfold cat, Cat_sub, Cat_Kleisli. cbn. rewrite bind_ret_l.
    apply eqit_Ret, split_merge.
Qed.

Instance ToBifunctor_Fun_fin : ToBifunctor Fun fin sum Nat.add :=
  fun n m y => split_fin_sum n m y.

Instance FromBifunctor_Fun_fin : FromBifunctor Fun fin sum Nat.add :=
  fun n m y => merge_fin_sum n m y.

Instance IsoBif_Fun_fin
  : forall a b, Iso Fun (a := fin (Nat.add a b)) to_bif from_bif.
Proof.
  constructor; intros x.
  - apply merge_split.
  - apply split_merge.
Qed.

Instance InitialObject_ktree_fin {E} : InitialObject (sub (ktree E) fin) 0.
Proof.
  intros n f x; apply fin_0; auto.
Qed.

Definition fin_add : forall {n m} (f1 : fin n) (f2 : fin m), fin (n + m - 1).
  intros n m [f1 f1P] [f2 f2P].
  exists (f1 + f2).
  destruct n. { lia. }
  destruct m. { lia. }
  lia.
Defined.

Definition fin_cast : forall {n m}, (n <= m) -> fin n -> fin m.
  intros n m le [f fP].
  exists f.
  lia.
Defined.

Theorem fin_mul_lem : forall {n m},
  (n - 1) * (m - 1) <= S (n * m - m - n).
Proof.
  intros n m.
  rewrite mul_sub_distr_l.
  repeat rewrite mul_sub_distr_r.
  rewrite mul_1_r, mul_1_l; simpl.
  destruct n. { simpl; lia. }
  destruct m. { rewrite <- mult_n_O; simpl; lia. }
  destruct n. { simpl; rewrite add_0_r, sub_diag; lia. }
  destruct m. { simpl; rewrite mul_1_r, sub_diag; lia. }
  rewrite add_sub_distr. 2: { lia. }
  2: { apply le_add_le_sub_r, add_le_mul; lia. }
  rewrite add_1_r; apply le_n.
Qed.

Definition fin_mul : forall {n m} (f1 : fin n) (f2 : fin m),
                            fin (S (S (n * m - m - n))).
  intros n m [f1 f1P] [f2 f2P].
  exists (f1 * f2).
  apply (le_lt_trans _ ((n - 1) * (m - 1))).
  + apply mul_le_mono.
    - rewrite <- lt_succ_r.
      replace (S (n - 1)) with n. { assumption. }
      lia.
    - rewrite <- lt_succ_r.
      replace (S (m - 1)) with m. { assumption. }
      lia.
  + apply (le_lt_trans _ (S (n * m - m - n))).
    - apply fin_mul_lem.
    - lia.
Defined.

Definition fin_max : forall n, fin (S n).
  intro n; exists n; lia.
Defined.

Theorem proj1_fin_cast : forall {n m} (f : fin n) (eq : n <= m),
  proj1_sig (fin_cast eq f) = proj1_sig f.
Proof. destruct f; reflexivity. Qed.

Theorem proj1_fin_add : forall {n m} (f : fin n) (g : fin m),
  proj1_sig (fin_add f g) = proj1_sig f + proj1_sig g.
Proof. destruct f, g; reflexivity. Qed.

Theorem proj1_fin_mul : forall {n m} (f : fin n) (g : fin m),
  proj1_sig (fin_mul f g) = proj1_sig f * proj1_sig g.
Proof. destruct f, g; reflexivity. Qed.

Theorem proj1_fin_max : forall {n},
  proj1_sig (fin_max n) = n.
Proof. reflexivity. Qed.

Theorem fin_rew : forall {n m o} (eq : n = m) (H : o < n),
  (rew eq in (exist (fun x => x < n) o H : fin n)) =
  exist (fun x => x < m) o (rew eq in H).
Proof. intros n m o eq; destruct eq; reflexivity. Qed.

Definition mk_fin {m} : forall n, n < m -> fin m.
  intros; exists n; assumption. Defined.


(* An argument that is used to prove that the "two worlds" style of security definition is equivalent to the "coin flipping" style. *)

Set Implicit Arguments.

Require Import Crypto.
Require Import Asymptotic.

Theorem evalDist_bool_support :
  forall (c : Comp bool)(ls : list bool),
    well_formed_comp c ->
    ls = getSupport c ->
    sumList ls (evalDist c) == evalDist c false + evalDist c true.

  intuition.
  specialize (support_NoDup c); intuition.
  rewrite <- H0 in H1.

  destruct ls; intuition.
  specialize (getSupport_length_nz H); intuition.
  rewrite <- H0 in H2.
  simpl in *.
  omega.

  destruct b.

  destruct ls.
  unfold sumList; simpl.

  eapply ratAdd_eqRat_compat.
  symmetry.
  eapply getSupport_not_In_evalDist.
  intuition.
  rewrite <- H0 in H2.
  simpl in *.
  intuition.
  intuition.

  destruct b.
  inversion H1; clear H1; subst.
  simpl in *.
  intuition.

  destruct ls.

  unfold sumList.
  simpl.
  rewrite <- ratAdd_0_l.
  eapply ratAdd_comm.

  destruct b.
  inversion H1; clear H1; subst.
  simpl in *.
  intuition.
  inversion H1; clear H1; subst.
  simpl in *.
  intuition.
  inversion H5; clear H5; subst.
  simpl in *; intuition.

  destruct ls.
  unfold sumList; simpl.

  rewrite ratAdd_comm.
  eapply ratAdd_eqRat_compat.
  intuition.
  symmetry.
  eapply getSupport_not_In_evalDist.
  intuition.
  rewrite <- H0 in H2.
  simpl in *.
  intuition.

  destruct b.

  destruct ls.

  unfold sumList.
  simpl.
  rewrite <- ratAdd_0_l.
  intuition.

  destruct b.
  inversion H1; clear H1; subst.
  simpl in *.
  intuition.
  inversion H5; clear H5; subst.
  simpl in *; intuition.
  inversion H1; clear H1; subst.
  simpl in *; intuition.
  inversion H1; clear H1; subst.
  simpl in *; intuition.

Qed.

Theorem evalDist_bool_complement :
  forall (c : Comp bool),
    well_formed_comp c ->
    evalDist c false == ratSubtract 1 (evalDist c true).

  intuition.
  eapply (eqRat_ratAdd_same_r (evalDist c true)).
  symmetry.
  rewrite ratAdd_comm.
  rewrite ratSubtract_ratAdd_inverse_2.

  specialize (@evalDist_lossless _ c); intuition.
  rewrite <- H1.
  clear H1.
  eapply evalDist_bool_support.
  intuition.
  intuition.

  eapply evalDist_le_1.
  unfold eq_dec.
  eapply (EqDec_dec _).
  intuition.
Qed.

Theorem rndBool_bind :
  forall
    (f : bool -> Comp bool),
    Pr[b <-$ {0, 1}; f b] == (1 / 2) * Pr[f true] + (1 / 2) * Pr[f false].

  intuition.
  simpl.
  destruct (bind_eq_dec ({ 0 , 1 }^1) (fun m : Bvector 1 => ret Vector.hd m)
    false true).
  discriminate.

  unfold sumList.
  simpl.
  destruct (EqDec_dec bool_EqDec true false).
  discriminate.
  destruct (EqDec_dec bool_EqDec false true).
  discriminate.
  destruct (EqDec_dec bool_EqDec true true).
  destruct (EqDec_dec bool_EqDec false false).

  repeat rewrite <- ratAdd_0_l.
  repeat rewrite ratMult_0_r.
  repeat rewrite <- ratAdd_0_r.
  repeat rewrite <- ratAdd_0_l.
  repeat rewrite ratMult_1_r.
  eapply ratAdd_eqRat_compat;
    eapply ratMult_eqRat_compat; intuition.

  intuition.
  intuition.
Qed.

Section TwoWorldsEquiv.

  Variable f : nat -> bool -> Comp bool.

  Hypothesis f_wf : forall n b, well_formed_comp (f n b).

  Section TwoWorldsEquiv_eta.
    Variable eta : nat.

    Definition StandardDef_G :=
      b <-$ {0, 1};
      b' <-$ f eta b;
      ret (eqb b b').

    Theorem StandardDef_equiv_2W_h :
      | Pr[StandardDef_G] - 1 / 2 | == (1 / 2) * | Pr[f eta true] - Pr[f eta false] |.

      unfold StandardDef_G.

      rewrite rndBool_bind.

      assert ( Pr[b' <-$ f eta true; ret eqb true b'] == Pr[f eta true]).
      symmetry.
      rewrite <- evalDist_right_ident.
      comp_skip.
      comp_ute.
      rewrite H.
      clear H.

      assert ( Pr  [b' <-$ f eta false; ret eqb false b' ] == (ratSubtract 1 (Pr[f eta false]))).
      assert (Pr  [b' <-$ f eta false; ret eqb false b' ]  == evalDist (f eta false) false).
      symmetry.
      rewrite <- evalDist_right_ident.
      comp_skip.
      comp_ute.
      rewrite H.
      clear H.

      eapply evalDist_bool_complement.
      wftac.

      rewrite H.
      clear H.

      rewrite <- ratMult_distrib.
      rewrite <- (ratMult_1_r (1/2)) at 2.

      rewrite ratMult_ratDistance_factor_l.
      eapply ratMult_eqRat_compat; intuition.

      assert ((Pr  [f eta false])  + ratSubtract 1 (Pr  [f eta false]) == 1).
      rewrite <- ratSubtract_ratAdd_assoc.
      eapply ratSubtract_ratAdd_inverse.

      eapply evalDist_le_1.
      unfold eq_dec.
      eapply (EqDec_dec _).
      wftac.

      rewrite <- H at 2.

      rewrite ratDistance_add_same_r.
      intuition.
    Qed.

    Theorem Def_equiv_2W :
      | Pr[StandardDef_G] - 1 / 2 | == (1 / 2) * | Pr[f eta false] - Pr[f eta true] |.

      rewrite StandardDef_equiv_2W_h.
      rewrite ratDistance_comm.
      intuition.

    Qed.

    End TwoWorldsEquiv_eta.

    Theorem TwoWorlds_equiv_f :
      negligible (fun eta => (| Pr[f eta false] - Pr[f eta true] |)) ->
      negligible (fun eta => | Pr[StandardDef_G eta] - 1 / 2 |).

      unfold negligible.
      intuition.
      destruct (H c).
      exists x.
      intuition.
      eapply H0.
      intuition.
      rewrite H2.
      rewrite Def_equiv_2W.

      rewrite ratMult_comm.
      eapply ratMult_small_le.

      eapply rat_le_1.
      simpl.
      omega.

    Qed.

    Theorem TwoWorlds_equiv_b :
      negligible (fun eta => | Pr[StandardDef_G eta] - 1 / 2 |) ->
      negligible (fun eta => (| Pr[f eta false] - Pr[f eta true] |)).

      unfold negligible.
      intuition.
      edestruct (H (1 + c)%nat).
      exists (S x)%nat.
      intuition.
      eapply H0.
      omega.

      assert ((RatIntro (S O)
        (@natToPosnat (expnat x0 (plus (S O) c))
           (@expnat_nz (plus (S O) c) x0 pf_nz))) == (1 / x0) * (1 / (expnat x0 c))).

      simpl.
      rewrite <- ratMult_denom.
      eapply eqRat_terms; intuition.

      rewrite H3.
      clear H3.
      rewrite H2.

      eapply leRat_trans.
      Focus 2.
      eapply eqRat_impl_leRat.
      symmetry.
      eapply Def_equiv_2W.

      eapply ratMult_leRat_compat; intuition.
      unfold leRat.
      eapply leRat_terms; intuition.
      unfold natToPosnat, posnatToNat.
      omega.

    Qed.

    Theorem TwoWorlds_equiv :
      negligible (fun eta => (| Pr[f eta false] - Pr[f eta true] |)) <->
      negligible (fun eta => | Pr[StandardDef_G eta] - 1 / 2 |).

      intuition.
      eapply TwoWorlds_equiv_f; intuition.
      eapply TwoWorlds_equiv_b; intuition.

    Qed.

End TwoWorldsEquiv.


Require Import prosa.classic.util.tactics.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

(* Lemmas about big operators over Ordinals that use Ordinal functions.
   There is no support for them in ssreflect. *)
Section BigOrdFunOrd.

  Definition fun_ord_to_nat {n} {T} (x0: T) (f: 'I_n -> T) : nat -> T.
  (* if x < n, apply the function f in the (Ordinal x: 'I_n), else return default x0. *)
    intro x; destruct (x < n) eqn:LT;
      [by apply (f (Ordinal LT)) | by apply x0].
  Defined.

  Lemma eq_fun_ord_to_nat :
    forall n {T: Type} x0 (f: 'I_n -> T) (x: 'I_n),
      (fun_ord_to_nat x0 f) x = f x.
  Proof.
    ins; unfold fun_ord_to_nat; des_eqrefl.
      by f_equal; apply ord_inj.
      by destruct x; ins; rewrite i in EQ.
  Qed.

  Lemma eq_bigr_ord T n op idx r (P : pred 'I_n)
                    (F1: nat -> T) (F2: 'I_n -> T) :
    (forall i, P i -> F1 i = F2 i) ->
    \big[op/idx]_(i <- r | P i) F1 i = \big[op/idx]_(i <- r | P i) F2 i.
  Proof.
    induction r; ins; first by rewrite 2!big_nil.
    rewrite 2!big_cons; destruct (P a) eqn:EQ;
      by rewrite IHr; ins; rewrite H; ins.
  Qed.

  Lemma big_mkord_ord {T} {n} {op} {idx} x0 (P : pred 'I_n) (F: 'I_n -> T) :
    \big[op/idx]_(i < n | P i) F i =
      \big[op/idx]_(i < n | P i) (fun_ord_to_nat x0 F) i.
  Proof.
    have EQ := eq_bigr_ord T n op idx _ _ (fun_ord_to_nat x0 F) F.
    rewrite EQ; [by ins | by ins; rewrite eq_fun_ord_to_nat].
  Qed.

End BigOrdFunOrd.


From mathcomp Require Import all_ssreflect all_algebra.
Require Import classical funlib category functor.

Open Scope category_scope.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section rings.
Open Scope ring_scope.

Fact rmorphism_comp_assoc (R S T U : ringType) (f : {rmorphism R -> S}) (g : {rmorphism S -> T}) (h : {rmorphism T -> U}) : [rmorphism of [rmorphism of h \o g] \o f] =
  [rmorphism of h \o [rmorphism of g \o f]].
Proof.
  move: f g h => [f ?] [g ?] [h ?] //=.
  congr (GRing.RMorphism.Pack _ (GRing.RMorphism.Class _ _)); apply: Prop_irrelevance.
Qed.

Fact rmorphism_id_left (R S : ringType) (f : {rmorphism R -> S}) :
  [rmorphism of f \o [rmorphism of idfun]] = f.
Proof.
  move: f => [f H] //=.
  congr (GRing.RMorphism.Pack _ _); apply: Prop_irrelevance.
Qed.

Fact rmorphism_id_right (R S : ringType) (f : {rmorphism R -> S}) :
  [rmorphism of [rmorphism of idfun] \o f] = f.
Proof.
  move: f => [f H] //=.
  congr (GRing.RMorphism.Pack _ _); apply: Prop_irrelevance.
Qed.

Definition ringType_CatMixin := @CatMixin ringType (fun R S => {rmorphism R -> S})
                                          (fun _ _ _ f g => [rmorphism of g \o f])
                                          rmorphism_comp_assoc
                                          (fun R => [rmorphism of @idfun R])
                                          rmorphism_id_left
                                          rmorphism_id_right.
Definition comRingType_CatMixin := @CatMixin comRingType (fun R S => {rmorphism R -> S})
                                          (fun _ _ _ f g => [rmorphism of g \o f])
                                          rmorphism_comp_assoc
                                          (fun R => [rmorphism of @idfun R])
                                          rmorphism_id_left
                                          rmorphism_id_right.

Definition ringType_Category := Eval hnf in Category ringType ringType_CatMixin.
Definition comRingType_Category := Eval hnf in Category comRingType comRingType_CatMixin.
Canonical ringType_Category.
Canonical comRingType_Category.
End rings.

Notation Ring := ringType_Category.
Notation CRing := comRingType_Category.


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Tarski_dev.Ch11_angles.

Section thales_postulate_thales_converse_postulate.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

(** This comes from the proof of Martin's Theorem 23.7 (N -> O) *)

Lemma thales_postulate__thales_converse_postulate : thales_postulate -> thales_converse_postulate.
Proof.
  intros thales A B C M HM HPer.
  destruct (col_dec A B C) as [|HNCol].
    destruct (l8_9 A C B); Col; subst; Cong.
  assert_diffs.
  assert(M <> C) by (intro; subst; apply HNCol; Col).
  destruct (segment_construction_3 M C M A) as [C' [HC' HCong]]; auto.
  apply cong_symmetry in HCong.
  elim(eq_dec_points C C').
    intro; subst; assumption.
  intro.
  exfalso.
  assert_diffs.
  assert(~ Col A B C') by (intro; apply HNCol; ColR).
  assert(~ Col A C C') by (intro; apply HNCol; ColR).
  assert(~ Col B C C') by (intro; apply HNCol; ColR).
  assert_diffs.
  assert(CongA A C B A C' B).
    apply l11_16; auto; apply (thales _ _ _ M); assumption.
  assert(OS A B C C') by (apply (out_one_side_1 _ _ _ _ M); Col).
  destruct HC' as [_ [_ [HMCC'|HMC'C]]].
  - assert(Hlta : LtA A C' B A C B); [|destruct Hlta; CongA].
    apply os3__lta; Side;
    apply (one_side_transitivity _ _ _ M).
      apply invert_one_side; apply out_one_side; Col; apply l6_6; apply bet_out; Between.
      apply out_one_side; Col; apply l6_6; apply bet_out; Between.
      apply invert_one_side; apply out_one_side; Col; apply l6_6; apply bet_out; Between.
      apply out_one_side; Col; apply l6_6; apply bet_out; Between.

  - assert(Hlta : LtA A C B A C' B); [|destruct Hlta; CongA].
    apply os3__lta; Side;
    apply (one_side_transitivity _ _ _ M).
      apply invert_one_side; apply out_one_side; Col; apply l6_6; apply bet_out; Between.
      apply out_one_side; Col; apply l6_6; apply bet_out; Between.
      apply invert_one_side; apply out_one_side; Col; apply l6_6; apply bet_out; Between.
      apply out_one_side; Col; apply l6_6; apply bet_out; Between.
Qed.

End thales_postulate_thales_converse_postulate.


Require Import List EquivDec FunctionalExtensionality.
Require Import Isomorphism Eqdep_dec.

Require Import LibUtils.
Require Import Lia.
Require Import ListAdd Vector.

Class Finite (A:Type) :=
 { elms  : list A ;
  finite : forall x:A, In x elms
 }.

Lemma Finite_equivlist {A:Type} (fin1:Finite A) (fin2:Finite A) :
  equivlist (@elms _ fin1) (@elms _ fin2).
Proof.
  destruct fin1 as [??]
  ; destruct fin2 as [??].
  split; intuition.
Qed.

Program Instance Finite_iso {A B} {iso:Isomorphism A B} {fin:Finite A} : Finite B
  := {
  elms:= (List.map iso_f elms)
    }.
Next Obligation.
  apply in_map_iff.
  exists (iso_b x).
  split.
  - now rewrite iso_f_b.
  - apply finite.
Qed.

Lemma in_dec_nd_pf_irrel {A:Type} {dec:EqDec A eq} {a:A} {l:list A} (nd:NoDup l) (pf1 pf2:In a l) :
  pf1 = pf2.
Proof.
  induction l.
  - inversion pf1.
  - simpl in pf1, pf2.
    invcs nd.
    destruct pf1; destruct pf2.
    + f_equal.
      apply UIP_dec.
      apply dec.
    + congruence.
    + congruence.
    + f_equal.
      auto.
Qed.

(* When we have a decidable equality, we can define a version of In which
   only admits unique proofs. This is important for avoiding proof irrelevance.
 *)
Fixpoint Inb {A} {dec:EqDec A eq} (a:A) l
  := match l with
     | nil => false
     | b::m => if b == a then
               true
             else Inb a m
     end.

Definition In_strong {A} {dec:EqDec A eq} (a:A) l := Inb a l = true.

Lemma In_strong_In {A} {dec:EqDec A eq} (a:A) l : In_strong a l -> In a l.
Proof.
  unfold In_strong.
  induction l; simpl; intuition.
  destruct (equiv_dec a0 a); intuition.
Qed.

Lemma In_In_strong {A} {dec:EqDec A eq} (a:A) l : In a l -> In_strong a l.
Proof.
  unfold In_strong.
  induction l; simpl; trivial.
  - intuition.
  - destruct (equiv_dec a0 a); simpl; intuition.
Qed.

Lemma in_strong_dec_pf_irrel_helper
  {SBP:Prop} (v:{SBP} + {~SBP}) (P:Prop)

    (pf1 pf2 : if v then True else P)
    (IH : forall pf1 pf2 : P, pf1 = pf2) : pf1 = pf2.
Proof.
  destruct v.
  - destruct pf1; destruct pf2; trivial.
  - apply IH.
Qed.

Lemma in_strong_dec_pf_irrel {A:Type} {dec:EqDec A eq} {a:A} {l:list A} (pf1 pf2:In_strong a l) :
  pf1 = pf2.
Proof.
  apply UIP_dec.
  apply equiv_dec.
Qed.

Program Fixpoint Finite_fun_dep_elems_aux {A:Type} {dec:EqDec A eq} {B:A->Type} (la:list A)
        {struct la} : (forall x, In_strong x la -> list (B x)) -> list (forall a, In_strong a la -> B a)
  := match la as la' return (forall x, In_strong x la' -> list (B x)) -> list (forall a, In_strong a la' -> B a) with
     | nil => fun _ => _ :: nil
     | a::xs => fun lb => let rest := Finite_fun_dep_elems_aux xs (fun x inx => lb x _) in
                     let lbx := lb a _ in
                     List.concat (List.map (fun b => List.map (fun x => _) rest) lbx)
     end.
Next Obligation.
  unfold In_strong in *.
  simpl.
  rewrite inx.
  now destruct (a == x).
Defined.
Next Obligation.
  unfold In_strong in *.
  simpl.
  now destruct (a == a); [| congruence].
Defined.
Next Obligation.
  destruct (a == a0).
  - now destruct e.
  - apply x.
    unfold In_strong in *.
    simpl in H.
    destruct (a == a0); trivial.
    congruence.
Defined.

Definition Finite_fun_dep_elems
        {A:Type} {dec:EqDec A eq} {B:A->Type} (finA:Finite A) (finB:forall a, Finite (B a))
  : list (forall a, B a)
  := List.map (fun X a => X a (In_In_strong _ _ (finite a))) (Finite_fun_dep_elems_aux (B:=B) elms (fun a ina => elms)).

Lemma Finite_fun_dep_elems_aux_all
      {A:Type} {dec:EqDec A eq} {B:A->Type} (la:list A)
      (lb:forall a, In_strong a la -> list (B a))
      (lbf:forall a pf x, In x (lb a pf))
  : forall x:(forall a:A, In_strong a la -> B a), In x (Finite_fun_dep_elems_aux la lb).
Proof.
  revert lb lbf.
  induction la; simpl; intros lb lbf x.
  - left.
    apply FunctionalExtensionality.functional_extensionality_dep; intros a.
    apply FunctionalExtensionality.functional_extensionality_dep; intros ina.
    intuition.
  - specialize (IHla (fun (x0 : A) (inx : In_strong x0 la) => lb x0 (Finite_fun_dep_elems_aux_obligation_2 A dec a la x0 inx))).
    cut_to IHla; [| intros; apply lbf].
    rewrite concat_In.
    refine (ex_intro _ (List.map _
                                 (Finite_fun_dep_elems_aux la
                                                           (fun (x0 : A) (inx : In_strong x0 la) => lb x0 (Finite_fun_dep_elems_aux_obligation_2 A dec a la x0 inx)))) _).
    split.
    rewrite in_map_iff.
    eexists; split; [reflexivity | ].
    + apply (lbf a (Finite_fun_dep_elems_aux_obligation_3 A dec a la) (x a (Finite_fun_dep_elems_aux_obligation_3 A dec a la))).
    + apply in_map_iff.
      exists (fun a' pfin => x a' (Finite_fun_dep_elems_aux_obligation_2 A dec a la a' pfin)).
      split; trivial.
      apply FunctionalExtensionality.functional_extensionality_dep; intros a'.
      apply FunctionalExtensionality.functional_extensionality_dep; intros ina'.
      unfold Finite_fun_dep_elems_aux_obligation_4.
      clear.
      revert ina'.
      unfold In_strong.
      simpl.
      pattern (a == a') at 2.
      destruct (a == a'); simpl; intros.
      * destruct e.
        f_equal.
        apply in_strong_dec_pf_irrel.
      * f_equal.
        apply in_strong_dec_pf_irrel.
Qed.

Lemma Finite_fun_dep_elems_all
      {A:Type} {dec:EqDec A eq} {B:A->Type} (finA:Finite A) (finB:forall a, Finite (B a))
  : forall x:(forall a:A, B a), In x (Finite_fun_dep_elems finA finB).
Proof.
  unfold Finite_fun_dep_elems; simpl.
  intros.
  generalize (Finite_fun_dep_elems_aux_all elms (B:=B) (fun a _ => elms))
  ; intros HH.
  specialize (HH (fun a _ xx => (finite xx))).
  apply List.in_map_iff.
  exists (fun a _ => x a).
  split; trivial.
Qed.

Instance Finite_fun_dep {A:Type} {dec:EqDec A eq} {B:A->Type} (finA:Finite A) (finB:forall a, Finite (B a)): Finite (forall a : A, B a) :=
  {|
  elms := Finite_fun_dep_elems finA finB
  ; finite := Finite_fun_dep_elems_all finA finB
|}.

Instance Finite_fun {A:Type} {dec:EqDec A eq} {B} (finA:Finite A) (finB:Finite B): Finite (A -> B) :=
  @Finite_fun_dep A dec (fun _ => B) finA (fun _ => finB).

Lemma concat_length {A:Type} (l:list (list A)) : length (concat l) = fold_right plus 0 (map (@length _) l).
Proof.
  induction l; simpl; trivial.
  now rewrite app_length, IHl.
Qed.

Lemma fold_right_add_const {A:Type} c (l:list A) :
  fold_right Nat.add 0
    (map (fun _  => c) l) =  c * length l.
Proof.
  induction l; simpl; trivial.
  rewrite IHl; simpl.
  rewrite NPeano.Nat.mul_succ_r.
  now rewrite NPeano.Nat.add_comm.
Qed.

Lemma fold_right_mult_const {A:Type} c (l:list A) :
  fold_right Nat.mul 1
    (map (fun _  => c) l) =  NPeano.Nat.pow c (length l).
Proof.
  induction l; simpl; trivial.
  now rewrite IHl; simpl.
Qed.

Lemma Finite_fun_dep_size {A:Type} {dec:EqDec A eq} {B:A->Type} (finA:Finite A) (finB:forall a, Finite (B a))
  : length (@elms _ (Finite_fun_dep finA finB)) =
    fold_right Nat.mul 1 (List.map (fun a => length (@elms _ (finB a))) (@elms _ finA)).
Proof.
  destruct finA.
  unfold elms; simpl.
  unfold Finite_fun_dep_elems.
  rewrite map_length.
  simpl.
  clear finite0.
  induction elms0; simpl; trivial; intros.
  rewrite concat_length.
  rewrite map_map.
  rewrite (map_ext _ (fun x : B a =>
        length
          (Finite_fun_dep_elems_aux elms0 (fun (x0 : A) (_ : In_strong x0 elms0) => elms))))
    by (intros; now rewrite map_length).
  rewrite fold_right_add_const.
  rewrite NPeano.Nat.mul_comm.
  now rewrite <- IHelms0.
Qed.

Lemma Finite_fun_size {A:Type} {dec:EqDec A eq} {B:Type} (finA:Finite A) (finB:Finite B)
  : length (@elms _ (Finite_fun finA finB)) = NPeano.pow (length (@elms _ finB)) (length (@elms _ finA)).
Proof.
  unfold Finite_fun.
  rewrite Finite_fun_dep_size.
  apply fold_right_mult_const.
Qed.

Global Program Instance finite_prod {A B} (finA:Finite A) (finB:Finite B) : Finite (A*B)
  := { elms := list_prod elms elms }.
Next Obligation.
  apply in_prod_iff.
  split; apply finite.
Qed.

Definition bounded_nat_finite_list n : list {x : nat | (x < n)%nat}.
Proof.
  induction n.
  - exact nil.
  - apply cons.
    + exists n; lia.
    + eapply List.map; [| exact IHn].
      intros [x ?].
      exists x; lia.
Defined.

Lemma bounded_nat_finite_list_proj n : List.map (@proj1_sig _ _) (bounded_nat_finite_list n) = rev (seq 0 n).
Proof.
  induction n; trivial.
  rewrite ListAdd.seq_Sn.
  rewrite List.rev_app_distr.
  simpl rev.
  simpl.
  rewrite List.map_map; simpl.
  rewrite <- IHn.
  f_equal.
  now apply map_ext; intros [??].
Qed.

Global Program Instance bounded_nat_finite n : Finite {x : nat | (x < n)%nat}
  := {|
  (* put them in numeric order for the convenience of users *)
  elms := rev (bounded_nat_finite_list n)
    |}.
Next Obligation.
  apply -> in_rev.
  assert (inn:In x (rev (seq 0 n))).
  - apply -> in_rev.
    apply in_seq; lia.
  - rewrite <- (bounded_nat_finite_list_proj n) in inn.
    apply in_map_iff in inn.
    destruct inn as [[??] [??]].
    simpl in *; subst.
    erewrite index_pf_irrel; eauto.
Qed.


(** * 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.*)

(* ################################################################# *)
(** * FULL: 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 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.
  induction l as [|x l'].
  - simpl. reflexivity.
  - simpl. rewrite IHl'. reflexivity.
Qed.

Theorem app_assoc : forall A (l m n:list A),
  l ++ m ++ n = (l ++ m) ++ n.
Proof.
  intros.
  induction l as [|x 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.
  induction l1 as [|x 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.
  induction l1 as [|a l1' IHl1'].
  - 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.
intros.
  induction l as [|a l' IHl'].
  - simpl. reflexivity.
  - simpl. rewrite -> rev_app_distr. simpl. rewrite -> IHl'. 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? *)
(** [] *)

(** **** 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
  | [] => ([], [])
  | (x, y) :: t => (x :: fst (split t), y :: snd (split t))
  end.

Example test_split:
  split [(1,false);(2,false)] = ([1;2],[false;false]).
Proof.
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
  | h :: l' => if beq_nat n O then Some h 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 :: l => 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. reflexivity. Qed.
Example test_hd_error2 : hd_error  [[1];[2]]  = Some [1].
Proof. 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 minustwo (n : nat) : nat :=
  match n with
    | O => O
    | S O => O
    | S (S n') => n'
  end.

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 oddb (n:nat) : bool   :=   negb (evenb n).

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 evn_g7 (n:nat) : bool :=
    if evenb n then (negb (leb (minus n 7) 0))
               else false.

Definition filter_even_gt7 (l : list nat) : list nat :=
  filter evn_g7 l.

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

Example test_filter_even_gt7_2 :
  filter_even_gt7 [5;2;6;19;129] = [].
Proof. 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. *)

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

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

Example test_partition1: partition oddb [1;2;3;4;5] = ([1;3;5], [2;4]).
Proof. reflexivity.  Qed.
Example test_partition2: partition (fun x => false) [5;9;0] = ([], [5;9;0]).
Proof. 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. *)

(* Looked up HELP for this lemma and theorem, did not finish it*)

(* Lemma map_helper : forall (X Y : Type) (f: X -> Y) (l : list X) (x : X),
  map f (helper l x) = helper (map f l) (f x).
Proof.
  intros X Y f l x.
  induction l as [| z l'].
    - reflexivity.
    - simpl. rewrite -> IHl'. 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 as [| x l'].
  Case "l = nil".
    reflexivity.
  Case "l = cons".
    simpl. rewrite -> map_snoc. rewrite -> IHl'. 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
  | nil => nil
  | h :: t => (app (f h)  (flat_map f t))
  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. 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. induction l as [| x xs].
  - reflexivity.
  - simpl. rewrite <- IHxs. 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 x y => (f x) :: y) l [].

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

(* 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.
intros. simpl. 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.
  destruct p as [m n].
  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: *)

(* HAD SOME ISSUES WITH CURCH NUMERALS, LOOKE UP STUFF *)

Definition succ (n : nat) : nat :=
  fun X f x => n X f (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 f x => m X f (n 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
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example mult_1 : mult one one = one.
Proof. (* FILL IN HERE *) Admitted.

Example mult_2 : mult zero (plus three three) = zero.
Proof. (* FILL IN HERE *) Admitted.

Example mult_3 : mult two three = plus three three.
Proof. (* FILL IN HERE *) Admitted.

(** 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
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example exp_1 : exp two two = plus two two.
Proof. (* FILL IN HERE *) Admitted.

Example exp_2 : exp three two = plus (mult two (mult two two)) one.
Proof. (* FILL IN HERE *) Admitted.

Example exp_3 : exp three zero = one.
Proof. (* FILL IN HERE *) Admitted.

End Church.
(** [] *)

End Exercises.


Require Import List.
Require Import LambdaSyntax.

(** A representation that's a variation of De Bruijn indices, avoiding the
  shifting of free variables. Shifting is only used to preserve the identity
  of free variables when under binders, but here we distinguish free and
  bound variables in a term explicitly. *)

Set Implicit Arguments.

Inductive dbv_var : Set :=
| Free : nat -> dbv_var
| Bound : nat -> dbv_var.

Inductive dbv_term (A : Type) : Type :=
| DBV_const : A -> dbv_term A
| DBV_var : dbv_var -> dbv_term A
| DBV_abs : dbv_term A -> dbv_term A
| DBV_app : dbv_term A -> dbv_term A -> dbv_term A.

Notation "\\ M" := (DBV_abs M) (at level 60, right associativity).
Notation "M $$ N" := (DBV_app M N) (at level 60, right associativity).
Notation "[ v ]" := (DBV_var (Free v)) (at level 40, no associativity).
Notation "[ v # T ]" := (DBV_var T (Free v)) (at level 40, no associativity).
Notation "[| v |]" := (DBV_var (Bound v)) (at level 40, no associativity).
Notation "[| v # T |]" := (DBV_var T (Bound v)) (at level 40, no associativity).

Definition binders := list var.

Fixpoint find_var_in_binders (bs : binders) (v : var) (i : nat) : option nat :=
  match bs with
    | nil => None
    | v' :: bs' => if beq_nat v v' then Some i
                   else find_var_in_binders bs' v (S i)
  end.

Definition var_to_dbv_var (v : var) (bs : binders) : dbv_var :=
  match find_var_in_binders bs v 0 with
    | None => Free v
    | Some i => Bound i
  end.

Fixpoint term_to_dbv_aux {A : Type} (t : term A) (bs : binders) : dbv_term A :=
  match t with
    | Const a => DBV_const a
    | Var v => DBV_var A (var_to_dbv_var v bs)
    | Abs x body => DBV_abs (term_to_dbv_aux body (x :: bs))
    | App m n => DBV_app (term_to_dbv_aux m bs) (term_to_dbv_aux n bs)
  end.

Definition term_to_dbv {A : Type} (t : term A) : dbv_term A :=
  term_to_dbv_aux t nil.

Example dbv_conv_ex1 :
  term_to_dbv (\X # nat --> Var X) = (\\ (DBV_var nat (Bound 0))).
Proof. reflexivity. Qed.

Example dbv_conv_ex2 :
  term_to_dbv (\X # nat --> (Var X) $ (Var Y)) =
  \\ ((DBV_var nat (Bound 0)) $$ (DBV_var nat (Free 1))).
Proof. reflexivity. Qed.

Example dbv_conv_ex3 :
  term_to_dbv (\Y # nat --> Var Y) = (DBV_abs (DBV_var nat (Bound 0))).
Proof. reflexivity. Qed.

Example dbv_conv_ex4 :
  term_to_dbv (\Y # nat --> (Var Y) $ (Var Z)) =
  (DBV_abs (DBV_app (DBV_var nat (Bound 0)) (DBV_var nat (Free Z)))).
Proof. reflexivity. Qed.

Fixpoint dbv_var_to_var (ix : nat) (bs : binders) : var :=
  match ix, bs with
    | 0, v :: bs' => v
    | S i, v :: bs' => dbv_var_to_var i bs'
    | _, _ => 666
  end.

Fixpoint dbv_to_term_aux {A : Type} (dt : dbv_term A) (bs : binders) (v : var) : term A :=
  match dt with
    | DBV_const c => Const c
    | DBV_var (Free n) => Var n
    | DBV_var (Bound n) => Var (dbv_var_to_var n bs)
    | DBV_abs body => Abs v (dbv_to_term_aux body (v :: bs) (S v))
    | DBV_app m n => App (dbv_to_term_aux m bs v) (dbv_to_term_aux n bs v)
  end.

Fixpoint dbv_to_term_aux_2 {A : Type} (dt : dbv_term A) (i v : var) : term A :=
  match dt with
    | DBV_const c => Const c
    | DBV_var (Free n) => Var n
    | DBV_var (Bound n) => Var (v + i - n)
    | DBV_abs body => Abs (v + (S i)) (dbv_to_term_aux_2 body (S i) v)
    | DBV_app m n => App (dbv_to_term_aux_2 m i v) (dbv_to_term_aux_2 n i v)
  end.

Fixpoint max_free_var {A : Type} (dt : dbv_term A) : nat :=
  match dt with
    | DBV_const _ => 0
    | DBV_var (Bound _) => 0
    | DBV_var (Free n) => n
    | DBV_abs body => max_free_var body
    | DBV_app m n => max (max_free_var m) (max_free_var n)
  end.

Definition dbv_to_term {A : Type} (dt : dbv_term A) : term A :=
  dbv_to_term_aux dt nil (S (max_free_var dt)).

Example dbv_to_term_1 : dbv_to_term (\\ (DBV_var nat (Bound 0))) = (Abs 1 (Var 1)).
Proof. reflexivity. Qed.

Example dbv_to_term2_1 : dbv_to_term_aux_2 (\\ (DBV_var nat (Bound 0))) 0 0 = (Abs 1 (Var 1)).
Proof. reflexivity. Qed.

Example dbv_to_term_2 :
  dbv_to_term (\\ ((DBV_var nat (Bound 0)) $$ (DBV_var nat (Free Z)))) =
  (\3 --> (Var 3) $ (Var Z)).
Proof. reflexivity. Qed.

Example dbv_to_term2_2 :
  dbv_to_term_aux_2 (\\ ((DBV_var nat (Bound 0)) $$ (DBV_var nat (Free Z)))) 0 2 =
  (\3 --> (Var 3) $ (Var Z)).
Proof. reflexivity. Qed.

Example dbv_to_term_3 :
  dbv_to_term (\\ (\\ ((DBV_var nat (Bound 0)) $$ (DBV_var nat (Bound 1))))) =
  \1 --> \2 --> Var 2 $ Var 1.
Proof. reflexivity. Qed.

Example dbv_to_term2_3 :
  dbv_to_term_aux_2 (\\ (\\ ((DBV_var nat (Bound 0)) $$ (DBV_var nat (Bound 1))))) 0 0 =
  \1 --> \2 --> Var 2 $ Var 1.
Proof. reflexivity. Qed.

(** Verifying if a DBV term is well-formed.  *)

Fixpoint well_formed_aux {A : Type} (dt : dbv_term A) (b : nat) : bool :=
  match dt with
    | DBV_const _ => true
    | DBV_var (Free _) => true
    | DBV_var (Bound n) => leb (S n) b
    | DBV_abs body => well_formed_aux body (S b)
    | DBV_app m n => andb (well_formed_aux m b) (well_formed_aux n b)
  end.

Lemma well_formed_var : forall (A : Type) (v n : nat),
                          well_formed_aux (DBV_var A (Bound v)) n = true ->
                          v < n.
Proof.
  intros A v n H.
  simpl in H. destruct n. inversion H. apply le_lt_n_Sm. apply leb_complete. assumption.
Qed.

(*
Theorem dbv_to_from : forall (A : Type) (dt : dbv_term A) (v : var),
                        v > (max_free_var dt) -> well_formed_aux dt 0 = true ->
                        term_to_dbv_aux (dbv_to_term_aux_2 dt 0 v) nil = dt.
Proof.
  intros A dt v Hgt Hwf.
  induction dt.

  reflexivity. simpl. destruct d. reflexivity.
  assert (Hcontra: well_formed_aux ([| n # A |]) 0 = false).
  reflexivity. congruence.

  simpl. f_equal.
*)


From CoqAlgs Require Export CMon.
From CoqAlgs Require Export Sorting.InsertionSort.
From CoqAlgs Require Export Sorting.SortSpec.

Set Implicit Arguments.

Inductive exp (X : CMon) : Type :=
    | Id : exp X
    | Var : nat -> exp X
    | Op : exp X -> exp X -> exp X.

Arguments Id  {X}.
Arguments Var {X} _.
Arguments Op  {X} _ _.

Fixpoint expDenote {X : CMon} (envX : Env X) (e : exp X) : X :=
match e with
    | Id => neutr
    | Var n => nth n envX neutr
    | Op e1 e2 => op (expDenote envX e1) (expDenote envX e2)
end.

Fixpoint flatten {X : CMon} (e : exp X) : list nat :=
match e with
    | Id => []
    | Var v => [v]
    | Op e1 e2 => flatten e1 ++ flatten e2
end.

Theorem flatten_correct :
  forall (X : CMon) (envX : Env X) (e : exp X),
    expDenoteL envX (flatten e) = expDenote envX e.
Proof.
  induction e; simpl.
    reflexivity.
    rewrite neutr_r. reflexivity.
    rewrite expDenoteL_app. rewrite IHe1, IHe2. reflexivity.
Qed.

Function list_to_exp {X : CMon} (l : list nat) : exp X :=
match l with
    | [] => Id
    | [x] => Var x
    | h :: t => Op (Var h) (list_to_exp t)
end.

Theorem list_to_exp_correct :
  forall (X : CMon) (envX : Env X) (l : list nat),
    expDenote envX (list_to_exp l) = expDenoteL envX l.
Proof.
  intros. functional induction list_to_exp l; cbn.
    trivial.
    rewrite neutr_r. trivial.
    rewrite IHe. trivial.
Qed.

Theorem flatten_lte :
  forall (X : CMon) (l : list nat),
    flatten (list_to_exp l) = l.
Proof.
  intros. functional induction list_to_exp l; cbn;
  rewrite ?IHe; trivial.
Qed.

Theorem flatten_idempotent :
  forall (X : CMon) (e : exp X),
    flatten (list_to_exp (flatten e)) = flatten e.
Proof.
  intros. rewrite flatten_lte. trivial.
Qed.

Theorem sort_correct :
  forall (X : CMon) (envX : Env X) (l : list nat) (s : Sort trich_le),
    expDenoteL envX (s l) = expDenoteL envX l.
Proof.
  intros. apply expDenoteL_Permutation. rewrite Permutation_sort.
  reflexivity.
Qed.

Definition simplify {X : CMon} (e : exp X) : exp X :=
  list_to_exp (insertionSort natlt (flatten e)).

Theorem simplify_correct :
  forall (X : CMon) (envX : Env X) (e : exp X),
    expDenote envX (simplify e) = expDenote envX e.
Proof.
  unfold simplify. intros.
  rewrite !list_to_exp_correct.
  pose (sort_correct _ envX (flatten e) (Sort_insertionSort natlt)).
  cbn in e0. rewrite e0.
  erewrite ?flatten_correct.
  reflexivity.
Qed.

Theorem simplify_idempotent :
  forall (X : CMon) (e : exp X),
    simplify (simplify e) = simplify e.
Proof.
  intros. unfold simplify.
  rewrite ?flatten_lte.
  pose (sort_idempotent (Sort_insertionSort natlt)). simpl in e0.
  rewrite e0. reflexivity.
Qed.

Theorem reflectEq :
  forall (X : CMon) (envX : Env X) (e1 e2 : exp X),
    expDenote envX (simplify e1) = expDenote envX (simplify e2) ->
      expDenote envX e1 = expDenote envX e2.
Proof.
  intros. rewrite !simplify_correct in H. assumption.
Qed.

Ltac allVarsExp xs e :=
match e with
    | op ?e1 ?e2 =>
        let xs' := allVarsExp xs e2 in allVarsExp xs' e1
    | _ => addToList e xs
end.

Ltac reifyExp envX x :=
match x with
    | neutr => constr:(Id)
    | op ?a ?b =>
        let e1 := reifyExp envX a in
        let e2 := reifyExp envX b in constr:(Op e1 e2)
    | _ =>
        let n := lookup x envX in constr:(Var n)
end.

Ltac reifyEq envX a b :=
    let e1 := reifyExp envX a in
    let e2 := reifyExp envX b in
      constr:(expDenote envX e1 = expDenote envX e2).

Ltac cmon_simpl' := cbn; intros;
match goal with
    | X : CMon |- ?a = ?b =>
        let xs := allVarsExp constr:(@nil X) b in
        let xs' := allVarsExp xs a in
        let e := reifyEq xs' a b in
          change e; apply reflectEq; cbn;
          rewrite ?neutr_l, ?neutr_r
end.

Ltac cmon_simpl := subst; cmon_simpl'.

Ltac cmon := cmon_simpl; reflexivity.

(* Formulas. [not f] will be represented as [fImpl f fFalse] and
   [f1 <-> f2] as [fAnd (fImpl f1 f2) (fImpl f2 f1)]. *)
Inductive formula (X : CMon) : Type :=
    | fFalse : formula X
    | fTrue : formula X
    | fEq : exp X -> exp X -> formula X
    | fVar : nat -> formula X
    | fAnd : formula X -> formula X -> formula X
    | fOr : formula X -> formula X -> formula X
    | fImpl : formula X -> formula X -> formula X.

Arguments fFalse {X}.
Arguments fTrue  {X}.
Arguments fEq    {X} _ _.
Arguments fVar   {X} _.
Arguments fAnd   {X} _ _.
Arguments fOr    {X} _ _.
Arguments fImpl  {X} _ _.

Fixpoint formulaDenote
  {X : CMon} (envX : Env X) (envP : Env Prop) (f : formula X) : Prop :=
match f with
    | fFalse => False
    | fTrue => True
    | fVar i => holds i envP
    | fEq e1 e2 => expDenote envX e1 = expDenote envX e2
    | fAnd f1 f2 => formulaDenote envX envP f1 /\ formulaDenote envX envP f2
    | fOr f1 f2 => formulaDenote envX envP f1 \/ formulaDenote envX envP f2
    | fImpl f1 f2 => formulaDenote envX envP f1 -> formulaDenote envX envP f2
end.

Function subst {X : CMon} (e1 : exp X) (n : nat) (e2 : exp X) : exp X :=
match e1 with
    | Id => Id
    | Var m => if Nat.eq_dec n m then e2 else Var m
    | Op e11 e12 => Op (subst e11 n e2) (subst e12 n e2)
end.

Theorem subst_correct :
  forall (X : CMon) (envX : Env X) (envP : Env Prop) (e1 e2 : exp X)
  (i : nat),
    formulaDenote envX envP (fEq (Var i) e2) ->
      expDenote envX (subst e1 i e2) = expDenote envX e1.
Proof.
  intros. functional induction subst e1 i e2; cbn in *;
  try rewrite IHe, IHe0; congruence.
Qed.

Theorem subst_idempotent :
  forall (X : CMon) (envX : Env X) (e1 e2 : exp X) (i : nat),
    nth i envX neutr = expDenote envX e2 ->
      subst (subst e1 i e2) i e2 = subst e1 i e2.
Proof.
  intros. functional induction subst e1 i e2; cbn.
    reflexivity.
    gen e2. induction e2; intros; cbn in *.
      reflexivity.
      destruct (Nat.eq_dec n n0); reflexivity.
      admit.
    rewrite e0. reflexivity.
    erewrite IHe0, IHe; eauto.
Abort.

Function substF {X : CMon} (f : formula X) (i : nat) (e : exp X)
  : formula X :=
match f with
    | fEq e1 e2 => fEq (subst e1 i e) (subst e2 i e)
    | fAnd f1 f2 => fAnd (substF f1 i e) (substF f2 i e)
    | fOr f1 f2 => fOr (substF f1 i e) (substF f2 i e)
    | fImpl f1 f2 => fImpl (substF f1 i e) (substF f2 i e)
    | _ => f
end.

Theorem substF_correct :
  forall (X : CMon) (envX : Env X) (envP : Env Prop) (f : formula X)
  (i : nat) (e : exp X),
    nth i envX neutr = expDenote envX e ->
    (formulaDenote envX envP (substF f i e) <->
      formulaDenote envX envP f).
Proof.
  intros. functional induction substF f i e; cbn in *.
    rewrite !(@subst_correct _ envX envP); cbn; firstorder.
    all: firstorder.
Qed.

Function list_eq {A : Type} (p : A -> A -> bool) (l1 l2 : list A) : bool :=
match l1, l2 with
    | []      , []       => true
    | _ :: _  , []       => false
    | []      , _ :: _   => false
    | h1 :: t1, h2 :: t2 => p h1 h2 && list_eq p t1 t2
end.

Lemma list_eq_spec :
  forall {A : Type} (p : A -> A -> bool),
    (forall x y : A, reflect (x = y) (p x y)) ->
      forall l1 l2 : list A, reflect (l1 = l2) (list_eq p l1 l2).
Proof.
  intros A p Spec l1 l2.
  functional induction list_eq p l1 l2;
  repeat constructor.
    inv 1.
    inv 1.
    destruct (Spec h1 h2); cbn.
      destruct IHb; constructor; congruence.
      constructor. congruence.
Qed.

Function simplifyEq {X : CMon} (f : formula X) : formula X :=
match f with
    | fEq e1 e2 =>
        (* fEq (simplify e1) (simplify e2) *)
        let l1 := insertionSort natlt (flatten e1) in
        let l2 := insertionSort natlt (flatten e2) in
          if list_eq Nat.eqb l1 l2
          then fTrue
          else fEq (simplify e1) (simplify e2)
    | fAnd f1 f2 => fAnd (simplifyEq f1) (simplifyEq f2)
    | fOr f1 f2 => fOr (simplifyEq f1) (simplifyEq f2)
    | fImpl f1 f2 =>
        let f2' := simplifyEq f2 in
        match simplifyEq f1 with
            | fEq (Var i) e as f1' => fImpl f1' (substF f2' i e)
            | f1' => fImpl f1' f2'
        end
    | _ => f
end.

Theorem simplifyEq_correct :
  forall (X : CMon) (envX : Env X) (envP : Env Prop) (f : formula X),
    formulaDenote envX envP (simplifyEq f) <->
    formulaDenote envX envP f.
Proof.
  intros.
  functional induction simplifyEq f;
  cbn in *; rewrite ?simplify_correct;
  repeat multimatch goal with
      | H : forall _, _ <-> _ |- _ => rewrite ?H
  end; try tauto.
    split; intro; auto.
    {
      apply reflectEq. unfold simplify.
      destruct (list_eq_spec _ Nat.eqb_spec
                (insertionSort natlt (flatten e1))
                (insertionSort natlt (flatten e2))).
        rewrite e. reflexivity.
        congruence.
    }
    split; intros.
      rewrite <- IHf0. rewrite substF_correct in H.
        apply H. rewrite e1 in IHf1. cbn in IHf1. rewrite IHf1. assumption.
        rewrite <- IHf1 in H0. rewrite e1 in H0. cbn in H0. assumption.
      rewrite substF_correct.
        rewrite IHf0. apply H. rewrite <- IHf1, e1. cbn. assumption.
        assumption.
Qed.

Fixpoint size {X : CMon} (f : formula X) : nat :=
match f with
    | fFalse => 1
    | fTrue => 1
    | fEq _ _ => 1
    | fVar _ => 1
    | fAnd f1 f2 => size f1 + size f2
    | fOr f1 f2 => size f1 + size f2
    | fImpl f1 f2 => size f1 + size f2
end.

Lemma size_gt_0 :
  forall (X : CMon) (f : formula X), Nat.lt 0 (size f).
Proof.
  induction f; cbn; lia.
Qed.

Lemma size_substF :
  forall (X : CMon) (f : formula X) (i : nat) (e : exp X),
    size (substF f i e) = size f.
Proof.
  intros. functional induction substF f i e; cbn; lia.
Qed.

#[global] Hint Resolve size_gt_0 : core.

Set Warnings "-unused-pattern-matching-variable". (* Line 350 - bug in Coq? *)
Function simplifyEq' {X : CMon} (f : formula X) {measure size f}
  : formula X :=
match f with
    | fEq e1 e2 =>
        (* fEq (simplify e1) (simplify e2) *)
        let l1 := insertionSort natlt (flatten e1) in
        let l2 := insertionSort natlt (flatten e2) in
          if list_eq Nat.eqb l1 l2
          then fTrue
          else fEq (simplify e1) (simplify e2)
    | fAnd f1 f2 => fAnd (simplifyEq' f1) (simplifyEq' f2)
    | fOr f1 f2 => fOr (simplifyEq' f1) (simplifyEq' f2)
    | fImpl f1 f2 =>
        match simplifyEq' f1 with
            (* | fEq (Var i) e as f1' => fImpl f1' (simplifyEq' (substF f2 i e)) *)
            (* | fEq (Var i) e as f1' => fImpl f1' (substF (simplifyEq' f2) i e) *)
            | fEq (Var i) e => substF (simplifyEq' f2) i e
            | f1' => fImpl f1' (simplifyEq' f2)
        end
    | _ => f
end.
Proof.
  all: cbn; intros;
  repeat multimatch goal with
      | f : formula _ |- _ =>
          match goal with
              | H : Nat.lt 0 (size f) |- _ => idtac
              | _ => pose (size_gt_0 f)
          end
  end; try lia.
Defined.
Set Warnings "unused-pattern-matching-variable".

Theorem simplifyEq'_correct :
  forall (X : CMon) (envX : Env X) (envP : Env Prop) (f : formula X),
    formulaDenote envX envP f ->
      formulaDenote envX envP (simplifyEq' f).
Proof.
  intros.
  functional induction simplifyEq' f;
  cbn in *; rewrite ?simplify_correct;
  intros; try tauto.
Abort.

Theorem simplifyEq'_correct :
  forall (X : CMon) (envX : Env X) (envP : Env Prop) (f : formula X),
    formulaDenote envX envP (simplifyEq' f) ->
    formulaDenote envX envP f.
Proof.
  intros.
  functional induction simplifyEq' f;
  cbn in *; rewrite ?simplify_correct;
  intros; try tauto.
    {
      apply reflectEq. unfold simplify.
      destruct (list_eq_spec _ Nat.eqb_spec
                (insertionSort natlt (flatten e1))
                (insertionSort natlt (flatten e2))).
        rewrite e. reflexivity.
        congruence.
    }
    rewrite ?simplify_correct in *. assumption.
    apply IHf1. rewrite substF_correct in H.
      assumption.
      apply (f_equal (formulaDenote envX envP)) in e1. cbn in e1.
Abort.

Theorem simplifyEq'_correct :
  forall (X : CMon) (envX : Env X) (envP : Env Prop) (f : formula X),
    formulaDenote envX envP (simplifyEq' f)
      <->
    formulaDenote envX envP f.
Proof.
  intros.
  functional induction simplifyEq' f;
  cbn in *; rewrite ?simplify_correct;
  intros; try tauto.
    split; intro; auto.
    {
      apply reflectEq. unfold simplify.
      destruct (list_eq_spec _ Nat.eqb_spec
                (insertionSort natlt (flatten e1))
                (insertionSort natlt (flatten e2))).
        rewrite e. reflexivity.
        congruence.
    }
    rewrite substF_correct.
      rewrite IHf1.
Abort.

Function simplifyLogic {X : CMon} (f : formula X) : formula X :=
match f with
    | fAnd f1 f2 =>
        match simplifyLogic f1, simplifyLogic f2 with
            | fOr f11 f12, f2' => fOr (fAnd f11 f2') (fAnd f12 f2')
            | f1', fOr f21 f22 => fOr (fAnd f1' f21) (fAnd f1' f22)
            | fFalse, _ => fFalse
            | _, fFalse => fFalse
            | fTrue, f2' => f2'
            | f1', fTrue => f1'
            | f1', f2' => fAnd f1' f2'
        end
    | fOr f1 f2 =>
        match simplifyLogic f1, simplifyLogic f2 with
            | fAnd f11 f12, f2' => fAnd (fOr f11 f2') (fOr f12 f2')
            | f1', fAnd f21 f22 => fAnd (fOr f1' f21) (fOr f1' f22)
            | fFalse, f2' => f2'
            | f1', fFalse => f1'
            | fTrue, _ => fTrue
            | _, fTrue => fTrue
            | f1', f2' => fOr f1' f2'
        end
    | fImpl f1 f2 =>
        let f2' := simplifyLogic f2 in
        match simplifyLogic f1 with
            | fFalse => fTrue
            | fTrue => f2'
            | fAnd f11 f12 => fImpl f11 (fImpl f12 f2')
            | fOr f11 f12 => fAnd (fImpl f11 f2') (fImpl f12 f2')
            | f1' => fImpl f1' f2'
        end
    | _ => f
end.

Theorem simplifyLogic_correct :
  forall (X : CMon) (f : formula X) (envX : Env X) (envP : Env Prop),
    formulaDenote envX envP (simplifyLogic f) <-> formulaDenote envX envP f.
Proof.
  intros. functional induction simplifyLogic f; cbn.
  all:
  repeat match goal with
      | envX : Env _, IH : forall _ : Env _, _ |- _ => specialize (IH envX)
      | e : simplifyLogic ?f = _,
        IH : formulaDenote _ _ (simplifyLogic ?f) <-> _ |- _ =>
        rewrite <- IH, e; cbn
  end; try (tauto; fail).
Qed.

Definition simplifyFormula {X : CMon} (f : formula X) : formula X :=
  simplifyLogic (simplifyEq f).

Theorem simplifyFormula_correct :
  forall (X : CMon) (envX : Env X) (envP : Env Prop) (f : formula X),
    formulaDenote envX envP (simplifyFormula f) <->
    formulaDenote envX envP f.
Proof.
  intros. unfold simplifyFormula.
  rewrite simplifyLogic_correct, simplifyEq_correct.
  reflexivity.
Qed.

Definition solveEq
  {X : CMon} (envX : Env X) (envP : Env Prop)
    : forall e1 e2 : exp X, solution (formulaDenote envX envP (fEq e1 e2)).
Proof.
  refine (
  fix solve (e1 e2 : exp X)
    : solution (formulaDenote envX envP (fEq e1 e2)) :=
  match e1, e2 with
      | Id, Id => Yes
      | Var n, Var m => if Nat.eq_dec n m then Yes else No
      | Op e11 e12, Op e21 e22 => solve e11 e21 &&& solve e12 e22
      | _, _ => No
  end);
  cbn in *; congruence.
Defined.

Definition solveHypothesis {X : CMon} (envX : Env X) (envP : Env Prop) :
  forall (proofs : Proofs) (hyp f : formula X)
    (cont : forall proofs : Proofs,
      solution (allTrue envP proofs -> formulaDenote envX envP f)),
        solution (allTrue envP proofs -> formulaDenote envX envP hyp ->
          formulaDenote envX envP f).
Proof.
  refine (
  fix solve
    (proofs : Proofs) (hyp f : formula X)
      (cont : forall proofs : Proofs,
        solution (allTrue envP proofs -> formulaDenote envX envP f)) :
          solution (allTrue envP proofs -> formulaDenote envX envP hyp ->
            formulaDenote envX envP f) :=
  match hyp with
      | fFalse => Yes
      | fTrue => Reduce (cont proofs)
      | fVar i => Reduce (cont (i :: proofs))
      (*| fEq (Var i) e => Reduce (cont proofs)*)
      | fEq _ _ => Reduce (cont proofs)
      | fAnd f1 f2 =>
          Reduce (solve proofs f1 (fImpl f2 f)
                        (fun proofs' => Reduce (cont proofs')))
      | fOr f1 f2 =>
          solve proofs f1 f cont &&&
          solve proofs f2 f cont
      | _ => No
  end).
  all: cbn in *; try tauto.
Defined.

Definition solveGoal {X : CMon} (envX : Env X) (envP : Env Prop)
  : forall (proofs : Proofs) (f : formula X),
      solution (allTrue envP proofs -> formulaDenote envX envP f).
Proof.
  refine (
  fix solve
    (proofs : Proofs) (f : formula X)
      : solution (allTrue envP proofs -> formulaDenote envX envP f) :=
  match f with
      | fFalse => No
      | fTrue => Yes
      | fVar i =>
          match in_dec Nat.eq_dec i proofs with
              | left _ => Yes
              | right _ => No
          end
      | fEq e1 e2 => Reduce (solveEq envX envP e1 e2)
      | fAnd f1 f2 => solve proofs f1 &&& solve proofs f2
      | fOr f1 f2 => solve proofs f1 ||| solve proofs f2
      | fImpl f1 f2 =>
          solveHypothesis envX envP proofs f1 f2
            (fun proofs' => solve proofs' f2)
  end).
  all: cbn; try tauto.
    intro. apply find_spec with proofs; assumption.
Defined.

Definition solveFormula
  {X : CMon} (envX : Env X) (envP : Env Prop) (f : formula X)
    : solution (formulaDenote envX envP f).
Proof.
(*  refine (Reduce (solveGoal envX envP [] (simplifyFormula f))).*)
  refine (Reduce (solveGoal envX envP [] f)).
  (*rewrite <- simplifyFormula_correct.*)
  apply f0. cbn. trivial.
Defined.

Theorem solveFormula_correct :
  forall (X : CMon) (envX : Env X) (envP : Env Prop) (f : formula X),
    (exists p : formulaDenote envX envP f,
      solveFormula envX envP f = Yes' p) ->
        formulaDenote envX envP f.
Proof.
  intros. destruct H. assumption.
Qed.

Ltac allVarsX xs P :=
match P with
    | False => xs
    | True => xs
    | ?a = ?b =>
        let xs' := allVarsExp xs b in allVarsExp xs' a
    | ~ ?P' => allVarsX xs P'
    | ?P1 /\ ?P2 =>
        let xs' := allVarsX xs P2 in allVarsX xs' P1
    | ?P1 \/ ?P2 =>
        let xs' := allVarsX xs P2 in allVarsX xs' P1
    | ?P1 -> ?P2 =>
        let xs' := allVarsX xs P2 in allVarsX xs' P1
    | ?P1 <-> ?P2 =>
        let xs' := allVarsX xs P2 in allVarsX xs' P1
    | _ =>
        match type of P with
            | Prop => xs
            | _ => addToList P xs
        end
end.

Ltac allVarsProp xs P :=
match P with
    | False => xs
    | True => xs
    | ?a = ?b => xs
    | ~ ?P' => allVarsProp xs P'
    | ?P1 /\ ?P2 =>
        let xs' := allVarsProp xs P2 in allVarsProp xs' P1
    | ?P1 \/ ?P2 =>
        let xs' := allVarsProp xs P2 in allVarsProp xs' P1
    | ?P1 -> ?P2 =>
        let xs' := allVarsProp xs P2 in allVarsProp xs' P1
    | ?P1 <-> ?P2 =>
        let xs' := allVarsProp xs P2 in allVarsProp xs' P1
    | _ => addToList P xs
end.

Ltac reifyFormula envX envP P :=
match P with
    | False => constr:(fFalse)
    | True => constr:(fTrue)
    | ?a = ?b =>
        let e1 := reifyExp envX a in
        let e2 := reifyExp envX b in constr:(fEq e1 e2)
    | ~ ?P' =>
        let e := reifyFormula envX envP P' in constr:(fImpl e fFalse)
    | ?P1 /\ ?P2 =>
        let e1 := reifyFormula envX envP P1 in
        let e2 := reifyFormula envX envP P2 in constr:(fAnd e1 e2)
    | ?P1 \/ ?P2 =>
        let e1 := reifyFormula envX envP P1 in
        let e2 := reifyFormula envX envP P2 in constr:(fOr e1 e2)
    | ?P1 -> ?P2 =>
        let e1 := reifyFormula envX envP P1 in
        let e2 := reifyFormula envX envP P2 in constr:(fImpl e1 e2)
    | ?P1 <-> ?P2 =>
        let e1 := reifyFormula envX envP P1 in
        let e2 := reifyFormula envX envP P2 in
          constr:(fAnd (fImpl e1 e2) (fImpl e2 e1))
    | _ =>
        let i := lookup P envP in constr:(fVar i)
end.

Ltac solveGoal' X :=
match goal with
    | |- ?P =>
        let envX := allVarsX constr:(@nil X) P in
        let envP := allVarsProp constr:(@nil Prop) P in
        let f := reifyFormula envX envP P in
          change (formulaDenote envX envP f);
          rewrite <- simplifyFormula_correct; cbn;
          try apply (unwrap (solveFormula envX envP (simplifyFormula f)))
end.

#[refine]
#[export]
Instance CMon_unit : CMon :=
{
    carrier := unit;
    op := fun _ _ => tt
}.
Proof. all: try destruct x; firstorder. Defined.

Ltac solveGoal :=
match goal with
    | X : CMon |- ?P => solveGoal' X
    | |- ?P => solveGoal' CMon_unit
end.


Fixpoint fact (n:nat) : nat :=
  match n with
    | O => 1
    | S n' => n * fact n'
  end.

Require Import CoqIO.IO.
Require Import ExtLib.Programming.Show.

Import ShowNotation.
Local Open Scope show_scope.

Definition main : IO unit :=
  runShow ((show_exact "3! = ") << (show (fact 3))).


(* for all things you could prove,
    if you have a proof of it, then you have a proof of it. *)

Theorem my_first_proof :
  (forall A : Prop,
   A -> A).
Proof.
  intros A.
  intros proof_of_A.
  exact proof_of_A.
Qed.

(*
Theorem forward_small : (forall A B : Prop, A -> (A->B) -> B).
Proof.
 intros A.
 intros B.
 intros proof_of_A.
 intros A_implies_B.
 pose (proof_of_B := A_implies_B proof_of_A).
 exact proof_of_B.
Qed.
*)

Theorem forward_small : (forall A B : Prop, A -> (A -> B) -> B).
Proof.
  intros A.
  intros B.
  intros proof_of_A.
  intros A_implies_B.
  pose (proof_of_B := A_implies_B proof_of_A).
  exact proof_of_B.
Qed.