(*
  install Coq and the VSCode plugin
  or use the online CoqIDE
  https://jscoq.github.io/scratchpad.html

*)
Notation "⊥" := False.
Notation "⊤" := True.
Notation "¬" := not.

(* (φ -> ψ) -> (φ -> ψ) *)
(* use intros *)
(* Ltac ImplIntro := intro. *)
Tactic Notation "ImplIntro" :=
    let h := fresh "H" in
    intro h.
Tactic Notation "ImplIntro" ident(x) :=
    intro x.

(* φ /\ ψ -> (φ -> ψ -> P) -> P *)
(* use destruct *)
Definition and_elim {A B P} H :=
  fun R => @and_rect A B P R H.
Ltac AndElim H :=
    apply (and_elim H); do 2 intro.
    (* let name := name of H in
    match type of H with
    | _ /\ _ => pose proof H;destruct H
    | _ => fail "only conjunctions can be eliminated using this rule"
    end. *)

(* φ -> ψ -> φ /\ ψ *)
(* use split *)
Ltac AndIntro := apply conj.
(* φ -> φ *)
(* use assumption *)
Ltac Assumption := assumption.

(* ⊤ *)
(* use easy *)
Ltac TruthIntro := exact I.

(* ⊥ -> P *)
(* use destruct *)
Ltac FalsityElim H :=
    exfalso;exact H.

(* (φ -> χ) -> (ψ -> χ) -> (φ \/ ψ -> χ) *)
(* use destruct *)
Definition or_elim {A B P} H :=
  fun R1 R2 => @or_ind A B P R1 R2 H.
Ltac OrElim H :=
    apply (or_elim H);intro.

(* φ -> φ \/ ψ *)
Ltac OrIntro1 := left.
(* ψ -> φ \/ ψ *)
Ltac OrIntro2 := right.

(* (φ -> ψ) -> φ -> ψ *)
Ltac ImplApply H :=
    apply H.

    (* TODO: test *)
Ltac ImplSpecialize H :=
    let fn := fresh in
    specialize H as fn.

Ltac NegElim H :=
    let fn := fresh in
    pose proof (fn := H);
    unfold not in fn.

Ltac NegIntro :=
    ImplIntro.

Ltac Assert H := assert H.

Require Import Classical Lia.

Ltac EitherOf P :=
    destruct (classic P).

Section S3_2_2.
  Variables (P Q:Prop).

  Goal P /\ Q -> Q /\ P.
  Proof.
    ImplIntro.
    AndElim H.
    AndIntro.
    - Assumption.
    - Assumption.
  Qed.

End S3_2_2.

Section S3_2_3.
  Variables (P Q R:Prop).

    Goal P \/ Q -> Q \/ P.
    Proof.
      ImplIntro H1.
      OrElim H1.
      - OrIntro2.
        Assumption.
      - OrIntro1.
        Assumption.
    Qed.

    Goal (P -> Q -> R) -> (P /\ Q -> R).
    Proof.
      ImplIntro H1.
      ImplIntro H2.
      AndElim H2.
      ImplSpecialize (H1 H).
      ImplApply H3.
      Assumption.
    Restart.
      (* coq notation *)
      intros H1 H2.
      destruct H2 as [H3 H4].
      specialize (H1 H3) as H5.
      apply H5.
      assumption.
    Restart.
      (* shorter *)
      intros H [HP HQ].
      apply (H HP HQ).
    Qed.

    Goal (P \/ Q -> R) -> (P -> R) /\ (Q -> R).
    Proof.
      ImplIntro.
      AndIntro.
      - ImplIntro.
        ImplApply H.
        OrIntro1.
        Assumption.
      - ImplIntro.
        ImplApply H.
        OrIntro2.
        Assumption.
    Qed.

    Goal P -> P /\ True.
    Proof.
      ImplIntro.
      AndIntro.
      - Assumption.
      - TruthIntro.
    Qed.

    Goal P \/ False -> P.
    Proof.
      ImplIntro.
      OrElim H.
      - Assumption.
      - FalsityElim H0.
    Qed.

    Goal (P -> Q \/ R) -> (P -> Q) \/ (P -> R).
    Proof.
      ImplIntro.
      EitherOf (P -> Q).
      - OrIntro1.
        Assumption.
      - OrIntro2.
        ImplIntro.
        ImplSpecialize (H H1).
        OrElim H2.
        + NegElim H0.
          Assert False.
          * ImplApply H4.
            ImplIntro.
            Assumption.
          * FalsityElim H5.
        + Assumption.
    Qed.

End S3_2_3.

Ltac Contradiction := apply NNPP;ImplIntro.

Section S3_2_4.

  Lemma Contradiction φ
    (Asm: ~ φ -> ⊥):
    φ.
  Proof.
    EitherOf φ.
    - Assumption.
    - Assert ⊥.
      + ImplApply (Asm H).
      + FalsityElim H0.
  Qed.

  Variables (P:Prop).

  Goal P \/ ¬ P.
  Proof.
    Contradiction.
    NegElim H.
    ImplApply H0.
    OrIntro2.
    NegIntro.
    ImplApply H0.
    OrIntro1.
    Assumption.
  Qed.
End S3_2_4.

Ltac NegElimApply H :=
  exfalso;apply H.
Ltac ExFalso := exfalso.

Ltac EquivChain Q :=
  transitivity Q.

Ltac ForallIntro n :=
  intro n.

Ltac ForallElim H v :=
  let fn := fresh in
  specialize (H v) as fn.

Ltac ExistsIntro t :=
  exists t.
Ltac ExistsElim H v :=
  let fn := fresh in
  pose proof (fn := H);
  destruct fn as [v ?].

Ltac EqualsIntro := reflexivity.

Ltac EqualsElim H := rewrite H.
Tactic Notation "EqualsElim←" constr(H) := rewrite <- H.

(* not Axiom due to naming restriction *)
Ltac axiom H := pose proof H.
Ltac lemma H := pose proof H.

Ltac Defn H := unfold H.

