From LF Require Export Induction.
From LF Require Export Basics.

Module NatList.

(* ## Pairs of Numbers *)

Inductive natprod : Type :=
| pair (n1 n2 : nat).

Definition fst (p : natprod) : nat :=
match p with
| pair x y => x
end.

Definition snd (p : natprod) : nat :=
match p with
| pair x y => y
end.

Definition swap_pair (p : natprod) : natprod :=
match p with
| pair x y => pair y x
end.

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

Fixpoint minus (n m : nat) : nat :=
 match n, m with
 | O   , _    => O
 | S _ , O    => n
 | S n', S m' => minus n' m'
 end.

Theorem surjective_pairing_stuck : forall (p : natprod),
  p = (fst p, snd p).
Proof.
  intros p.
  destruct p as [x y].
  simpl.
  reflexivity.
Qed.

Theorem snd_fst_is_swap : forall (p : natprod),
  (snd p, fst p) = swap_pair p.
Proof.
  intros p.
  destruct p as [x y].
  simpl.
  reflexivity.
Qed.

Theorem fst_swap_is_snd : forall (p : natprod),
  fst (swap_pair p) = snd p.
Proof.
  intros p.
  destruct p as [x y].
  simpl.
  reflexivity.
Qed.

(* # Lists of Numbers *)

Inductive natlist : Type :=
  | nil
  | cons (n : nat) (l : natlist).

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

Definition mylist1 := 1 :: (2 :: (3 :: nil)).
Definition mylist2 := 1 :: 2 :: 3 :: nil.
Definition mylist3 := [1;2;3].

Fixpoint repeat (n count : nat) : natlist :=
match count with
| O => nil
| S count' => n :: (repeat n count')
end.

Fixpoint length (l:natlist) : nat :=
match l with
| nil => O
| h :: t => S (length t)
end.

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

Notation "x ++ y" := (app x y)
                     (right associativity, at level 60).

Definition hd (default:nat) (l:natlist) : nat :=
match l with
| nil => default
| h :: t => h
end.

Definition tl (l:natlist) : natlist :=
match l with
| nil => nil
| h :: t => t
end.

Fixpoint nonzeros (l:natlist) : natlist :=
match l with
| nil => nil
| cons O t => (nonzeros t)
| cons x t => x :: (nonzeros t)
end.

Example test_nonzeros:
  nonzeros [0;1;0;2;3;0;0] = [1;2;3].
  simpl. reflexivity.
Qed.

Fixpoint oddmembers (l:natlist) : natlist :=
match l with
| nil => nil
| h :: t => if(oddb h) then h :: oddmembers t else oddmembers t
end.

Example test_oddmembers:
  oddmembers [0;1;0;2;3;0;0] = [1;3].
  simpl.
  reflexivity.
Qed.

Definition countoddmembers (l:natlist) : nat := length (oddmembers l).

Example test_countoddmembers1:
  countoddmembers [1;0;3;1;4;5] = 4.
  simpl.
  reflexivity.
Qed.

Example test_countoddmembers2:
  countoddmembers [0;2;4] = 0.
  simpl.
  reflexivity.
Qed.

Example test_countoddmembers3:
  countoddmembers nil = 0.
  simpl.
  reflexivity.
Qed.

Fixpoint alternate (l1 l2 : natlist) : natlist :=
match l1, l2 with
| nil, nil => nil
| nil, _ => l2
| _, nil => l1
| h :: t, h' :: t' => h :: h' :: (alternate t t')
end.

Example test_alternate1:
  alternate [1;2;3] [4;5;6] = [1;4;2;5;3;6].
Proof.
reflexivity.
Qed.

Example test_alternate2:
  alternate [1] [4;5;6] = [1;4;5;6].
Proof.
reflexivity.
Qed.

Example test_alternate3:
  alternate [1;2;3] [4] = [1;4;2;3].
Proof.
reflexivity.
Qed.

Example test_alternate4:
  alternate [] [20;30] = [20;30].
Proof.
reflexivity.
Qed.

Definition bag := natlist.

Fixpoint filter (v:nat) (s:bag) : bag :=
match s with
| nil => nil
| h :: t => if eqb h v then h :: filter v t else filter v t
end.

Fixpoint count (v:nat) (s:bag) : nat :=
  match s with
  | nil => O
  | h :: t => if(eqb h v) then 1 + (count v t) else count v t
end.

Example test_count1: count 1 [1;2;3;1;4;1] = 3.
Proof.
 reflexivity.
Qed.

Example test_count2: count 6 [1;2;3;1;4;1] = 0.
Proof.
  reflexivity.
Qed.

Definition sum : bag -> bag -> bag :=
  fun l1 l2 => l1 ++ l2.

Example test_sum1: count 1 (sum [1;2;3] [1;4;1]) = 3.
 simpl. reflexivity.
Qed.

Definition add (v:nat) (s:bag) : bag :=
  (v :: nil) ++ s.

Example test_add1: count 1 (add 1 [1;4;1]) = 3.
  reflexivity.
Qed.

Example test_add2: count 5 (add 1 [1;4;1]) = 0.
  simpl. reflexivity.
Qed.

Definition member (v:nat) (s:bag) : bool :=
match (count v s) with
| O => false
| S n => true
end.

Example test_member1: member 1 [1;4;1] = true.
reflexivity.
Qed.

Example test_member2: member 2 [1;4;1] = false.
reflexivity.
Qed.

Fixpoint remove_one (v:nat) (s:bag) : bag :=
match s with
| nil => nil
| h :: t => if(eqb v h) then t else h :: remove_one v t
end.

Example test_remove_one1:
  count 5 (remove_one 5 [2;1;5;4;1]) = 0.
Proof. reflexivity. Qed.

Example test_remove_one2:
  count 5 (remove_one 5 [2;1;4;1]) = 0.
Proof. reflexivity. Qed.

Example test_remove_one3:
  count 4 (remove_one 5 [2;1;4;5;1;4]) = 2.
Proof. reflexivity. Qed.

Example test_remove_one4:
  count 5 (remove_one 5 [2;1;5;4;5;1;4]) = 1.
Proof. reflexivity. Qed.

Fixpoint remove_all (v:nat) (s:bag) : bag :=
match s with
| nil => nil
| h :: t => if(eqb v h) then remove_all v t else h :: remove_all v t
end.

Example test_remove_all1:  count 5 (remove_all 5 [2;1;5;4;1]) = 0.
Proof. reflexivity. Qed.

Example test_remove_all2:  count 5 (remove_all 5 [2;1;4;1]) = 0.
Proof. reflexivity. Qed.

Example test_remove_all3:  count 4 (remove_all 5 [2;1;4;5;1;4]) = 2.
Proof. reflexivity. Qed.

Example test_remove_all4:  count 5 (remove_all 5 [2;1;5;4;5;1;4;5;1;4]) = 0.
Proof. reflexivity. Qed.

Fixpoint exist (v:nat) (s:bag) : bool :=
  match s with
  | nil => false
  | h :: t => if (eqb v h) then true else exist v t
end.

Fixpoint subset (s1:bag) (s2:bag) : bool :=
  match s1 with
  | nil => true
  | h :: t => if exist h s2 then subset t (remove_one h s2) else false
end.

Example test_subset1: subset [1;2] [2;1;4;1] = true.
Proof. reflexivity. Qed.

Example test_subset2: subset [1;2;2] [2;1;4;1] = false.
Proof. reflexivity. Qed.