Section S3_3.

  Variable (X:Type).
  Implicit Type (x y:X).

  Example QuantHandling
    (P Q : X*X -> Prop):
    (forall x y, P (x,y) -> Q (y,x)) /\
    (forall x, P(x,x)) ->
    forall y, Q (y,y).
  Proof.
    ImplIntro H1.
    AndElim H1.
    ForallIntro z.
    ForallElim H z.
    ForallElim H2 z.
    ImplApply H3.
    ForallElim H0 z.
    Assumption.
  Qed.

  Lemma L10 (φ:X*X -> Prop):
    (forall x, forall y, φ(x,y)) <->
    (forall x, forall y, φ(y,x)).
  Proof.
    AndIntro.
    - ImplIntro.
      ForallIntro x.
      ForallIntro y.
      ForallElim H y.
      ForallElim H0 x.
      Assumption.
    - ImplIntro.
      ForallIntro x.
      ForallIntro y.
      ForallElim H y.
      ForallElim H0 x.
      Assumption.
  Qed.

  Goal forall x y, x=y -> y=x.
  Proof.
    ForallIntro x.
    ForallIntro y.
    ImplIntro.
    EqualsElim H.
    EqualsIntro.
  Qed.

  (* Lemma 12 *)
  Lemma EqTrans:
    forall x y z, x=y -> y=z -> x=z.
  Proof.
    ForallIntro x.
    ForallIntro y.
    ForallIntro z.
    ImplIntro.
    ImplIntro.
    EqualsElim H.
    EqualsElim← H0.
    EqualsIntro.
  Qed.

  Definition leq n m := exists k, m = n+k.
  Notation "n ≤ m" := (leq n m) (at level 67).

  (* Lemma 13 *)
  Lemma LeqRefl:
    forall n, n ≤ n.
  Proof.
    ForallIntro x.
    ExistsIntro 0.
    axiom plus_n_O.
    ForallElim H x.
    EqualsElim← H0.
    EqualsIntro.
  Restart.
    ForallIntro x.
    Defn leq.
    ExistsIntro 0.
    axiom plus_n_O.
    ForallElim H x.
    EqualsElim← H0.
    EqualsIntro.
  Qed.

  Definition divide (x:nat) n := exists k, x*k = n.
  Notation "x | n" := (divide x n) (at level 67).
  Definition even n := 2 | n.

  Lemma even_add:
    forall (x y:nat),
      even x -> even y -> even (x+y).
  Proof.
    ForallIntro x.
    ForallIntro y.
    ImplIntro.
    ImplIntro.
    Defn even.
    Defn divide.
    ExistsElim H k1.
    ExistsElim H0 k2.
    ExistsIntro (k1+k2).
    axiom (PeanoNat.Nat.mul_add_distr_l).
    ForallElim H3 2.
    ForallElim H4 k1.
    ForallElim H5 k2.
    EqualsElim H6.
    EqualsElim← H1.
    EqualsElim← H2.
    EqualsIntro.
  Restart.
    (* shortened version *)
    intros x y [k1 H1] [k2 H2].
    unfold even, divide.
    exists (k1+k2).
    rewrite PeanoNat.Nat.mul_add_distr_l.
    rewrite H1,H2.
    reflexivity.
  Restart.
    (* even shorter *)
    intros.
    destruct H as [kx ?],H0 as [ky ?].
    exists (kx+ky).
    lia.
  Qed.

  Example ComplexApply
    (P:X*X -> Prop):
  (forall a b c, P (a,b) -> P(c,b) -> P(a,c)) -> forall a b, P(a,b) -> P(a,a).
  Proof.
    intros.
    apply (H a b a).
    - assumption.
    - assumption.
  Qed.

End S3_3.