(* # Reasoning About Lists *)

Theorem nil_app : forall l:natlist,
  [] ++ l = l.
Proof. reflexivity. Qed.

Theorem tl_length_pred : forall l:natlist,
  pred (length l) = length (tl l).
Proof.
  intros l.
  destruct l as [| n l'].
  - (* l = nil *)
    reflexivity.
  - (* l = cons n l' *)
  reflexivity.
Qed.

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

Example test_rev1: rev [1;2;3] = [3;2;1].
Proof. reflexivity. Qed.

Example test_rev2: rev nil = nil.
Proof. reflexivity. Qed.

Theorem app_length : forall l1 l2 : natlist,
  length (l1 ++ l2) = (length l1) + (length l2).
Proof.
intros l1 l2.
induction l1 as [| n l1' IHl1'].
- (* l1 = nil *)
  reflexivity.
- (* l1 = cons *)
  simpl. rewrite -> IHl1'. reflexivity.
Qed.

Theorem app_assoc : forall l1 l2 l3 : natlist,
  (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
  intros l1 l2 l3. induction l1 as [| n l1' IHl1'].
  - (* l1 = nil *)
    reflexivity.
  - (* l1 = cons n l1' *)
    simpl. rewrite -> IHl1'. reflexivity.
Qed.

Theorem rev_length : forall l : natlist,
  length (rev l) = length l.
Proof.
  intros l. induction l as [| n l' IHl'].
  - reflexivity.
  - simpl. rewrite -> app_length, plus_comm.
  simpl.
  rewrite -> IHl'.
  reflexivity.
Qed.

Theorem app_nil_r : forall l : natlist,
  l ++ [] = l.
Proof.
intros l.
induction l as [| n l' IHl'].
- simpl. reflexivity.
- simpl. rewrite -> IHl'. reflexivity.
Qed.

Theorem rev_app_distr: forall l1 l2 : natlist,
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros l1 l2.
  induction l1 as [| n l1' IHl1'].
  - simpl. rewrite -> app_nil_r. reflexivity.
  - simpl. rewrite -> IHl1'. apply app_assoc.
Qed.

Theorem rev_involutive : forall l : natlist,
  rev (rev l) = l.
Proof.
  intros l.
  induction l as [| n l' IHl].
  - reflexivity.
  - simpl.
    rewrite -> rev_app_distr.
    rewrite -> IHl.
    reflexivity.
Qed.

Theorem app_assoc4 : forall l1 l2 l3 l4 : natlist,
  l1 ++ (l2 ++ (l3 ++ l4)) = ((l1 ++ l2) ++ l3) ++ l4.
Proof.
intros l1 l2 l3 l4.
rewrite -> app_assoc.
rewrite -> app_assoc.
reflexivity.
Qed.

Lemma nonzeros_app : forall l1 l2 : natlist,
  nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2).
Proof.
intros l1 l2. induction l1 as [| n1 l1'].

- reflexivity.
- simpl.
  rewrite -> IHl1'.
  destruct n1 as [| n1'].
  + reflexivity.
  + reflexivity.
Qed.

Fixpoint eqblist (l1 l2 : natlist) : bool :=
match l1, l2 with
| nil, nil => true
| nil, _ => false
| _, nil => false
| h :: t, h' :: t' => if eqb h h' then eqblist t t' else false
end.

Example test_beq_natlist1 :
  (eqblist nil nil = true).
Proof. reflexivity. Qed.

Example test_beq_natlist2 :
  eqblist [1;2;3] [1;2;3] = true.
Proof. reflexivity. Qed.

Example test_beq_natlist3 :
  eqblist [1;2;3] [1;2;4] = false.
Proof. reflexivity. Qed.

Theorem eqblist_refl : forall l:natlist,
  true = eqblist l l.
Proof.
  intros l.
  induction l as [| n l'].
  - reflexivity.
  - { induction n.
    - simpl. rewrite <- IHl'. reflexivity.
    - rewrite -> IHn. simpl. reflexivity. }
Qed.

Theorem count_member_nonzero : forall (s : bag),
  1 <=? (count 1 (1 :: s)) = true.
Proof.
intros s. reflexivity.
Qed.

Theorem leb_n_Sn : forall n,
  n <=? (S n) = true.
Proof.
  intros n. induction n as [| n' IHn'].
    simpl. reflexivity.
    simpl. rewrite IHn'. reflexivity.
Qed.

Theorem remove_does_not_increase_count: forall (s : bag),
  leb (count 0 (remove_one 0 s)) (count 0 s) = true.
Proof.
  intros s. induction s.
  - simpl. reflexivity.
  - simpl. { induction n.
             - simpl. rewrite leb_n_Sn. reflexivity.
             - simpl. rewrite IHs. reflexivity.
           }
Qed.

(* Options *)

Fixpoint nth_bad (l:natlist) (n:nat) : nat :=
match l with
| nil => 42 (* arbitrary! *)
| a :: l' => match n =? O with
             | true => a
             | false => nth_bad l' (pred n)
             end
end.

Inductive natoption : Type :=
| Some (n : nat)
| None.

Fixpoint nth_error (l:natlist) (n:nat) : natoption :=
match l with
| nil => None
| a :: l' => if n =? O then Some a
             else nth_error l' (pred n)
end.

Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.
simpl. reflexivity.
Qed.

Example test_nth_error2 : nth_error [4;5;6;7] 3 = Some 7.
simpl. reflexivity.
Qed.

Example test_nth_error3 : nth_error [4;5;6;7] 9 = None.
simpl. reflexivity.
Qed.

Definition option_elim (d : nat) (o : natoption) : nat :=
match o with
| Some n' => n'
| None => d
end.

Definition hd_error (l : natlist) : natoption :=
  match l with
  | nil => None
  | a :: l => Some a
end.

Example test_hd_error1 : hd_error [] = None.
reflexivity.
Qed.

Example test_hd_error2 : hd_error [1] = Some 1.
reflexivity.
Qed.

Example test_hd_error3 : hd_error [5;6] = Some 5.
reflexivity.
Qed.

Theorem option_elim_hd : forall (l:natlist) (default:nat),
  hd default l = option_elim default (hd_error l).
Proof.
 intros l def. induction l as [| n l' IHl].
  - reflexivity.
  - reflexivity.
Qed.

(* Partial Maps *)

Inductive id : Type :=
  | Id (n : nat).

Definition eqb_id (x1 x2 : id) :=
match x1, x2 with
| Id n1, Id n2 => n1 =? n2
end.

Theorem eqb_id_refl : forall x, true = eqb_id x x.
Proof.
intros x.
destruct x.
simpl.
Search "nat_refl".
apply eqb_nat_refl.
Qed.

Module PartialMap.

Inductive partial_map : Type :=
  | empty
  | record (i : id) (v : nat) (m : partial_map).

Definition update (d : partial_map)
                  (x : id) (value : nat)
                  : partial_map :=
  record x value d.

Fixpoint find (x : id) (d : partial_map) : natoption :=
  match d with
  | empty => None
  | record y v d' => if eqb_id x y
                     then Some v
                     else find x d'
  end.

Theorem update_eq :
  forall (d : partial_map) (x : id) (v: nat),
    find x (update d x v) = Some v.
Proof.
  intros d k v.
  simpl.
  rewrite <- eqb_id_refl.
  reflexivity.
Qed.

Theorem update_neq :
  forall (d : partial_map) (x y : id) (o: nat),
    eqb_id x y = false -> find x (update d y o) = find x d.
Proof.
  intros d k v o H.
  simpl.
  rewrite H.
  reflexivity.
Qed.

End PartialMap.

Inductive baz : Type :=
  | Baz1 (x : baz)
  | Baz2 (y : baz) (b : bool).

End NatList.


Require Import Overture.
Set Universe Polymorphism.

Set Implicit Arguments.
Generalizable All Variables.

Delimit Scope morphism_scope with morphism.
Delimit Scope category_scope with category.
Delimit Scope object_scope with object.

Local Open Scope morphism_scope.

Reserved Notation "f ∘ g" (at level 40, left associativity).

Record Category : Type :=
  Build_Category' {
      object :> Type;
      morphism : object -> object -> Type;

      identity : forall x, morphism x x;
      compose : forall s d d',
          morphism d d'
          -> morphism s d
          -> morphism s d'
      where "f ∘ g" := (compose f g);

      associativity : forall x1 x2 x3 x4
                             (m1 : morphism x1 x2)
                             (m2 : morphism x2 x3)
                             (m3 : morphism x3 x4),
          (m3 ∘ m2) ∘ m1 ≡ m3 ∘ (m2 ∘ m1);

      associativity_sym : forall x1 x2 x3 x4
                                 (m1 : morphism x1 x2)
                                 (m2 : morphism x2 x3)
                                 (m3 : morphism x3 x4),
          m3 ∘ (m2 ∘ m1) ≡ (m3 ∘ m2) ∘ m1;

      left_identity : forall a b (f : morphism a b), identity b ∘ f ≡ f;
      right_identity : forall a b (f : morphism a b), f ∘ identity a ≡ f;

      identity_identity : forall x, identity x ∘ identity x ≡ identity x
    }.

Bind Scope category_scope with Category.
Bind Scope object_scope with object.
Bind Scope morphism_scope with morphism.

Arguments object !C%category / : rename.
Arguments morphism !C%category / s d : rename.
Arguments identity {!C%category} / x%object : rename.
Arguments compose {!C%category} / {s d d'}%object (m1 m2)%morphism : rename.

Global Infix "∘" := compose : morphism_scope.
Global Notation "x --> y" := (morphism _ x y) (at level 99, right associativity, y at level 200) : type_scope.
Global Notation "1" := (identity _) : morphism_scope.

Definition Build_Category
           object morphism compose identity
           associativity left_identity right_identity
  := @Build_Category'
       object
       morphism
       compose
       identity
       associativity
       (fun _ _ _ _ _ _ _ => Einverse (associativity _ _ _ _ _ _ _))
       left_identity
       right_identity
       (fun _ => left_identity _ _ _).

Definition TYPE : Category.
Proof.
  rapply Build_Category.
  - exact Type.
  - exact (λ A B, A -> B).
  - exact (λ A, idmap).
  - exact (λ A B C g f, g o f).
  - reflexivity.
  - reflexivity.
  - reflexivity.
Defined.

(* Lifting property between f and g *)
Definition LP {C: Category} {x y: C} (f: x --> y) {x' y': C} (g: x' --> y')
  := ∀ (F: x --> x') (G: y --> y'), g ∘ F ≡ G ∘ f -> ∃ (Ɣ: y --> x'), (Ɣ ∘ f ≡ F) × (g ∘ Ɣ ≡ G).

Definition LLP {C: Category} (R: ∀ {x y: C}, (x --> y) -> Type) {x y: C} (f: x --> y)
  := ∀ x' y' (g: x' --> y'), R g -> LP f g.

Definition RLP {C: Category} (L: ∀ {x y: C}, (x --> y) -> Type) {x' y': C} (g: x' --> y')
  := ∀ x y (f: x --> y), L f -> LP f g.

Definition LLP_functor {C: Category} (R R': ∀ {x y: C}, (x --> y) -> Type)
           (RR': ∀ x y (f: x --> y), R f -> R' f)
           {x y: C} (f: x --> y)
  : LLP (@R') f -> LLP (@R) f.
Proof.
  intros H x' y' g Hg. apply H. apply RR'; assumption.
Defined.

Definition RLP_functor {C: Category} (L L': ∀ {x y: C}, (x --> y) -> Type)
           (LL': ∀ x y (f: x --> y), L f -> L' f)
           {x y: C} (f: x --> y)
  : RLP (@L') f -> RLP (@L) f.
Proof.
  intros H x' y' g Hg. apply H. apply LL'; assumption.
Defined.

Record weak_factorization_system {C: Category} (L R: ∀ {x y: C}, (x --> y) -> Type) :=
  { facto: ∀ (x z: C) (f: x --> z),
      ∃ y (g: x --> y) (h: y --> z), (h ∘ g ≡ f) × L g × R h;
    LLP_R: ∀ (x y: C) (f: x --> y), L f <-> LLP (@R) f;
    RLP_L: ∀ (x y: C) (f: x --> y), R f <-> RLP (@L) f
  }.

Definition wfs_iff_R {C: Category} (L R R': ∀ {x y: C}, (x --> y) -> Type)
           (H: ∀ x y (f: x --> y), R f <-> R' f)
           (W: weak_factorization_system (@L) (@R))
  : weak_factorization_system (@L) (@R').
Proof.
  destruct W. use Build_weak_factorization_system.
  - intros x z f. destruct (facto0 x z f) as [y [g [h [H1 [H2 H3]]]]].
    ref (y; (g; h; (H1, (H2, _)))). now apply H.
  - intros x y f; split; intro H1.
    + eapply LLP_functor. apply H.
      apply LLP_R0. assumption.
    + apply LLP_R0. eapply LLP_functor.
      apply H. assumption.
  - intros x y f; split; intro H1.
    + apply RLP_L0. apply H. assumption.
    + apply H. eapply RLP_L0. assumption.
Defined.

Definition wfs_iff_L {C: Category} (L L' R: ∀ {x y: C}, (x --> y) -> Type)
           (H: ∀ x y (f: x --> y), L f <-> L' f)
           (W: weak_factorization_system (@L) (@R))
  : weak_factorization_system (@L') (@R).
Proof.
  destruct W. use Build_weak_factorization_system.
  - intros x z f. destruct (facto0 x z f) as [y [g [h [H1 [H2 H3]]]]].
    ref (y; (g; h; (H1, (_, H3)))). now apply H.
  - intros x y f; split; intro H1.
    + apply LLP_R0. apply H. assumption.
    + apply H. eapply LLP_R0. assumption.
  - intros x y f; split; intro H1.
    + eapply RLP_functor. apply H.
      apply RLP_L0. assumption.
    + apply RLP_L0. eapply RLP_functor.
      apply H. assumption.
Defined.

Definition two_out_of_three {C: Category} (W: ∀ {x y: C}, (x --> y) -> Type)
  := ∀ (x y z: C) (f: x --> y) (g: y --> z),
    (W f -> W g -> W (g ∘ f)) × (W g -> W (g ∘ f) -> W f) × (W (g ∘ f) -> W f -> W g).

Record model_structure (C: Category) :=
  { W: ∀ {x y: C}, (x --> y) -> Type;
    F: ∀ {x y: C}, (x --> y) -> Type;
    C: ∀ {x y: C}, (x --> y) -> Type;
    tot: two_out_of_three (@W);
    C_AF: weak_factorization_system (@C) (λ x y f, W f × F f);
    AC_F: weak_factorization_system (λ x y f, W f × C f) (@F)
  }.


(** * Typy hybrydowe *)

(** Ostatnim z typów istotnych z punktu widzenia silnych specyfikacji
    jest typ o wdzięcznej nazwie [sumor]. *)

Module sumor.

Inductive sumor (A : Type) (B : Prop) : Type :=
| inleft : A -> sumor A B
| inright : B -> sumor A B.

(** Jak sama nazwa wskazuje, [sumor] jest hybrydą sumy rozłącznej [sum]
    oraz dysjunkcji [or]. Możemy go interpretować jako typ, którego
    elementami są elementy [A] albo wymówki w stylu "nie mam elementu [A],
    ponieważ zachodzi zdanie [B]". [B] nie zależy od [A], a więc jest to
    zwykła suma (a nie suma zależna, czyli uogólnienie produktu). [sumor]
    żyje w [Type], a więc jest to specyfikacja i liczy się konkretna
    postać jego termów, a nie jedynie fakt ich istnienia. *)

(** **** Ćwiczenie ([pred']) *)

(** Zdefiniuj funkcję [pred'], która przypisuje liczbie naturalnej jej
    poprzednik. Poprzednikiem [0] nie powinno być [0]. Mogą przydać ci
    się typ [sumor] oraz sposób definiowania za pomocą taktyk, omówiony
    w podrozdziale dotyczącym sum zależnych. *)

(* begin hide *)
Definition pred' (n : nat) : sumor nat (n = 0) :=
match n with
| 0 => inright _ _ eq_refl
| S n' => inleft _ _ n'
end.
(* end hide *)

End sumor.


Require Import Basics.
Require Import Types.
Require Import Pointed.Core.

Local Open Scope pointed_scope.

(* pointed homotopy is a reflexive relation *)
Global Instance phomotopy_reflexive {A B} : Reflexive (@pHomotopy A B).
Proof.
  intro.
  serapply Build_pHomotopy.
  + intro. reflexivity.
  + apply concat_1p.
Defined.

(** ** Whiskering of pointed homotopies by pointed functions *)

Definition pmap_postwhisker {A B C : pType} {f g : A ->* B}
  (h : B ->* C) (p : f ==* g) : h o* f ==* h o* g.
Proof.
  pointed_reduce.
  simple refine (Build_pHomotopy _ _); cbn.
  - intros a; apply ap, p.
  - reflexivity.
Qed.

Definition pmap_prewhisker {A B C : pType} (f : A ->* B)
  {g h : B ->* C} (p : g ==* h) : g o* f ==* h o* f.
Proof.
  pointed_reduce.
  simple refine (Build_pHomotopy _ _); cbn.
  - intros a; apply p.
  - refine (concat_p1 _ @ (concat_1p _)^).
Qed.

(** ** Composition of pointed homotopies *)

Definition phomotopy_compose {A B : pType} {f g h : A ->* B}
  (p : f ==* g) (q : g ==* h) : f ==* h.
Proof.
  pointed_reduce.
  simple refine (Build_pHomotopy _ _); cbn.
  - intros x; exact (p x @ q x).
  - apply concat_p1.
Qed.

Infix "@*" := phomotopy_compose : pointed_scope.

(* pointed homotopy is a transitive relation *)
Global Instance phomotopy_transitive {A B} : Transitive (@pHomotopy A B)
  := @phomotopy_compose A B.

Definition phomotopy_inverse {A B : pType} {f g : A ->* B}
: (f ==* g) -> (g ==* f).
Proof.
  intros p; pointed_reduce.
  simple refine (Build_pHomotopy _ _); cbn.
  - intros x; exact ((p x)^).
  - apply concat_Vp.
Qed.

(* pointed homotopy is a symmetric relation *)
Global Instance phomotopy_symmetric {A B} : Symmetric (@pHomotopy A B)
  := @phomotopy_inverse A B.

Notation "p ^*" := (phomotopy_inverse p) : pointed_scope.

Definition issig_phomotopy {A B : pType} (f g : A ->* B)
: { p : f == g & p (point A) @ point_eq g = point_eq f } <~> (f ==* g).
Proof.
  issig.
Defined.


(******************************************************************************)
(* Chapter 1.6.1: Product Categories                                          *)
(******************************************************************************)

(*
(0)
同じディレクトリにある Categories.v と Functor.v を使う。

(1) ベースライン
http://www.megacz.com/berkeley/coq-categories/
これをもとに改変。Instance ... Proper を使うようにした。
 *)

Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import finset fintype.

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

Require Import Notations.                   (* coq standard libs. *)
Require Import Categories.                  (* same dir. *)
Require Import Functors.                    (* same dir. *)
Require Import Isomorphisms.                (* same dir. *)

(* 積圏 *)
Section ProductCategories.

  Locate "_ ~~{ _ }~~> _".                  (* Categories.v *)

(*
  Context `(C1 : Category Obj1 Hom1).
  Context `(C2 : Category Obj2 Hom2).
*)
  Context `(C1 : Category).                 (* Obj Hom *)
  Context `(C2 : Category).                 (* Obj0 Hom0 *)

  (* trying to use the standard "prod" here causes a universe
  inconsistency once we get to coqBinoidal; moreover, using a
  general fully-polymorphic pair type seems to trigger some serious
  memory leaks in Coq *)

  Inductive  prod_obj : Type :=
  | pair_obj : C1 -> C2 -> prod_obj.

  Definition fst_obj (x : prod_obj) : C1 :=
    match x with
      | pair_obj a _ => a
    end.

  Definition snd_obj (x : prod_obj) : C2 :=
    match x with
      | pair_obj _ b => b
    end.

  Inductive prod_mor (a b : prod_obj) : Type :=
    pair_mor :
      ((fst_obj a) ~~{C1}~~> (fst_obj b)) -> (* f1 *)
      ((snd_obj a) ~~{C2}~~> (snd_obj b)) -> (* f2 *)
      prod_mor a b.                          (* f *)
  Check prod_mor : prod_obj → prod_obj → Type.

  Definition prod_eqv (a b : prod_obj)
             (f : prod_mor a b) (g : prod_mor a b) : Prop :=
    match f with
      | pair_mor f1 f2 =>
        match g with
          | pair_mor g1 g2 =>
            f1 === g1 /\ f2 === g2
        end
    end.

  Program Instance prod_Equiv (a b : prod_obj) : Equivalence (@prod_eqv a b).
  Obligation 1.                             (* Reflexive *)
  Proof.
    rewrite /prod_eqv /Reflexive /=.
    case=> f1 f2.
    split.
    - reflexivity.
    - reflexivity.
  Qed.
  Obligation 2.                             (* Symmetric *)
  Proof.
    rewrite /prod_eqv /Symmetric /=.
    case=> f1 f2.
    case=> g1 g2.
    case=> H1 H2.
    split.
    - rewrite H1.
      reflexivity.
    - rewrite H2.
      reflexivity.
  Qed.
  Obligation 3.                             (* Transitive *)
  Proof.
    rewrite /prod_eqv /Transitive /=.
    case=> f1 f2.
    case=> g1 g2.
    case=> h1 h2.
    case=> Hfg1 Hfg2.
    case=> Hgh1 Hgh2.
    split.
    - rewrite Hfg1 Hgh1.
      reflexivity.
    - rewrite Hfg2 Hgh2.
      reflexivity.
  Qed.

  (* 射はSetoidでないといけない。 *)
  Instance PC_mor (a b : prod_obj) : Setoid :=
    {
      carrier := prod_mor a b;
      eqv := @prod_eqv a b
    }.
  Check PC_mor : prod_obj → prod_obj → Setoid.
  Print PC_mor.

  Definition fst_mor {a b : prod_obj} (f : prod_mor a b) :=
    match f with
      | pair_mor a _ => a
    end.

  Definition snd_mor {a b : prod_obj} (f : prod_mor a b) :=
    match f with
      | pair_mor _ b => b
    end.

  Check @Category.
  Check prod_obj : Type.
  Check prod_mor : prod_obj → prod_obj → Type.
  Check PC_mor   : prod_obj → prod_obj → Setoid.
  Check @Category prod_obj PC_mor.

  Program Instance ProductCategory : @Category prod_obj PC_mor.
  Obligation 1.                             (* id *)
  Proof.
    apply pair_mor.
    - apply id.
    - apply id.
  Defined.
  Obligation 2.                             (* comp *)
  Proof.
    apply pair_mor.
    Check (fun (f1 : fst_obj a ~~{ C1 }~~> fst_obj b)
               (g1 : fst_obj b ~~{ C1 }~~> fst_obj c) => (g1 \\o f1)).
    - apply (fun (f1 : fst_obj a ~~{ C1 }~~> fst_obj b)
                 (g1 : fst_obj b ~~{ C1 }~~> fst_obj c) => (g1 \\o f1));
        by [apply X | apply X0].
    - apply (fun (f2 : snd_obj a ~~{ C2 }~~> snd_obj b)
                 (g2 : snd_obj b ~~{ C2 }~~> snd_obj c) => (g2 \\o f2));
        by [apply X | apply X0].
  Defined.
  Obligation 3.                             (* comp_respects *)
  Proof.
    rewrite /ProductCategory_obligation_2.
    move=> g1 g2 Hg.
    move=> f1 f2 Hf.
    move: Hg Hf.
    rewrite /prod_eqv.
    case g1 => gf1 gs1.
    case f1 => ff1 fs1.
    case g2 => gf2 gs2.
    case f2 => ff2 fs2.
    case=> Hgf Hgs.
    case=> Hff Hfs.
    split.
    - rewrite Hgf Hff.
      reflexivity.
    - rewrite Hgs Hfs.
      reflexivity.
  Defined.
  Obligation 4.                             (* id \\o f === f  *)
  Proof.
    case: f => ff fs.
    split.
    - rewrite left_identity.
      reflexivity.
    - rewrite left_identity.
      reflexivity.
  Defined.
  Obligation 5.                             (* f \\o id === f  *)
  Proof.
    case: f => ff fs.
    split.
    - rewrite right_identity.
      reflexivity.
    - rewrite right_identity.
      reflexivity.
  Defined.
  Obligation 6.                             (* f \\o g \\o h === f \\o (g \\o h) *)
  Proof.
    case: f => ff fs.
    split.
    - case: g => gf gs.
      case: h => hf hs.
      rewrite associativity.
      reflexivity.
    - case: g => gf gs.
      case: h => hf hs.
      rewrite associativity.
      reflexivity.
  Defined.
End ProductCategories.

Notation "C ×× D" := (ProductCategory C D).

(*
Implicit Arguments pair_obj [ Ob1 Hom1 Ob2 Hom2 C1 C2 ].
Implicit Arguments pair_mor [ Ob1 Hom1 Ob2 Hom2 C1 C2 ].
 *)

Check @pair_obj : ∀Obj Hom C1 Obj Hom C2 a b, prod_obj C1 C2.
Check @pair_mor : ∀Obj Hom C1 Obj Hom C2 a b f g, prod_mor a b.
Check @fst_obj.
Check @fst_mor.
Arguments pair_obj {Obj1 Hom1 C1 Obj2 Hom2 C2} a b : rename.
Arguments pair_mor {Obj1 Hom1 C1 Obj2 Hom2 C2 a b} f g : rename.
Arguments fst_obj  {Obj1 Hom1 C1 Obj2 Hom2 C2} D : rename.
Arguments snd_obj  {Obj1 Hom1 C1 Obj2 Hom2 C2} D : rename.
Arguments fst_mor  {Obj1 Hom1 C1 Obj2 Hom2 C2 a b} i : rename.
Arguments snd_mor  {Obj1 Hom1 C1 Obj2 Hom2 C2 a b} i : rename.
Check pair_obj : _ -> _ -> prod_obj _ _.    (* 圏の指定は要らない。 *)
Check pair_mor : _ ~> _ ->  _ ~> _ -> prod_mor _ _.
Check fst_obj  : prod_obj _ _ -> _.
Check snd_obj  : prod_obj _ _ -> _.
Check fst_mor  : prod_mor _ _ -> _ ~> _.

Check @PC_mor : ∀Obj Hom C1 Obj0 Hom0 C2 _ _, Setoid.
Arguments PC_mor {Obj1 Hom1 C1 Obj2 Hom2 C2} f g : rename.
Check PC_mor : prod_obj _ _ → prod_obj _ _ → Setoid.

Check @Functor : ∀Obj Hom C1 Obj0 Hom0 C2 _, Type.
Arguments Functor {Obj Hom} C1 {Obj0 Hom0} C2 i : rename.

Section ProductCategoryFunctors.

  Context `{C : Category}.                  (* Obj Hom C *)
  Context `{D:Category}.                    (* Obj0 Hom0 D *)

  Check @Functor.
  Check @Functor _ _ (C ×× D) Obj Hom C (fun c => fst_obj c).
  Check Functor (C ×× D) C (fun c => fst_obj c).

  Check @prod_obj Obj Hom C Obj0 Hom0 D.
  Check prod_obj C D.

  Check @PC_mor Obj Hom C Obj0 Hom0 D.
  Check PC_mor.

  Check @fst_obj Obj Hom C Obj0 Hom0 D : prod_obj C D → C.
  Check fst_obj : prod_obj C D → C.

  Check fun (c : prod_obj C D) => @fst_obj Obj Hom C Obj0 Hom0 D c.
  Check fun (c : prod_obj C D) => fst_obj c.

  Check @Functor (prod_obj C D) (@PC_mor Obj Hom C Obj0 Hom0 D) (C ×× D)
        Obj Hom C (fun c => fst_obj _ _ c).
  Check Functor (C ×× D) C (fun (c : prod_obj C D) => @fst_obj Obj Hom C Obj0 Hom0 D c).

  (* 積圏からもとの圏をとりだす関手 *)
  Program Instance func_pi1 : Functor (C ×× D) C
                                      (fun (c : prod_obj C D) => fst_obj c).
  Obligation 1.
  (* fst_obj a ~~{ C }~~> fst_obj b *)
  Proof.
    by apply fst_mor.
  Defined.
  Obligation 2.
  (* fst_mor f === fst_mor f' *)
  Proof.
    rewrite /func_pi1_obligation_1.
    case: f H => ff fs.
    case: f' => f'f f's H /=.
    by case: H.
  Defined.
  Obligation 3.
  (* id === id *)
  Proof.
    reflexivity.
  Defined.
  Obligation 4.
  Proof.
    rewrite /func_pi1_obligation_1.
    case: f => ff fs.
    case: g => gf gs.
    reflexivity.
  Defined.

  Program Instance func_pi2 : Functor (C ×× D) D
                                      (fun (c : prod_obj C D) => snd_obj c).
  Obligation 1.
  (* snd_obj a ~~{ D }~~> snd_obj b *)
  Proof.
    by apply snd_mor.
  Defined.
  Obligation 2.
  (* snd_mor f === snd_mor f' *)
  Proof.
    rewrite /func_pi2_obligation_1.
    case: f H => ff fs.
    case: f' => f'f f's H /=.
    by case: H.
  Defined.
  Obligation 3.
  (* id === id *)
  Proof.
    reflexivity.
  Defined.
  Obligation 4.
  Proof.
    rewrite /func_pi2_obligation_1.
    case: f => ff fs.
    case: g => gf gs.
    reflexivity.
  Defined.

  (* 積圏の左が恒等射である場合 *)
  Definition llecnac_fmor (I : C) (a b : D) (g : a ~~{D}~~> b) :
    (pair_obj I a) ~~{C××D}~~> (pair_obj I b).
  Proof.
    apply: pair_mor => /=.
    - by apply: id.
    - by apply: g.
  Defined.

  (* 圏から左が恒等射である積圏への関手 *)
  Program Instance func_llecnac (I : C) : Functor D (C ×× D) (pair_obj I).
  Obligation 1.
  (* prod_mor (pair_obj I a) (pair_obj I b) *)
   Proof.
    apply: pair_mor;
      by apply llecnac_fmor.
  Defined.
  Obligation 2.
  Proof.
    split; [reflexivity | done].
  Defined.
  Obligation 3.
    split; [reflexivity | reflexivity].
  Defined.
  Obligation 4.
  Proof.
    split.
    - rewrite left_identity.
      reflexivity.
    - reflexivity.
  Defined.

  (* 積圏の右が恒等射である場合 *)
  Definition rlecnac_fmor (I : D) (a b : C) (f : a ~~{C}~~> b) :
    (pair_obj a I) ~~{C××D}~~> (pair_obj b I).
  Proof.
    apply: pair_mor => /=.
    - by apply: f.
    - by apply: id.
  Defined.

  (* 圏から右が恒等射である積圏への関手 *)
  Program Instance func_rlecnac (I : D) : Functor C (C ×× D) (fun c => (pair_obj c I)).
  Obligation 1.
  (* prod_mor (pair_obj a I) (pair_obj b I) *)
  Proof.
    apply: pair_mor;
      by apply rlecnac_fmor.
  Defined.
  Obligation 2.
  Proof.
    split; [done | reflexivity].
  Defined.
  Obligation 3.
    split; [reflexivity | reflexivity].
  Defined.
  Obligation 4.
  Proof.
    split.
    - reflexivity.
    - rewrite right_identity.
      reflexivity.
  Defined.

  Context `{E : Category}.

  (* 積圏の結合律 *)
  Definition cossa : ((C ×× D) ×× E) -> (C ×× (D ×× E)).
  Proof.
    move=> [[HC HD] HE].
    by [].
  Defined.

  (* 次の定理のための補題 *)
  Definition cossa_fmor (a : ((C ×× D) ×× E)) (b : ((C ×× D) ×× E))
             (f : a ~~{(C ×× D) ×× E}~~> b) :
    (cossa a) ~~{C ×× (D ×× E)}~~> (cossa b).
  Proof.
    case: a f => HCxD HE.
    case: b => GCxD GE.
    case: HCxD.
    case: GCxD.
    move=> HC HD GC GD.
    case=> fCD fE.
    case: fCD => fC fD.
    done.
  Defined.

  (* cossa は、関手である。 *)
  Program Instance func_cossa : Functor ((C ×× D) ×× E) (C ×× (D ×× E)) cossa :=
    {|
      fmor := fun a b f => cossa_fmor f
    |}.
  Obligation 1.
  Proof.
    move: a b f f' H.
    (* ∀a b f f' _, cossa_fmor f === cossa_fmor f' *)
    move=> [[a11 a12] a2].                  (* case a *)
    move=> [[b11 b12] b2].                  (* case b *)
    move=> [[f11 f12] f2].                  (* case f *)
    move=> [[g11 g12] g2].                  (* case f' *)
    case; case.
    split; [exact | split; exact].
  Defined.
  Obligation 2.
  Proof.
    (* ∀ a : (C ×× D) ×× E, cossa_fmor id === id *)
    case: a => HCxD HE.
    case: HCxD => HC HD.
    split; [reflexivity | split; reflexivity].
  Defined.
  Obligation 3.
  Proof.
    move: a b c f g.
    (* ∀a b c f g, cossa_fmor g \\o cossa_fmor f === cossa_fmor (g \\o f) *)
    move=> [[a11 a12] a2].                  (* case a *)
    move=> [[b11 b12] b2].                  (* case b *)
    move=> [[c11 c12] c2].                  (* case c *)
    move=> [[f11 f12] f2].                  (* case f *)
    move=> [[g11 g12] g2].                  (* case g *)
    rewrite /=; split; [reflexivity | split; reflexivity].
  Defined.

  (* 同じ圏の積 C^2 *)
  Program Instance func_diagonal : Functor C (C ×× C) (fun c => (pair_obj c c)).
  Obligation 1.
  (* prod_mor (pair_obj a a) (pair_obj b b) *)
  Proof.
    by apply: pair_mor.
  Defined.
  Obligation 3.
  (* id === id ∧ id === id *)
  Proof.
    split; reflexivity.
  Defined.
  Obligation 4.
  (* g \\o f === g \\o f ∧ g \\o f === g \\o f *)
  Proof.
    split; reflexivity.
  Defined.
End ProductCategoryFunctors.

Section func_prod.

  Context `{C1 : Category} `{C2 : Category} `{C3 : Category} `{C4 : Category}.
  Variables (Fobj1 : C1 -> C2) (Fobj2 : C3 -> C4).
  Variables (F1 : Functor C1 C2 Fobj1) (F2 : Functor C3 C4 Fobj2).

  Definition functor_product_fobj (a : prod_obj C1 C3) :=
    pair_obj (Fobj1 (fst_obj a)) (Fobj2 (snd_obj a)).
  Check functor_product_fobj.
  Check functor_product_fobj : prod_obj C1 C3 → prod_obj C2 C4.

  Definition functor_product_fmor (a b : (C1 ×× C3)) (f : a ~~{C1 ×× C3}~~> b) :
    (functor_product_fobj a) ~~{C2 ×× C4}~~> (functor_product_fobj b).
  Proof.
    case: a f => HC1 HC3 H.
    apply: pair_mor => /=.
    - apply (fmor F1); by case H.
    - apply (fmor F2); by case H.
  Defined.

  Hint Unfold fst_obj.

  Program Instance func_prod : Functor (C1 ×× C3) (C2 ×× C4) functor_product_fobj :=
    {|
      fmor := fun a b (f:a~~{C1 ×× C3}~~>b) => functor_product_fmor f
    |}.
  Obligation 1.
  Proof.
    move: a b f f' H.
    (* ∀a b f f' _, functor_product_fmor f === functor_product_fmor f' *)
    move=> [a1 a2].                         (* case a *)
    move=> [b1 b2].                         (* case b *)
    move=> [f1 f2].                         (* case f *)
    move=> [g1 g2].                         (* case g *)
    case=> H1 H2.                           (* case H *)
    split; [rewrite H1 | rewrite H2]; reflexivity.
  Defined.
  Obligation 2.
  Proof.
  (* ∀ a : C1 ×× C3, functor_product_fmor id === id *)
    case: a => [a1 a2] /=.
      by split; apply fmor_preserves_id.
  Defined.
  Obligation 3.
  Proof.
    move: a b c f g.
  (* ∀a b c f g,
   functor_product_fmor g \\o functor_product_fmor f ===
   functor_product_fmor (g \\o *)
    move=> [a1 a2].                         (* case a *)
    move=> [b1 b2].                         (* case b *)
    move=> [c1 c2].                         (* case c *)
    case=> f1 f3.                           (* case f *)
    case=> g1 g3.                           (* csae g *)
    by move=> /=; split; apply fmor_preserves_comp.
  Defined.
End func_prod.

Notation "f **** g" := (func_prod f g).

Program Instance iso_prod `{C : Category} `{D : Category} {a b : C} {c d : D}
         (ic : a ≅ b) (id : @Isomorphic _ _ D c d) :
  @Isomorphic _ _ (C ×× D) (pair_obj a c) (pair_obj b d).
Obligation 1.                               (* prod_mor (pair_obj a c) (pair_obj b d) *)
Proof.
  apply: pair_mor => /=.
  - by case: ic.
  - by case: id.
Defined.
Obligation 2.                               (* prod_mor (pair_obj b d) (pair_obj a c) *)
Proof.
  apply: pair_mor => /=.
  - by case: ic.
  - by case: id.
Defined.
Obligation 3.
Proof.
   by split; apply iso_comp1.
Defined.
Obligation 4.
Proof.
   by split; apply iso_comp2.
Defined.

(* END *)


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (z : natural) (lf2 : natural) : natural := plus z lf2.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (y : natural) (lf2 : natural) : natural := plus y lf2.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

Definition synth (y : natural) (x : natural) : natural := plus (Succ y) x.


From Babel Require Import FQP.premises.
From Babel Require Import TerminalDogma.Sequence.

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

Require ComplexTheories.
Require VectorSpaceTheories.

Module HilbertSpaceTheory.

Export ComplexTheories.ComplexTheory.
Export VectorSpaceTheories.VectorSpaceTheory.

(** Definition 2.1.2 (complex inner product space) *)
Record CIP_space := build_ipspace {
    Vs :> vspace ℂ_field;
    Vsdot : Vs -> Vs -> ℂ;

    (** dot non-negative *)
    Vsdot_realc : forall u : Vs, realc (Vsdot u u);
    Vsdot_pos_def : forall u : Vs, Vsdot_realc u >= 0;
    Vsdot_pos_0 : forall u : Vs, ((Vsdot_realc u) = 0%R :> R) <-> u = 𝟎;

    (** dot conjugate *)
    Vsdot_conj : forall u v : Vs, (Vsdot u v)^* = Vsdot v u;

    (** dot linearity *)
    Vsdot_linear : forall (c1 c2 : ℂ) (u v1 v2 : Vs),
        Vsdot u (Vadd (@Vscal _ Vs c1 v1) (@Vscal _ Vs c2 v2)) =
        (c1 * (Vsdot u v1) + c2 * (Vsdot u v2))%ℂ;
}.

(** Note : The level for a ∗ b is 30, and we want
        a ∗ u ∙ v to
    to mean
        a ∗ (u ∙ v),
    so level 35 is appropriate. *)
Notation " u '∙' v " := (Vsdot u v) (at level 35) : Vspace_scope.

(** Dirac Notation *)
Notation " <[ u | v ]> " := (Vsdot u v) : Vspace_scope.

(** orthogonal *)
Definition orthogonal (CIPs : CIP_space) (u v : CIPs) := <[ u | v ]> = 0.
Notation " u '⊥' v " := (orthogonal u v) (at level 20) : Vspace_scope.
(** [] *)

Definition f_norm (CIPs : CIP_space) (u : CIPs) := √ (Vsdot_realc u).
Notation " |[ u ]| " := (f_norm u) : Vspace_scope.

Definition unit_vector (CIPs : CIP_space) (u : CIPs) : Prop := |[ u ]| = 1%R.

(** Definition 2.1.3 *)

Record v_Cauchy_seq (H : CIP_space) := mk_v_Cauchy_seq {
    f_v_seq :> infSeq H;
    seq_conv_proof :
        forall e : { r : R | r > 0 },
        exists N : nat, forall m n : { n : nat | (n > N)%nat },
        |[ (f_v_seq (proj1_sig m)) + (- (f_v_seq (proj1_sig n))) ]| < proj1_sig e;
}.

Definition seq_lim (H : CIP_space) (f : infSeq H) (psi : H) :=
    forall e : { r : R | r > 0 },
    exists N : nat, forall n : { n : nat | (n > N)%nat },
    |[ (f (proj1_sig n)) + (- psi) ]| < proj1_sig e.

(** Definition 2.1.4 *)
Record Hilbert_space := build_Hspace {
    H :> CIP_space;
    H_complete : forall s : v_Cauchy_seq H, exists psi, seq_lim s psi;
}.

(** Definition 2.1.5 *)

Definition is_ortho_basis (H : Hilbert_space) (s : Seque H) : Prop :=
    forall i j : index s, s i ⊥ s j.

Record ortho_basis (H : Hilbert_space) := build_ortho_basis {
    ortho_basis_obj :> Seque H;
    ortho_basis_proof : is_ortho_basis ortho_basis_obj;
}.

Definition in_linear_comb (H : Hilbert_space) (s : Seque H) (psi : H) :=
    exists

End HilbertSpaceTheory.


Require Export Iron.Language.SystemF2Cap.Type.
Require Export Iron.Language.SystemF2Cap.Value.
Require Export Iron.Language.SystemF2Cap.Store.Bind.

(********************************************************************)
(* Small Step Evaluation (pure rules)
   These are pure transitions that don't depend on the store. *)
Inductive StepP : exp  -> exp -> Prop :=

 (* Value application. *)
 | SpAppSubst
   :  forall t11 x12 v2
   ,  StepP (XApp (VLam t11 x12) v2)
            (substVX 0 v2 x12)

 (* Type application. *)
 | SpAPPSubst
   :  forall k11 x12 t2
   ,  StepP (XAPP (VLAM k11 x12) t2)
            (substTX 0 t2 x12)

 (* Take the successor of a natural. *)
 | SpSucc
   :  forall n
   ,  StepP (XOp1 OSucc (VConst (CNat n)))
            (XVal (VConst (CNat (S n))))

 (* Test a natural for zero. *)
 | SpIsZero
   :  forall n
   ,  StepP (XOp1 OIsZero (VConst (CNat n)))
            (XVal (VConst (CBool (beq_nat n 0)))).

Hint Constructors StepP.

(********************************************************************)
(* Preservation for pure single step rules. *)
Lemma stepp_preservation
 :  forall se sp x x' t e
 ,  StepP  x x'
 -> Forall ClosedT se
 -> TypeX  nil nil se sp x  t e
 -> TypeX  nil nil se sp x' t e.
Proof.
 intros se sp x x' t e HS HC HT. gen t e.
 induction HS; intros; inverts_type; rip.

 - Case "SpAppSubst".
   eapply subst_val_exp; eauto.

 - Case "SpAPPSubst".
   rrwrite (TBot KEffect = substTT 0 t2 (TBot KEffect)).
   have HTE: (nil = substTE 0 t2 nil).
   have HSE: (se  = substTE 0 t2 se) by (symmetry; auto).
   rewrite HTE. rewrite HSE.

   lets D: subst_type_exp H4 H8.
   rrwrite (liftTE 0 se = se).
   simpl in D. simpl. auto.

 - Case "SpSucc".
   snorm. inverts H5. auto.

 - Case "SpIsZero".
   snorm. inverts H5. auto.
Qed.


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

Require Import Nat Arith.

Inductive lst : Type := Nil : lst | Cons : nat -> lst -> lst.

Inductive queue : Type := Queue : lst -> lst -> queue.

Fixpoint len (len_arg0 : lst) : nat
           := match len_arg0 with
              | Nil => 0
              | Cons x y => plus 1 (len y)
              end.

Definition qlen (qlen_arg0 : queue) : nat
           := let 'Queue x y := qlen_arg0 in
              plus (len x) (len y).

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.

Definition amortizeQueue (amortizeQueue_arg0 : lst) (amortizeQueue_arg1 : lst) : queue
           := match amortizeQueue_arg0, amortizeQueue_arg1 with
              | x, y => if leb (len y) (len x) then Queue x y else Queue (append x (rev y)) Nil
              end.

Definition qpush (qpush_arg0 : queue) (qpush_arg1 : nat) : queue
           := match qpush_arg0, qpush_arg1 with
              | Queue x y, n => amortizeQueue x (Cons n y)
              end.

Definition queue_to_lst (queue_to_lst_arg0 : queue) : lst
           := let 'Queue x y := queue_to_lst_arg0 in
              append x (rev y).

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

Theorem theorem0 : forall (q : queue) (n : nat), eq (append (queue_to_lst q) (Cons n Nil)) (queue_to_lst (qpush q n)).
Proof.
  intros.
  destruct q.
  induction l.
  - simpl. rewrite append_nil. reflexivity.
  - simpl. simpl in IHl. rewrite IHl. unfold amortizeQueue. simpl. destruct (len l) eqn:?.
    + simpl. destruct (len l0 <=? 0) eqn:?.
      * simpl. rewrite append_nil. reflexivity.
      * simpl. reflexivity.
    + destruct (len l0 <=? n1) eqn:?.
      * simpl. apply Nat.leb_le in Heqb. apply le_S in Heqb. rewrite <- Nat.leb_le in Heqb. rewrite Heqb. simpl. reflexivity.
      * destruct (len l0 <=? S n1) eqn:?.
        -- simpl. lfind. Admitted.


Require Import QArith ZArith Zwf Omega.
Require Import ssreflect eqtype ssrbool ssrnat div fintype seq ssrfun.
Require Import bigop fingroup choice.
Require Export ssralg orderedalg infra pol.

Import GroupScope .
Import GRing.Theory.
Import OrderedRing.Theory.
Open Local Scope ring_scope .

Set Printing Width 50.

(* We want to prove a simple and contructive approximation of the
 middle value theorem: if a polynomial is negative in a and positive in b,
 and a < b, then for any positive epsilon, there exists c and d, so that
 a <= c < d <= b, the polynomial is negative in c and positive and d,
 and the variation between c and d is less than epsilon.  To prove this,
 we use a second polynomial, obtained by taking the the absolute value
 of each coefficient.
*)

(* Theorem binding the slope between two points inside an interval. *)
Lemma cm2 :
  forall l b, { c |
  forall x, 0 <= x -> x <= b ->
    `|(eval_pol l x - eval_pol l 0)| <= c * x}.
Proof.
move=> l b; case: l =>[| a l].
- by exists 0; move=> /= x; rewrite mul0r oppr0 addr0 absr0 lerr.
- exists (eval_pol (abs_pol l) b) => x px xb /=; rewrite mul0r addr0.
  rewrite addrC addKr absf_mul ger0_abs // mulrC lter_mulp //=.
  rewrite (ler_trans (ler_absr_eval_pol _ _)) //.
  by rewrite eval_pol_abs_pol_increase // ger0_abs.
Qed.

(* Cannot be abstracted since not every ordered ring has a floor ring *)
Lemma QZ_bound : forall x:Q, (0 <= x)%Q -> {n : Z | x <= n#1}%Q.
intros [n d]; exists(Zdiv n (Zpos d)+1)%Z.
assert (dpos : (('d) > 0)%Z) by apply (refl_equal Gt).
unfold Qle; simpl; rewrite Zmult_1_r; rewrite Zmult_plus_distr_l.
rewrite Zmult_1_l {1}(Z_div_mod_eq n ('d)) //.
rewrite (Zmult_comm ('d)); apply Zplus_le_compat; auto with zarith.
destruct (Z_mod_lt n ('d)) as [_ H2]; auto.
by apply Zlt_le_weak.
Defined.

(* We will look at n points regularly placed between a and b,  a satisfies
  a property P and b does not, we want to find the first point among the
  n points that satisfies P and has a neighbour that does not. *)
Definition find_pair : forall A:eqType, forall P:A->bool, forall Q:A->A->Prop,
    forall l:seq A, forall a b:A, P a -> ~P b ->
    (forall l1 l2 x y, a::l ++ b::nil= l1 ++ x :: y :: l2 -> Q x y) ->
    {c :A & { d | Q c d /\ P c /\ ~P d}}.
Proof.
move => A P Q l; elim: l => [ | a l IHl] a' b' Pa Pb connect.
  by exists a'; exists b'; split => //; apply: (connect [::] [::]).
case Pa1: (P a).
  have tmp :
     forall l1 l2 x y,  a :: l ++ [:: b' ]= l1 ++ [::x, y & l2] -> Q x y.
    by move => l1 l2 x y q; apply: (connect (a'::l1) l2); rewrite /= q.
  by move: (IHl a b' Pa1 Pb tmp) => [c [d [cd Pc]]]; exists c; exists d.
exists a'; exists a; split; first by apply (connect nil (l++b'::nil)).
by rewrite Pa1.
Qed.

Fixpoint nat_ns (p : Z)(n : nat) :=
  match n with
    |0 => [:: p]
    |m.+1 => (p - (Z_of_nat m.+1)) :: nat_ns p m
  end.

Definition ns p n :=
  match n with
    |Zpos q => nat_ns p (nat_of_P q)
    |_ => [:: p]
  end.

Lemma ltb_Zneg0 : forall x, (Zneg x) < 0.
Proof. move=> x; by []. Qed.

Lemma leb_Zneg0N : forall x, 0 <= (Zneg x) = false.
Proof. by move=> x. Qed.

Lemma nat_ns_head : forall (p : Z) n,
  exists l, nat_ns p n = (p - (Z_of_nat n)) :: l.
Proof.
move=> p; elim=>[|n [l Ih]] /=.
  by rewrite oppr0 addr0; exists [::].
by rewrite Ih; exists [:: p - Z_of_nat n & l].
Qed.

Lemma ns_head :  forall p n :Z, (0 <= n) -> exists l, ns p n = (p - n) :: l.
Proof.
move=> p [|n|n] /=; last 1 first.
- by rewrite leb_Zneg0N.
- by exists [::]; rewrite oppr0 addr0.
- move=> _; set m := nat_of_P n; case: (nat_ns_head p m)=> l' ->; exists l'.
  by rewrite /m Zpos_eq_Z_of_nat_o_nat_of_P.
Qed.

Lemma nat_ns_step : forall p n, forall l1 l2 x y,
  nat_ns p n = l1 ++ [:: x, y & l2] -> y = x + 1.
Proof.
move=> p; elim=> [|n Ihn] l1 l2 x y /=.
  by move/(congr1 size)=> /=; rewrite size_cat /= !addnS; move/eqP; rewrite eqSS.
case: l1 => [|u l3] /=; last by case=> _; move/Ihn.
case=> <-; case: (nat_ns_head p n)=> [l' ->]; case=> <- _.
rewrite Zpos_P_of_succ_nat /Zsucc /= -[(_ + 1)%Z]/((Z_of_nat n) + 1) oppr_add addrA.
by rewrite addrK.
Qed.

Lemma ns_step : forall p n, forall l1 l2 x y, 0 <= n ->
  ns p n = l1 ++ [:: x, y & l2] -> y = x + 1.
Proof.
move=> p [|n|n] /=; last 1 first.
- by rewrite leb_Zneg0N.
- move=> ? ? ? ? ?.
  by move/(congr1 size)=> /=; rewrite size_cat /= !addnS; move/eqP; rewrite eqSS.
- move=> l1 l2 x y _; exact: nat_ns_step.
Qed.

Lemma nat_ns_tail : forall p n, exists l, nat_ns p n = l ++ [:: p].
Proof.
move=> p; elim=> [|n [l' Ihn]] /=.
- by exists [::]; rewrite cat0s.
- by rewrite Ihn; exists [:: (p - (' P_of_succ_nat n)%Z) & l']; rewrite cat_cons.
Qed.

Lemma ns_tail : forall p n, exists l, ns p n = l ++ p ::nil.
Proof.
move=> p [|n|n] /=.
- by exists [::]; rewrite cat0s.
- by case: (nat_ns_tail p (nat_of_P n))=> l' ->; exists l'.
- by exists [::]; rewrite cat0s.
Qed.

(* Lemmas about minus are missing in xssralg .. .*)
Lemma nat_ns_bounds : forall p n x l1 l2, nat_ns p n = l1 ++ [:: x & l2] ->
        (p - Z_of_nat n <= x) && (x <= p).
Proof.
move=> p; elim=> [|n Ihn] x l1 l2 /= h.
- rewrite oppr0 addr0.
  suff exp : p = x by rewrite exp lerr.
  case: l1 h => /=; first by case.
  move=> z s.
  by move/(congr1 size)=> /=; rewrite size_cat /= !addnS; move/eqP;
      rewrite eqSS.
- case: l1 h => [| u l1] /=.
  + by set sn := (' _)%Z; case=> h _; rewrite -h lerr lter_addlr /= oppr_lte0.
  + case=> _; move/Ihn; case/andP=> h1 h2; rewrite h2 andbT; apply: ler_trans h1.
    rewrite lter_add2r /= -lter_opp2 /= Zpos_P_of_succ_nat /Zsucc.
    by rewrite -[Zplus _ _]/(Z_of_nat n + 1) lter_addrr /= ler01.
Qed.

Lemma ns_bounds : forall p n x l1 l2, 0 <= n -> ns p n = l1 ++ x::l2 ->
        (p - n <= x) && ( x <= p).
Proof.
move=> p [| n | n] x l1 l2 /=.
- move=> _ h; rewrite oppr0 addr0.
  suff exp : p = x by rewrite exp lerr.
  case: l1 h => /=; first by case.
  move=> z s.
  by move/(congr1 size)=> /=; rewrite size_cat /= !addnS; move/eqP; rewrite eqSS.
- by move=> _; move/nat_ns_bounds; rewrite Zpos_eq_Z_of_nat_o_nat_of_P.
- by rewrite leb_Zneg0N.
Qed.

Lemma map_contiguous :
forall (A B : Type)(f : A -> B) l l1 l2 a b,
  map f l = l1 ++ [:: a, b & l2] ->
  {l'1 : seq A &
    {l'2 : seq A &
      {x : A &
        {y : A | [/\ l1 = map f l'1, l2= map f l'2, a = f x,
          b = f y & l = l'1 ++ [:: x, y & l'2]]}}}}.
Proof.
intros A B f; elim=> [|x l Ihl] /= l1 l2 a b h; first by case: l1 h.
case: l Ihl h => [|a' l'] /= h.
- by move/(congr1 size)=> /=; rewrite size_cat /= !addnS; move/eqP; rewrite eqSS.
- case: l1 h => [|a1 l1] /= h.
    by case=> <- <- <-; exists [::]; exists l'; exists x; exists a' => /=.
  case=> e1; move/h => [l1' [l2' [x' [y' [h1 h2 h3 h4 h5]]]]].
  exists [:: x & l1']; rewrite /= -h1 h2 e1; exists l2'; exists x'; exists y'.
  by split=> //; rewrite h5.
Qed.

(*This is map_cat.
Lemma map_app :
  forall A B:Type, forall f : A -> B, forall l1 l2, map f (l1++l2) = map f l1 ++ map f l2.
intros A B f l1; induction l1; simpl; auto.
intros l2; rewrite IHl1; auto.
Qed.
*)

Lemma non_empty_tail :
  forall (A : Type) (a : A) l, exists l', exists b, [:: a & l] = l' ++ [::b].
Proof.
move=> A a l; elim: l a => [| x l  Ihl] a.
- by exists [::]; exists a.
- case: (Ihl x)=> s [b Ihb]; rewrite Ihb; exists [:: a & s]; exists b.
  by rewrite cat_cons.
Qed.

(* wait and see ...
Lemma Qfrac_add_Z_l : forall a b c,
  (a # 1) + (b # c)%Q = ( a * ' c + b # c)%Q :> Qcb.
intros;unfold Qeq; simpl; ring.
Qed.
*)

Lemma leb_Z : forall x y:Z, x <= y -> Qcb_make x <= Qcb_make y.
Proof.
move => x y xy; apply/QcblebP; rewrite /qcb_val /Qcb_make /Qle /Qnum /Qden.
by rewrite 2!Zmult_1_r; apply/Zle_is_le_bool.
Qed.

Lemma leb_0_Z : forall y, 0%Z <= y -> 0 <= Qcb_make y.
Proof. by move => y yp; apply: leb_Z. Qed.

Lemma ltb_Z : forall x y:Z, x < y -> Qcb_make x < Qcb_make y.
Proof.
  move => x y xy. apply/QcblebP; rewrite /qcb_val /Qcb_make /Qle /Qnum /Qden.
rewrite 2!Zmult_1_r; move/Zle_is_le_bool; rewrite -[Zle_bool y x]/(y <= x).
by rewrite ler_nlt xy.
Qed.

Lemma ltb_0_Z : forall y, 0%Z < y -> 0 < Qcb_make y.
Proof. by move => y yp; apply: ltb_Z. Qed.

Lemma Qcb_make_add :
  forall x y, Qcb_make (x + y) == Qcb_make x + Qcb_make y.
move => x y; apply/Qcb_QeqP.
by rewrite  -[(Qcb_make _ + _)%R]/(Q2Qcb(Qplus (qcb_val (Qcb_make x))
                                  (qcb_val (Qcb_make y)))) /Qcb_make
   ?qcb_valE /Qplus /Qnum /Qden !Zmult_1_r Pmult_1_r /Q2Qcb ?qcb_valE
   (eqP (Qcb_Z _)).
Qed.

Lemma half_lt : forall a b :Qcb, 0 < a -> 0 <  b ->
   a / ((Qcb_make 2) * b) < a / b.
move => a b Ha Hb; rewrite ltef_mulpl // invr_mul //=; last first.
  by rewrite unitfE eq_sym ltrWN.
by rewrite ltef_divp //= -{1}[_^-1]mulr1 ltef_mulp //= invf_cp0.
Qed.

Lemma cut_epsilon : forall eps:Qcb, 0 < eps ->
  exists eps1, exists eps2, 0 < eps1 /\ 0 < eps2 /\ eps1 + eps2 <= eps /\
      eps1 < eps /\ eps2 < eps.
move => eps p; exists (eps/Qcb_make 2); exists (eps/Qcb_make 2).
have p1 : 0 < eps/Qcb_make 2 by rewrite ltef_divp.
split; first done; split; first done; split.
  rewrite -mulr_addr.
  have q2 : (Qcb_make 2)^-1 + (Qcb_make 2)^-1 == 1 by [].
  by rewrite (eqP q2) mulr1 lerr.
suff cmp : eps/Qcb_make 2 < eps by [].
by rewrite ltef_divp //= -{1}[eps]mulr1 ltef_mulp.
Qed.

Lemma constructive_ivt :
  forall l x y, x < y -> eval_pol l x < 0%R -> 0%R <= eval_pol l y  ->
       forall epsilon, 0 < epsilon ->
       exists x', exists y',  - epsilon <= eval_pol l x' /\
         eval_pol l x' < 0 /\ 0 <= eval_pol l y' /\
         eval_pol l y' <= epsilon /\ x <= x' /\ x' < y' /\ y' <= y.
Proof.
move=> l a b ab nla plb.
have ba' : 0 < b - a by rewrite -(addrN a) lter_add2l.
(*have mpolapos : 0 < - eval_pol l a by rewrite gtr0_ltNr0 opprK.*)
have evalba : 0 < eval_pol l b - eval_pol l a.
  rewrite -(lter_add2l (eval_pol l a)) add0r -addrA addNr addr0.
  exact: lter_le_trans plb.
case: (translate_pol l a) => l' q.
case: (@cm3 (b - a) ba' l') => /= c pc.
have cpos : 0 < c.
  rewrite -(ltef_mulp _ _ _ ba') /= mul0r -[b -a]addr0.
  apply: lter_le_trans (pc 0 (b - a) _ _ _); rewrite ?lerr // ?(ltrW ba') //.
  by rewrite -{2}(addrN a) -!q ger0_abs // ltrW.
move=> eps pe.
have pdiv : (0 < (b - a) * c / eps).
  by rewrite ltef_divp // mul0r mulf_gte0 /= ba' cpos.
move: (pdiv); move/ltrW; move/QcblebP; case/QZ_bound => n qn.
(* assia : canonical structures are missing here for Z -> Qcb *)
have qn' : (((b - a) * c / eps) <= (Qcb_make n)).
    by apply/QcblebP; rewrite /Qcb_make qcb_valE.
have fact1 : 0 < n.
  have tmp : 0 < Qcb_make n.
    by apply: lter_le_trans pdiv qn'.
  move: tmp; move/QcblebP. rewrite /Qcb_make /=.
  by move/Qle_bool_iff; rewrite /Qle_bool /= Zmult_1_r; move/negP.
have mkl:
  exists l, forall l1 l2 x y,
    [:: a & l] ++ [:: b] = l1 ++ [:: x, y & l2] ->
    y - x = (b - a) / (Qcb_make n) /\
    exists k : Z,
      x = a + (b - a)* (Qcb_make k)/ (Qcb_make n) /\
      (0<= k) /\ (k <= n - 1).
  case en : (n == 1).
  - rewrite (eqP en); exists [::] => l1 l2 x y /=; case: l1 => [| t1 ql1] /=.
      case=> e1 e2 e3; rewrite e1 e2 Qcb_make1 invr1 mulr1; split=> //.
      by exists 0; rewrite addrN lerr Qcb_make0 mulr0 mul0r addr0; split.
    by move/(congr1 size)=> /=; rewrite size_cat /= !addnS; move/eqP; rewrite eqSS.
- exists (map  (fun x => a + (b-a)*((Qcb_make x)/(Qcb_make n))) (ns (n-1) (n-2))).
  have fact8 : 0 <= n - 2%Z.
    move/eqP: en; move: fact1; rewrite -[1]/1%Z -[0]/0%Z.
    clear. rewrite /is_true. rewrite -Zle_is_le_bool-[(n-2%Z)%R]/(n - 2)%Z.
    rewrite -[0%Z < n]/(~~(Zle_bool n 0)); move/negP.
    rewrite /is_true -Zle_is_le_bool; omega.
  have fact2 : 0 <= n - 1.
    by rewrite  ler_eqVlt (ler_lte_trans fact8) ?orbT // lter_add2r.
  move=> l1 l2 x y; case: l1 => [|t1 ql1] /=.
    case: (ns_head (n - 1) (n - 2) fact8) => a1 qa1.
    rewrite qa1 /= (_ : (n - 1) - (n - 2)%Z = 1) ?Qcb_make1; last first.
      by rewrite addrAC [-(n - 2%Z)]oppr_add addrA opprK addrN add0r.
    case => -> <- /=; split.
      by rewrite addrAC addrN add0r mulrA mulr1.
    exists 0; rewrite Qcb_make0 mulr0 mul0r addr0 lerr; split=> //; split=> //.
  case=> ->; case: l2 => [|d l2] /=.
    rewrite -[[:: x, y & [::]]]/([::x]++[:: y]) catA.
    rewrite !cats1 -!rot1_cons; move/rot_inj; case=> <-.
    case: (ns_tail (n - 1) (n - 2))=> l3 ->; rewrite map_cat /=.
    rewrite cats1 -rot1_cons; move/rot_inj; case=> <- h2.
    have fact3 : (Qcb_make (n - 1) / Qcb_make n) = 1 - (Qcb_make n)^-1.
      have nn0 : ~~ (Qcb_make n == 0).
         by apply/negP => nis0; move/Qcb_QeqP: nis0;
         rewrite /Qeq /= Zmult_1_r => nis0; move: fact1;
         rewrite nis0 ltrr.
      by apply/eqP; rewrite /= (eqP (Qcb_make_add _ _)) mulr_addl mulrV /= //.
    rewrite fact3 mulr_addr mulr1 oppr_add !addrA oppr_add addrA addrN add0r.
    rewrite -mulrN opprK; split=> //.
    exists (n - 1); split; last by rewrite lerr.
    by rewrite  -mulrA fact3 mulr_addr mulr1 !addrA.
  case: (non_empty_tail  _ d l2) => l3 [e qe]; rewrite qe.
  rewrite -[ql1 ++ [:: x, y & l3 ++ [:: e]]]/(ql1 ++ [:: x, y & l3] ++ [:: e]).
  rewrite [_ ++ _ ++ [:: e]]catA !cats1 -!rot1_cons; move/rot_inj; case=> -> q''.
  case: (map_contiguous _ _ (fun x => t1+(e-t1)*((Qcb_make x)/(Qcb_make n)))
             _ _ _ _ _ q'') =>  [l'1 [l'2 [n1 [n2 [_ [_ [qx [qy st]]]]]]]].
  rewrite qx qy.
  have n21 : n2 = n1 + 1 by apply: ns_step st.
  split.
    rewrite n21 [t1 + _]addrC -addrA oppr_add [t1 + _]addrA addrN add0r -mulrN
       -mulr_addr -mulNr -[_ * _^-1 + _]mulr_addl.
    have fact5: Qcb_make (n1 + 1) - Qcb_make n1 = 1.
      by rewrite -[_ - _]/(Q2Qcb (Qcb_make _ + Qcbopp(Qcb_make _)))
          /Qcbopp /Qcb_make ?qcb_valE /Qopp /Qden /Qnum /Q2Qcb ?qcb_valE
          (eqP (Qcb_Z _)) /Qplus /Qden /Qnum /Pmult 2!Zmult_1_r -Zplus_assoc
          [Zplus _ (Zopp _)]Zplus_comm Zplus_assoc Zplus_opp_r Zplus_0_l.
    by rewrite fact5 mul1r.
  exists n1; split; first by rewrite mulrA.
  have bds : (1 <= n1) && (n1 <= (n-1)).
    have fact9 : (n - 1) - (n - 2%Z) = 1
        by rewrite oppr_add opprK addrA [ _ - n]addrC addKr.
    by rewrite -{1}fact9; apply: ns_bounds _ _ _ _ _ fact8 st.
  move/andP: bds => [bds1 bds2];split; last by [].
  have fact6: 0 <= n1 by apply: ler_trans bds1; apply: ltrW; apply ltr01.
  by [].
case: mkl => [sl qsl].
have fact7 : ~ eval_pol l b < 0.
  by apply/negP; rewrite ltrNge.
case: (find_pair _ (fun x => (eval_pol l x) < 0)
             (fun x y => y - x = (b-a)/Qcb_make n /\
                (exists k, x = a + (b-a)*Qcb_make k / Qcb_make n /\
                        0 <= k /\ k <= (n-1))) sl a b nla fact7 qsl) =>
             [a' [b' [[A1 [k [A4 A5]]] [A2 A3]]]] {qsl sl}.
exists a'; exists b'.
have aa' : a <= a'.
  rewrite -(addr0 a) A4; apply: lter_add=> /=; first by apply lerr.
  rewrite mulr_ge0pp //; first apply: mulr_ge0pp; rewrite ?(ltrW ba') //.
    by apply: leb_0_Z; case: A5.
  by rewrite invf_gte0 /=; apply: leb_0_Z; apply: ltrW.
have bb' :  b' <= b.
  have bdec : b = a + (b - a) * (Qcb_make n) / (Qcb_make n).
    have nn0 : Qcb_unit (Qcb_make n).
      apply/negP => nq0; move/Qcb_QeqP: nq0.
      rewrite /Qeq Zmult_1_r /Qcb_make qcb_valE /Qnum Zmult_0_l => nq0.
      by move: fact1; rewrite nq0 ltrr.
    by rewrite mulrK // addrA [a + _]addrC addrK.
  have b'a: b' = a' + (b' - a') by rewrite addrA [ a' + _]addrC addrK /=.
  rewrite b'a A1 A4 -addrA {3}bdec -mulr_addl; apply: lter_add; rewrite /= ?lerr //=.
  rewrite lter_mulpr //=; first by rewrite invf_gte0; apply: leb_0_Z; apply: ltrW.
  rewrite -{2}[b - a]mulr1 -mulr_addr lter_mulpl //= ?(ltrW ba') //.
  rewrite -Qcb_make1  -(eqP (Qcb_make_add _ _)) /=; apply: leb_Z.
  by case: A5=> _; rewrite -(lter_add2l 1) addrNK.
have ab' :  a' < b'.
  by rewrite -(lter_add2l (- a')) addrN A1 /=  mulf_gte0 /= invf_cp0 /= ltb_0_Z // ba'.
have epsban: (b-a)*c/Qcb_make n <= eps.
  by rewrite ltef_divpl ?ltb_0_Z // [eps * _]mulrC -ltef_divpl.
have main: eval_pol l b' - eval_pol l a' <= eps.
  rewrite !q -(@ger0_abs _ (_ - _)).
    have b'a': c * (b' - a') <= eps by rewrite A1 mulrA (mulrC c).
    apply: ler_trans b'a'; rewrite -{2}(addr0 b') -(addNr a) addrA
        -(addrA (b' - a)) -(opprK (a - a')) oppr_add opprK (addrC (-a)).
    apply: pc.
    - by rewrite subr_gte0.
    - by rewrite lter_add2l /= ltrW.
    - by rewrite lter_add2l.
  rewrite -!q lter_addpl //=; first by rewrite oppr_gte0 /= ltrW.
  by rewrite -ltrNge; apply/negP.
split; last (split; first exact A2).
  rewrite lter_oppl /=; apply: ler_trans main.
  by rewrite lter_addrl /= -ltrNge; apply/negP.
split; first by rewrite -ltrNge; move/negP: A3.
split; last by auto.
apply: ler_trans main; rewrite -{1}(addr0 (eval_pol l b')); apply: lter_add; rewrite /= ?lerr //.
by rewrite /= oppr_gte0 /= ltrW.
Qed.


Require Export ZArith.
Require Export ZArithRing.

Open Scope Z_scope.

(* The following tactic looks for all the instances of
   "Zpos (xO p)" and "Zpos (xI p)" and replaces them with
   polynomial expressions in p, but avoids doing it for the numbers
   2 and 3 which are "Zpos (xO xH)" and "Zpos (xI xH)". *)

Ltac Zpos_x_tac :=
 match goal with
   |- context [Zpos (xO ?P)] =>
       match P with
        | xH => fail 1
        | ?X2 => rewrite (Zpos_xO X2); Zpos_x_tac
       end
 | |- context [Zpos (xI ?P)] =>
       match P with
        | xH => fail 1
        | ?X2 => rewrite (Zpos_xI X2); Zpos_x_tac
       end
 | |- _ => idtac
 end.

(* Here is an example using this tactic. *)

Theorem ex1 :
  forall p, Zpos (xO (xI p))=4*(Zpos p)+2.
Proof.
 intros p.
 Zpos_x_tac.
(* the goal becomes:
  p : positive
  ============================
   2 * (2 * Zpos p + 1) = 2 * 2 * Zpos p + 2 (in Coq CVS Nov 2004)
 *)
 rewrite Zmult_plus_distr_r; simpl (2*1).
 rewrite Zmult_assoc.
 reflexivity.
Qed.


Definition lem := forall p, p \/ ~p.
Print lem.

Definition f := forall (A: Set) (p: A -> Prop) (q: Prop),
  (forall x : A, q \/ p x) <-> (q \/ forall x : A, p x).

Theorem lem_to_f : lem -> f.

Proof.
  unfold f, lem.
  firstorder.
  assert (G := H q).
  destruct (H q); firstorder.

  (* firstorder logic
  left.
  assumption.
  right.
  intro.
  destruct (H0 x).
  elim H1.
  assumption.
  assumption.
   *)
Qed.

Print lem_to_f.


Load Preamble.

Definition eq X := fun p : X*X => match p with (x,y) =>  x = y end.
Definition ap X := fun p : X*X => match p with (x,y) =>  ~~ x = y end.

Goal forall X, Sdec (eq X) -> Dec (eq X).
Proof.
  intros X [f H]. intros [x y].
  assert (exists n, f n (x, x) = true) as Hn.
  { now apply H. }
  apply WO_nat in Hn.
  destruct Hn as [n Hn].
  2 : { intros. decide equality. }
  destruct (f n (x,y)) eqn:Hfn.
  - left. apply H. now exists n.
  - right. intros ->. congruence.
Qed.

Goal forall X, enum (eq X) -> Dec (eq X).
Proof.
  intros X [f H]. intros [x y].
  assert (exists n, f n = Some (x, x)) as Hn.
  { now apply H. }
  apply WO_nat in Hn.
  destruct Hn as [n Hn].
  2 : { intros. decide equality. }
  destruct (f n) eqn:Hfn.
  - left. apply H. exists n. admit.
  - right. intros ->. congruence.
Admitted.

Section FixF.

  Variable F : Type.
  Notation "¬ A" := (A -> F) (at level 10).

  Goal forall A B : Prop, (¬A -> ~B) -> ¬ ¬(B -> A).
  Proof.
    intros A B H1 H2.
    apply H2. intros b. exfalso.
    apply H1. intros a. all: tauto.
  Qed.

End FixF.


Set Implicit Arguments.

Require Import
        Discrete.DiscreteType
        Finite.FinType
        Finite.Constructions.Vector
        Finite.Constructions.Cardinality
        Tactics.Tactics.

Import ListNotations.

Section Fixedpoints.
  Variable A : Type.
  Variable f : A -> A.

  Definition fp x := f x = x.

  Lemma fp_trans x : fp x -> fp (f x).
  Proof.
    congruence.
  Qed.

  Lemma fInduction
        (p : A -> Prop)
        (x : A)
        (px : p x)
        (IHf : forall y, p y -> p (f y)) n
    : p (Nat.iter n f x).
  Proof.
    induction n ; crush.
  Qed.

  Lemma fp_iter_trans x n
    : fp (Nat.iter n f x) -> forall m, m >= n -> fp (Nat.iter m f x).
  Proof.
    intros F m H. induction m.
    -
      destruct n ; crush.
    -
      decide (S m = n).
      +
        now rewrite e.
      +
        assert (m >= n) as G by omega.
        specialize (IHm G).
        simpl.
        now apply fp_trans.
  Qed.
End Fixedpoints.

Definition admissible (A : discType) f
  := forall xs : list A,  fp f xs \/ card (f xs) > card xs.

Lemma fp_card_admissible
      (A : discType) f n
  : admissible f ->
    forall xs : list A, fp f (Nat.iter n f xs) \/ card (Nat.iter n f xs) >= n.
 Proof.
   intros M xs. induction n.
     - cbn in *. right. omega.
     - simpl in *. destruct IHn as [IHn | IHn] .
       + left.  now apply fp_trans.
       + destruct (M ((Nat.iter n f xs))) as [M' | M'].
         * left.  now apply fp_trans.
         * right. omega.
 Qed.

 Lemma fp_admissible (A : finType) (f : list A -> list A)
   : admissible f -> forall (xs : list A), fp f (Nat.iter (Cardinality A) f xs).
 Proof.
   intros F xs.
   destruct (fp_card_admissible (Cardinality A) F xs) as [H | H].
   -
     exact H.
   -
     specialize (F (Nat.iter (Cardinality A) f xs)).  destruct F as [F |F] ; crush.
     +
       pose proof (card_upper_bound (f (Nat.iter (Cardinality A) f xs))) ; crush.
Qed.

Section FiniteIteration.
  Variable A : finType.
  Variable step : list A -> A -> Prop.
  Variable step_dec: forall xs x, dec (step xs x).

  Lemma pick xs : {x | step xs x /\ ~ (x el xs)} + forall x, step xs x -> x el xs.
  Proof.
    decide (forall x : A, step xs x -> x el xs).
    - tauto.
    - left. destruct (DM_notAll _ (p:= fun x => step xs x -> x el xs)) as [H _].
      destruct (finType_cc _ (H n)) as [x H']. firstorder.
  Defined.

  Definition finite_iter_step xs :=
    match (pick xs) with
    | inl L => match L with
                exist _ x _ => x :: xs end
    | inr _ => xs
    end.

  Definition finite_iter := Nat.iter (Cardinality A) finite_iter_step.

  Lemma finite_iter_step_admissible: admissible finite_iter_step.
  Proof.
    intro xs.
    unfold fp.
    unfold finite_iter_step.
    destruct (pick xs) as [[y [S ne]] | S] ; repeat (crush ; dec).
  Qed.

  Lemma finite_iter_fp xs : fp finite_iter_step (finite_iter xs).
  Proof.
    unfold finite_iter.
    apply fp_admissible.
    exact finite_iter_step_admissible.
  Qed.

  (* inclp A p means every x in A satisfies p *)

  Lemma finite_iter_ind (p : A -> Prop) xs
    :  inclp xs p -> (forall xs x , (inclp xs p) -> (step xs x -> p x)) ->
       inclp (finite_iter xs) p.
  Proof.
    intros incl H. unfold finite_iter. apply fInduction.
    -
      assumption.
    -
      intros B H1 x E.
      unfold finite_iter_step in E.
      destruct (pick B) as [[y [S nE]] | S].
      +
        destruct E as [E|E] ; try subst x ; eauto.
      +
        auto.
  Qed.

  Lemma list_cycle (B : Type) (xs : list B) x
    : x :: xs <> xs.
  Proof.
    intros D.
    assert (C : |x :: xs| <> |xs|) by (simpl; omega).
    apply C. now rewrite D.
  Qed.

  Lemma closure x xs : fp finite_iter_step xs -> step xs x -> x el xs.
  Proof.
    intros F.
    unfold fp in F.
    unfold finite_iter_step in F.
    destruct (pick xs) as [[y _] | S].
    -
      contradiction (list_cycle F).
    - exact (S x).
  Qed.

  Lemma closure_finite_iter x xs
    : step (finite_iter xs) x -> x el (finite_iter xs).
  Proof.
    apply closure.
    apply finite_iter_fp.
  Qed.

  Lemma preservation_step xs : xs <<= finite_iter_step xs.
  Proof.
    intro H.
    unfold finite_iter_step.
    destruct (pick xs) as [[y [S ne]] | S]; cbn; tauto.
  Qed.

  Lemma preservation_iter xs n
    : xs <<= Nat.iter n finite_iter_step xs.
  Proof.
    intros x E. induction n.
    -
      assumption.
    -
      simpl. now apply preservation_step.
  Qed.

  Lemma preservation_finite_iter xs : xs <<= finite_iter xs.
  Proof.
    apply preservation_iter.
  Qed.

  Definition least_fp_containing f (ys xs : list A) :=
    fp f ys /\ xs <<= ys /\ forall ys', fp f ys' /\ xs <<= ys' -> ys <<= ys'.

  Definition step_consistent :=
    forall xs x, step xs x -> forall xs', xs <<= xs' -> step xs' x.

  Lemma step_iter_consistent
    : step_consistent -> forall xs x n, step xs x -> step (Nat.iter n finite_iter_step xs) x.
  Proof.
    intros H xs x n S. eapply H.
    -
      exact S.
    -
      apply preservation_iter.
  Qed.

  Lemma step_trans_fp_incl
    : step_consistent ->
      forall xs ys, fp finite_iter_step ys -> xs <<= ys ->
               forall n, Nat.iter n finite_iter_step xs <<= ys.
  Proof.
    intros ST xs ys F H n. apply fInduction.
    -
      exact H.
    -
      intros ys' H'.
      unfold finite_iter_step at 1.
      destruct (pick ys') as [[y [S _]] | _].
      +
        specialize (ST  _ _ S _ H').
        intros x [E |E].
        *
          subst x.
          now apply closure.
        *
          auto.
      +
        exact H'.
  Qed.

  Lemma step_consistent_least_fp
    : step_consistent -> forall xs, least_fp_containing finite_iter_step (finite_iter xs) xs.
  Proof.
    intros ST xs.
    repeat split.
    -
      apply finite_iter_fp.
    -
      apply preservation_finite_iter.
    -
      intros B [H H'].
      now apply step_trans_fp_incl.
  Qed.

  Lemma dup_free_finite_iter_step xs
    : dup_free xs -> dup_free (finite_iter_step xs).
  Proof.
    intro DA.
    unfold finite_iter_step.
    destruct (pick xs) as [[y [S ne]] | S] ; auto.
  Qed.

  Lemma dup_free_iter_step n xs
    : dup_free xs -> dup_free (Nat.iter n finite_iter_step xs).
  Proof.
    induction n.
    -
      now cbn.
    -
      intro H.
      simpl. apply dup_free_finite_iter_step ; tauto.
  Qed.

  Lemma dup_free_finite_iter xs
    : dup_free xs -> dup_free (finite_iter xs).
  Proof.
    apply dup_free_iter_step.
  Qed.
End FiniteIteration.

Arguments finite_iter {A} step {step_dec} x.
Arguments finite_iter_step {A} step {step_dec} xs.
Arguments pick {A} {step} {step_dec} xs.


From Coq Require Import Strings.String. (* for manual grading *)
From Coq Require Import ZArith.
From Coq Require Import PArith.
From VFA Require Import Perm.
From VFA Require Import Maps.
Import FunctionalExtensionality.

Module Integers.

Inductive positive : Set :=
  | (* 1 + 2n *) xI : positive -> positive
  | (* 2n     *) xO : positive -> positive
  | (* 1      *) xH : positive.

Definition ten := xO (xI (xO xH)).

Fixpoint positive2nat (p: positive) : nat :=
  match p with
  | xI q => 1 + 2 * positive2nat q
  | xO q => 0 + 2 * positive2nat q
  | xH   => 1
 end.

Eval compute in positive2nat ten.

Fixpoint print_in_binary (p: positive) : list nat :=
  match p with
  | xI q => print_in_binary q ++ [1]
  | xO q => print_in_binary q ++ [0]
  | xH   =>  [1]
 end.
Eval compute in print_in_binary ten.

Notation "p ~ 1" := (xI p) (at level 7, left associativity, format "p '~' '1'").
Notation "p ~ 0" := (xO p) (at level 7, left associativity, format "p '~' '0'").
Print ten.

Fixpoint succ x :=
  match x with
    | p~1 => (succ p)~0
    | p~0 => p~1
    | xH  => xH~0
  end.

Fixpoint addc (carry: bool) (x y: positive) {struct x} : positive :=
  match carry, x, y with
    | false, p~1, q~1 => (addc true p q)~0
    | false, p~1, q~0 => (addc false p q)~1
    | false, p~1, xH  => (succ p)~0
    | false, p~0, q~1 => (addc false p q)~1
    | false, p~0, q~0 => (addc false p q)~0
    | false, p~0, xH  => p~1
    | false, xH,  q~1 => (succ q)~0
    | false, xH,  q~0 => q~1
    | false, xH,  xH  => xH~0
    | true,  p~1, q~1 => (addc true p q)~1
    | true,  p~1, q~0 => (addc true p q)~0
    | true,  p~1, xH  => (succ p)~1
    | true,  p~0, q~1 => (addc true p q)~0
    | true,  p~0, q~0 => (addc false p q)~1
    | true,  p~0, xH  => (succ p)~0
    | true,  xH,  q~1 => (succ q)~1
    | true,  xH,  q~0 => (succ q)~0
    | true,  xH,  xH  => xH~1
  end.
Definition add (x y: positive) : positive := addc false x y.

Lemma succ_correct: forall p,
   positive2nat (succ p) = S (positive2nat p).
Proof.
  intros. induction p; simpl.
  - rewrite IHp. lia.
  - lia.
  - reflexivity.
Qed.

Lemma addc_correct: forall (c: bool) (p q: positive),
   positive2nat (addc c p q) =
        (if c then 1 else 0) + positive2nat p + positive2nat q.
Proof.
  intros c p.
  generalize dependent c.
  induction p; simpl; intros.
  - destruct c.
    + destruct q.
      * simpl. rewrite IHp. simpl.
        remember (positive2nat p) as p'.
        remember (positive2nat q) as q'.
        lia.
      * simpl. rewrite IHp. simpl.
        remember (positive2nat p) as p'.
        remember (positive2nat q) as q'.
        lia.
      * simpl. rewrite succ_correct. simpl.
        remember (positive2nat p) as p'.
        lia.
    + destruct q.
      * simpl. rewrite IHp. simpl.
        remember (positive2nat p) as p'.
        remember (positive2nat q) as q'.
        lia.
      * simpl. rewrite IHp. simpl.
        remember (positive2nat p) as p'.
        remember (positive2nat q) as q'.
        lia.
      * simpl. rewrite succ_correct. simpl.
        remember (positive2nat p) as p'.
        lia.
  - destruct c.
    + destruct q.
      * simpl. rewrite IHp. simpl.
        remember (positive2nat p) as p'.
        remember (positive2nat q) as q'.
        lia.
      * simpl. rewrite IHp. simpl.
        remember (positive2nat p) as p'.
        remember (positive2nat q) as q'.
        lia.
      * simpl. rewrite succ_correct. simpl.
        remember (positive2nat p) as p'.
        lia.
    + destruct q.
      * simpl. rewrite IHp. simpl.
        remember (positive2nat p) as p'.
        remember (positive2nat q) as q'.
        lia.
      * simpl. rewrite IHp. simpl.
        remember (positive2nat p) as p'.
        remember (positive2nat q) as q'.
        lia.
      * simpl.
        remember (positive2nat p) as p'.
        lia.
  - destruct c.
    + destruct q.
      * simpl. rewrite succ_correct. simpl.
        remember (positive2nat q) as q'.
        lia.
      * simpl. rewrite succ_correct. simpl.
        remember (positive2nat q) as q'.
        lia.
      * simpl. reflexivity.
    + destruct q.
      * simpl. rewrite succ_correct. simpl.
        remember (positive2nat q) as q'.
        lia.
      * simpl.
        remember (positive2nat q) as q'.
        lia.
      * simpl. reflexivity.
Qed.

Theorem add_correct: forall (p q: positive),
   positive2nat (add p q) = positive2nat p + positive2nat q.
Proof.
  intros.
  unfold add.
  apply addc_correct.
Qed.

Inductive comparison : Set :=
    Eq : comparison | Lt : comparison | Gt : comparison.

Fixpoint compare x y {struct x}:=
  match x, y with
    | p~1, q~1 => compare p q
    | p~1, q~0 => match compare p q with
                  | Lt => Lt
                  | _  => Gt end
    | p~1, xH  => Gt
    | p~0, q~1 => match compare p q with
                  | Gt => Gt
                  | _  => Lt end
    | p~0, q~0 => compare p q
    | p~0, xH  => Gt
    | xH, q~1  => Lt
    | xH, q~0  => Lt
    | xH, xH   => Eq
  end.

Lemma positive2nat_pos:
 forall p, positive2nat p > 0.
Proof.
  intros.
  induction p; simpl; lia.
Qed.

Lemma positive_not_less_1: forall x, positive2nat x < 1 -> False.
Proof.
  intro x. induction x; simpl; intro HContra.
  - simpl in *. apply IHx. lia.
  - simpl in *. apply IHx. lia.
  - simpl in *. inversion HContra. lia.
Qed.

Lemma positive_geq_1: forall x, positive2nat x >= 1.
Proof.
  intro x. induction x; simpl.
  - lia.
  - lia.
  - lia.
Qed.

Theorem compare_correct:
 forall x y,
  match compare x y with
  | Lt => positive2nat x < positive2nat y
  | Eq => positive2nat x = positive2nat y
  | Gt => positive2nat x > positive2nat y
 end.
Proof.
  induction x; destruct y; simpl.
  - repeat (rewrite Nat.add_0_r).
    specialize (IHx y).
    destruct (compare x y).
    + rewrite Nat.succ_inj_wd. rewrite IHx. reflexivity.
    + rewrite <- Nat.succ_lt_mono. lia.
    + apply gt_n_S. lia.
  - repeat (rewrite Nat.add_0_r).
    specialize (IHx y).
    destruct (compare x y).
    + rewrite IHx. constructor.
    + lia.
    + lia.
  - repeat (rewrite Nat.add_0_r).
    specialize (IHx xH).
    destruct (compare x xH); simpl in *.
    + rewrite IHx. lia.
    + exfalso. apply (positive_not_less_1 x IHx).
    + lia.
  - repeat (rewrite Nat.add_0_r).
    specialize (IHx y).
    destruct (compare x y); lia.
  - repeat (rewrite Nat.add_0_r).
    specialize (IHx y).
    destruct (compare x y); lia.
  - repeat (rewrite Nat.add_0_r).
    assert (G:= positive_geq_1 x).
    lia.
  - assert (G:= positive_geq_1 y).
    lia.
  - assert (G:= positive_geq_1 y).
    lia.
  - reflexivity.
Qed.

Inductive Z : Set :=
  | Z0 : Z
  | Zpos : positive -> Z
  | Zneg : positive -> Z.

End Integers.

(* Trie *)

Inductive trie (A : Type) :=
    | Leaf : trie A
    | Node : trie A -> A -> trie A -> trie A.
Arguments Leaf {A}.
Arguments Node {A} _ _ _.

Definition trie_table (A: Type) : Type := (A * trie A)%type.
Definition empty {A: Type} (default: A) : trie_table A :=
      (default, Leaf).

Fixpoint look {A: Type} (default: A) (i: positive) (m: trie A): A :=
    match m with
    | Leaf       => default
    | Node l x r =>
        match i with
        | xH    => x
        | xO i' => look default i' l
        | xI i' => look default i' r
        end
    end.

Definition lookup {A: Type} (i: positive) (t: trie_table A) : A :=
   look (fst t) i (snd t).

Fixpoint ins {A: Type} default (i: positive) (a: A) (m: trie A): trie A :=
    match m with
    | Leaf =>
        match i with
        | xH    => Node Leaf a Leaf
        | xO i' => Node (ins default i' a Leaf) default Leaf
        | xI i' => Node Leaf default (ins default i' a Leaf)
        end
    | Node l o r =>
        match i with
        | xH => Node l a r
        | xO i' => Node (ins default i' a l) o r
        | xI i' => Node l o (ins default i' a r)
        end
    end.
Definition insert {A: Type} (i: positive) (a: A) (t: trie_table A)
                 : trie_table A :=
  (fst t, ins (fst t) i a (snd t)).

Definition three_ten : trie_table bool :=
 insert 3 true (insert 10 true (empty false)).
Eval compute in three_ten.
Eval compute in map (fun i => lookup i three_ten) [3;1;4;1;5]%positive.

(* Trie correctness TODO *)

Lemma look_leaf: forall A (a:A) j,
  look a j Leaf = a.
Proof.
  intros.
  induction j.
  - simpl. reflexivity.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

Lemma look_ins_same: forall {A} a k (v:A) t,
  look a k (ins a k v t) = v.
Proof.
  intros A a k.
  induction k; simpl; intros.
  - destruct t.
    + apply IHk.
    + apply IHk.
  - destruct t.
    + apply IHk.
    + apply IHk.
  - destruct t.
    + reflexivity.
    + reflexivity.
Qed.

Lemma look_ins_other: forall {A} a j k (v:A) t,
   j <> k -> look a j (ins a k v t) = look a j t.
Proof.
  intros A a j.
  induction j; simpl; intros.
  - destruct k.
    + simpl.
      destruct t.
      * rewrite IHj.
        apply look_leaf.
        lia.
      * apply IHj.
        lia.
    + simpl.
      destruct t.
      * apply look_leaf.
      * reflexivity.
    + simpl.
      destruct t.
      * apply look_leaf.
      * reflexivity.
  - destruct k.
    + simpl.
      destruct t.
      * apply look_leaf.
      * reflexivity.
    + simpl.
      destruct t.
      * rewrite IHj.
        apply look_leaf.
        lia.
      * apply IHj.
        lia.
    + simpl.
      destruct t.
      * apply look_leaf.
      * reflexivity.
  - destruct k.
    + simpl.
      destruct t.
      * reflexivity.
      * reflexivity.
    + simpl.
      destruct t.
      * reflexivity.
      * reflexivity.
    + simpl.
      destruct t.
      * exfalso. apply H. lia.
      * exfalso. apply H. lia.
Qed.

Definition nat2pos (n: nat) : positive := Pos.of_succ_nat n.
Definition pos2nat (n: positive) : nat := pred (Pos.to_nat n).

Lemma pos2nat2pos: forall p, nat2pos (pos2nat p) = p.
Proof.
  intro. unfold nat2pos, pos2nat.
  rewrite <- (Pos2Nat.id p) at 2.
  destruct (Pos.to_nat p) eqn:?.
  pose proof (Pos2Nat.is_pos p). lia.
  rewrite <- Pos.of_nat_succ.
  reflexivity.
Qed.

Lemma nat2pos2nat: forall i, pos2nat (nat2pos i) = i.
Proof.
  intro. unfold nat2pos, pos2nat.
  rewrite SuccNat2Pos.id_succ.
  reflexivity.
Qed.

Lemma pos2nat_injective: forall p q, pos2nat p = pos2nat q -> p = q.
Proof.
  intros.
  rewrite <- pos2nat2pos.
  rewrite <- H.
  symmetry.
  apply pos2nat2pos.
Qed.

Lemma nat2pos_injective: forall i j, nat2pos i = nat2pos j -> i = j.
Proof.
  intros.
  rewrite <- nat2pos2nat.
  rewrite <- H.
  symmetry.
  apply nat2pos2nat.
Qed.

Definition is_trie {A: Type} (t: trie_table A) : Prop := True.

Definition abstract {A: Type} (t: trie_table A) (n: nat) : A :=
  lookup (nat2pos n) t.

Definition Abs {A: Type} (t: trie_table A) (m: total_map A) :=
  abstract t = m.

Theorem empty_is_trie: forall {A} (default: A), is_trie (empty default).
Proof.
Admitted.

Theorem insert_is_trie: forall {A} i x (t: trie_table A),
   is_trie t -> is_trie (insert i x t).
Proof.
Admitted.

Theorem empty_relate: forall {A} (default: A),
    Abs (empty default) (t_empty default).
Proof.
  intros.
  unfold Abs, abstract, t_empty.
  extensionality o.
  unfold lookup.
  simpl.
  apply look_leaf.
Qed.

Theorem lookup_relate: forall {A} i (t: trie_table A) m,
    is_trie t -> Abs t m -> lookup i t = m (pos2nat i).
Proof.
  intros.
  unfold Abs, abstract, t_empty in *.
  rewrite <- H0.
  rewrite pos2nat2pos.
  reflexivity.
Qed.

Theorem insert_relate: forall {A} k (v: A) t cts,
    is_trie t ->
    Abs t cts ->
    Abs (insert k v t) (t_update cts (pos2nat k) v).
Proof.
  intros.
  unfold Abs, abstract, t_empty, t_update in *.
  extensionality o.
  unfold lookup. destruct t. simpl.
  bdestruct (pos2nat k =? o).
  - rewrite <- H1.
    rewrite pos2nat2pos.
    apply look_ins_same.
  - rewrite <- H0.
    unfold lookup. simpl.
    apply look_ins_other.
    intros Hcontra.
    apply H1.
    rewrite <- pos2nat2pos in Hcontra.
    apply nat2pos_injective in Hcontra.
    symmetry.
    assumption.
Qed.

Example Abs_three_ten:
    Abs
       (insert 3 true (insert 10 true (empty false)))
       (t_update (t_update (t_empty false) (pos2nat 10) true) (pos2nat 3) true).
Proof.
  try (apply insert_relate; [hnf; auto | ]).
  try (apply insert_relate; [hnf; auto | ]).
  try (apply empty_relate).
Qed.


Require Export NatList.
Require Export Nat.
Require Import Induction.

(* /////////////////// POLYMOPHIC LISTS \\\\\\\\\\\\\\\\\\\\\\ *)
(* Let's introduce generic types, and the 'Type' → Type ≡ * , ∋ , ∀ t , t : * ≡ Type *)
Inductive list (X : Type) : Type :=
  | nil : list X                  (* nil : ∀ X : Type, list X *)
  | cons : X -> list X -> list X.   (* cons : ∀ X : Type, X → list X → list X *)

(* Implementation of Polymorphic functions for Lists *)
Fixpoint repeat' (X : Type) (x : X) (count : nat) : list X :=
  match count with
  | O => nil X
  | S count' => cons X x (repeat' X x count')
  end.

(* We can _substantially_ simplify snytax by leaving out input type annotations, as Coq will use Type Inference *)
(* Type Inference - repeat'' *)
Fixpoint repeat'' X x count : list X :=
  match count with
  | O => nil X
  | S count' => cons X x (repeat'' X x count')
  end.

(* For both cases, Coq will Type Inference `repeat''` as :
  ∀ X : Type, X → nat → list X *)

(* We can avoid '_' by asserting the implicit arguments that Coq must always determine by Type Inference *)
(* Imnplicitness must be associated in one-to-one correspondence with some Function *)
Arguments nil {X}.
Arguments cons {X} _ _.
Arguments repeat' {X} x count.

(* We can also make function arguments implicit by surrounding them with : {} *)
Fixpoint repeat''' {X : Type} (x : X) (count : nat) : list X :=
  match count with
  | O => nil
  | S count' => cons x (repeat''' x count')
  end.

(* We can extend the idea of implicitness to writing Inductive Types *)
Inductive list' {X : Type} : Type :=
  | nil' : list'
  | cons' : X -> list' -> list'.
(* NOTE : THE ABOVE IS NOT USED, BECAUSE, list' nat ≡ list' bool IN type-signature *)

(* Implicit + Polymorphic re-implementation of standard List Functions *)
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 => O
  | cons h t => S (length t)
  end.

(* Some convenient notation again *)
(* The implicitness allows the constructors to be written as before *)
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).

(* ////////// PROOFS 1 \\\\\\\\\\\\\ *)
Theorem app_nil_r : forall X : Type, forall l : list X,
  l ++ [ ]  = l.
Proof.
  intros X l.
  induction l as [| n1 l1 IHl1].
  - simpl. reflexivity.
  - simpl. rewrite -> IHl1. reflexivity.
Qed.

Theorem app_assoc : forall A : Type, forall l1 l2 l3 : list A,
  l1 ++ l2 ++ l3 = (l1 ++ l2) ++ l3.
Proof.
  intros A l1 l2 l3.
  induction l1 as [| n1 l1' IHl1'].
  - simpl. reflexivity.
  - simpl. rewrite <- IHl1'. reflexivity.
Qed.

Theorem app_length : forall X : Type, forall l1 l2 : list X,
  length (l1 ++ l2) = (length l1) + (length l2).
Proof.
  intros X l1 l2.
  induction l1 as [| n' l1' IHl1'].
  - simpl. reflexivity.
  - simpl. rewrite -> IHl1'. simpl. reflexivity.
Qed.

Theorem rev_app_distr : forall X : Type, forall l1 l2 : list X,
  rev (app l1 l2) = app (rev l2) (rev l1).
Proof.
  intros X l1 l2.
  induction l1 as [| n 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 X l.
  induction l as [| n l' IHl'].
  - simpl. reflexivity.
  - simpl. rewrite -> rev_app_distr. rewrite -> IHl'. simpl. reflexivity.
Qed.

(* //////////// POLYMORPHIC PAIRS \\\\\\\\\\\\\\\\\\\ *)
Inductive prod (X Y : Type) : Type :=
| pair : X -> Y -> prod X Y.

Arguments pair {X} {Y} _ _.

Notation "( x , y )" := (pair x y).
Notation "X * Y" := (prod X Y) : type_scope.
(* "type_scope" : Tells Coq to only use (X * Y) when parsing types, thereby, avoiding a clash with the multliplication symbol *)

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

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

(* Zip ≡ Combine *)
Fixpoint combine {X Y : Type} (l1 : list X) (l2 : list Y): list (X * Y) :=
  match l1, l2 with
  | nil, _ => [ ]
  | _, nil => [ ]
  | x1 :: t1, x2 :: t2 => (x1, x2) :: (combine t1 t2)
  end.

(* Split ≡ ¬ Combine *)
Fixpoint split {X Y : Type} (l : list (X * Y)) : ((list X) * (list Y)) :=
  match l with
  | [ ] => ([ ], [ ])
  | (x1, y1) :: t => pair (x1 :: (fst (split t))) (y1 :: (snd (split t)))
  end.

(* //////////// POLYMORPHIC OPTIONS \\\\\\\\\\\\\\\ *)
Inductive option (X : Type): Type :=
| Some : X -> option X
| None : option X.

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

Fixpoint nth_error {X : Type} (l : list X) (n : nat) : option X :=
  match l with
  | [ ] => None
  | h :: t => match n with
             | O => Some h
             | _ => nth_error t (pred n)
             end
  end.

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

(* /////////////// HIGHER-ORDER FUNCTIONS + ANONYMOUS FUNCTIONS \\\\\\\\\\\\\\\\\\\\ *)

(* Coq allows Functions to be passed around → Higher-Order Functions *)
(* {Map,Filter,Fold} *)

Fixpoint filter {X : Type} (f : X -> bool) (l : list X) : list X :=
  match l with
  | [ ] => [ ]
  | h :: t => match f h with
             | true => h :: (filter f t)
             | false => filter f t
             end
  end.

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

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

(* The "fun" keyword allows for the definition of anonymous functions. 'fun' ≡ λ *)

(* A Helper Bool Function *)
Definition and_bool (b1 b2 : bool) : bool :=
  match b1, b2 with
  | true, true => true
  | _, _ => false
  end.

Definition filter_even_gt7 (l : list nat) : list nat :=
  filter (fun n => (and_bool (even_nat n) (negate_bool (leq_nat n (S (S (S (S (S (S O)))))))))) l.

Definition failure_test {X : Type} (x : X) (y : list X * list X) (z : X -> bool) : list X * list X :=
  match z x with
  | true => pair (x :: (fst y)) (snd y)
  | false => pair (fst y) (x :: (snd y))
  end.

Definition partition {X : Type} (test : X -> bool) (l : list X) : list X * list X :=
  fold (fun x y => (failure_test x y test)) l (pair [ ] [ ]).

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

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.

(* Higher-Order Function Constructors *)
Definition constfun {X : Type} (x : X) : nat -> X :=
  fun (k : nat) => x.

(* /////////////// PROOF \\\\\\\\\\\\\\\\\\\ *)

Theorem map_rev : forall X Y : Type, forall f : X -> Y, forall l : list X,
  map f (rev l) = rev (map f l).
(* Proof.
  intros X Y f l.
  induction l as [| n l' IHl'].
  - simpl. reflexivity.
  - simpl. rewrite -> IHl'. reflexivity.
Qed. *)
Admitted.

(* ////////////// EXERCISES \\\\\\\\\\\\\\\\\ *)

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

(* Proof that : fold_length ≡ length *)
Theorem fold_length_correct : forall X : Type, forall l : list X,
  fold_length l = length l.
Proof.
  intros X l.
  induction l as [| n l' IHl'].
  - simpl. reflexivity.
  - simpl. rewrite <- IHl'. reflexivity.
Qed.

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

(* Proof that fold_map ≡ map *)
Theorem fold_map_correct : forall X Y : Type, forall f : X -> Y, forall l : list X,
  fold_map f l = map f l.
Proof.
  intros X Y f l.
  induction l as [| n l' IHl'].
  - simpl. reflexivity.
  - simpl. rewrite <- IHl'. reflexivity.
Qed.

(* Currying *)
(* f : A → B → C ≡ f : A → (B → C) [Right-Associative Typing, in keeping with the λ-calculus [Typed]] *)
(* So, f a, for some a ∈ A is - f a : B → C --> This is the standard Currying format *)
(* Uncurrying --> Given some f : A → B → C ≡ (A * B) → C ≡ ∏α:(A * B) → C, where `*` denotes the Product-Type *)
Definition prod_curry {X Y Z : Type} (f : X * Y -> Z) (x : X) (y : Y) : Z :=
  f (x, y).

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

(* Proof that : prod_curry = (prod_curry)^(-1) *)
Theorem uncurry_curry : forall X Y Z : Type, forall f : X -> Y -> Z, forall x : X, forall y : Y,
  prod_curry (prod_uncurry f) x y = f x y.
Proof.
  intros X Y Z f x y.
  simpl.
  reflexivity.
Qed.

Theorem curry_uncurry : forall X Y Z : Type, forall f : (X * Y) -> Z, forall p : (X * Y),
  prod_uncurry (prod_curry f) p = f p.
Proof.
  intros X Y Z f p.
  destruct p as [x y].
  reflexivity.
Qed.

(* N⁽ᵗʰ⁾-error function proof *)
(* Informal Proof
Theorem curried_nth_error : forall X : Type, forall n : nat, forall l : list X,
  length l = n -> @nth_error X l n = None.
Proof. `
  intros X n l H.
  induction l as [ | m l' IHl'].
  - simpl. reflexivity.
  - (rewrite ← curr_H). rewrite <- H. simpl. rewrite <- IHl'. simpl. reflexivity.
Qed. *)

(* Church Numerals *)
Definition nat_number := forall X : Type, (X -> X) -> X -> X.

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

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

(* Let use define :
1) The Successor Function
2) Addition ≡ Plus
3) Multiplication ≡ Repeated Addition
4) Exponentitation ≡ Repeated Multiplication *)
Definition succ_nat (n : nat_number) : nat_number :=
  fun (X : Type) (f : X -> X) (x : X) => f (n X f x).

Definition plus_nat (n m : nat_number) : nat_number :=
  fun (X : Type) (f : X -> X) (x : X) => m X f (n X f x).

Definition mult_nat (n m : nat_number) : nat_number :=
  fun (X : Type) (f : X -> X) (x : X) => m X (n X f) x.

Definition exp_nat (n m : nat_number): nat_number :=
  m mult_nat (mult_nat n) one. (* FIX THIS! *)


From Undecidability.Shared.Libs.PSL Require Import FinTypes.

(* * Definition of prod as finType *)

Lemma ProdCount (T1 T2: eqType) (A: list T1) (B: list T2) (a:T1) (b:T2)  :
  count (prodLists A B) (a,b) =  count A a * count B b .
Proof.
  induction A.
  - reflexivity.
  - cbn. rewrite <- countSplit. decide (a = a0) as [E | E].
    + cbn. f_equal. subst a0. apply countMap. eauto.
    + rewrite <- plus_O_n. f_equal. now apply countMapZero. eauto.
Qed.

Lemma prod_enum_ok (T1 T2: finType) (x: T1 * T2):
  count (prodLists (elem T1) (elem T2)) x = 1.
Proof.
  destruct x as [x y]. rewrite ProdCount. unfold elem.
  now repeat rewrite enum_ok.
Qed.

#[global]
Instance finTypeC_Prod (F1 F2: finType) : finTypeC (EqType (F1 * F2)).
Proof.
  econstructor.  apply prod_enum_ok.
Defined.

(* * Definition of option as finType *)

(* Wrapping elements in "Some" does not change the number of occurences in a list *)
Lemma SomeElement (X: eqType) (A: list X) x:
  count (toOptionList A) (Some x) = count A x .
Proof.
  unfold toOptionList. simpl. dec; try congruence.
  induction A.
  + tauto.
  + simpl. dec; congruence.
Qed.

(* A list produced by toOptionList contains None exactly once *)
Lemma NoneElement (X: eqType) (A: list X) :
  count (toOptionList A) None = 1.
Proof.
  unfold toOptionList. simpl. dec; try congruence. f_equal.
  induction A.
  - reflexivity.
  - simpl; dec; congruence.
Qed.

Lemma option_enum_ok (T: finType) x :
  count (toOptionList (elem T)) x = 1.
Proof.
  destruct x.
  + rewrite SomeElement. apply enum_ok.
  + apply NoneElement.
Qed.

#[global]
Instance  finTypeC_Option(F: finType): finTypeC (EqType (option F)).
Proof.
  eapply FinTypeC.  apply option_enum_ok.
Defined.

(* * Definition of sum as finType *)

(* The sum of two nats can only be 1 if one of them is 1 and the other one is 0 *)
Lemma proveOne m n: m = 1 /\ n = 0 \/ n = 1 /\ m = 0 -> m + n = 1.
Proof.
  lia.
Qed.

Lemma sum_enum_ok (X: finType) (Y: finType) x :
  count (toSumList1 Y (elem X) ++ toSumList2 X (elem Y)) x = 1.
Proof.
  rewrite <- countSplit. apply proveOne. destruct x.
  - left. split; cbn.
    + rewrite toSumList1_count. apply enum_ok.
    + apply toSumList2_missing.
  - right. split; cbn.
    + rewrite toSumList2_count. apply enum_ok.
    + apply toSumList1_missing.
Qed.

(* Instance declaration for sum types for  the type class *)
#[global]
Instance finTypeC_sum (X Y: finType) : finTypeC (EqType ( X + Y)).
Proof.
  eapply FinTypeC. apply sum_enum_ok.
Defined.

(* Some hints to make the typeclass inference work *)

#[export] Hint Extern 4 (finTypeC (EqType (_ * _))) => eapply finTypeC_Prod : typeclass_instances.
#[export] Hint Extern 4 (finTypeC (EqType (_ + _))) => eapply finTypeC_sum : typeclass_instances.
#[export] Hint Extern 4 (finTypeC (EqType (option _))) => eapply finTypeC_Option : typeclass_instances.