Section S4.
  Require Import Sets.Classical_sets
  Sets.Powerset_Classical_facts.

  (* Import Sets.Classical_sets. *)
  (* Print In. *)

  Variable (U:Type).
  Implicit Type (A B:Ensemble U).

  Check In.
  Locate "_ \/ _".
  (* Print Notations. *)
  Notation "x ∈ A" := (In _ A x) (at level 67).
  Notation " x ∉ A " := (~(x∈A)) (only parsing, at level 67).
  Print Included.
  Notation "A ⊆ B" := (Included _ A B) (at level 67).
  (* Check Union_inv. *)

  Definition union A B :=
    fun x => x ∈ A \/ x ∈ B.

  (* Goal forall A B, forall x, union A B x <-> Union _ A B x.
  Proof.
    intros;split;intros H.
    - destruct H.
      + now left.
      + now right.
    - apply Union_inv in H as [];firstorder.
  Qed. *)
  (* Print Union. *)
  (* Print Empty_set. *)

  Definition intersection A B :=
    fun x => x ∈ A /\ x ∈ B.

  Definition difference A B :=
    fun x => x ∈ A /\ x ∉ B.

  Check Empty_set.
  Print Complement.

  Notation "A ∪ B" := (union A B) (at level 67).
  Notation "A ∩ B" := (intersection A B) (at level 67).
  Notation "A \ B" := (difference A B) (at level 67).
  Definition setequality A B := (forall x, x ∈ A <-> x ∈ B).
  Notation "A ≡ B" := (setequality A B) (at level 70).
  Notation "∅" := (Empty_set U).
  Notation "A 'ᶜ'" := (Complement _ A) (at level 75).

  Notation "{ x1 , x2 , .. , xn }" := (fun x => or (x = x1) (or (x=x2) (.. (or (x = xn) True) ..))).

  Theorem SetEqualitySubset A B:
    A ≡ B <-> A ⊆ B /\ B ⊆ A.
  Proof.
    (* Proof from the lecture notes *)
    split.
    - intros.
      unfold Included, setequality in *.
      now setoid_rewrite H.
    - now intros [H1 H2] x;split;[intros H%H1 | intros H%H2].
  Restart.
    (* single steps *)
    split.
    - intros.
      unfold setequality in H.
      split.
      + intros x HA.
        apply H.
        assumption.
      + intros x HB.
        apply H.
        assumption.
    - intros [H1 H2] x.
      split.
      + intros HA.
        specialize (H1 x).
        apply H1 in HA.
        assumption.
      + intros HB.
        specialize (H2 x).
        apply H2 in HB.
        assumption.
    Restart.
      (* short with automation *)
      split.
      - intros. split;intros x Hx;specialize (H x);now apply H.
      - intros [] ?. split; eauto.
    Restart.
      firstorder.
    Qed.

  Theorem DifferenceComplement A B:
    A \ B ≡ (B ᶜ) ∩  A.
  Proof.
    split.
    - intros H.
      destruct H.
      split.
      + apply H0.
      + assumption.
    - intros H.
      destruct H.
      split.
      + assumption.
      + apply H.
  Qed.

  (* Definition cart_product {X Y} (A:set X) (B:set Y) :=
    (fun '(a,b) => a ∈ A /\ b ∈ B). *)

  Lemma disjoint_difference A B:
    (A \ B) ∩ (A ∩ B) ≡ ∅.
  Proof.
    (* proof from the script but without contraposition *)
    split.
    - intros [[] []].
      contradict H0.
      assumption.
    - intros H. contradict H.
  Qed.

  Lemma commutative_intersection A B:
    A ∩ B ≡ B ∩ A.
  Proof.
    firstorder.
  Qed.

  Theorem disjoint_decomposition A B :
    A ∪ B ≡ (A \ B) ∪ (B \ A) ∪ (A ∩ B) /\
    (
      (A\B) ∩ (B\A) ≡ ∅ /\
      (A\B) ∩ (A ∩ B) ≡ ∅ /\
      (B\A) ∩ (A ∩ B) ≡ ∅
    )
    .
    Proof.
      split.
      - split.
        (* ⊆ *)
        + intros H.
          destruct H.
          * destruct (classic (x ∈ B)).
            -- right. split;assumption.
            -- left. left. split;assumption.
          * destruct (classic (x ∈ A)).
            -- right. split;assumption.
            -- left. right. split;assumption.
        (* ⊇ *)
        + intros H.
          destruct H as [[H | H] | H].
          all: destruct H.
          * left. assumption.
          * right. assumption.
          * left. assumption.
      (* disjooint *)
      - split;[|split].
        + split. 2: easy. (* 2 is easy because it is contradictory *)
          intros [[][]].
          contradict H0.
          assumption.
        + apply disjoint_difference.
        (* TODO: use lemma *)
        + split. 2: easy.
          intros [[][]].
          contradict H0.
          assumption.
    Qed.

    (* TODO: cardinality *)

    Print Power_set.
    (* Arguments Power_set {U}. *)
    Definition powerset A := (fun x => x ⊆ A).
    (* Notation powerset := Power_set. *)

    Theorem T12 A:
      ∅ ∈ powerset A /\ A ∈ powerset A.
    Proof.
      split; intros x Hx.
      - contradict Hx.
      - assumption.
    Qed.

    Set Implicit Arguments.

    Definition surjective_fun (X Y:Type) (f:X->Y) : Prop :=
      forall y, exists x, f x = y.

    Theorem Cantor X:
      ~ exists (f:X->X->Prop), surjective_fun f.
    Proof.
      intros [f H].
      pose (S := fun x => x ∉ f x).
      destruct (H S) as [x Hf].
      assert(HS: x ∈ S <-> x ∈ f x).
      {
        rewrite Hf. tauto.
      }
      unfold S, In in HS. tauto.
    Qed.

    Section Relations.
      (* TODO: relations *)
      Variable (Y Z : Type).
      Variable (A:set Y) (B:set Z).
      Implicit Type (a:Y) (b:Z).

      Definition left_total R :=
          forall a, a ∈ A -> exists b, b ∈ B /\ R (a,b).

      Definition surjective R :=
          forall b, b ∈ B -> exists a, a ∈ A /\ R (a,b).

      Definition injective R :=
          forall a1 a2, a1 ∈ A -> a2 ∈ A -> forall b, b ∈ B ->
          R (a1,b) -> R (a2,b) -> a1 = a2.

      Definition functional R :=
          forall b1 b2, b1 ∈ B -> b2 ∈ B -> forall a, a ∈ A ->
          R (a,b1) -> R (a,b2) -> b1 = b2.

      Definition bijective R :=
        surjective R /\ injective R.

      Definition total_function R :=
        left_total R /\ functional R.

      Definition bijection R :=
        total_function R /\ bijective R.

      (* Z -> N
          (BinNums)
          2x
          -2x-1
      *)

    End Relations.

    Arguments bijection {Y Z}.

    (* first with our relation machinery *)
    (* then nice functional in type theory
        (maybe the one from my Forum picture?) *)
    (* not directly Lawvere (too abstract) *)

    Theorem T15 A:
      ~ exists f, bijection A (powerset A) f.
    Proof.
      intros [f [[Htot Hfun] [Hsur Hinj]]].
      assert (S:set X).
      {
        refine (fun x => exists (h:x∈A), _).
        specialize (Htot x h).
        Search "exists" "sig".
        apply exists_to_inhabited_sig in Htot.
        (* destruct (classic (x ∈ A)). *)
        (* {x∈A | _ } *)
        (* refine (fun x => x ∈ A /\ _).
        specialize (Htot x). *)
      }
      pose (S:= fun x => x ∈ A /\ x ∉ (f x)).

End S4.


Require Import JMeq ProofIrrelevance FunctionalExtensionality.
Require Export Notations Functor.
Require Import Common StructureEquality FEqualDep.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Local Infix "==" := JMeq.

Section SpecializedNaturalTransformation.
  Context `(C : @SpecializedCategory objC).
  Context `(D : @SpecializedCategory objD).
  Variables F G : SpecializedFunctor C D.

  (**
     Quoting from the lecture notes for 18.705, Commutative Algebra:

     A map of functors is known as a natural transformation. Namely, given two functors
     [F : C -> D], [G : C -> D], a natural transformation [T: F -> G] is a collection of maps
     [T A : F A -> G A], one for each object [A] of [C], such that [(T B) ○ (F m) = (G m) ○ (T A)]
     for every map [m : A -> B] of [C]; that is, the following diagram is commutative:

           F m
     F A -------> F B
      |            |
      |            |
      | T A        | T B
      |            |
      V    G m     V
     G A --------> G B
     **)
  Record SpecializedNaturalTransformation :=
    {
      ComponentsOf :> forall c, D.(Morphism) (F c) (G c);
      Commutes : forall s d (m : C.(Morphism) s d),
                   Compose (ComponentsOf d) (F.(MorphismOf) m) = Compose (G.(MorphismOf) m) (ComponentsOf s)
    }.
End SpecializedNaturalTransformation.

Section NaturalTransformation.
  Variable C : Category.
  Variable D : Category.
  Variable F G : Functor C D.

  Definition NaturalTransformation := SpecializedNaturalTransformation F G.
End NaturalTransformation.

Bind Scope natural_transformation_scope with SpecializedNaturalTransformation.
Bind Scope natural_transformation_scope with NaturalTransformation.

Create HintDb natural_transformation discriminated.

Arguments ComponentsOf {objC%type C%category objD%type D%category F%functor G%functor} T%natural_transformation c%object : rename, simpl nomatch.
Arguments Commutes [objC C objD D F G] T _ _ _ : rename.

Identity Coercion NaturalTransformation_SpecializedNaturalTransformation_Id : NaturalTransformation >-> SpecializedNaturalTransformation.
Definition GeneralizeNaturalTransformation `(T : @SpecializedNaturalTransformation objC C objD D F G) :
  NaturalTransformation F G := T.
Global Coercion GeneralizeNaturalTransformation : SpecializedNaturalTransformation >-> NaturalTransformation.

Arguments GeneralizeNaturalTransformation [objC C objD D F G] T /.
Hint Extern 0 => unfold GeneralizeNaturalTransformation : category natural_transformation.
Ltac fold_NT :=
  change @SpecializedNaturalTransformation with
    (fun objC (C : SpecializedCategory objC) objD (D : SpecializedCategory objD) => @NaturalTransformation C D) in *; simpl in *.

Hint Resolve @Commutes : category natural_transformation.

Ltac nt_hideProofs :=
  repeat match goal with
             | [ |- context[{|
                               ComponentsOf := _;
                               Commutes := ?pf
                             |}] ] =>
               hideProofs pf
         end.

Ltac nt_tac_abstract_trailing_props T tac :=
  let T' := (eval hnf in T) in
  let T'' := (tac T') in
  let H := fresh in
  pose T'' as H;
    hnf in H;
    revert H; clear; intro H; clear H;
    match T'' with
      | @Build_SpecializedNaturalTransformation ?objC ?C
                                                ?objD ?D
                                                ?F
                                                ?G
                                                ?CO
                                                ?COM =>
        refine (@Build_SpecializedNaturalTransformation objC C objD D F G
                                                        CO
                                                        _);
          abstract exact COM
    end.
Ltac nt_abstract_trailing_props T := nt_tac_abstract_trailing_props T ltac:(fun T' => T').
Ltac nt_simpl_abstract_trailing_props T := nt_tac_abstract_trailing_props T ltac:(fun T' => let T'' := eval simpl in T' in T'').

Section NaturalTransformations_Equal.
  Lemma NaturalTransformation_contr_eq' objC C objD D F G
        (T U : @SpecializedNaturalTransformation objC C objD D F G)
        (D_morphism_proof_irrelevance
         : forall s d (m1 m2 : Morphism D s d) (pf1 pf2 : m1 = m2),
             pf1 = pf2)
  : ComponentsOf T = ComponentsOf U
    -> T = U.
    destruct T, U; simpl; intros; repeat subst;
    f_equal;
    repeat (apply functional_extensionality_dep; intro).
    trivial.
  Qed.

  Lemma NaturalTransformation_contr_eq objC C objD D F G
        (T U : @SpecializedNaturalTransformation objC C objD D F G)
        (D_morphism_proof_irrelevance
         : forall s d (m1 m2 : Morphism D s d) (pf1 pf2 : m1 = m2),
             pf1 = pf2)
  : (forall x, ComponentsOf T x = ComponentsOf U x)
    -> T = U.
    intros; apply NaturalTransformation_contr_eq'; try assumption.
    destruct T, U; simpl in *;
    repeat (apply functional_extensionality_dep; intro);
    trivial.
  Qed.

  Lemma NaturalTransformation_eq' objC C objD D F G :
    forall (T U : @SpecializedNaturalTransformation objC C objD D F G),
    ComponentsOf T = ComponentsOf U
    -> T = U.
    intros T U.
    apply NaturalTransformation_contr_eq'.
    intros; apply proof_irrelevance.
  Qed.

  Lemma NaturalTransformation_eq objC C objD D F G :
    forall (T U : @SpecializedNaturalTransformation objC C objD D F G),
    (forall x, ComponentsOf T x = ComponentsOf U x)
    -> T = U.
    intros T U.
    apply NaturalTransformation_contr_eq.
    intros; apply proof_irrelevance.
  Qed.

  Lemma NaturalTransformation_JMeq' objC C objD D objC' C' objD' D' :
    forall F G F' G'
      (T : @SpecializedNaturalTransformation objC C objD D F G) (U : @SpecializedNaturalTransformation objC' C' objD' D' F' G'),
      objC = objC'
      -> objD = objD'
      -> C == C'
      -> D == D'
      -> F == F'
      -> G == G'
      -> ComponentsOf T == ComponentsOf U
      -> T == U.
    simpl; intros; intuition; destruct T, U; simpl in *; repeat subst;
      JMeq_eq.
    f_equal; apply proof_irrelevance.
  Qed.
  Lemma NaturalTransformation_JMeq objC C objD D objC' C' objD' D' :
    forall F G F' G'
      (T : @SpecializedNaturalTransformation objC C objD D F G) (U : @SpecializedNaturalTransformation objC' C' objD' D' F' G'),
      objC = objC'
      -> objD = objD'
      -> C == C'
      -> D == D'
      -> F == F'
      -> G == G'
      -> (forall x x', x == x' -> ComponentsOf T x == ComponentsOf U x')
      -> T == U.
    intros; apply NaturalTransformation_JMeq'; trivial;
    destruct T, U; simpl in *; repeat subst.
    apply functional_extensionality_dep_JMeq; trivial.
    intuition.
  Qed.
End NaturalTransformations_Equal.

Ltac nt_eq_step_with tac :=
  structures_eq_step_with_tac ltac:(apply NaturalTransformation_eq || apply NaturalTransformation_JMeq) tac.

Ltac nt_eq_with tac := repeat nt_eq_step_with tac.

Ltac nt_eq_step := nt_eq_step_with idtac.
Ltac nt_eq := nt_hideProofs; nt_eq_with idtac.

Ltac nt_tac_abstract_trailing_props_with_equality_do tac T thm :=
  let T' := (eval hnf in T) in
  let T'' := (tac T') in
  let H := fresh in
  pose T'' as H;
    hnf in H;
    revert H; clear; intro H; clear H;
    match T'' with
      | @Build_SpecializedNaturalTransformation ?objC ?C
                                                ?objD ?D
                                                ?F
                                                ?G
                                                ?CO
                                                ?COM =>
        let COM' := fresh in
        let COMT' := type of COM in
        let COMT := (eval simpl in COMT') in
        assert (COM' : COMT) by abstract exact COM;
          exists (@Build_SpecializedNaturalTransformation objC C objD D F G
                                                          CO
                                                          COM');
          expand; abstract (apply thm; reflexivity) || (apply thm; try reflexivity)
    end.
Ltac nt_tac_abstract_trailing_props_with_equality tac :=
  pre_abstract_trailing_props;
  match goal with
    | [ |- { T0 : SpecializedNaturalTransformation _ _ | T0 = ?T } ] =>
      nt_tac_abstract_trailing_props_with_equality_do tac T @NaturalTransformation_eq'
    | [ |- { T0 : SpecializedNaturalTransformation _ _ | T0 == ?T } ] =>
      nt_tac_abstract_trailing_props_with_equality_do tac T @NaturalTransformation_JMeq
  end.
Ltac nt_abstract_trailing_props_with_equality := nt_tac_abstract_trailing_props_with_equality ltac:(fun T' => T').
Ltac nt_simpl_abstract_trailing_props_with_equality := nt_tac_abstract_trailing_props_with_equality ltac:(fun T' => let T'' := eval simpl in T' in T'').

Section NaturalTransformationComposition.
  Context `(C : @SpecializedCategory objC).
  Context `(D : @SpecializedCategory objD).
  Context `(E : @SpecializedCategory objE).
  Variables F F' F'' : SpecializedFunctor C D.
  Variables G G' : SpecializedFunctor D E.

  Hint Resolve @Commutes f_equal f_equal2 : natural_transformation.
  Hint Rewrite @Associativity : natural_transformation.

  (*
     We have the diagram
          F
     C -------> D
          |
          |
          | T
          |
          V
     C -------> D
          F'
          |
          | T'
          |
          V
     C ------> D
          F''

     And we want the commutative diagram
           F m
     F A -------> F B
      |            |
      |            |
      | T A        | T B
      |            |
      V    F' m    V
     F' A -------> F' B
      |            |
      |            |
      | T' A       | T' B
      |            |
      V    F'' m   V
     F'' A ------> F'' B

  *)

  Definition NTComposeT (T' : SpecializedNaturalTransformation F' F'') (T : SpecializedNaturalTransformation F F') :
    SpecializedNaturalTransformation F F''.
    exists (fun c => Compose (T' c) (T c));
    (* XXX TODO: Find a way to get rid of [m] in the transitivity call *)
    abstract (
        intros;
        transitivity (Compose (T' _) (Compose (MorphismOf F' m) (T _)));
        try_associativity ltac:(eauto with natural_transformation)
      ).
  Defined.

  (*
     We have the diagram
          F          G
     C -------> D -------> E
          |          |
          |          |
          | T        | U
          |          |
          V          V
     C -------> D -------> E
          F'         G'

     And we want the commutative diagram
             G (F m)
     G (F A) -------> G (F B)
        |                |
        |                |
        | U (T A)        | U (T B)
        |                |
        V     G' (F' m)  V
     G' (F' A) -----> G' (F' B)

  *)
  (* XXX TODO: Automate this better *)

  Hint Rewrite @Commutes : natural_transformation.
  Hint Resolve f_equal2 : natural_transformation.
  Hint Extern 1 (_ = _) => apply @FCompositionOf : natural_transformation.

  Lemma FCompositionOf2 : forall `(C : @SpecializedCategory objC) `(D : @SpecializedCategory objD)
    (F : SpecializedFunctor C D) x y z u (m1 : C.(Morphism) x z) (m2 : C.(Morphism) y x) (m3 : D.(Morphism) u _),
    Compose (MorphismOf F m1) (Compose (MorphismOf F m2) m3) = Compose (MorphismOf F (Compose m1 m2)) m3.
    intros; symmetry; try_associativity ltac:(eauto with natural_transformation).
  Qed.

  Hint Rewrite @FCompositionOf2 : natural_transformation.

  Definition NTComposeF (U : SpecializedNaturalTransformation G G') (T : SpecializedNaturalTransformation F F'):
    SpecializedNaturalTransformation (ComposeFunctors G F) (ComposeFunctors G' F').
    exists (fun c => Compose (G'.(MorphismOf) (T c)) (U (F c)));
    abstract (
        simpl; intros; autorewrite with category;
        repeat try_associativity ltac:(repeat rewrite <- @Commutes; repeat rewrite <- @FCompositionOf);
        reflexivity
      ).
  Defined.
End NaturalTransformationComposition.

Section IdentityNaturalTransformation.
  Context `(C : @SpecializedCategory objC).
  Context `(D : @SpecializedCategory objD).
  Variable F : SpecializedFunctor C D.

  (* There is an identity natrual transformation. *)
  Definition IdentityNaturalTransformation : SpecializedNaturalTransformation F F.
    exists (fun c => Identity (F c));
    abstract (intros; autorewrite with morphism; reflexivity).
  Defined.

  Lemma LeftIdentityNaturalTransformation (F' : SpecializedFunctor C D) (T : SpecializedNaturalTransformation F' F) :
    NTComposeT IdentityNaturalTransformation T = T.
    nt_eq; auto with morphism.
  Qed.

  Lemma RightIdentityNaturalTransformation (F' : SpecializedFunctor C D) (T : SpecializedNaturalTransformation F F') :
    NTComposeT T IdentityNaturalTransformation = T.
    nt_eq; auto with morphism.
  Qed.
End IdentityNaturalTransformation.

Hint Rewrite @LeftIdentityNaturalTransformation @RightIdentityNaturalTransformation : category.
Hint Rewrite @LeftIdentityNaturalTransformation @RightIdentityNaturalTransformation : natural_transformation.

Section IdentityNaturalTransformationF.
  Context `(C : @SpecializedCategory objC).
  Context `(D : @SpecializedCategory objD).
  Context `(E : @SpecializedCategory objE).
  Variable G : SpecializedFunctor D E.
  Variable F : SpecializedFunctor C D.

  Lemma NTComposeFIdentityNaturalTransformation :
    NTComposeF (IdentityNaturalTransformation G) (IdentityNaturalTransformation F) = IdentityNaturalTransformation (ComposeFunctors G F).
  Proof.
    nt_eq; repeat rewrite FIdentityOf; auto with morphism.
  Qed.
End IdentityNaturalTransformationF.

Hint Rewrite @NTComposeFIdentityNaturalTransformation : category.
Hint Rewrite @NTComposeFIdentityNaturalTransformation : natural_transformation.

Section Associativity.
  Context `(B : @SpecializedCategory objB).
  Context `(C : @SpecializedCategory objC).
  Context `(D : @SpecializedCategory objD).
  Context `(E : @SpecializedCategory objE).
  Variable F : SpecializedFunctor D E.
  Variable G : SpecializedFunctor C D.
  Variable H : SpecializedFunctor B C.

  Let F0 := ComposeFunctors (ComposeFunctors F G) H.
  Let F1 := ComposeFunctors F (ComposeFunctors G H).

  Definition ComposeFunctorsAssociator1 : SpecializedNaturalTransformation F0 F1.
    refine (Build_SpecializedNaturalTransformation F0 F1
                                                   (fun _ => Identity (C := E) _)
                                                   _
           );
    abstract (
        simpl; intros;
        autorewrite with morphism; reflexivity
      ).
  Defined.

  Definition ComposeFunctorsAssociator2 : SpecializedNaturalTransformation F1 F0.
    refine (Build_SpecializedNaturalTransformation F1 F0
                                                   (fun _ => Identity (C := E) _)
                                                   _
           );
    abstract (
        simpl; intros;
        autorewrite with morphism; reflexivity
      ).
  Defined.
End Associativity.

Section IdentityFunctor.
  Context `(C : @SpecializedCategory objC).
  Context `(D : @SpecializedCategory objD).

  Local Ltac t :=
    repeat match goal with
             | [ |- SpecializedNaturalTransformation ?F ?G ] =>
               refine (Build_SpecializedNaturalTransformation F G
                                                              (fun _ => Identity _)
                                                              _)
             | _ => abstract (simpl; intros; autorewrite with morphism; reflexivity)
             | _ => split; nt_eq
           end.

  Section left.
    Variable F : SpecializedFunctor D C.

    Definition LeftIdentityFunctorNaturalTransformation1 : SpecializedNaturalTransformation (ComposeFunctors (IdentityFunctor _) F) F. t. Defined.
    Definition LeftIdentityFunctorNaturalTransformation2 : SpecializedNaturalTransformation F (ComposeFunctors (IdentityFunctor _) F). t. Defined.

    Theorem LeftIdentityFunctorNT_Isomorphism
    : NTComposeT LeftIdentityFunctorNaturalTransformation1 LeftIdentityFunctorNaturalTransformation2 = IdentityNaturalTransformation _
      /\ NTComposeT LeftIdentityFunctorNaturalTransformation2 LeftIdentityFunctorNaturalTransformation1 = IdentityNaturalTransformation _.
      t.
    Qed.
  End left.

  Section right.
    Variable F : SpecializedFunctor C D.

    Definition RightIdentityFunctorNaturalTransformation1 : SpecializedNaturalTransformation (ComposeFunctors F (IdentityFunctor _)) F. t. Defined.
    Definition RightIdentityFunctorNaturalTransformation2 : SpecializedNaturalTransformation F (ComposeFunctors F (IdentityFunctor _)). t. Defined.

    Theorem RightIdentityFunctorNT_Isomorphism
    : NTComposeT RightIdentityFunctorNaturalTransformation1 RightIdentityFunctorNaturalTransformation2 = IdentityNaturalTransformation _
      /\ NTComposeT RightIdentityFunctorNaturalTransformation2 RightIdentityFunctorNaturalTransformation1 = IdentityNaturalTransformation _.
      t.
    Qed.
  End right.
End IdentityFunctor.

Section NaturalTransformationExchangeLaw.
  Context `(C : SpecializedCategory objC).
  Context `(D : SpecializedCategory objD).
  Context `(E : SpecializedCategory objE).

  Variables F G H : SpecializedFunctor C D.
  Variables F' G' H' : SpecializedFunctor D E.

  Variable T : SpecializedNaturalTransformation F G.
  Variable U : SpecializedNaturalTransformation G H.

  Variable T' : SpecializedNaturalTransformation F' G'.
  Variable U' : SpecializedNaturalTransformation G' H'.

  Local Ltac t_progress := progress repeat
    match goal with
      | _ => apply f_equal
      | _ => apply f_equal2; try reflexivity; []
      | _ => apply Commutes
      | _ => symmetry; apply Commutes
    end.

  Local Ltac t_exch := repeat
    match goal with
      | _ => repeat rewrite FCompositionOf; repeat rewrite Associativity;
        t_progress
      | _ => repeat rewrite <- FCompositionOf; repeat rewrite <- Associativity;
        t_progress
    end.

  Theorem NaturalTransformationExchangeLaw :
    NTComposeF (NTComposeT U' T') (NTComposeT U T) =
    NTComposeT (NTComposeF U' U) (NTComposeF T' T).
  Proof.
    nt_eq;
    t_exch.
  Qed.
End NaturalTransformationExchangeLaw.

Hint Resolve @NaturalTransformationExchangeLaw : category.
Hint Resolve @NaturalTransformationExchangeLaw : natural_transformation.

Ltac nt_solve_associator' :=
  repeat match goal with
           | _ => exact (ComposeFunctorsAssociator1 _ _ _)
           | _ => exact (ComposeFunctorsAssociator2 _ _ _)
           | [ |- SpecializedNaturalTransformation (ComposeFunctors ?F _) (ComposeFunctors ?F _) ] =>
             refine (NTComposeF (IdentityNaturalTransformation F) _)
           | [ |- SpecializedNaturalTransformation (ComposeFunctors _ ?F) (ComposeFunctors _ ?F) ] =>
             refine (NTComposeF _ (IdentityNaturalTransformation F))
         end.
Ltac nt_solve_associator :=
  repeat match goal with
           | _ => refine (NTComposeT (ComposeFunctorsAssociator1 _ _ _) _); progress nt_solve_associator'
           | _ => refine (NTComposeT _ (ComposeFunctorsAssociator1 _ _ _)); progress nt_solve_associator'
           | _ => refine (NTComposeT (ComposeFunctorsAssociator2 _ _ _) _); progress nt_solve_associator'
           | _ => refine (NTComposeT _ (ComposeFunctorsAssociator2 _ _ _)); progress nt_solve_associator'
           | _ => progress nt_solve_associator'
         end.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Infinite streams                                                        *
**************************************************************************)

Set Implicit Arguments.
Generalizable Variables A B.
Require Import LibTactics LibLogic LibInt LibList LibRelation LibWf.

(* ********************************************************************** *)
(** * Construction of streams *)

(* ---------------------------------------------------------------------- *)
(** ** Definition *)

CoInductive stream (A:Type) : Type :=
  | stream_intro : A -> stream A -> stream A.

Notation "x ::: s" := (stream_intro x s) (at level 35).

(* ---------------------------------------------------------------------- *)
(** ** Projections *)

Definition stream_head A (s:stream A) :=
  let '(x:::s') := s in x.

Definition stream_tail A (s:stream A) :=
  let '(x:::s') := s in s'.

(* ---------------------------------------------------------------------- *)
(** ** Basic operations *)

(** Constant stream *)

CoFixpoint const A (x:A) : stream A :=
  x:::(const x).

(** List obtained by cutting a stream at length [n] *)

Fixpoint take A (n:nat) (s:stream A) : list A :=
  match n with
  | O => nil
  | S n' => let '(x:::s') := s in x::(take n' s')
  end.

(** Mapping of a function on values from a stream *)

CoFixpoint map A B (f:A->B) (s:stream A) : stream B :=
  let '(x:::s') := s in f x ::: (map f s').

(** N-th element of a stream *)

Fixpoint nth A (n:nat) (s:stream A) : A :=
  let '(x:::s') := s in
  match n with
  | O => x
  | S n' => nth n' s'
  end.

(** Streams are inhabited *)

Instance stream_inhab : forall `{Inhab A}, Inhab (stream A).
Proof using. intros. apply (prove_Inhab (const arbitrary)). Qed.

(* ---------------------------------------------------------------------- *)
(** ** Diagonal stream *)

(** Diagonal stream constructed from a sequence of streams *)

CoFixpoint diagonal A (u:nat->stream A) (n:nat) : stream A :=
  (nth n (u n)):::(diagonal u (S n)).

(** Description of the [n]-th element of a diagonal stream *)

Lemma stream_diagonal_nth : forall A (u:nat->stream A) n k,
  nth n (diagonal u k) = nth ((n+k)%nat) (u (n+k)%nat).
Proof using.
  intros. gen k. induction n; intros.
  simple~.
  math_rewrite ((S n + k)%nat = (n + (S k))%nat). rewrite~ <- IHn.
Qed.

(* ********************************************************************** *)
(** * Bisimilarity *)

(* ---------------------------------------------------------------------- *)
(** ** Definition of bisimilarity *)

(** Bisimilarity modulo [E] *)

CoInductive bisimilar_mod (A:Type) (E:binary A) : binary (stream A) :=
  | bisimilar_mod_intro : forall x1 x2 s1 s2,
      E x1 x2 ->
      bisimilar_mod E s1 s2 ->
      bisimilar_mod E (x1:::s1) (x2:::s2).

(** Bisimilarity modulo Leibnitz *)

Definition bisimilar (A:Type) := bisimilar_mod (@eq A).

Notation "x === y" := (bisimilar x y) (at level 68).

(** Bisimilarity is an equivalence *)

Lemma bisimilar_mod_equiv : forall A (E:binary A),
  equiv E -> equiv (bisimilar_mod E).
Proof using.
  introv Equiv. constructor.
  unfolds. cofix IH. destruct x. constructor; dauto.
  unfolds. cofix IH. destruct x; destruct y; introv M.
   inversions M. constructor; dauto.
  unfolds. cofix IH. destruct x; destruct y; destruct z; introv M1 M2.
   inversions M1. inversions M2. constructor; dauto.
Qed.

Lemma bisimilar_equiv : forall A,
  equiv (@bisimilar A).
Proof using. intros. apply~ bisimilar_mod_equiv. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Bisimilarity up to a given index *)

(** Bisimilarity modulo [E] up to index [n] *)

Definition bisimilar_mod_upto A (E:binary A) n s1 s2 :=
  list_equiv E (take n s1) (take n s2).

Section Bisimilar.
Hint Unfold list_equiv.
Hint Constructors Forall2.

(** This relation is an equivalence *)

Lemma bisimilar_mod_upto_equiv : forall A (E:binary A) n,
  equiv E -> equiv (bisimilar_mod_upto E n).
Proof using.
  introv Equiv. unfold bisimilar_mod_upto.
  lets: (list_equiv_equiv Equiv). constructor; unfolds; dauto.
Qed.

(** Bisimilarity implies bisimilarity at any index *)

Lemma bisimilar_mod_to_upto : forall A (E:binary A) n s1 s2,
  bisimilar_mod E s1 s2 -> bisimilar_mod_upto E n s1 s2.
Proof using.
  unfold bisimilar_mod_upto.
  induction n; introv H. simple~.
  destruct s1; destruct s2; simpls. inversions H. constructor~. apply~ IHn.
Qed.

(** Bisimilarity at any index imply bisimilarity *)

Lemma bisimilar_mod_take : forall A (E:binary A) s1 s2,
  (forall i, list_equiv E (take i s1) (take i s2)) ->
  bisimilar_mod E s1 s2.
Proof using.
  intros A E. cofix IH. intros.
  destruct s1 as [x1 s1]. destruct s2 as [x2 s2]. constructor.
    lets_inverts (H 1%nat). auto.
    apply IH. intros i. lets_inverts (H (S i)). auto.
Qed.

(** Bisimilarity up to index zero always holds *)

Lemma bisimilar_mod_upto_zero : forall A (E:binary A) s1 s2,
  bisimilar_mod_upto E 0%nat s1 s2.
Proof using. intros; hnf; simple~. Qed.

(** Bisimilarity up to [S n] from bisimilarity up to [n]
    and equality between n-th elements *)

Lemma bisimilar_mod_upto_succ : forall A (E:binary A) n s1 s2,
  equiv E ->
  bisimilar_mod_upto E n s1 s2 ->
  nth n s1 = nth n s2 ->
  bisimilar_mod_upto E (S n) s1 s2.
Proof using.
  introv Equiv Bis Equ. unfolds bisimilar_mod_upto.
  gen s1 s2. induction n; intros; destruct s1; destruct s2.
  simpls. subst. constructor; dauto.
  set_eq m: (S n). simpls.
  inversions Bis. constructor~. apply~ IHn.
Qed.

End Bisimilar.

Hint Resolve bisimilar_mod_upto_equiv.
Hint Resolve bisimilar_mod_upto_zero.

(* ********************************************************************** *)
(** * Properties of streams *)

(** [eventually P s] holds if [s] contains a value satisfying [P] *)

Inductive eventually A (P:A->Prop) : stream A -> Prop :=
  | eventually_head : forall x s,
      P x -> eventually P (x:::s)
  | eventually_tail : forall x s,
      eventually P s -> eventually P (x:::s).

(** [always P s] holds if every substream of [s] satisfies [P] *)

CoInductive always A (P:stream A -> Prop) : stream A -> Prop :=
  | always_intro : forall s x,
      always P s -> P (x:::s) -> always P (x:::s).

(** [infinitely_often P s] holds if the stream [s] contains
    infinitely many values satisfying [P] *)

Definition infinitely_often A (P:A->Prop) :=
  always (eventually P).

(** [first_st P s n] holds if the first element of [s] satisfying
    [P] is found at index [n] *)

Fixpoint first_st_at A (P:A->Prop) (s:stream A) (n:nat) :=
  let '(x:::s') := s in
  match n with
  | O => P x
  | S n' => ~ P x /\ first_st_at P s' n'
  end.

(** [first_st] is a functional relation; there is at most
    one index [n] such that [first_st_at P s n] holds *)

Lemma first_st_at_unique : forall n1 n2 A (P:A->Prop) s,
  first_st_at P s n1 -> first_st_at P s n2 -> n1 = n2.
Proof using.
  induction n1; destruct n2; destruct s; simpl; introv H1 H2.
  auto. destruct H2. false. destruct H1. false.
  destruct H1. destruct H2. fequals. apply* IHn1.
Qed.

Implicit Arguments first_st_at_unique [n1 n2 A P s].


(* Software Foundations *)
(* Exercice 1 star, hd_opt_poly *)

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

Arguments nil {X}.
Arguments cons {X} _ _.

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

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

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

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

Check @hd_opt.

Example test_hd_opt1: hd_opt ([1;2]) = Some 1. Proof. reflexivity. Qed.
Example test_hd_opt2: hd_opt ([[1];[2]]) = Some ([1]). Proof. reflexivity. Qed.


Require Import Reals.
Open Scope R_scope.

Lemma  not_exist : forall {U:Type} (p1 p2:U->Prop),
  (~ exists x, p1 x /\ p2 x) -> (forall x, p1 x -> ~ p2 x).
Proof.
  intros.
  unfold not; intro.
  destruct H; exists x; auto.
Qed.

Lemma total_eq_or_neq : forall r1 r2:R, r1=r2 \/ r1<>r2.
Proof.
  intros.
  generalize (total_order_T r1 r2); intros.
  destruct H. destruct s; auto.
  apply Rlt_not_eq in r; auto.
  apply Rgt_not_eq in r; auto.
Qed.

Lemma Rmult_par_inv_eq : forall r r1:R, r<>0 -> r * (r1 /r) = r*r1/r.
Proof.
  intros; unfold Rdiv.
  rewrite Rmult_assoc; auto.
Qed.

Lemma Rmult_eq_r : forall r r1:R, r<>0 -> r * r1 /r = r1.
Proof.
  intros.
  unfold Rdiv.
  rewrite Rinv_r_simpl_m; auto.
Qed.

Lemma Rmult_0_lt_reg : forall r1 r2:R, 0<r2 -> 0<r1*r2 -> 0<r1.
Proof.
  intros.
  apply Rmult_lt_reg_r with (r:=r2); auto; rewrite Rmult_0_l; auto.
Qed.

Lemma Rmult_le_r :
  forall r r1 r2 r3:R, 0 < r -> r1 * r <= r2 * r <= r3 * r -> r1 <= r2 <= r3.
Proof.
  intros.
  destruct H0.
  split; apply Rmult_le_reg_r with (r:=r); auto.
Qed.

Lemma Rinv_le_r :
  forall r r1 r2 r3:R, 0 < r -> r1 <= r2 <= r3 <-> r1/r <= r2/r <= r3/r.
Proof.
  intros; unfold Rdiv.
  split; intro.
  assert(/r>=0). { apply Rgt_ge. apply Rinv_0_lt_compat; auto. }
  - destruct H0.
    split; apply Rmult_le_compat_r; auto; apply Rge_le; auto.
  - apply Rmult_le_r with (r:=/r); auto.
    apply Rinv_0_lt_compat; auto.
Qed.

Lemma Rminus_plus_r : forall r r1:R, r1-r+r=r1.
Proof.
  intros.
  unfold Rminus; rewrite Rplus_assoc.
  rewrite Rplus_opp_l; rewrite Rplus_0_r; auto.
Qed.

Lemma Rplus_le_3_r:
  forall r r1 r2 r3 : R, r1 <= r2 + r <= r3 <-> r1 - r <= r2 <= r3 - r.
Proof.
  intros.
  split; intros.
  - destruct H; split.
    apply Rplus_le_reg_r with (r:=r).
    rewrite Rminus_plus_r; auto.
    apply Rplus_le_reg_r with (r:=r).
    rewrite Rminus_plus_r; auto.
  - destruct H; split.
    apply Rplus_le_compat_r with (r:=r) in H.
    rewrite Rminus_plus_r in H; auto.
    apply Rplus_le_compat_r with (r:=r) in H0.
    rewrite Rminus_plus_r in H0; auto.
Qed.

Lemma Rlt_x_le :
  forall r r1 r2:R, r>0 -> 0<r1/r<=r2/r -> 0<r1<=r2.
Proof.
  unfold Rdiv; intros.
  assert(/r>0). { apply Rinv_0_lt_compat; auto. }
  destruct H0; split.
  apply Rmult_lt_reg_r with (r:= /r); auto.
  rewrite Rmult_0_l; auto.
  eapply Rmult_le_reg_r. apply H1. apply H2.
Qed.

Lemma Rmult_minus_distr_1_3:
  forall r r1 r2 r3 : R, r * (r1 - r2 - r3) = r * r1 - r * r2 -r * r3.
Proof.
  intros.
  unfold Rminus.
  repeat rewrite Ropp_mult_distr_r.
  rewrite <- Rmult_plus_distr_l with (r1:=r)(r2:=r1)(r3:=- r2).
  rewrite <- Rmult_plus_distr_l with (r1:=r)(r2:=(r1 + - r2))(r3:=- r3); auto.
Qed.

Lemma Rle_abcd : forall a b c d:R, a<=b -> c<=d -> b<=c -> a<=d.
Proof.
  intros.
  assert(a<=c). { eapply Rle_trans. apply H. auto. }
  eapply Rle_trans. apply H2. auto.
Qed.

Lemma Rinv_minus_distr_r:
  forall r1 r2 r3 : R, r3 <> 0 -> (r1 - r2)/r3 = r1/r3 - r2/r3.
Proof.
  intros.
  unfold Rdiv. unfold Rminus.
  rewrite <- Ropp_mult_distr_l_reverse.
  rewrite Rmult_plus_distr_r. auto.
Qed.

Lemma plus_ab_minus_cd : forall a b c d e f:R, (a+b)-(c+d)-(e+f) = (a-c-e)+(b-d-f).
Proof.
 intros; ring.
Qed.

Lemma Rlt_x_le_reg :
  forall r r1 r2:R, r>0 -> 0<r1<=r2 -> 0<r1/r<=r2/r .
Proof.
  unfold Rdiv; intros.
  destruct H0; split.
  apply Rmult_lt_0_compat; auto.
  apply Rinv_0_lt_compat; auto.
  apply Rmult_le_compat_r; auto.
  apply Rlt_le; apply Rinv_0_lt_compat; auto.
Qed.

Lemma Rminus_distr : forall r1 r2 r3:R, r1-(r2-r3) = r1-r2+r3.
Proof.
  intros; ring.
Qed.
Lemma R_distr : forall r1 r2 r3:R, r1-r2+r3=r1+r3-r2.
Proof.
  intros; ring.
Qed.

Lemma Rgt_mult : forall r r1 r2, r>0 -> r1*r>r2->r1>r2/r.
Proof.
  intros.
  apply Rmult_gt_compat_r with (r:=/r)(r1:=r1*r) in H0.
  rewrite Rinv_r_simpl_l with (r1:=r)in H0; unfold Rdiv; auto.
  apply Rgt_not_eq in H; auto.
  apply Rinv_0_lt_compat; auto.
Qed.

Lemma Rlt_mult : forall r r1 r2, r>0 -> r1*r<r2->r1<r2/r.
Proof.
  intros.
  apply Rmult_lt_compat_r with (r:=/r)(r1:=r1*r) in H0.
  rewrite Rinv_r_simpl_l with (r1:=r)in H0; unfold Rdiv; auto.
  apply Rgt_not_eq in H; auto.
  apply Rinv_0_lt_compat; auto.
Qed.

Lemma Rinv_mult_rgt0 :forall r r1, r>0 -> r1*/r*r=r1.
Proof.
  intros.
  rewrite Rmult_assoc; rewrite Rinv_l.
  rewrite Rmult_1_r; auto.
  apply Rgt_not_eq in H; auto.
Qed.

Lemma Rlt_inv : forall r1 r2, r1>0 -> r2>0 -> r1</r2-> r2</r1.
Proof.
  intros.
  apply Rmult_lt_reg_r with (r:=/r2); try apply Rinv_0_lt_compat; auto.
  apply Rmult_lt_reg_l with (r:=r1); try apply Rinv_0_lt_compat; auto.
  rewrite Rinv_r; try rewrite Rmult_1_r.
  rewrite <- Rmult_assoc; rewrite Rinv_r; try rewrite Rmult_1_l; auto.
  apply Rgt_not_eq; auto.
  apply Rgt_not_eq; auto.
Qed.

Lemma Rinv_le : forall r1 r2, r1>0 -> r2>0 -> /r1<=r2-> r1>=/r2.
Proof.
  intros.
  apply Rle_ge.
  apply Rmult_le_reg_r with (r:=/r1); try apply Rinv_0_lt_compat; auto.
  apply Rmult_le_reg_l with (r:=r2); try apply Rinv_0_lt_compat; auto.
  rewrite Rinv_r; try rewrite Rmult_1_r.
  rewrite <- Rmult_assoc; rewrite Rinv_r; try rewrite Rmult_1_l; auto.
  apply Rgt_not_eq; auto.
  apply Rgt_not_eq; auto.
Qed.

Lemma Rminus_Rabs : forall a b c d r1 r2,
  a<=r1<=b -> c<=r2<=d -> Rabs(r2 - r1) <= Rabs(d - a) \/ Rabs(r2 - r1) <= Rabs(c - b).
Proof.
  intros.
  destruct H, H0.
  assert(r2-r1<=d-a).
   { unfold Rminus.
     apply Ropp_le_contravar in H.
     apply Rplus_le_compat; auto. }
  assert(c-b<=r2-r1).
    { unfold Rminus.
     apply Ropp_le_contravar in H1.
     apply Rplus_le_compat; auto. }
  generalize (total_order_T (r2-r1) 0); intro.
  destruct H5.
  - destruct s.
    + generalize Rle_lt_trans; intro.
      generalize H4; intro.
      apply H5 with (r3:=0) in H4; auto. clear H5.
      right; repeat rewrite Rabs_left; auto.
      apply Ropp_le_contravar; auto.
    + left; repeat rewrite e.
      rewrite Rabs_R0; apply Rabs_pos.
  - generalize Rge_gt_trans; intro.
    generalize r;intro.
    apply H5 with(r1:=d-a) in r.
    left; repeat rewrite Rabs_right; auto.
    apply Rgt_ge; auto.
    apply Rgt_ge; auto.
    apply Rle_ge; auto.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type :=  Nil : lst | Cons : natural -> lst -> lst .

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Lemma append_nil : forall (x : lst), append x Nil = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma rev_append : forall (x y : lst), rev (append x y) = append (rev y) (rev x).
Proof.
   intros.
   induction x.
   - simpl. rewrite append_nil. reflexivity.
   - simpl. rewrite IHx. rewrite append_assoc. reflexivity.
Qed.

Lemma rev_rev : forall (x : lst), rev (rev x) = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite rev_append. simpl. rewrite IHx. reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rev (append (rev x) (rev y))) (append y x).
Proof.
   induction x.
   - intros. simpl. rewrite rev_rev. rewrite append_nil. reflexivity.
   - intros. simpl. lfind. Admitted.


From Cofq.SystemF Require Import
     SystemFDefinitions
     SystemFUtils
     SystemFSemantics.

From Coq Require Import Lia ssrbool.

From ExtLib Require Import
     Structures.Monads
     Structures.Functor
     Eqv.

Import MonadNotation.
Local Open Scope monad_scope.

From Vellvm.Utils Require Import Util.

Fixpoint well_formed_type (ftv : N) (τ : FType) : bool
  := match τ with
     | Arrow τ1 τ2 => well_formed_type ftv τ1 && well_formed_type ftv τ2
     | Prod τs => forallb (well_formed_type ftv) τs
     | TForall τ' => well_formed_type (ftv + 1) τ'
     | TVar x => N.ltb x ftv
     | IntType => true
     end.

Obligation Tactic := try Tactics.program_simpl; try solve [cbn; try lia | repeat split; try solve [intros; discriminate | intros; intros CONTRA; inversion CONTRA; discriminate]].
Program Fixpoint typeof' {I} `{FInt I} (ftv : N) (Γ : list FType) (e : Term) {measure (term_size e)}: option FType :=
  match e with
  | Var x => nth_error Γ (N.to_nat x)
  | Ann e τ =>
    τ' <- (typeof' ftv Γ e);;
    if ftype_eq τ' τ
    then Some τ
    else @None FType
  | Fix fix_τ arg_τ body =>
    if (well_formed_type ftv fix_τ && well_formed_type ftv arg_τ)%bool
    then τ <- typeof' ftv (fix_τ::arg_τ::Γ) body;;
         let τ' := (Arrow arg_τ τ) in
         if ftype_eq fix_τ τ'
         then Some τ'
         else @None FType
    else None
  | App e1 e2 =>
    τ12 <- typeof' ftv Γ e1;;
    τ1 <- typeof' ftv Γ e2;;
    match τ12 with
    | Arrow τ1' τ2 =>
      if ftype_eq τ1 τ1'
      then Some τ2
      else @None FType
    | _ => @None FType
    end
  | TAbs e =>
    τ <- typeof' (N.succ ftv) (map (type_lift 0) Γ) e;;
    ret (TForall τ)
  | TApp e τ =>
    τ2 <- typeof' ftv Γ e;;
    if well_formed_type ftv τ
    then match τ2 with
         | TForall τ2' => Some (type_subst_in_type 0 τ2' τ)
         | _ => @None FType
         end
    else @None FType
  | Tuple es =>
    es' <- map_monad (fun e => typeof' ftv Γ e) es;;
    ret (Prod es')
  | ProjN i (Tuple es) =>
    e <- nth_error es (N.to_nat i);;
    typeof' ftv Γ e
  | ProjN _ _ => None
  | Num x => Some IntType
  | If0 c e1 e2 =>
    cτ <- typeof' ftv Γ c;;
    if ftype_eq cτ IntType
    then e1τ <- typeof' ftv Γ e1;;
         e2τ <- typeof' ftv Γ e2;;
         if ftype_eq e1τ e2τ
         then Some e1τ
         else @None FType
    else @None FType
  | Op op e1 e2 =>
    e1τ <- typeof' ftv Γ e1;;
    e2τ <- typeof' ftv Γ e2;;
    if (ftype_eq e1τ IntType && ftype_eq e2τ IntType)%bool
    then Some e1τ
    else @None FType
  end.
Next Obligation.
Admitted.
Next Obligation.
Admitted.

Definition typeof {I} `{FInt I} : Term -> option FType := typeof' 0 nil.

(* Check whether a type is closed *)
Fixpoint is_closed' (tc : N) (τ : FType) : bool
  := match τ with
     | Arrow τ1 τ2 => is_closed' tc τ1 && is_closed' tc τ2
     | Prod τs => forallb (is_closed' tc) τs
     | TForall τ => is_closed' (tc+1) τ
     | TVar x => N.ltb x tc
     | IntType => true
     end.

Definition is_closed := is_closed' 0.

Definition well_typed {I} `{FInt I} (e : Term) : bool
  := ssrbool.isSome (typeof e).