(* begin hide *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq fintype.
From mathcomp Require Import bigop path.
From RegexpBrzozowski Require Import glue gfinset regexp finite_der equiv.
From RegexpBrzozowski Require Import sim1 sim2.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.
(* end hide *)
(** Some computation tests *)

Definition V : bregexp := (@Void _).
Definition E : bregexp := (@Eps _).
Definition D : bregexp := (@Dot _ ).
Definition n : seq bregexp := [::].
Definition v : seq bregexp := [:: V].
Definition ve : seq bregexp := [:: V ; E].
Definition eve : seq bregexp := [:: E ; V ; E].
Definition deve : seq bregexp := [:: D ; E ; V ; E].

Definition sim1_dec := sim_dec (@ssim1 [eqType of bool]).
Definition sim2_dec := sim_dec ssim2.

Definition T : bregexp := Atom true.
Definition F : bregexp := Atom false.
Definition SS : bregexp := Conc (Star T) (Star T).
Definition S : bregexp := Star T.

Eval vm_compute in ( (sim1_build_list_fun V V)).
Eval vm_compute in ( (sim1_build_list_fun E V)).
Eval vm_compute in ( (sim1_build_list_fun E D)).
Eval vm_compute in ( (sim1_build_list_fun
 (Conc
  (Atom true) (Conc (Atom false) (Atom true)))
 (Conc
  (Atom true) (Conc (Atom false) (Atom true))))).
Eval vm_compute in ( (sim1_build_list_fun SS S)).

Eval vm_compute in ( (sim1_build_list_der (Plus (Atom true) (Atom false)))).
Eval vm_compute in ( (sim1_build_list_der (Star (Atom true)))).

Eval vm_compute in
  (sim1_bregexp_eq (Plus (Atom true) (Atom true)) (Atom true)).
Eval vm_compute in
   (sim1_bregexp_eq (Conc (Atom true) V) (And (Atom true) (Atom false))).

Eval vm_compute in ( (sim2_build_list_fun V V)).
Eval vm_compute in ( (sim2_build_list_fun E V)).
Eval vm_compute in ( (sim2_build_list_fun E D)).
Eval vm_compute in ( (sim2_build_list_fun
 (Conc
  (Atom true) (Conc (Atom false) (Atom true)))
 (Conc
  (Atom true) (Conc (Atom false) (Atom true))))).
Eval vm_compute in ( (sim2_build_list_fun SS S)).

Eval vm_compute in ( (sim2_build_list_der (Plus (Atom true) (Atom false)))).
Eval vm_compute in ( (sim2_build_list_der (Star (Atom true)))).

Eval vm_compute in
  (sim2_bregexp_eq (Plus (Atom true) (Atom true)) (Atom true)).
Eval vm_compute in
   (sim2_bregexp_eq (Conc (Atom true) V) (And (Atom true) (Atom false))).

(** L1 = 0(0+1)*1 *)
Definition L1 := Conc (Atom false)
                 (Conc (Star (Plus (Atom false) (Atom true)))
                 (Atom true)).
(** L2 = 00*1(0+1)* *)
Definition L2 := Conc (Atom false) (Conc (Star (Atom false)) (Conc (Atom true) (Star (Plus (Atom false) (Atom true))))).

Eval vm_compute in
 (sim1_bregexp_sub (Conc (Atom true) (Atom true)) (Star (Atom true))).
Eval vm_compute in
 (sim1_bregexp_sub (Star (Atom true)) (Conc (Atom true) (Atom true))).

Eval vm_compute in
 (sim2_bregexp_sub (Conc (Atom true) (Atom true)) (Star (Atom true))).
Eval vm_compute in
 (sim2_bregexp_sub (Star (Atom true)) (Conc (Atom true) (Atom true))).

Time Eval vm_compute in (sim1_bregexp_sub L1 L2).
Time Eval vm_compute in (sim2_bregexp_sub L1 L2).

Definition L3 := Conc (Atom true) (Star (Conc (Atom false) (Atom true))).
Definition L4 := Conc (Star (Conc (Atom true) (Atom false))) (Atom true).

Time Eval vm_compute in (sim1_bregexp_eq L3 L4).
Time Eval vm_compute in (sim2_bregexp_eq L3 L4).

Definition L5 := And L1 (Not L2).
Time Eval vm_compute in (sim1_bregexp_eq L5 V).
Time Eval vm_compute in (sim2_bregexp_eq L5 V).

Definition K1 := Conc (Atom false) (Plus (Conc (Atom false) (Conc (Star (Atom false)) (Star (Atom true)))) (Star (Atom true))).
Definition K2 := Conc (Atom false) (Conc (Star (Atom false)) (Star (Atom true))).

Time Eval vm_compute in (sim1_bregexp_sub K1 K2).
Time Eval vm_compute in (sim2_bregexp_sub K1 K2).

Definition a := Conc (Atom false) (Atom false).
Definition b := Conc (Atom false) (Atom true).
Definition c := Conc (Atom true) (Atom false).
Definition d := Conc (Atom true) (Atom true).

(**  a*b(c+da*b)* = (a+bc*d)*bc* *)
Definition K3  :=
 Conc (Star a) (Conc b (Star (Plus c (Conc d (Conc (Star a) b))))).
Definition K4 :=
  Conc (Star (Plus a (Conc b (Conc (Star c) d)))) (Conc b (Star c)).

Time Eval vm_compute in (sim1_bregexp_eq K3 K4).
Time Eval vm_compute in (sim2_bregexp_eq K3 K4).

(** forall n >= 8, exists x y,  n = 3 x + 5 y *)
Fixpoint unary (n:nat) : bregexp := match n with
 | O => (@Eps _)
 | Datatypes.S p => Conc (unary p) F
end.

Definition eight := unary 8.
Definition three := unary 3.
Definition five  := unary 5.

Definition M1 := Conc eight (Star F).
Definition M2 := Star (Plus three five).
Time Eval vm_compute in (sim1_bregexp_sub M1 M2).
Time Eval vm_compute in (sim2_bregexp_sub M1 M2).


Require Import XR_Rmax.
Require Import XR_Rle_dec.

Local Open Scope R_scope.

Lemma Rmax_case : forall r1 r2 (P:R -> Type), P r1 -> P r2 -> P (Rmax r1 r2).
Proof.
  intros x y P px py.
  unfold Rmax.
  destruct (Rle_dec x y) as [ hmaxl | hmaxr ].
  { exact py. }
  { exact px. }
Qed.


(** * Defining Impartial Games *)

From GameTheory Require Export In.
From Coq Require Export List.
Export ListNotations.

(** We define an impartial game as the following structure: *)
(** - A type of positions, *)
(** - A start position, *)
(** - A function mapping states to valid next moves, *)
(** - A proof that the induced relation between moves is well founded (corresponding to the fact that any game must terminate). *)
(** This definition is adapted from a #blog post# from the Polero blog. *)

Inductive impartial_game :=
  ImpartialGame {
      position: Type;
      start : position;
      moves : position -> list position;
      valid_move next current := In next (moves current);
      finite_game : well_founded valid_move;
    }.
Check ImpartialGame.

(** We define the notion of _winning_ and _losing_ states. *)
(** A state is winning if there is at least one transition to a losing state, *)
(** and a state is losing if all transitions are to a winning state. *)
(** The advantage of defining winning and losing like this is that it is quite natural and aligns with how winning and losing is usually understood. *)
(** One downside is that it is not immediately clear that these two notions are mutually exclusive, or that a state must be either winning or losing. *)
(** We show this by constructing a recursive decision procedure that will take a state and determine whether it is winning or losing. *)

Section Winning.
  Variable game: impartial_game.
  Let S := position game.

  Fail Inductive winning_state : S -> Prop :=
  | trans_to_losing : forall (s s' : S), valid_move game s' s -> (~ winning_state s) -> winning_state s.

  Inductive winning_state : S -> Prop :=
  | trans_to_losing : forall (s s' : S), valid_move game s' s -> losing_state s' -> winning_state s
  with losing_state : S -> Prop :=
  | all_winning : forall (s : S), (forall (s' : S), valid_move game s' s -> winning_state s') -> losing_state s.

  (** A state cannot be both winning and losing at the same time. *)
  Lemma not_both_winning_losing : forall (s : S), ~ ((winning_state s) /\ (losing_state s)).
  Proof.
    apply (well_founded_induction (finite_game game)); intuition.
    match goal with
    | [ H : forall y, _ -> _ -> False, H1 : winning_state ?x, H2: losing_state ?x |- _ ] =>
        destruct H1 as [s s' H1]; destruct H2; apply H with s'; auto
    end.
  Qed.
  Hint Resolve not_both_winning_losing : core.

  Lemma losing_implies_not_winning : forall (s : S), losing_state s -> ~ winning_state s.
  Proof.
    intros s H.
    pose (not_both_winning_losing s).
    unfold not in *.
    intuition.
  Qed.

  Definition get_outcome_b : S -> bool :=
  Fix (finite_game game) (fun _ : position game => bool)
    (fun (s : position game)
      (F : forall y : position game, valid_move game y s -> bool) =>
    existsb_In (moves game s)
      (fun (x : position game) (HIn : In x (moves game s)) => negb (F x HIn))).

  Lemma get_outcome_b_ext:
    forall
      (x : S)
      (f g : forall y : position game, valid_move game y x -> bool),
    (forall (y : position game) (p : valid_move game y x),
      f y p = g y p) ->
    existsb_In (moves game x)
      (fun (x0 : position game) (HIn : In x0 (moves game x)) =>
        negb (f x0 HIn)) =
      existsb_In (moves game x)
        (fun (x0 : position game) (HIn : In x0 (moves game x)) =>
          negb (g x0 HIn)).
  Proof.
    intros.
    eapply existsb_In_ext.
    intuition.
    apply f_equal.
    intuition.
  Qed.

  Lemma get_outcome_b_unfold : forall (s : S),
    get_outcome_b s = existsb_In (moves game s) (fun x P => negb (get_outcome_b x)).
  Proof.
    intros.
    unfold get_outcome_b.
    rewrite Fix_eq.
    reflexivity.
    apply get_outcome_b_ext.
  Qed.

  Lemma w_reflect':
    forall s, (get_outcome_b s = true -> winning_state s) /\
                (get_outcome_b s = false -> losing_state s).
  Proof.
    apply (well_founded_induction (finite_game game)); intuition.
    - rewrite get_outcome_b_unfold in H0.
      rewrite existsb_In_existsb with (g := fun x => negb (get_outcome_b x)) in H0; auto.
      apply existsb_exists in H0.
      destruct H0 as [y [Hy1 Hy2]].
      econstructor. apply Hy1. apply H; auto. apply negb_true_iff in Hy2. assumption.
    - rewrite get_outcome_b_unfold in H0.
      constructor. intros.
      apply H; auto.

      rewrite existsb_In_existsb with (g := fun x => negb (get_outcome_b x)) in H0; auto.
      eapply existsb_false in H0. apply negb_false_iff in H0. apply H0.
      assumption.
  Qed.

  Lemma w_reflect:
    forall s, reflect (winning_state s) (get_outcome_b s).
  Proof.
    intros.
    destruct (get_outcome_b s) eqn:?; constructor.
    - apply w_reflect'. assumption.
    - assert (losing_state s). apply w_reflect'. assumption.
      apply losing_implies_not_winning. assumption.
  Qed.

  Lemma winning_or_losing : forall s, winning_state s + losing_state s.
  Proof.
    intros.
    pose proof (w_reflect' s) as [? ?].
    destruct (get_outcome_b s); auto.
  Qed.

  (** If we have two predicates P and Q that are disjoint and at least one is true, then P <-> ~ Q and Q <-> ~ P. *)
  Lemma dec_disjoint_implies_negation {A : Type} : forall (P Q : A -> Prop), forall s, ~ (P s /\ Q s) -> P s + Q s -> (P s <-> ~ Q s) /\ (Q s <-> ~ P s).
  Proof.
    intuition.
  Qed.

  Lemma losing_equiv_not_winning : forall s, losing_state s <-> ~ winning_state s.
  Proof.
    intros s; apply dec_disjoint_implies_negation, winning_or_losing.
    apply not_both_winning_losing.
  Qed.

  Lemma winning_decidable : forall s, winning_state s + ~ (winning_state s).
  Proof.
    intros.
    destruct (w_reflect s); auto.
  Qed.

  Lemma get_outcome_b_false :
    forall s, (get_outcome_b s = false) -> losing_state s.
  Proof.
    intros.
    apply losing_equiv_not_winning.
    destruct (w_reflect s); [ discriminate | auto ].
  Qed.

  Lemma get_outcome_b_true :
    forall s, (get_outcome_b s = true) -> winning_state s.
  Proof.
    intros.
    destruct (w_reflect s); [ auto | discriminate].
  Qed.

End Winning.

(** Definition of the zero game. *)
Definition zero : impartial_game.
  refine {|
    position := unit;
    start := tt;
    moves s := [];
  |}.
  constructor; intros y H; inversion H.
Defined.


Require Import List.

Import ListNotations.

Require Import Nat.
Require Import Arith.

Section SKIPN.

Variables (A : Type).

(* firstn_nil: forall (A : Type) (n : nat), firstn n nil = nil *)
Lemma skipn_nil : forall (n : nat),
  skipn n nil = (nil : list A).
Proof. destruct n; reflexivity. Qed.

Lemma skipn_nil_length : forall (n : nat) (ws : list A),
  skipn n ws = nil -> length ws <= n.
Proof.
  induction n; intros; simpl in H.
  - subst ws. apply Peano.le_0_n.
  - destruct ws.
    + apply Peano.le_0_n.
    + apply IHn in H.
      apply Peano.le_n_S, H.
Qed.

(*

firstn_cons:  forall (A : Type) (n : nat) (a : A) (l : list A),
  firstn (S n) (a :: l) = a :: firstn n l
firstn_O: forall (A : Type) (l : list A), firstn 0 l = nil
firstn_le_length: forall (A : Type) (n : nat) (l : list A), length (firstn n l) <= n
firstn_length_le:  forall (A : Type) (l : list A) (n : nat),
  n <= length l -> length (firstn n l) = n
firstn_firstn:  forall (A : Type) (l : list A) (i j : nat),
  firstn i (firstn j l) = firstn (min i j) l

removelast_firstn:  forall (A : Type) (n : nat) (l : list A),
  n < length l -> removelast (firstn (S n) l) = firstn n l
firstn_removelast:  forall (A : Type) (n : nat) (l : list A),
  n < length l -> firstn n (removelast l) = firstn n l
*)

(*
firstn_all2: forall (A : Type) (n : nat) (l : list A), length l <= n -> firstn n l = l
*)
Lemma skipn_lt : forall (n : nat) (l : list A),
  skipn n l <> nil -> n < length l.
Proof.
  induction n; intros.
  - destruct (zerop (length l)).
    + apply length_zero_iff_nil in e.
      contradiction.
    + assumption.
  - destruct l; simpl in H.
    + contradiction.
    + apply IHn in H.
      apply lt_n_S, H.
Qed.

Lemma skipn_head_lt : forall (n : nat) (l : list A) (x : A) (xs : list A),
  skipn n l = x::xs -> n < length l.
Proof.
  intros.
  assert (skipn n l <> nil).
    intro. rewrite -> H0 in H. inversion H.
  apply skipn_lt.
  assumption.
Qed.

(* firstn_length:  forall (A : Type) (n : nat) (l : list A),
  length (firstn n l) = min n (length l) *)
Lemma skipn_length: forall (n : nat) (l : list A),
  length (skipn n l) <= length l.
Proof.
  induction n; auto.
  intros.
  destruct l; auto.
  simpl.
  apply le_S.
  apply IHn.
Qed.

Lemma skipn_not_lengthen : forall (n : nat) (a : A) (l : list A),
  skipn n l <> a::l.
Proof.
  unfold not.
  intros. assert (length (skipn n l) <= length l) by (apply skipn_length).
  rewrite -> H in H0. simpl in H0.
  apply le_S_gt in H0.
  apply (gt_irrefl _ H0).
Qed.

Lemma skipn_short : forall (l l': list A),
  skipn (length l) (l ++ l') = l'.
Proof.
  induction l.
  intros. reflexivity.
  assumption.
Qed.
(*
firstn_all: forall (A : Type) (l : list A), firstn (length l) l = l
firstn_all2: forall (A : Type) (n : nat) (l : list A), length l <= n -> firstn n l = l
*)
Lemma skipn_head_all : forall (n : nat) (a : A) (l l': list A),
  skipn n (l ++ (a::l')) = (a::l') -> n = length l.
Proof.
  induction n; intros; simpl in H.
  - rewrite <- app_nil_l in H.
    apply app_inv_tail in H.
    subst l.
    reflexivity.
  - destruct l.
    + apply skipn_not_lengthen in H. contradiction.
    + simpl. f_equal. apply IHn in H. assumption.
Qed.

(* firstn_app:  forall (A : Type) (n : nat) (l1 l2 : list A),
  firstn n (l1 ++ l2) = firstn n l1 ++ firstn (n - length l1) l2
firstn_app_2:  forall (A : Type) (n : nat) (l1 l2 : list A),
  firstn (length l1 + n) (l1 ++ l2) = l1 ++ firstn n l2 *)

Lemma skipn_app : forall (a : A) (l l' : list A),
  skipn (length l) (l ++ (a::l')) = (a::l').
Proof. induction l; auto. Qed.

Lemma skipn_succ : forall {T} n l (x : T) xs,
  x :: xs = skipn n l -> xs = skipn (1 + n) l.
Proof.
  induction n; intros; destruct l; (try rewrite -> skipn_nil' in H; inversion H).
  + inversion H.
    reflexivity.
  + simpl in H.
    apply IHn in H.
    subst xs.
    destruct l; reflexivity.
Qed.

End SKIPN.

Lemma app_app : forall {A : Type} (x y: list A) (a : A),
  x ++ a::y = (x ++ [a]) ++ y.
Proof.
  induction x; auto.
  intros.
  simpl.
  rewrite <- IHx.
  reflexivity.
Qed.

Lemma cons_inj : forall {A : Type} (l : list A) (a : A),
  l <> a::l.
Proof.
  unfold not.
  induction l; intros; inversion H.
  apply IHl in H2.
  assumption.
Qed.


Require Import init.

Require Export topology_basis.
Require Export topology_subbasis.
Require Export topology_axioms.

(* begin hide *)
Section ProductTopology.

Local Open Scope set_scope.

Context {U V} `{Topology U, Topology V}.
(* end hide *)
Program Instance product_topology : TopologyBasis (U * V) := {
    top_basis S := ∃ A B, open A ∧ open B ∧ S = (A * B)
}.
Next Obligation.
    exists all.
    split; try exact true.
    exists all, all.
    repeat split; try apply all_open.
    apply predicate_ext.
    intros y.
    repeat split.
Qed.
Next Obligation.
    rename H1 into S1, H9 into T1, H2 into S2, H5 into T2.
    rename H10 into S1_open, H11 into T1_open, H6 into S2_open, H7 into T2_open.
    destruct x as [u v].
    destruct H3 as [S1u T1v], H4 as [S2u T2v]; cbn in *.
    exists (λ x, (S1 ∩ S2) (fst x) ∧ (T1 ∩ T2) (snd x)); cbn.
    split.
    2: split.
    2: split.
    -   exists (S1 ∩ S2), (T1 ∩ T2).
        repeat split.
        all: apply inter_open2.
        all: assumption.
    -   split; assumption.
    -   split; assumption.
    -   intros [u' v'] [[S1u' S2u'] [T1v' T2v']]; cbn in *.
        repeat split.
        all: assumption.
Qed.

Theorem product_open : ∀ A B, open A → open B → open (A * B).
Proof.
    intros A B A_open B_open [x1 x2] ABx.
    exists (A * B).
    split. 2: split.
    -   exists A, B.
        repeat split; trivial.
    -   exact ABx.
    -   apply refl.
Qed.
(* begin hide *)

Program Instance subbasis_product_topology : TopologySubbasis (U * V) := {
    top_subbasis S := (∃ A, S = inverse_image fst A ∧ open A) ∨
                      (∃ A, S = inverse_image snd A ∧ open A)
}.

Theorem subbasis_product_topology_eq :
    @basis_topology _ product_topology =
    @basis_topology _ (@subbasis_topology _ subbasis_product_topology).
Proof.
    apply topology_finer_antisym.
    -   apply subbasis_finer.
        intros S [S_basis|S_basis].
        +   destruct S_basis as [A [S_eq A_open]]; subst S.
            apply basis_open.
            exists A, all.
            split; [>|split].
            *   exact A_open.
            *   apply all_open.
            *   apply antisym.
                --  intros x Ax.
                    split; [>exact Ax|exact true].
                --  intros x [Ax Bx].
                    exact Ax.
        +   destruct S_basis as [A [S_eq A_open]]; subst S.
            apply basis_open.
            exists all, A.
            split; [>|split].
            *   apply all_open.
            *   exact A_open.
            *   apply antisym.
                --  intros x Ax.
                    split; [>exact true|exact Ax].
                --  intros x [Bx Ax].
                    exact Ax.
    -   apply basis_finer.
        intros S [A [B [A_open [B_open S_eq]]]]; subst S.
        assert (A * B = (A * all) ∩ (all * B)) as AB_eq.
        {
            apply antisym.
            -   intros [a b] [Aa Bb].
                repeat split; trivial.
            -   intros [a b] [[Aa C0] [C1 Bb]].
                split; assumption.
        }
        rewrite AB_eq.
        apply inter_open2; apply subbasis_open.
        +   left.
            exists A.
            split; [>|exact A_open].
            apply antisym.
            *   intros x [Ax Bx].
                exact Ax.
            *   intros x Ax.
                split; [>exact Ax|exact true].
        +   right.
            exists B.
            split; [>|exact B_open].
            apply antisym.
            *   intros x [Bx Ax].
                exact Ax.
            *   intros x Ax.
                split; [>exact true|exact Ax].
Qed.

End ProductTopology.

Section BasisProduct.

Context {U V} `{TopologyBasis U, TopologyBasis V}.

Local Existing Instance product_topology.
Local Open Scope set_scope.
(* end hide *)

Definition product_basis (S : U * V → Prop) :=
    ∃ A B, top_basis A ∧ top_basis B ∧ S = (A * B).

Theorem product_basis_open : product_basis ⊆ open.
Proof.
    intros S [A [B [A_basis [B_basis S_eq]]]]; subst S.
    apply basis_open.
    exists A, B.
    split; [>|split].
    -   exact (basis_open _ A_basis).
    -   exact (basis_open _ B_basis).
    -   reflexivity.
Qed.

Theorem product_basis_contains :
    ∀ S x, open S → S x → ∃ B, product_basis B ∧ B ⊆ S ∧ B x.
Proof.
    intros S x S_open Sx.
    specialize (S_open x Sx).
    destruct S_open as [B [B_basis [Bx B_sub]]].
    destruct B_basis as [A1 [A2 [A1_open [A2_open B_eq]]]]; subst B.
    destruct Bx as [A1x A2x].
    specialize (A1_open _ A1x) as [B1 [B1_basis [B1x B1_sub]]].
    specialize (A2_open _ A2x) as [B2 [B2_basis [B2x B2_sub]]].
    exists (B1 * B2).
    split; [>|split].
    -   exists B1, B2.
        split; [>|split]; trivial.
    -   apply (trans2 B_sub).
        apply cartesian_product_sub; assumption.
    -   split; assumption.
Qed.

Definition product_basis_topology :=
    make_basis_topology product_basis product_basis_open product_basis_contains.

Theorem product_basis_eq : @basis_topology _ product_basis_topology =
                           @basis_topology _ product_topology.
Proof.
    apply make_basis_equal.
Qed.

(* begin hide *)
End BasisProduct.
(* end hide *)
Section ProductHausdorff.

(* begin hide *)
Local Open Scope set_scope.
(* end hide *)
Context {U V} `{HausdorffSpace U, HausdorffSpace V}.
Existing Instance product_topology.

Program Instance product_hausdorff : HausdorffSpace (U * V).
Next Obligation.
    rename H3 into neq.
    destruct x1 as [u1 v1], x2 as [u2 v2].
    classic_case (u1 = u2) as [u_eq|u_neq].
    -   subst.
        assert (v1 ≠ v2) as v_neq by (intro contr; subst; contradiction).
        pose proof (hausdorff_space v1 v2 v_neq)
            as [S1 [S2 [S1_open [S2_open [S1v1 [S2v2 dis]]]]]].
        exists (all * S1), (all * S2).
        repeat split.
        +   apply product_open; try assumption.
            exact all_open.
        +   apply product_open; try assumption.
            exact all_open.
        +   exact S1v1.
        +   exact S2v2.
        +   apply empty_eq.
            intros [x1 x2] [[C0 S1x] [C1 S2x]]; clear C0 C1; cbn in *.
            apply ((land (empty_eq _)) dis x2).
            split; assumption.
    -   pose proof (hausdorff_space u1 u2 u_neq)
            as [S1 [S2 [S1_open [S2_open [S1u1 [S2u2 dis]]]]]].
        exists (S1 * all), (S2 * all).
        repeat split.
        +   apply product_open; try assumption.
            exact all_open.
        +   apply product_open; try assumption.
            exact all_open.
        +   exact S1u1.
        +   exact S2u2.
        +   apply empty_eq.
            intros [x1 x2] [[S1x C0] [S2x C1]]; clear C0 C1; cbn in *.
            apply ((land (empty_eq _)) dis x1).
            split; assumption.
Qed.

End ProductHausdorff.


(* in_ellipsoid_Q?(n:posnat, Q:SquareMat(n), x:Vector[n]): bool =
    semidef_pos_22?(Q) AND
    symmetric_22?(Q) AND
    semidef_pos_22?(Block2M(M2Block(1,n,1,n)
        (I(1),transpose(V2Ml(n,x)),V2Ml(n,x),Q)))

ellipsoid_general: LEMMA
    FORALL (n:posnat,m:posnat, Q:SquareMat(n),
        M: Mat(m,n), x:Vector[n], y:Vector[m]):
            in_ellipsoid_Q?(n,Q,x)
            AND y = M*x
    IMPLIES
    in_ellipsoid_Q?(m,M*Q*transpose(M),y)

Let's define in_ellipsoid_Q? for 2x2 matrices

Need: semidef_pos_22, symmetric_22 and semidef_pos_33 (to represent the block matrix)

We don't need to check if the matrix is square because we are defining this on 2x2 matrices. *)
Require Import Floats.
Open Scope float_scope.

(* Control Theory Definitions *)

Definition semidef_pos_22 (x11 x12 x21 x22: float) :=
    forall (a b: float),
    a <> 0 /\ b <> 0 -> (
        (
            a * (a * x11 + b * x12)
            +
            b * (a * x21 + b * x22)
        ) <? 0) = false.

Example is_semidef_pos_22: semidef_pos_22 1 1 1 1.
Proof.
    unfold semidef_pos_22.
    intros.
    destruct H as [HA HB].
    simpl.
    rewrite Rmult_1_r.
    rewrite Rmult_1_r.
    rewrite mult_factor.
    set (a + b) as c.
    rewrite is_r_sqr.
    apply Rle_ge.
    apply Rle_0_sqr.
    Qed.

Definition semidef_pos_33 (x11 x12 x13 x21 x22 x23 x31 x32 x33: R) :=
    forall (a b c : R),
    a <> 0 /\ b <> 0 /\ c <> 0 ->
        (
        a * (a * x11 + b * x21 + c * x31)
        +
        b * (a * x12 + b * x22 + c * x32)
        +
        c * (a * x13 + b * x23 + c * x33)
        ) >= 0.

Definition symmetric_22 (x11 x12 x21 x22 : R) :=
    x12 = x21.

Definition in_ellipsoid_Q (q11 q12 q21 q22 : R) (x1 x2 : R) :=
    semidef_pos_22 q11 q12 q21 q22 /\
    symmetric_22 q11 q12 q21 q22 /\
    semidef_pos_33 1 x1 x2 x1 q11 q12 x2 q21 q22.

(* Useful Theorems *)

Theorem mul_neg_1_r :
    forall x : R, x * -1 = -x.
Proof.
    Admitted.

Theorem mult_factor :
    forall a b x y : R, a * (x + y) + b * (x + y) = (a + b) * (x + y).
Proof.
    intros.
    symmetry.
    set (x + y) as c.
    rewrite Rmult_comm.
    rewrite Rmult_plus_distr_l.
    set (c * b) as d.
    set (b * c) as e.
    assert (d = e). {subst d. subst e. rewrite Rmult_comm. reflexivity. }
    rewrite H.
    rewrite Rmult_comm.
    reflexivity.
    Qed.

Theorem is_r_sqr (n : R) : n * n = Rsqr n.
Proof.
    unfold Rsqr.
    reflexivity.
    Qed.

(* semidef_pos_22 Examples *)

(* Need to negate hypothesis *)
Example not_semidef_pos_22 : semidef_pos_22 (-1) (-1) (-1) (-1).
Proof.
    unfold semidef_pos_22.
    (* unfold not. *)
    intros.
    destruct H as [HA HB].
    rewrite mul_neg_1_r.
    rewrite mul_neg_1_r.
    rewrite mult_factor.
    set (-a + -b) as c.
    (* Need to show this is false *)
    Admitted.

(* Need to negate hypothesis *)
Example not_semidef_pos_22_b: semidef_pos_22 1 2 2 1.
Proof.
    unfold semidef_pos_22.
    intros.
    destruct H as [HA HB].
    rewrite Rmult_1_r.
    rewrite Rmult_1_r.
    set (a * 2) as c.
    set (b * 2) as d.
    (* This is obiviously untrue *)
    Admitted.

Example is_semidef_pos_22: semidef_pos_22 1 1 1 1.
Proof.
    unfold semidef_pos_22.
    intros.
    destruct H as [HA HB].
    rewrite Rmult_1_r.
    rewrite Rmult_1_r.
    rewrite mult_factor.
    set (a + b) as c.
    rewrite is_r_sqr.
    apply Rle_ge.
    apply Rle_0_sqr.
    Qed.

(* semidef_pos_33 Examples *)

Example is_semidef_pos_33 : semidef_pos_33 1 1 1 1 1 1 1 1 1.
    unfold semidef_pos_33.
    intros.
    destruct H as [HA [HB HC]].
    rewrite Rmult_1_r.
    rewrite Rmult_1_r.
    rewrite Rmult_1_r.
    rewrite mult_factor.
    rewrite mult_factor.
    set (a + b + c) as d.
    Admitted.
    (* rewrite Rle_ge.
    rewrite is_r_sqr.
    apply Rle_0_sqr. *)

(* symmetric_22 Examples *)

Example is_symmetric_22: symmetric_22 1 1 1 1.
Proof.
    unfold symmetric_22.
    reflexivity.
    Qed.

Example this_is_not_symmetric_22 : ~ symmetric_22 1 2 1 1.
Proof.
    unfold symmetric_22.
    apply not_eq_sym.
    apply Rlt_not_eq.
    replace 2 with (1+1).
    apply Rlt_plus_1.
    auto.
    Qed.

(* in_ellipsoid_Q Examples *)

Example is_in_ellipsoid_Q :
    in_ellipsoid_Q 1 1 1 1 1 1.
Proof.
    unfold in_ellipsoid_Q.
    split.
    apply is_semidef_pos_22.
    split.
    apply is_symmetric_22.
    apply is_semidef_pos_33.
    Qed.


Goal forall T (x y : T), Some x = Some y -> x = y.
Proof.
  intros T x y H.
  refine match H with eq_refl => eq_refl end.
Qed.

Goal true <> false.
Proof.
  refine (fun H => match H with end).
  (* You could also write [refine (fun H => match H with eq_refl => I end).] *)
Qed.

Goal forall P, true = false -> P.
Proof.
  refine (fun P H => match H with end).
Qed.

Local Set Boolean Equality Schemes.
Inductive foo := a | b | c | d.

Definition foo_dec_bl x y : foo_beq x y = true -> x = y
  := match x, y with
     | a, a
     | b, b
     | c, c
     | d, d
       => fun _ => eq_refl
     | _, _ => fun H : false = true => match H with end
     end.


Require Import FP.CoreData.Bool.
Require Import FP.CoreData.Function.
Require Import FP.CoreClasses.Injection.

Import FunctionNotation.

Section RelDec.
  Context (T:Type).

  Class RelDecCorrect (R: T -> T -> Prop) (D:T -> T -> bool) : Prop :=
    { rel_correct : forall {x y}, R x y -> D x y = true
    ; dec_correct : forall {x y}, D x y = true -> R x y
    }.
End RelDec.
Arguments rel_correct {T R D RelDecCorrect x y _}.
Arguments dec_correct {T R D RelDecCorrect x y _}.

Section neg_rel_dec_correct.
  Context {T R D} `{! RelDecCorrect T R D }.

  Definition neg_rel_correct : forall {x y}, ~R x y -> D x y = false.
    intros.
    destruct (consider_bool (D x y)) ; auto.
    apply dec_correct in e.
    specialize (H e).
    contradiction.
    Qed.
  Definition neg_dec_correct : forall {x y}, D x y = false -> ~R x y.
    unfold "~" ; intros.
    apply rel_correct in H0.
    congruence.
    Qed.
End neg_rel_dec_correct.

Section rel_dec_p.
  Context {T R D} `{! RelDecCorrect T R D }.

  Definition rel_dec_p (x:T) (y:T) : {R x y} + {~R x y}.
    destruct (consider_bool (D x y)) as [H0 | H0].
    apply dec_correct in H0 ; eauto.
    apply neg_dec_correct in H0 ; eauto.
  Qed.

  Definition neg_rel_dec_p (x:T) (y:T) : {~R x y} + {R x y}.
  Proof. destruct (rel_dec_p x y) ; [ right | left ] ; auto. Qed.
End rel_dec_p.


Set Implicit Arguments.

Section trc.
  Variable A : Type.
  Variable R : A -> A -> Prop.

  Inductive trc : A -> A -> Prop :=
  | TrcRefl : forall x, trc x x
  | TrcFront : forall x y z,
    R x y
    -> trc y z
    -> trc x z.

  Hint Constructors trc : core.

  Theorem trc_one : forall x y, R x y
    -> trc x y.
  Proof.
    eauto.
  Qed.

  Hint Resolve trc_one : core.

  Theorem trc_trans : forall x y, trc x y
    -> forall z, trc y z
      -> trc x z.
  Proof.
    induction 1; eauto.
  Qed.

  Hint Resolve trc_trans : core.

  Inductive trcEnd : A -> A -> Prop :=
  | TrcEndRefl : forall x, trcEnd x x
  | TrcBack : forall x y z,
    trcEnd x y
    -> R y z
    -> trcEnd x z.

  Hint Constructors trcEnd : core.

  Lemma TrcFront' : forall x y z,
    R x y
    -> trcEnd y z
    -> trcEnd x z.
  Proof.
    induction 2; eauto.
  Qed.

  Hint Resolve TrcFront' : core.

  Theorem trc_trcEnd : forall x y, trc x y
    -> trcEnd x y.
  Proof.
    induction 1; eauto.
  Qed.

  Hint Resolve trc_trcEnd : core.

  Lemma TrcBack' : forall x y z,
    trc x y
    -> R y z
    -> trc x z.
  Proof.
    induction 1; eauto.
  Qed.

  Hint Resolve TrcBack' : core.

  Theorem trcEnd_trans : forall x y, trcEnd x y
    -> forall z, trcEnd y z
      -> trcEnd x z.
  Proof.
    induction 1; eauto.
  Qed.

  Hint Resolve trcEnd_trans : core.

  Theorem trcEnd_trc : forall x y, trcEnd x y
    -> trc x y.
  Proof.
    induction 1; eauto.
  Qed.

  Hint Resolve trcEnd_trc : core.

  Inductive trcLiteral : A -> A -> Prop :=
  | TrcLiteralRefl : forall x, trcLiteral x x
  | TrcTrans : forall x y z, trcLiteral x y
    -> trcLiteral y z
    -> trcLiteral x z
  | TrcInclude : forall x y, R x y
    -> trcLiteral x y.

  Hint Constructors trcLiteral : core.

  Theorem trc_trcLiteral : forall x y, trc x y
    -> trcLiteral x y.
  Proof.
    induction 1; eauto.
  Qed.

  Theorem trcLiteral_trc : forall x y, trcLiteral x y
    -> trc x y.
  Proof.
    induction 1; eauto.
  Qed.

  Hint Resolve trc_trcLiteral trcLiteral_trc : core.

  Theorem trcEnd_trcLiteral : forall x y, trcEnd x y
    -> trcLiteral x y.
  Proof.
    induction 1; eauto.
  Qed.

  Theorem trcLiteral_trcEnd : forall x y, trcLiteral x y
    -> trcEnd x y.
  Proof.
    induction 1; eauto.
  Qed.

  Hint Resolve trcEnd_trcLiteral trcLiteral_trcEnd : core.
End trc.

Notation "R ^*" := (trc R) (at level 0).
Notation "*^ R" := (trcEnd R) (at level 0).

Hint Constructors trc : core.


Require Import HoTT.
Require Import UnivalenceAxiom.

Require Import trunc_lemmas.
Require Import monoids_and_groups.
Require Import set_quotient.

(* Defining sets with a monoid action (see MacLane, p5) *)
Section Monoid_action.
  Open Scope monoid_scope.

  (* Global Instance isset_hom {M N : Monoid} : IsHSet (Hom M N). *)
  (* Proof. *)
  (*   apply (trunc_equiv' _ (issig_hom M N)). *)
  (* Defined.   *)

  Record Monoid_Action (M : Monoid) (X : hSet) := {function_of : M -> (X -> X);
                                                   assoc_function_of : forall (m1 m2 : M) (x : X),
                                                       function_of (m1 + m2) x = function_of m1 (function_of m2 x);
                                                   preserve_id_function_of : forall x : X,
                                                       function_of (mon_id) x = x
                                                  }.
  Global Arguments function_of {M} {X} _ _ _.

    (* [S X] *)
  (* The quotient X/~, where x ~ y if there is a s : S s.t. s + x = y *)
  Definition grp_compl_relation {M : Monoid} (X : hSet) (a : Monoid_Action M X) : relation X
    := (fun x y => {m : M | function_of a m x = y}).

  Lemma relation_is_mere {M : Monoid} (X : hSet)
           (a : Monoid_Action M X)
           (isfree_a : forall (m1 m2 : M) (x : X), (function_of a m1 x = function_of a m2 x -> m1 = m2))
    : is_mere_relation X (grp_compl_relation X a).
  Proof.
    intros.
    unfold grp_compl_relation.
    apply (trunc_sigma' _).
    - intros [m1 p1] [m2 p2]. simpl.
      apply (contr_inhabited_hprop _).
      exact (isfree_a m1 m2 x (p1 @ p2^)).
  Qed.

  (* Lemma relation_is_transitive  *)

  (* Lemma classes_eq_related *)

End Monoid_action.

Section Group_Completion_Quotient.
  Open Scope monoid_scope.
  Variable M : Symmetric_Monoid.
  Variable right_cancellation_M : forall l m n : M, m + l = n + l -> m = n.

  Definition product_action : Monoid_Action M (BuildhSet (M*M)).
  Proof.
    srapply (@Build_Monoid_Action).
    (* The action *)
    - intro m.
      intros [a b].
      exact (m + a, m + b).
    - intros m1 m2 [x1 x2].
      apply path_prod; apply mon_assoc.
    - intros [x1 x2]. apply path_prod; apply mon_lid.
  Defined.

  Definition right_cancel_action : forall (m1 m2 : M) (x : M*M),
      function_of product_action m1 x = function_of product_action m2 x -> m1 = m2.
  Proof.
    intros m1 m2 [x1 x2]. simpl.
    intro p.
    apply (right_cancellation_M x1).
    exact (ap fst p).
  Defined.

  Instance product_action_is_mere : is_mere_relation (M*M) (grp_compl_relation (BuildhSet (M*M)) product_action) :=
    relation_is_mere (BuildhSet (M*M)) (product_action) right_cancel_action.

  Definition group_completion  :=
    set_quotient (grp_compl_relation (BuildhSet (M*M)) product_action).

  Definition group_completion_rec (Y : Type) {isset_Y : IsTrunc 0 Y}
             (f : M -> M -> Y)
             (cancel_f : forall (s : M) (a b : M),
                 f a b = f (s + a) (s + b))
    : group_completion -> Y.
  Proof.
    srapply @set_quotient_rec.
    - intros [a b]. exact (f a b).
    - intros [a1 b1] [a2 b2].
      unfold grp_compl_relation. intros [s p].
      set (pa := (fst ((equiv_path_prod (_,_) (_,_))^-1 p))). simpl in pa. destruct pa.
      set (pb := (snd ((equiv_path_prod (_,_) (_,_))^-1 p))). simpl in pb. destruct pb. clear p.
      apply cancel_f.
  Defined.

  Definition to_groupcompletion' : M -> M -> group_completion.
  Proof.
    intros m n. apply class_of.
    exact (m, n).
  Defined.

  Definition lcancel_to_groupcompletion (s a b : M)
    : to_groupcompletion' a b =
      to_groupcompletion' (mon_mult s a) (mon_mult s b).
  Proof.
    unfold to_groupcompletion'.
    apply related_classes_eq. simpl.
    unfold grp_compl_relation. exists s. simpl.
    reflexivity.
  Defined.

  Definition group_completion_ind_prop
             (P : group_completion -> Type)
             {isprop_P : forall z : group_completion, IsHProp (P z)}
             (f : forall (a b : M), P (to_groupcompletion' a b))
    : forall z : group_completion, P z.
  Proof.
    apply (@set_quotient_ind_prop _ _ P isprop_P).
    intros [a b]. exact (f a b).
  Defined.

  Definition grp_compl_mult : group_completion -> group_completion -> group_completion.
  Proof.
    srapply @set_quotient_rec2; simpl.
    - intros [a1 a2] [b1 b2].
      exact (to_groupcompletion' (a1 + b1) (a2 + b2)).
      (* apply class_of. *)
      (* exact (a1 + b1, a2 + b2).  *)
    - intros [a1 a2] [b1 b2] [c1 c2].
      intros [s p]. simpl in p.
      apply related_classes_eq. red.
      exists s. simpl.
      apply path_prod; simpl; refine (mon_assoc^ @ _).
      + apply (ap (fun x => x + c1)). apply (ap fst p).
      + apply (ap (fun x => x + c2)). apply (ap snd p).
    - intros [a1 a2] [b1 b2] [c1 c2].
      intros [s p]. simpl in p.
      apply related_classes_eq. red.
      exists s. simpl.
      apply path_prod; simpl;
      refine (mon_assoc^ @ _).
      + refine (ap (fun x => x + b1) mon_sym @ _).
        refine (mon_assoc @ _).
        apply (ap (mon_mult a1)). apply (ap fst p).
      + refine (ap (fun x => x + b2) mon_sym @ _).
        refine (mon_assoc @ _).
        apply (ap (mon_mult a2)). apply (ap snd p).
  Defined.

  Definition grp_compl_inv : group_completion -> group_completion.
  Proof.
    srapply group_completion_rec.
    - intros a b. exact (to_groupcompletion' b a).
    - intros s a b. simpl.
      apply lcancel_to_groupcompletion.
  Defined.

  (*   srapply @set_quotient_functor. *)
  (*   - intros [a1 a2]. exact (a2,a1). *)
  (*   - intros [a1 a2] [b1 b2]. *)
  (*     intros [s p].  *)
  (*     exists s. simpl in p. simpl. *)
  (*     apply path_prod. *)
  (*     + apply (ap snd p). + apply (ap fst p). *)
  (* Defined. *)

  Definition grp_compl_linv :
    forall x : group_completion,
      grp_compl_mult (grp_compl_inv x) x = to_groupcompletion' mon_id mon_id.
      (* class_of _ (mon_id,  mon_id). *)
  Proof.
    apply group_completion_ind_prop.
    - intro x.
      srefine (set_quotient_set (grp_compl_relation (BuildhSet (M * M)) product_action) _ _).
    - intros a b. simpl.
      apply inverse.
      refine (lcancel_to_groupcompletion (a + b) _ _ @ _).
      apply (ap011 to_groupcompletion');
        refine (mon_rid _ @ _).
      +  apply mon_sym. + reflexivity.
  Defined.

  (*   apply set_quotient_ind_prop. *)
  (*   - intro x. *)
  (*     srefine (set_quotient_set (grp_compl_relation (BuildhSet (M * M)) product_action) _ _). *)
  (*   - intros [a1 a2]. simpl. *)
  (*     apply inverse. *)
  (*     apply related_classes_eq. red. *)
  (*     exists (a1 + a2). simpl. *)
  (*     apply path_prod; simpl. *)
  (*     + refine (mon_rid _ @ _). apply mon_sym. *)
  (*     + apply mon_rid. *)
  (* Defined. *)

  Definition grp_compl_rinv :
    forall x : group_completion,
      grp_compl_mult x (grp_compl_inv x) = to_groupcompletion' mon_id mon_id.
      (* class_of _ (mon_id,  mon_id). *)
  Proof.
    apply group_completion_ind_prop.
    - intro x.
      srefine (set_quotient_set (grp_compl_relation (BuildhSet (M * M)) product_action) _ _).
    - intros a b. simpl.
      apply inverse.
      refine (lcancel_to_groupcompletion (a + b) _ _ @ _).
      apply (ap011 to_groupcompletion');
        refine (mon_rid _ @ _).
      + reflexivity.
      + apply mon_sym.
  Defined.

  (*   apply set_quotient_ind_prop. *)
  (*   - intro x. *)
  (*     srefine (set_quotient_set _ _ _). *)
  (*   - intros [a1 a2]. simpl. *)
  (*     apply inverse. *)
  (*     apply related_classes_eq. red. *)
  (*     exists (a1 + a2). simpl. *)
  (*     apply path_prod; simpl. *)
  (*     + apply mon_rid. *)
  (*     + refine (mon_rid _ @ _). apply mon_sym. *)
  (* Defined. *)

  (* Is group *)
  Definition group_completion_group : Group.
  Proof.
    srapply @Build_Group.
    { srapply @Build_Monoid.
      - exact (BuildTruncType 0 group_completion).
      - simpl.
        apply grp_compl_mult.
      - simpl.
        exact (to_groupcompletion' mon_id mon_id).
        (* apply class_of. *)
        (* exact (mon_id, mon_id). *)
      - unfold associative. simpl.
        apply (group_completion_ind_prop
                 (fun a : group_completion  => forall b c : group_completion,
                      grp_compl_mult (grp_compl_mult a b) c = grp_compl_mult a (grp_compl_mult b c))).
        intros a1 b1.
        apply (group_completion_ind_prop
                 (fun b : group_completion => forall c : group_completion,
                      grp_compl_mult (grp_compl_mult (to_groupcompletion' a1 b1) b) c =
                      grp_compl_mult (to_groupcompletion' a1 b1) (grp_compl_mult b c))).
        intros a2 b2.
        apply (group_completion_ind_prop _).
        intros a3 b3. simpl.
        apply (ap011 to_groupcompletion'); apply mon_assoc.
      - unfold left_identity.
        apply (group_completion_ind_prop _).
        intros a b. simpl.
        apply (ap011 to_groupcompletion'); apply mon_lid.
      - unfold right_identity.
        apply (group_completion_ind_prop _).
        intros a b. simpl.
        apply (ap011 to_groupcompletion'); apply mon_rid. }
    - simpl.
      apply grp_compl_inv.
    - unfold left_inverse. simpl.
      apply grp_compl_linv.
    - unfold right_inverse. simpl.
      apply grp_compl_rinv.
  Defined.

  Definition to_groupcompletion : Hom M (group_completion_group).
  Proof.
    srapply @Build_Homomorphism.
    - intro a. apply (to_groupcompletion' a mon_id).
      (* apply class_of. *)
      (* exact (a, mon_id). *)
    - simpl. reflexivity.
    - simpl. intros a b.
      apply (ap (to_groupcompletion' (a + b))).
      apply inverse. apply mon_lid.
  Defined.

  (* Definition antihom_inv {G : Group} : *)
  (*   forall (g1 g2 : G), *)
  (*     grp_inv (g1 + g2) = grp_inv g2 + grp_inv g1. *)
  (* Proof. *)
  (*   intros. *)
  (*   apply grp_moveL_Vg. *)
  (*   apply grp_moveL_V1. *)
  (*   refine (mon_assoc^ @ _). *)
  (*   apply (grp_rinv (g1 + g2)). *)
  (* Defined. *)

  Definition inverse_precompose_groupcompletion (G : Abelian_Group) :
    Hom M G -> Hom group_completion_group G.
  Proof.
    intro g.
    srapply @Build_Homomorphism.
    { srapply @group_completion_rec.
      - intros a b.
        exact (g a - g b).
      - intros s a b. simpl.
        rewrite preserve_mult. rewrite preserve_mult.
        rewrite grp_inv_distr.
        rewrite (grp_sym (a := g s) (b := g a)).
        rewrite (grp_sym (a := - g b) (b := - g s)).
        refine (_ @ mon_assoc^).
        refine (_ @ (ap (fun x => g a + x) mon_assoc)).
        rewrite grp_rinv. rewrite mon_lid.
        reflexivity. }
    + simpl.
      apply grp_rinv.
    + intro a.
      apply (group_completion_ind_prop _). intros a2 b2.
      revert a.
      apply (group_completion_ind_prop _). intros a1 b1. simpl.
      rewrite preserve_mult. rewrite preserve_mult.
      refine (mon_assoc @ _ @ mon_assoc^).
      apply (ap (fun x => g a1 + x)).
      rewrite grp_inv_distr.
      refine (mon_assoc^ @ _ @ mon_assoc).
      refine (grp_sym @ _).
      apply (mon_assoc^).
  Defined.

  Definition universal_groupcompletion (G : Abelian_Group) :
    IsEquiv (fun f : Hom group_completion_group G => compose_hom f to_groupcompletion).
  Proof.
    srapply @isequiv_adjointify.
    - apply inverse_precompose_groupcompletion.
    - unfold Sect. intro f.
      apply path_hom. apply path_arrow. intro x. simpl.
      rewrite preserve_id.
      rewrite inv_id.
      apply mon_rid.
    - unfold Sect.
      intro g. apply path_hom. apply path_arrow. intro x.  revert x.
      apply (group_completion_ind_prop _). intros a b. simpl.
      rewrite <- preserve_inv.
      rewrite <- preserve_mult. simpl.
      rewrite mon_rid. rewrite mon_lid. reflexivity.
  Defined.

  (* This is more in line with the proof in the thesis *)
  Definition universal_groupcompletion' (G : Abelian_Group) :
    IsEquiv (fun f : Hom group_completion_group G => compose_hom f to_groupcompletion).
  Proof.
    apply (isequiv_isepi_ismono
             (BuildhSet (Hom group_completion_group G))
             (BuildhSet (Hom M G))).
    - apply issurj_isepi.
      apply BuildIsSurjection. intro f.
      apply tr. unfold hfiber.
      exists (inverse_precompose_groupcompletion G f).
      apply path_hom. apply path_arrow.
      intro x. simpl.
      rewrite preserve_id. rewrite inv_id. apply mon_rid.
    - apply isinj_ismono.
      unfold isinj.
      intros f g.
      intro H.
      apply path_hom. apply path_arrow.
      intro x. revert x.
      apply (group_completion_ind_prop _).
      intros a b.
      cut (f (to_groupcompletion' a mon_id) - f (to_groupcompletion' b mon_id) =
           g (to_groupcompletion' a mon_id) - g (to_groupcompletion' b mon_id)).
      { intro p. refine (_ @ p @ _);
                   rewrite <- preserve_inv;
                   rewrite <- preserve_mult;
                   apply (ap011 (fun x y => _ (to_groupcompletion' x y))).
           - apply inverse. apply mon_rid.
           - apply inverse. apply mon_lid.
           - apply mon_rid.
           - apply mon_lid. }
      apply (ap011 (@mon_mult G)).
      + apply
          (ap10 (equiv_inverse (path_hom (f oH to_groupcompletion) (g oH to_groupcompletion)) H) a).
      + apply (ap grp_inv).
        apply
          (ap10 (equiv_inverse (path_hom (f oH to_groupcompletion) (g oH to_groupcompletion)) H) b).
  Defined.

End Group_Completion_Quotient.

Section Integers.
  Definition Integers : Group.
  Proof.
    srapply group_completion_group.
    - apply (Build_Symmetric_Monoid (nat_monoid)).
      intros a b. simpl.
      apply nat_plus_comm.
    (* - simpl. intros l m n. *)
    (*   intro p. *)
    (*   apply (nat_lemmas.nat_plus_cancelL l) . *)
    (*   refine (nat_plus_comm _ _ @ p @ nat_plus_comm _ _). *)
  Defined.

  Definition nat_to_integer : nat -> Integers.
  Proof.
    intro a.
    apply to_groupcompletion.
    exact a.
  Defined.

  Definition integer_to_nat : Integers -> nat.
  Proof.
    srapply group_completion_rec.
    - simpl. intros a b.
      apply (nat_lemmas.nat_minus b a).
    - simpl.
      intros s a b. induction s; try reflexivity.
      apply IHs.
  Defined.

  Definition issect_to_groupcompletion (a : nat)
    : integer_to_nat (nat_to_integer a) = a.
  Proof.
    reflexivity.
  Defined.

  Definition natnat_to_integer : nat -> nat -> Integers.
  Proof.
    intros a b.
    unfold Integers. unfold group_completion_group. simpl.
    apply (to_groupcompletion').
    - exact a.
    - exact b.
    (* unfold group_completion_quotient.group_completion. *)
    (* apply (set_quotient.Set_Quotient.class_of). *)
    (* exact (a, b). *)
  Defined.

  Definition rcancel_integers (s a b : nat) :
    natnat_to_integer a b = natnat_to_integer (s + a) (s + b).
  Proof.
    apply lcancel_to_groupcompletion.
  Defined.

  Definition inj_nat_to_integer (a b : nat) (p : nat_to_integer a = nat_to_integer b) : a = b.
  Proof.
    refine ((issect_to_groupcompletion a)^ @ _ @ issect_to_groupcompletion b).
    apply (ap integer_to_nat p).
  Defined.

  Definition diff_zero (a b : nat) (p : natnat_to_integer a b = nat_to_integer 0) : a = b.
  Proof.
    apply inj_nat_to_integer. apply inverse.
    apply grp_moveL_M1. refine (_ @ p).
    apply (ap011 natnat_to_integer); simpl.
    - reflexivity.
    - apply inverse. apply nat_plus_n_O.
  Defined.

  (* This definition of integers is equivalent to the other *)
    (* The function +1 from nat to the positives *)
  Definition succ_nat_to_pos : nat -> Pos.
  Proof.
    intro a. induction a.
    - exact Int.one.
    - exact (succ_pos IHa).
  Defined.

  (* the inclution nat to int *)
  Definition nat_to_int : nat -> Int.
  Proof.
    intro a.
    destruct a.
    - exact Int.zero.
    - exact (pos (succ_nat_to_pos a)).
  Defined.

  (* the function - on Int *)
  Definition int_neg : Int -> Int.
  Proof.
    intros [n | | p].
    - exact (pos n).
    - exact Int.zero.
    - exact (neg p).
  Defined.

  (* the function a-b *)
  Fixpoint nat_int_minus (a b : nat) : Int.
  Proof.
    destruct b.
    (* a-0 = a *)
    - exact (nat_to_int a).
    - destruct a.
      (* 0-(b+1) = -b+1 *)
      + apply int_neg.
        exact (nat_to_int b.+1).
      (* (a+1) - (b+1) = a - b *)
      + exact (nat_int_minus a b).
  Defined.

  Definition integers_to_int : Integers -> Int.
  Proof.
    srapply (group_completion_rec); simpl.
    - intros a b. exact (nat_int_minus a b).
    - intros s a b. simpl.
      induction s; try reflexivity. apply IHs.
  Defined.

  (* the function -1 from pos to nat *)
  Definition pred_pos_to_nat : Pos -> nat.
  Proof.
    intro p. induction p.
    - exact 0.
    - exact (IHp.+1).
  Defined.

  (* The inclusion of positives in the natural numbers *)
  Definition pos_to_nat (p : Pos) : nat
    := (pred_pos_to_nat p).+1.
  (* Proof. *)
  (*   destruct p as [ | p]. *)
  (*   - exact 1. *)
  (*   - exact (pos_to_nat p).+1. *)
  (* Defined. *)

  Definition int_to_natnat : Int -> nat * nat.
  Proof.
    intros [n | | p].
    - exact (0, pos_to_nat n).
    - exact (0,0).
    - exact (pos_to_nat p, 0).
  Defined.

  Definition int_to_integers : Int -> Integers.
  Proof.
    intro z.
    apply natnat_to_integer.
    - exact (fst (int_to_natnat z)).
    - exact (snd (int_to_natnat z)).
  Defined.

  (*   destruct z as [neg | | pos]. *)
  (*   - apply grp_inv. apply nat_to_integers. *)
  (*     exact (pos_to_nat neg). *)
  (*   - exact (nat_to_integers 0). *)
  (*   - apply nat_to_integers. *)
  (*     exact (pos_to_nat pos). *)
  (* Defined. *)

  Definition succ_pred_nat_pos (p : Pos)
    : succ_nat_to_pos (pred_pos_to_nat p) = p.
  Proof.
    induction p; try reflexivity.
    exact (ap (succ_pos) IHp).
  Defined.

  Definition pred_succ_nat_pos (a : nat)
    : pred_pos_to_nat (succ_nat_to_pos a) = a.
  Proof.
    induction a; try reflexivity.
    apply (ap S IHa).
  Defined.

  (* Fixpoint retr_nat (a b : nat) *)
  (*   : int_to_integers (integers_to_int (natnat_to_integer a b)) = natnat_to_integer a b. *)
  (* Proof. *)
  (*   destruct a, b; simpl; try reflexivity. *)
  (*   - unfold int_to_integers. simpl. *)
  (*     apply (ap (natnat_to_int 0)). *)
  (*     induction b. *)
  (*     { reflexivity. } apply (ap S IHb). *)
  (*   - unfold int_to_integers. simpl. *)
  (*     refine (ap011 natnat_to_int _ idpath). *)
  (*     induction a. { reflexivity. } apply (ap S IHa). *)
  (*   - refine (retr_nat a b @ _). *)
  (*     apply (rcancel_integers 1). *)
  (* Defined. *)

  Fixpoint retr_int_natnat (a b : nat) :
    natnat_to_integer
      (fst (int_to_natnat (nat_int_minus a b)))
      (snd (int_to_natnat (nat_int_minus a b))) =
    natnat_to_integer a b.
  Proof.
    destruct a, b; try reflexivity; simpl; unfold pos_to_nat.
    - rewrite pred_succ_nat_pos. reflexivity.
    - rewrite pred_succ_nat_pos. reflexivity.
    - refine (retr_int_natnat _ _ @ _).
      apply (rcancel_integers 1).
  Defined.

  Definition equiv_integers :
    Integers <~> Int.
  Proof.
    apply (equiv_adjointify integers_to_int int_to_integers).
    - intro z. simpl.
      destruct z as [n | | p]; try reflexivity.
      + destruct n; try reflexivity.
        simpl. apply (ap neg).
        apply (ap succ_pos). apply succ_pred_nat_pos.
      + simpl.
        apply (ap pos).
        apply succ_pred_nat_pos.
    - intro z. revert z.
      apply (group_completion_ind_prop _ _).
      simpl. intros a b.
      unfold int_to_integers.
      apply retr_int_natnat.
  Defined.

  Definition nat_to_int_commute
    : equiv_integers o nat_to_integer == nat_to_int.
  Proof.
    intro a. simpl.
    destruct a; reflexivity.
  Defined.
End Integers.


Fixpoint iseven (n:nat): bool.
Proof.
  induction n.
  - exact true.
  - destruct n.
    * exact false.
    * exact (iseven n).
Defined.


(****************************************************************************

          IEEE754  :  Fmin

          Laurent Thery

  ******************************************************************************)
Require Export Zenum.
Require Export FPred.

Section FMinMax.
Variable b : Fbound.
Variable radix : Z.
Variable precision : nat.

Let FtoRradix := FtoR radix.
Coercion FtoRradix : float >-> R.
Hypothesis radixMoreThanOne : (1 < radix)%Z.

Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne).
Hint Resolve radixMoreThanZERO: zarith.
Hypothesis precisionNotZero : precision <> 0.
Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision.
(* a function that returns a boundd greater than a given nat *)

Definition boundNat (n : nat) := Float 1%nat (digit radix n).

Theorem boundNatCorrect : forall n : nat, (n < boundNat n)%R.
intros n; unfold FtoRradix, FtoR, boundNat in |- *; simpl in |- *.
rewrite Rmult_1_l.
rewrite <- Zpower_nat_Z_powerRZ; auto with real zarith.
rewrite INR_IZR_INZ; auto with real zarith.
apply Rle_lt_trans with (Zabs n); [rewrite (Zabs_eq (Z_of_nat n))|idtac];auto with real zarith.
Qed.

Theorem boundBoundNat : forall n : nat, Fbounded b (boundNat n).
intros n; repeat split; unfold boundNat in |- *; simpl in |- *;
 auto with zarith.
apply vNumbMoreThanOne with (radix := radix) (precision := precision);
 auto with zarith.
apply Zle_trans with 0%Z;[case (dExp b)|idtac]; auto with zarith.
Qed.
(* A function that returns a bounded greater than a given r *)

Definition boundR (r : R) := boundNat (Zabs_nat (up (Rabs r))).

Theorem boundRCorrect1 : forall r : R, (r < boundR r)%R.
intros r; case (Rle_or_lt r 0); intros H'.
apply Rle_lt_trans with (1 := H').
unfold boundR, boundNat, FtoRradix, FtoR in |- *; simpl in |- *;
 auto with real.
rewrite Rmult_1_l; auto with real zarith.
apply Rlt_trans with (2 := boundNatCorrect (Zabs_nat (up (Rabs r)))).
replace (Rabs r) with r; auto with real.
apply Rlt_le_trans with (r2 := IZR (up r)); auto with real zarith.
case (archimed r); auto.
rewrite INR_IZR_INZ; auto with real zarith.
unfold Rabs in |- *; case (Rcase_abs r); auto with real.
intros H'0; Contradict H'0; auto with real.
Qed.

Theorem boundRrOpp : forall r : R, boundR r = boundR (- r).
intros R; unfold boundR in |- *.
rewrite Rabs_Ropp; auto.
Qed.

Theorem boundRCorrect2 : forall r : R, (Fopp (boundR r) < r)%R.
intros r; case (Rle_or_lt r 0); intros H'.
rewrite boundRrOpp.
pattern r at 2 in |- *; rewrite <- (Ropp_involutive r).
unfold FtoRradix in |- *; rewrite Fopp_correct.
apply Ropp_lt_contravar; apply boundRCorrect1; auto.
apply Rle_lt_trans with 0%R; auto.
replace 0%R with (-0)%R; auto with real.
unfold FtoRradix in |- *; rewrite Fopp_correct.
apply Ropp_le_contravar.
unfold boundR, boundNat, FtoRradix, FtoR in |- *; simpl in |- *;
 auto with real zarith.
rewrite Rmult_1_l; apply Rlt_le; auto with real zarith arith.
Qed.
(* A function that returns a list containing all the bounded smaller than a given real *)

Definition mBFloat (p : R) :=
  map (fun p : Z * Z => Float (fst p) (snd p))
    (mProd Z Z (Z * Z)
       (mZlist (- pPred (vNum b)) (pPred (vNum b)))
       (mZlist (- dExp b) (Fexp (boundR p)))).

Theorem mBFadic_correct1 :
 forall (r : R) (q : float),
 ~ is_Fzero q ->
 (Fopp (boundR r) < q)%R ->
 (q < boundR r)%R -> Fbounded b q -> In q (mBFloat r).
intros r q.
case (Zle_or_lt (Fexp (boundR r)) (Fexp q)); intros H'.
intros H'0 H'1 H'2 H'3; case H'0.
apply is_Fzero_rep2 with (radix := radix); auto.
rewrite <-
 FshiftCorrect with (n := Zabs_nat (Fexp q - Fexp (boundR r))) (x := q);
 auto with arith.
apply is_Fzero_rep1 with (radix := radix).
unfold is_Fzero in |- *.
cut (forall p : Z, (- 1%nat < p)%Z -> (p < 1%nat)%Z -> p = 0%Z);
 [ intros tmp; apply tmp | idtac ].
replace (- 1%nat)%Z with (Fnum (Fopp (boundR r))).
apply Rlt_Fexp_eq_Zlt with (radix := radix); auto with real zarith.
rewrite FshiftCorrect; auto.
unfold Fshift in |- *; simpl in |- *.
rewrite (fun x y => inj_abs (x - y)); auto with zarith.
simpl in |- *; auto.
replace (Z_of_nat 1) with (Fnum (boundR r)).
apply Rlt_Fexp_eq_Zlt with (radix := radix); auto with zarith.
rewrite FshiftCorrect; auto.
unfold Fshift in |- *; simpl in |- *.
rewrite inj_abs; auto with zarith.
generalize H'; simpl in |- *; auto with zarith.
simpl in |- *; auto.
intros p0; case p0; simpl in |- *; auto with zarith.
intros H'0 H'1 H'2 H'3; unfold mBFloat in |- *.
replace q with
 ((fun p : Z * Z => Float (fst p) (snd p)) (Fnum q, Fexp q)).
apply in_map with (f := fun p : Z * Z => Float (fst p) (snd p));
 auto.
apply mProd_correct; auto.
apply mZlist_correct; auto with float.
apply Zle_Zabs_inv1; auto with float.
unfold pPred in |- *; apply Zle_Zpred; auto with float.
apply Zle_Zabs_inv2; auto with float.
unfold pPred in |- *; apply Zle_Zpred; auto with float.
apply mZlist_correct; auto with float.
auto with zarith.
case q; simpl in |- *; auto with zarith.
Qed.

Theorem mBFadic_correct2 : forall r : R, In (boundR r) (mBFloat r).
intros r; unfold mBFloat in |- *.
replace (boundR r) with
 ((fun p : Z * Z => Float (fst p) (snd p))
    (Fnum (boundR r), Fexp (boundR r))).
apply in_map with (f := fun p : Z * Z => Float (fst p) (snd p));
 auto.
apply mProd_correct; auto.
apply mZlist_correct; auto.
unfold boundR, boundNat in |- *; simpl in |- *; auto with zarith.
apply Zle_trans with (- (0))%Z; auto with zarith.
apply Zle_Zopp; unfold pPred in |- *; apply Zle_Zpred; simpl in |- *.
apply Zlt_trans with 1%Z; auto with zarith.
apply vNumbMoreThanOne with (3 := pGivesBound); auto.
unfold boundR, boundNat in |- *; simpl in |- *; auto with zarith.
unfold pPred in |- *; apply Zle_Zpred; simpl in |- *.
unfold boundR, boundNat in |- *; simpl in |- *; auto with zarith.
apply vNumbMoreThanOne with (3 := pGivesBound); auto.
apply mZlist_correct; auto.
unfold boundR, boundNat in |- *; simpl in |- *; auto with zarith.
apply Zle_trans with 0%Z; auto with zarith arith.
case (dExp b); auto with zarith.
case (boundR r); simpl in |- *; auto with zarith.
case (boundR r); simpl in |- *; auto with zarith.
Qed.

Theorem mBFadic_correct3 : forall r : R, In (Fopp (boundR r)) (mBFloat r).
intros r; unfold mBFloat in |- *.
replace (Fopp (boundR r)) with
 ((fun p : Z * Z => Float (fst p) (snd p))
    (Fnum (Fopp (boundR r)), Fexp (Fopp (boundR r)))).
apply in_map with (f := fun p : Z * Z => Float (fst p) (snd p));
 auto.
apply mProd_correct; auto.
apply mZlist_correct; auto.
unfold boundR, boundNat in |- *; simpl in |- *; auto with zarith.
replace (-1)%Z with (- Z_of_nat 1)%Z; auto with zarith.
apply Zle_Zopp.
unfold pPred in |- *; apply Zle_Zpred; simpl in |- *.
apply (vNumbMoreThanOne radix) with (precision := precision);
 auto with zarith.
unfold pPred in |- *; apply Zle_Zpred; simpl in |- *.
red in |- *; simpl in |- *; auto.
apply mZlist_correct; auto.
unfold boundR, boundNat in |- *; simpl in |- *; auto with zarith.
apply Zle_trans with 0%Z; auto with zarith.
case (dExp b); auto with zarith.
case (boundR r); simpl in |- *; auto with zarith.
case (boundR r); simpl in |- *; auto with zarith.
Qed.

Theorem mBFadic_correct4 :
 forall r : R, In (Float 0%nat (- dExp b)) (mBFloat r).
intros p; unfold mBFloat in |- *.
replace (Float 0%nat (- dExp b)) with
 ((fun p : Z * Z => Float (fst p) (snd p))
    (Fnum (Float 0%nat (- dExp b)), Fexp (Float 0%nat (- dExp b)))).
apply in_map with (f := fun p : Z * Z => Float (fst p) (snd p));
 auto.
apply mProd_correct; auto.
apply mZlist_correct; auto.
simpl in |- *; auto with zarith.
replace 0%Z with (- (0))%Z; [ idtac | simpl in |- *; auto ].
apply Zle_Zopp; unfold pPred in |- *; apply Zle_Zpred.
red in |- *; simpl in |- *; auto with zarith.
simpl in |- *; auto with zarith.
unfold pPred in |- *; apply Zle_Zpred.
red in |- *; simpl in |- *; auto with zarith.
apply mZlist_correct; auto.
simpl in |- *; auto with zarith.
unfold boundR, boundNat in |- *; simpl in |- *; auto with zarith.
apply Zle_trans with 0%Z; auto with zarith.
case (dExp b); auto with zarith.
simpl in |- *; auto with zarith.
Qed.

Theorem mBPadic_Fbounded :
 forall (p : float) (r : R), In p (mBFloat r) -> Fbounded b p.
intros p r H'; red in |- *; repeat (split; auto).
apply Zpred_Zle_Zabs_intro.
apply mZlist_correct_rev1 with (q := Zpred (Zpos (vNum b)));
 auto with real.
apply
 mProd_correct_rev1
  with
    (l2 := mZlist (- dExp b) (Fexp (boundR r)))
    (C := (Z * Z)%type)
    (b := Fexp p); auto.
apply
 in_map_inv with (f := fun p : Z * Z => Float (fst p) (snd p));
 auto.
intros a1 b1; case a1; case b1; simpl in |- *.
intros z z0 z1 z2 H'0; inversion H'0; auto.
generalize H'; case p; auto.
apply mZlist_correct_rev2 with (p := (- Zpred (Zpos (vNum b)))%Z);
 auto.
apply
 mProd_correct_rev1
  with
    (l2 := mZlist (- dExp b) (Fexp (boundR r)))
    (C := (Z * Z)%type)
    (b := Fexp p); auto.
apply
 in_map_inv with (f := fun p : Z * Z => Float (fst p) (snd p));
 auto.
intros a1 b1; case a1; case b1; simpl in |- *.
intros z z0 z1 z2 H'0; inversion H'0; auto.
generalize H'; case p; auto.
apply mZlist_correct_rev1 with (q := Fexp (boundR r)); auto.
apply
 mProd_correct_rev2
  with
    (l1 := mZlist (- pPred (vNum b)) (pPred (vNum b)))
    (C := (Z * Z)%type)
    (a := Fnum p); auto.
apply
 in_map_inv with (f := fun p : Z * Z => Float (fst p) (snd p));
 auto.
intros a1 b1; case a1; case b1; simpl in |- *.
intros z z0 z1 z2 H'0; inversion H'0; auto.
generalize H'; case p; auto.
Qed.
(* Some general properties of rounded predicate :
   -Projector A bounded is rounded to something equal to itself
  - Monotone : the rounded predicate is monotone *)

Definition ProjectorP (P : R -> float -> Prop) :=
  forall p q : float, Fbounded b p -> P p q -> p = q :>R.

Definition MonotoneP (P : R -> float -> Prop) :=
  forall (p q : R) (p' q' : float),
  (p < q)%R -> P p p' -> P q q' -> (p' <= q')%R.
(* What it is to be a minimum*)

Definition isMin (r : R) (min : float) :=
  Fbounded b min /\
  (min <= r)%R /\
  (forall f : float, Fbounded b f -> (f <= r)%R -> (f <= min)%R).
(* Min is a projector *)

Theorem isMin_inv1 : forall (p : float) (r : R), isMin r p -> (p <= r)%R.
intros p r H; case H; intros H1 H2; case H2; auto.
Qed.

Theorem ProjectMin : ProjectorP isMin.
red in |- *.
intros p q H' H'0; apply Rle_antisym.
elim H'0; intros H'1 H'2; elim H'2; intros H'3 H'4; apply H'4; clear H'2;
 auto with real.
apply isMin_inv1 with (1 := H'0); auto.
Qed.
(* It is monotone *)

Theorem MonotoneMin : MonotoneP isMin.
red in |- *.
intros p q p' q' H' H'0 H'1.
elim H'1; intros H'2 H'3; elim H'3; intros H'4 H'5; apply H'5; clear H'3 H'1;
 auto.
case H'0; auto.
apply Rle_trans with p; auto.
apply isMin_inv1 with (1 := H'0); auto.
apply Rlt_le; auto.
Qed.
(* What it is to be a maximum *)

Definition isMax (r : R) (max : float) :=
  Fbounded b max /\
  (r <= max)%R /\
  (forall f : float, Fbounded b f -> (r <= f)%R -> (max <= f)%R).
(* It is a projector *)

Theorem isMax_inv1 : forall (p : float) (r : R), isMax r p -> (r <= p)%R.
intros p r H; case H; intros H1 H2; case H2; auto.
Qed.

Theorem ProjectMax : ProjectorP isMax.
red in |- *.
intros p q H' H'0; apply Rle_antisym.
apply isMax_inv1 with (1 := H'0); auto.
elim H'0; intros H'1 H'2; elim H'2; intros H'3 H'4; apply H'4; clear H'2;
 auto with real.
Qed.
(* It is monotone *)

Theorem MonotoneMax : MonotoneP isMax.
red in |- *.
intros p q p' q' H' H'0 H'1.
elim H'0; intros H'2 H'3; elim H'3; intros H'4 H'5; apply H'5; clear H'3 H'0.
case H'1; auto.
apply Rle_trans with q; auto.
apply Rlt_le; auto.
apply isMax_inv1 with (1 := H'1); auto.
Qed.
(* Minimun is defined upto equality *)

Theorem MinEq :
 forall (p q : float) (r : R), isMin r p -> isMin r q -> p = q :>R.
intros p q r H' H'0; apply Rle_antisym.
elim H'0; intros H'1 H'2; elim H'2; intros H'3 H'4; apply H'4; clear H'2 H'0;
 auto.
case H'; auto.
apply isMin_inv1 with (1 := H'); auto.
elim H'; intros H'1 H'2; elim H'2; intros H'3 H'4; apply H'4; clear H'2 H';
 auto.
case H'0; auto.
apply isMin_inv1 with (1 := H'0); auto.
Qed.
(* Maximum is defined upto equality *)

Theorem MaxEq :
 forall (p q : float) (r : R), isMax r p -> isMax r q -> p = q :>R.
intros p q r H' H'0; apply Rle_antisym.
elim H'; intros H'1 H'2; elim H'2; intros H'3 H'4; apply H'4; clear H'2 H';
 auto.
case H'0; auto.
apply isMax_inv1 with (1 := H'0); auto.
elim H'0; intros H'1 H'2; elim H'2; intros H'3 H'4; apply H'4; clear H'2 H'0;
 auto.
case H'; auto.
apply isMax_inv1 with (1 := H'); auto.
Qed.
(* Min and Max are related *)

Theorem MinOppMax :
 forall (p : float) (r : R), isMin r p -> isMax (- r) (Fopp p).
intros p r H'; split.
apply oppBounded; case H'; auto.
split.
unfold FtoRradix in |- *; rewrite Fopp_correct.
apply Ropp_le_contravar; apply isMin_inv1 with (1 := H'); auto.
intros f H'0 H'1.
rewrite <- (Fopp_Fopp f).
unfold FtoRradix in |- *; rewrite Fopp_correct; rewrite Fopp_correct.
apply Ropp_le_contravar.
elim H'.
intros H'2 H'3; elim H'3; intros H'4 H'5; apply H'5; clear H'3.
apply oppBounded; case H'; auto.
rewrite <- (Ropp_involutive r).
unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real.
Qed.
(* Max and Min are related *)

Theorem MaxOppMin :
 forall (p : float) (r : R), isMax r p -> isMin (- r) (Fopp p).
intros p r H'; split.
apply oppBounded; case H'; auto.
split.
unfold FtoRradix in |- *; rewrite Fopp_correct.
apply Ropp_le_contravar; apply isMax_inv1 with (1 := H'); auto.
intros f H'0 H'1.
rewrite <- (Fopp_Fopp f).
unfold FtoRradix in |- *; repeat rewrite Fopp_correct.
apply Ropp_le_contravar.
rewrite <- (Fopp_correct radix f).
elim H'.
intros H'2 H'3; elim H'3; intros H'4 H'5; apply H'5; clear H'3.
apply oppBounded; auto.
rewrite <- (Ropp_involutive r).
unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real.
Qed.
(* If I have a strict min I can get a max using FNSucc *)

Theorem MinMax :
 forall (p : float) (r : R),
 isMin r p -> r <> p :>R -> isMax r (FNSucc b radix precision p).
intros p r H' H'0.
split.
apply FcanonicBound with (radix := radix); auto with float.
apply FNSuccCanonic; auto.
inversion H'; auto.
split.
case (Rle_or_lt (FNSucc b radix precision p) r); intros H'2; auto.
absurd (FNSucc b radix precision p <= p)%R.
apply Rlt_not_le.
unfold FtoRradix in |- *; apply FNSuccLt; auto.
inversion H'; auto.
elim H0; intros H'1 H'3; apply H'3; auto.
apply FcanonicBound with (radix := radix); auto with float.
apply Rlt_le; auto.
intros f H'2 H'3.
replace (FtoRradix f) with (FtoRradix (Fnormalize radix b precision f)).
unfold FtoRradix in |- *; apply FNSuccProp; auto.
inversion H'; auto.
apply FcanonicBound with (radix := radix); auto with float.
apply Rlt_le_trans with r; auto.
case (Rle_or_lt r p); auto.
intros H'4; Contradict H'0.
apply Rle_antisym; auto; apply isMin_inv1 with (1 := H'); auto.
rewrite FnormalizeCorrect; auto.
unfold FtoRradix in |- *; apply FnormalizeCorrect; auto.
Qed.
(* Find a minimun in a given list if it exists *)

Theorem MinExList :
 forall (r : R) (L : list float),
 (forall f : float, In f L -> (r < f)%R) \/
 (exists min : float,
    In min L /\
    (min <= r)%R /\ (forall f : float, In f L -> (f <= r)%R -> (f <= min)%R)).
intros r L; elim L; simpl in |- *; auto.
left; intros f H'; elim H'.
intros a l H'.
elim H';
 [ intros H'0; clear H'
 | intros H'0; elim H'0; intros min E; elim E; intros H'1 H'2; elim H'2;
    intros H'3 H'4; try exact H'4; clear H'2 E H'0 H' ].
case (Rle_or_lt a r); intros H'1.
right; exists a; repeat split; auto.
intros f H'; elim H';
 [ intros H'2; rewrite <- H'2; clear H' | intros H'2; clear H' ];
 auto with real.
intros H'; Contradict H'; auto with real.
apply Rlt_not_le; auto with real.
left; intros f H'; elim H';
 [ intros H'2; rewrite <- H'2; clear H' | intros H'2; clear H' ];
 auto.
case (Rle_or_lt a min); intros H'5.
right; exists min; repeat split; auto.
intros f H'; elim H';
 [ intros H'0; rewrite <- H'0; clear H' | intros H'0; clear H' ];
 auto.
case (Rle_or_lt a r); intros H'6.
right; exists a; repeat split; auto.
intros f H'; elim H';
 [ intros H'0; rewrite <- H'0; clear H' | intros H'0; clear H' ];
 auto with real.
intros H'; apply Rle_trans with (FtoRradix min); auto with real.
right; exists min; split; auto; split; auto.
intros f H'; elim H';
 [ intros H'0; elim H'0; clear H' | intros H'0; clear H' ];
 auto.
intros H'; Contradict H'6; auto with real.
apply Rle_not_lt; auto.
Qed.

Theorem MinEx : forall r : R, exists min : float, isMin r min.
intros r.
case (MinExList r (mBFloat r)).
intros H'0; absurd (Fopp (boundR r) <= r)%R; auto.
apply Rlt_not_le.
apply H'0.
apply mBFadic_correct3; auto.
(* A minimum always exists *)
apply Rlt_le.
apply boundRCorrect2; auto.
intros H'0; elim H'0; intros min E; elim E; intros H'1 H'2; elim H'2;
 intros H'3 H'4; clear H'2 E H'0.
exists min; split; auto.
apply mBPadic_Fbounded with (r := r); auto.
split; auto.
intros f H'0 H'2.
case (Req_dec f 0); intros H'6.
replace (FtoRradix f) with (FtoRradix (Float 0%nat (- dExp b))).
apply H'4; auto.
apply mBFadic_correct4; auto.
replace (FtoRradix (Float 0%nat (- dExp b))) with (FtoRradix f); auto.
rewrite H'6.
unfold FtoRradix, FtoR in |- *; simpl in |- *; auto with real.
rewrite H'6.
unfold FtoRradix, FtoR in |- *; simpl in |- *; auto with real.
case (Rle_or_lt f (Fopp (boundR r))); intros H'5.
apply Rle_trans with (FtoRradix (Fopp (boundR r))); auto.
apply H'4; auto.
apply mBFadic_correct3; auto.
apply Rlt_le.
apply boundRCorrect2; auto.
case (Rle_or_lt (boundR r) f); intros H'7.
Contradict H'2; apply Rlt_not_le.
apply Rlt_le_trans with (FtoRradix (boundR r)); auto.
apply boundRCorrect1; auto.
apply H'4; auto.
apply mBFadic_correct1; auto.
Contradict H'6; unfold FtoRradix in |- *; apply is_Fzero_rep1; auto.
Qed.

Theorem MaxEx : forall r : R, exists max : float, isMax r max.
intros r; case (MinEx r).
intros x H'.
case (Req_dec x r); intros H'1.
exists x.
rewrite <- H'1.
red in |- *; split; [ case H' | split ]; auto with real.
(* A maximum always exists *)
exists (FNSucc b radix precision x).
apply MinMax; auto.
Qed.

Theorem MinBinade :
 forall (r : R) (p : float),
 Fbounded b p ->
 (p <= r)%R -> (r < FNSucc b radix precision p)%R -> isMin r p.
intros r p H' H'0 H'1.
split; auto.
split; auto.
intros f H'2 H'3.
case (Rle_or_lt f p); auto; intros H'5.
Contradict H'3.
(* If we are between a bound and its successor, it is our minimum *)
apply Rlt_not_le.
apply Rlt_le_trans with (1 := H'1); auto with real.
replace (FtoRradix f) with (FtoRradix (Fnormalize radix b precision f)).
unfold FtoRradix in |- *; apply FNSuccProp; auto; try apply FnormalizeCanonic;
 auto.
unfold FtoRradix in |- *; repeat rewrite FnormalizeCorrect; auto with real.
apply FcanonicBound with (radix := radix); auto.
apply FnormalizeCanonic; auto.
unfold FtoRradix in |- *; rewrite FnormalizeCorrect; auto with real.
unfold FtoRradix in |- *; rewrite FnormalizeCorrect; auto with real.
Qed.

Theorem FminRep :
 forall p q : float,
 isMin p q -> exists m : Z, q = Float m (Fexp p) :>R.
intros p q H'.
replace (FtoRradix q) with (FtoRradix (Fnormalize radix b precision q)).
2: unfold FtoRradix in |- *; apply FnormalizeCorrect; auto.
case (Zle_or_lt (Fexp (Fnormalize radix b precision q)) (Fexp p)); intros H'1.
exists (Fnum p).
unfold FtoRradix in |- *; apply FSuccZleEq with (3 := pGivesBound); auto.
(* A min of a float is always represnetable with the same exposant *)
replace (Float (Fnum p) (Fexp p)) with p; [ idtac | case p ]; auto.
replace (FtoR radix (Fnormalize radix b precision q)) with (FtoR radix q);
 [ idtac | rewrite FnormalizeCorrect ]; auto.
apply isMin_inv1 with (1 := H'); auto.
replace (FSucc b radix precision (Fnormalize radix b precision q)) with
 (FNSucc b radix precision q); [ idtac | case p ];
 auto.
replace (Float (Fnum p) (Fexp p)) with p; [ idtac | case p ]; auto.
case (Req_dec p q); intros Eq0.
unfold FtoRradix in Eq0; rewrite Eq0.
apply FNSuccLt; auto.
case (MinMax q p); auto.
intros H'2 H'3; elim H'3; intros H'4 H'5; clear H'3.
case H'4; auto.
intros H'0; absurd (p <= q)%R; rewrite H'0; auto.
apply Rlt_not_le; auto.
unfold FtoRradix in |- *; apply FNSuccLt; auto.
inversion H'.
elim H0; intros H'3 H'6; apply H'6; clear H0; auto.
rewrite <- H'0; auto with real.
exists
 (Fnum
    (Fshift radix (Zabs_nat (Fexp (Fnormalize radix b precision q) - Fexp p))
       (Fnormalize radix b precision q))).
pattern (Fexp p) at 2 in |- *;
 replace (Fexp p) with
  (Fexp
     (Fshift radix
        (Zabs_nat (Fexp (Fnormalize radix b precision q) - Fexp p))
        (Fnormalize radix b precision q))).
unfold FtoRradix in |- *;
 rewrite <-
  FshiftCorrect
                with
                (n :=
                  Zabs_nat (Fexp (Fnormalize radix b precision q) - Fexp p))
               (x := Fnormalize radix b precision q).
case
 (Fshift radix (Zabs_nat (Fexp (Fnormalize radix b precision q) - Fexp p))
    (Fnormalize radix b precision q)); auto.
auto with arith.
simpl in |- *; rewrite inj_abs; auto with zarith.
Qed.

Theorem MaxBinade :
 forall (r : R) (p : float),
 Fbounded b p ->
 (r <= p)%R -> (FNPred b radix precision p < r)%R -> isMax r p.
intros r p H' H'0 H'1.
rewrite <- (Ropp_involutive r).
rewrite <- (Fopp_Fopp p).
apply MinOppMax.
apply MinBinade; auto with real float.
unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real.
(* Same for max *)
rewrite <- (Fopp_Fopp (FNSucc b radix precision (Fopp p))).
rewrite <- FNPredFopFNSucc; auto.
unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real arith.
Qed.

Theorem MaxMin :
 forall (p : float) (r : R),
 isMax r p -> r <> p :>R -> isMin r (FNPred b radix precision p).
intros p r H' H'0.
rewrite <- (Fopp_Fopp (FNPred b radix precision p)).
rewrite <- (Ropp_involutive r).
apply MaxOppMin.
rewrite FNPredFopFNSucc; auto.
rewrite Fopp_Fopp; auto.
(* Taking the pred of a max we get a min *)
apply MinMax; auto.
apply MaxOppMin; auto.
Contradict H'0.
rewrite <- (Ropp_involutive r); rewrite H'0; auto; unfold FtoRradix in |- *;
 rewrite Fopp_correct; auto; apply Ropp_involutive.
Qed.

Theorem FmaxRep :
 forall p q : float,
 isMax p q -> exists m : Z, q = Float m (Fexp p) :>R.
intros p q H'; case (FminRep (Fopp p) (Fopp q)).
unfold FtoRradix in |- *; rewrite Fopp_correct.
apply MaxOppMin; auto.
intros x H'0.
exists (- x)%Z.
rewrite <- (Ropp_involutive (FtoRradix q)).
(* The max of a float can be represented with the same exposant *)
unfold FtoRradix in |- *; rewrite <- Fopp_correct.
unfold FtoRradix in H'0; rewrite H'0.
unfold FtoR in |- *; simpl in |- *; auto with real.
rewrite Ropp_Ropp_IZR; rewrite Ropp_mult_distr_l_reverse; auto.
Qed.

End FMinMax.
Hint Resolve ProjectMax MonotoneMax MinOppMax MaxOppMin MinMax MinBinade
  MaxBinade MaxMin: float.


(*******************************************************************)
(*  This is part of RelationAlgebra, it is distributed under the   *)
(*    terms of the GNU Lesser General Public License version 3     *)
(*              (see file LICENSE for more details)                *)
(*                                                                 *)
(*  Copyright 2012: Damien Pous. (CNRS, LIP - ENS Lyon, UMR 5668)  *)
(*******************************************************************)

(** * powerfix: bounded fixpoint operator *)

(** we define a fixpoint operator which recursively unfolds an
   open-recursive function with recursive depth at most [2^n], for
   arbitrary [n].  This allows us to define arbitrary recursive
   functions, without needing to prove their termination. The operator
   is defined in a computationally efficient way. (We already used
   such a trick in ATBR ; it's simplified here thanks to the
   introduction of eta in Coq v8.4 *)

Require Import common.
Set Implicit Arguments.

Section powerfix.

Variables A B: Type.
Notation Fun := (A -> B).

(** the three following functions "iterate" their [f] argument lazily:
   iteration stops whenever [f] no longer makes recursive calls.
   - [powerfix' n f k] iterates [f] at most [(2^n-1)] times and then yields to [k]
   - [powerfix n f k] iterates [f] at most [(2^n)] times and then yields to [k]
   - [linearfix n f k] iterates [f] at most [n] times and then yields to [k]
   *)
Fixpoint powerfix' n (f: Fun -> Fun) (k: Fun): Fun :=
  fun a => match n with O => k a | S n => f (powerfix' n f (powerfix' n f k)) a end.
Definition powerfix n f k a := f (powerfix' n f k) a.

Fixpoint linearfix n (f: Fun -> Fun) (k: Fun): Fun :=
  fun a => match n with O => k a | S n => f (linearfix n f k) a end.

(** simple lemmas about [2^n]  *)
Lemma pow2_S n: pow2 n = S (pred (pow2 n)).
Proof. induction n. reflexivity. simpl. now rewrite IHn. Qed.

Lemma pred_pow2_Sn n: pred (pow2 (S n)) = S (double (pred (pow2 n))).
Proof. simpl. now rewrite pow2_S. Qed.

(** characterisation of [powerfix] with [linearfix] *)
Section linear_carac.

 Variable f: Fun -> Fun.

 Lemma linearfix_S: forall n k,
   f (linearfix n f k) = linearfix n f (f k).
 Proof. induction n; intros k; simpl. reflexivity. now rewrite IHn. Qed.

 Lemma linearfix_double: forall n k,
   linearfix n f (linearfix n f k) = linearfix (double n) f k.
 Proof.
   induction n; intros k. reflexivity. simpl linearfix.
   now rewrite <-IHn, <-linearfix_S.
 Qed.

 Lemma powerfix'_linearfix: forall n k,
   powerfix' n f k = linearfix (pred (pow2 n)) f k.
 Proof.
   induction n; intros. reflexivity.
   rewrite pred_pow2_Sn. simpl.
   now rewrite <-linearfix_double, 2IHn.
 Qed.

 Theorem powerfix_linearfix: forall n k,
   powerfix n f k = linearfix (pow2 n) f k.
 Proof. intros. unfold powerfix. now rewrite powerfix'_linearfix, pow2_S. Qed.

End linear_carac.

(** [powerfix_invariant] gives an induction principle for [powerfix],
   that does not care about the number of iterations -- in particular,
   the trivial "emptyfix" function : ([fun f k a => k a]) satisfies
   the same induction principle, so that this can only be used to
   reason about partial correctness. *)
Section invariant.
 Variable P: Fun -> Prop.

 Lemma powerfix_invariant: forall n f g,
   (forall k, P k -> P (f k)) -> P g -> P (powerfix n f g).
 Proof.
   intros n f g Hf Hg. apply Hf.
   revert g Hg. induction n; intros g Hg; simpl; auto.
 Qed.

End invariant.

End powerfix.


Require Export P04.

(* Hint:

   First study the chapter "Auto.v".

   Using [;], [try] and [eauto], you can prove it in 7 lines thanks to:.
     Hint Constructors bstep.

   You can use the following intro pattern:
     destruct ... as [[? | ?] | [? ?]].
*)

Hint Constructors aval.
Hint Constructors bstep.

Theorem bexp_strong_progress: forall st b,
  (b = BTrue \/ b = BFalse) \/
  exists b', b / st ==>b b'.
Proof.
  intros st b.
  induction b; eauto; try (destruct (aexp_strong_progress st a); destruct (aexp_strong_progress st a0); destruct H; destruct H0; subst; eauto).
  - destruct IHb; destruct H; subst; eauto.
  - destruct IHb1; destruct IHb2; destruct H; destruct H0; subst; eauto.
Qed.


From Cat Require Import Imports Category Preorder Monoid Poset Isomorphism
Terminal Dual Initial Product CoProduct Exponential CCC IPL STLC.
Require Import FunctionalExtensionality.
Require Import ProofIrrelevance.
Require Import Coq.Lists.List.
Require Import JMeq.
Require Import Coq.Program.Equality.
Set Universe Polymorphism.
Local Open Scope list_scope.

Class Functor (C D: Category): Type :=
  mk_Functor
  {
    fobj            : @obj C -> @obj D;
    fmap            : forall {a b: @obj C} (f: arrow b a), arrow (fobj b) (fobj a);
    fmapP           :> forall x y, Proper (eq ==> eq) (@fmap x y);
    preserve_id     : forall {a: @obj C}, fmap (@identity C a) = (@identity D (fobj a));
    preserve_comp   : forall {a b c: @obj C} (g : @arrow C c b) (f: @arrow C b a),
                        fmap (g o f) = (fmap g) o (fmap f)
  }.
Check Functor.

Notation " C → D " := (Functor C D) (at level 40, left associativity).

Arguments fmap {_} {_} _ _ _ _.
Arguments fobj {_} {_} _ _.

(** sameness of Functors using heterogenous (John Major's) equality *)
Lemma F_split: forall (C D: Category) (F G: Functor C D),
                 fobj F = fobj G -> JMeq (fmap F) (fmap G) -> F = G.
Proof.
    destruct F; destruct G; cbn; intros; subst. f_equal.
    now destruct (proof_irrelevance _ fmapP0 fmapP1).
    now destruct (proof_irrelevance _ preserve_id0 preserve_id1).
    now destruct (proof_irrelevance _ preserve_comp0 preserve_comp1).
Defined.

(** sameness of Functors, inspired by Amin Timany *)
Lemma F_splitA: forall
                (C D  : Category)
                (F G  : Functor C D)
                (ObjEq: (fobj F) = (fobj G)),
                ((fun a b =>
                    match ObjEq in _ = V return ((arrow b a) -> (arrow (V b) (V a))) with
                     | eq_refl => (fmap F a b)
                    end) = fmap G) -> F = G.
Proof.
    destruct F; destruct G; simpl; intros; subst; f_equal.
    now destruct (proof_irrelevance _ fmapP0 fmapP1).
    now destruct (proof_irrelevance _ preserve_id0 preserve_id1).
    now destruct (proof_irrelevance _ preserve_comp0 preserve_comp1).
Defined.

(** sameness of Functors using heterogenous (John Major's) equality *)
Lemma F_splitR: forall (C D: Category) (F G: Functor C D),
                 F = G -> fobj F = fobj G /\ JMeq (fmap F) (fmap G).
Proof. intros. subst. easy. Qed.

Definition Forgetful1: Functor Mon SetCat.
Proof. unshelve econstructor.
       - intros (M, e, Mf, Mob1, Mob2, Mob3).
         exact M.
       - simpl.
         intros (M1, e1, M1f, M1ob1, M1ob2, M1ob3).
         intros (M2, e2, M2f, M2ob1, M2ob2, M2ob3).
         intros (f, fax1, fax2).
         exact f.
       - simpl. repeat intro. now subst.
       - simpl.
         intros (M, e, Mf, Mob1, Mob2, Mob3).
         simpl. reflexivity.
       - simpl.
         intros (M1, e1, M1f, M1ob1, M1ob2, M1ob3).
         intros (M2, e2, M2f, M2ob1, M2ob2, M2ob3).
         intros (M3, e3, M3f, M3ob1, M3ob2, M3ob3).
         intros (f, fax1, fax2).
         intros (g, gax1, gax2).
         reflexivity.
Defined.

Definition Forgetful2: Functor PreOrderCat SetCat.
Proof. unshelve econstructor.
       - intros (pos, le, r, t).
         exact pos.
       - intros (pos1, le1, r1, t1) (pos2, le2, r2, t2).
         intros (f, fax).
         simpl in *. exact f.
       - simpl. repeat intro. now subst.
       - intros (pos, le, r, t).
         simpl. reflexivity.
       - intros (pos1, le1, r1, t1) (pos2, le2, r2, t2) (pos3, le3, r3, t3) (f, fax) (g, gax).
         simpl. reflexivity.
Defined.

Definition FreeMonoidPar (A: Set): Monoid.
Proof. unshelve econstructor.
       - exact (list A).
       - exact nil.
       - intros xs ys. exact (xs ++ ys).
       - intros. simpl. rewrite app_assoc. reflexivity.
       - simpl. intro xs. reflexivity.
       - simpl. intro xs. rewrite app_nil_r. reflexivity.
Defined.

Definition FreeMonoidFunctor: Functor SetCat Mon.
Proof. unshelve econstructor.
       - intro A. simpl in *.
         exact (FreeMonoidPar A).
       - simpl. intros A B f.
         unshelve econstructor.
         + simpl. intro l.
           exact (map f l).
         + simpl. reflexivity.
         + simpl. intros x y.
           rewrite map_app.
           reflexivity.
       - simpl. repeat intro. now subst.
       - simpl. intro A.
         apply MonoidMapEq.
         simpl.
         apply functional_extensionality.
         intro l.
         rewrite map_id.
         reflexivity.
       - simpl. intros A B C g f.
         apply MonoidMapEq.
         simpl.
         apply functional_extensionality.
         intro l.
         rewrite map_map.
         reflexivity.
Defined.

Definition Compose_Functors (C D E: Category)
                            (F    : Functor C D)
                            (G    : Functor D E): (Functor C E).
Proof. unshelve econstructor.
       - exact (fun a => fobj G (fobj F a)).
       - intros. exact ((((@fmap D E G _ _
                               (@fmap C D F a b f))))).
       - repeat intro. subst. easy.
       - intros. simpl.
         now rewrite (@preserve_id C D F), (@preserve_id D E G).
       - intros. simpl.
         now rewrite (@preserve_comp C D F), (@preserve_comp D E G).
Defined.

Arguments Compose_Functors {_} {_} {_} _ _.

Definition IdFunctor {C: Category}: Functor C C.
Proof. unshelve econstructor.
       - exact id.
       - unfold id. intros. exact f.
       - repeat intro. easy.
       - intros. now destruct C.
       - intros. now destruct C.
Defined.

Definition Id {C: Category}: @Functor C C.
Proof. refine (@mk_Functor C C id (fun a b f => f) _ _ _);
       intros; now unfold id.
Defined.

Definition iProdFunctor: forall (C: Category) (X: @obj C) (hp: hasProducts C), Functor C C.
Proof. intros C X hp.
       unshelve econstructor.
       - intro A.
         exact (@pobj C hp A X).
       - simpl. intros A B f.
         exact (@fprod C hp A X B X f (identity X)).
       - repeat intro. now subst.
       - simpl. intro A.
         unfold fprod. simpl.
         rewrite !identity_f.
         unfold prod_f.
         destruct (hasp A X).
         simpl.
         specialize (prod_f_uni (pobj A X) pi1 pi2 (identity (pobj A X))).
         apply prod_f_uni.
         + rewrite f_identity. reflexivity.

         + rewrite f_identity. reflexivity.
       - simpl. intros a b c g f.
         specialize (@fprod_distr C hp b c X X a X g (identity X) f (identity X)); intro H.
         destruct hp as (pobj, hasp).
         rewrite f_identity in H.
         rewrite <- H. reflexivity.
Defined.

Definition iExpFunctor: forall (C: Category) (X: @obj C) (hp: hasProducts C) (he: hasExponentials C hp), Functor C C.
Proof. intros C X hp he.
       unshelve econstructor.
       - intro A.
         destruct hp as (pobj, hasp).
         destruct he as (eobj, hase).
         exact (eobj X A).
       - simpl. intros A B f.
         specialize (@fExp C hp he A B X f); intro fX.
         destruct he as (eobj, hase).
(*       specialize (@Exponential.app C hp X A (eobj X A) (hase X A)); intro app.
         specialize (@Exponential.cur C hp X B (eobj X B) (hase X B) (eobj X A) ); intro fx. *)
         destruct hp as (pobj, hasp).
         simpl in *.
         exact fX.
       - simpl. repeat intro. now subst.
       - simpl. intro A.
         destruct hp as (pobj, hasp).
         destruct he as (eobj, hase).
         unfold fExp.
         simpl. rewrite identity_f.
         destruct ( hase X A ).
         simpl in *.
         specialize (curuni (eobj X A) app (identity (eobj X A))).
         rewrite curuni.
         + reflexivity.
         + rewrite fprod_id, f_identity. reflexivity.
       - simpl. intros a b c g f.
         specialize (@fExpDistributes C hp he a b c X f g); intro H.
         destruct hp as (pobj, hasp).
         destruct he as (eobj, hase).
         destruct ( hase X c ).
         destruct ( hase X b ).
         destruct ( hase X a ).
         simpl in *.
         exact H.
Defined.

Definition ContravariantFunctor (C D: Category) := Functor (DualCategory C) D.

Definition iExpContravariantFunctor: forall (C: Category) (X: @obj C) (hp: hasProducts C) (he: hasExponentials C hp), ContravariantFunctor C C.
Proof. intros C X hp he.
       unshelve econstructor.
       - intro A.
         destruct hp as (pobj, hasp).
         destruct he as (eobj, hase).
         exact (eobj A X).
       - simpl. intros A B f.
         specialize (@Expf C hp he B A X f); intro fX.
         destruct he as (eobj, hase).
(*       specialize (@Exponential.app C hp X A (eobj X A) (hase X A)); intro app.
         specialize (@Exponential.cur C hp X B (eobj X B) (hase X B) (eobj X A) ); intro fx. *)
         destruct hp as (pobj, hasp).
         simpl in *.
         exact fX.
       - simpl. repeat intro. now subst.
       - simpl. unfold Expf, fprod. intro A.
         specialize (prod_f_id C (eobj A X) A  (pobj (eobj A X) A) (hasp (eobj A X) A) ); intro h.
         destruct hp as (pobj, hasp).
         destruct he as (eobj, hase).
         simpl in *.
         destruct ( hase A X ).
         simpl in *.
         destruct ( hasp (eobj A X) A ).
         simpl in *.
         specialize (curuni (eobj A X) (app o prod_f (pobj (eobj A X) A) (identity (eobj A X) o pi1) (identity A o pi2))
                                       (identity (eobj A X))).
         rewrite curuni.
         + reflexivity.
         + rewrite fprod_id, f_identity, !identity_f.
           unfold fprod in curcomm.
           simpl in *.
           rewrite h, f_identity. reflexivity.
       - simpl. intros a b c g f.
         specialize (@ExpfDistributes C hp he c b a X g f); intro H.
         destruct hp as (pobj, hasp).
         destruct he as (eobj, hase).
         destruct ( hase X c ).
         destruct ( hase X b ).
         destruct ( hase X a ).
         simpl in *.
         exact H.
Defined.

Module ME.

Context (S: @obj SetCat).

Definition FunctorF: Functor SetCat SetCat.
Proof. specialize (hasProductsSetCat); intros (pobj, H).
       unshelve econstructor.
       - simpl. intro X.
         exact (prod S X).
       - simpl. intros X Y f.
         exact (@fprod SetCat hasProductsSetCat _ _ _ _ (identity S) f); intro h.
       - repeat intro. now subst.
       - simpl. intros X.
         unfold fprod.
         simpl.
         apply functional_extensionality.
         intros (s, x).
         reflexivity.
       - simpl. intros X Y Z g f.
         unfold fprod.
         simpl.
         apply functional_extensionality.
         intros (s, x).
         reflexivity.
Defined.

Definition FunctorG: Functor SetCat SetCat.
Proof. specialize (hasProductsSetCat); intros (pobj, H).
       unshelve econstructor.
       - simpl. intro X.
         exact (prod X S).
       - simpl. intros X Y f.
         exact (@fprod SetCat hasProductsSetCat _ _ _ _ f (identity S)); intro h.
       - repeat intro. now subst.
       - simpl. intros X.
         unfold fprod.
         simpl.
         apply functional_extensionality.
         intros (x, s).
         reflexivity.
       - simpl. intros X Y Z g f.
         unfold fprod.
         simpl.
         apply functional_extensionality.
         intros (x, s).
         reflexivity.
Defined.

Lemma IsoFXGX: forall (X: @obj SetCat), @Isomorphic SetCat (@fobj SetCat SetCat FunctorF X) (@fobj SetCat SetCat FunctorG X).
Proof. intro X.
       unshelve econstructor.
       - simpl. intros (s, x).
         exact (x, s).
       - unshelve econstructor.
         + simpl. intros (x, s).
           exact (s, x).
         + simpl. apply functional_extensionality.
           intros (x, s).
           reflexivity.
         + simpl. apply functional_extensionality.
           intros (s, x).
           reflexivity.
Qed.

End ME.

(** Associativity of functor composition *)
Lemma FunctorCompositionAssoc: forall {D C B A : Category}
  (F : Functor C D) (G : Functor B C) (H : Functor A B),
  Compose_Functors H (Compose_Functors G F) = Compose_Functors (Compose_Functors H G) F.
Proof. intros.
       apply F_split.
       - easy.
       - apply eq_dep_id_JMeq, EqdepFacts.eq_sigT_iff_eq_dep,
         eq_existT_uncurried; cbn.
         now exists (eq_refl
         (forall a b : obj, arrow b a ->
           arrow (fobj F (fobj G (fobj H b))) (fobj F (fobj G (fobj H a))))).
Defined.

(** Identity functors cancels on the right *)
Lemma ComposeIdr: forall {C D: Category} (F: Functor C D),
  Compose_Functors F IdFunctor = F.
Proof. intros.
       apply F_split.
       - easy.
       - apply eq_dep_id_JMeq, EqdepFacts.eq_sigT_iff_eq_dep,
         eq_existT_uncurried; cbn.
       unfold id in *.
       now exists (eq_refl
       (forall a b : obj, arrow b a -> arrow (fobj F b) (fobj F a))).
Defined.

(** Identity functors cancels on the left *)
Lemma ComposeIdl: forall {C D: Category} (F: Functor C D),
  Compose_Functors IdFunctor F = F.
Proof. intros.
       apply F_split.
       - easy.
       - apply eq_dep_id_JMeq, EqdepFacts.eq_sigT_iff_eq_dep,
         eq_existT_uncurried; cbn.
       unfold id in *.
       now exists (eq_refl
       (forall a b : obj, arrow b a -> arrow (fobj F b) (fobj F a))).
Defined.

(** the 2-category Cat *)
Definition Cat: Category.
Proof. unshelve econstructor.
       - exact Category.
       - intros C D. exact (Functor D C).
       - intro C. cbn in *. exact (@IdFunctor C).
       - intros C D E F G. exact (Compose_Functors G F).
       - repeat intro. now subst.
       - intros A B C D F G H. cbn in *.
         symmetry.
         exact (FunctorCompositionAssoc H G F).
       - intros C D F. exact (ComposeIdr F).
       - intros D C F. exact (ComposeIdl F).
Defined.

Definition sObjSetCat: @obj SetCat.
Proof. simpl. exact unit. Defined.

Definition sArrowSetCat: @arrow SetCat sObjSetCat sObjSetCat.
Proof. simpl. intro a. exact a. Defined.

Lemma SingletonCat: Category.
Proof. unshelve econstructor.
       - exact unit.
       - intros a b. exact unit.
       - simpl. intros. exact tt.
       - simpl. intros. exact tt.
       - repeat intro. now subst.
       - simpl. intros. reflexivity.
       - simpl. intros. destruct f. reflexivity.
       - simpl. intros. destruct f. reflexivity.
Defined.

Lemma hasTerminalCat: hasTerminal Cat.
Proof. unshelve econstructor.
       - simpl. exact SingletonCat.
       - unshelve econstructor.
         + simpl. intro C.
           unshelve econstructor.
           ++ simpl. intro a.
              exact tt.
           ++ simpl. intros. exact tt.
           ++ simpl. repeat intro. now subst.
           ++ simpl. intros. reflexivity.
           ++ simpl. intros. reflexivity.
         + simpl. intro C.
           intros F G.
           apply F_split.
           ++ destruct F, G. simpl in *.
              extensionality x.
              destruct (fobj0 x), (fobj1 x).
              reflexivity.
           ++ destruct F, G. simpl in *.
              apply eq_dep_id_JMeq, EqdepFacts.eq_sigT_iff_eq_dep,
              eq_existT_uncurried; cbn.
              exists eq_refl.
              simpl.
              extensionality a.
              extensionality b.
              extensionality f.
              destruct (fmap0 a b f), (fmap1 a b f).
              reflexivity.
Qed.

Definition ProductCategory (C D: Category): Category.
Proof. unshelve econstructor.
         + simpl in *. exact (@obj C * @obj D)%type.
         + simpl. intros (x, y) (x', y').
           exact ((@arrow C x x') * (@arrow D y y'))%type.
         + simpl. intros (x, y).
           exact ((identity x), (identity y)).
         + simpl. intros (a, b) (c, d) (i, j) (f1, f2) (g1, g2).
           split.
           ++ exact (f1 o g1).
           ++ exact (f2 o g2).
         + simpl. repeat intro. now subst.
         + simpl. intros (a, b) (c, d) (i, j) (f1, f2) (g1, g2) (h1, h2) (k1, k2).
           f_equal.
           ++ rewrite assoc. reflexivity.
           ++ rewrite assoc. reflexivity.
         + simpl. intros (a, b) (c, d) (f, g).
           f_equal.
           ++ rewrite identity_f. reflexivity.
           ++ rewrite identity_f. reflexivity.
         + simpl. intros (a, b) (c, d) (f, g).
           f_equal.
           ++ rewrite f_identity. reflexivity.
           ++ rewrite f_identity. reflexivity.
Defined.

Definition ProductFunctor {A B C D: Category} (F: Functor A B) (G: Functor C D):
 Functor (ProductCategory A C) (ProductCategory B D).
Proof. unshelve econstructor.
       - intros (a, c).
         exact (fobj F a, fobj G c).
       - intros (a, c) (b, d) (f, g).
         exact (fmap F a b f, fmap G c d g).
       - repeat intro. now subst.
       - intros (a, c). simpl.
         rewrite !preserve_id.
         reflexivity.
       - simpl. intros (a, d) (b, e) (c, f) (g1, g2) (f1, f2).
         rewrite !preserve_comp.
         reflexivity.
Defined.

Lemma Fpi1 (A B: Category): Functor (ProductCategory A B) A.
Proof. unshelve econstructor.
            +++ intros (a, b). exact a.
            +++ intros (a, b) (c, d) (f, g). exact f.
            +++ repeat intro. now subst.
            +++ intros (a, b). reflexivity.
            +++ intros (a, b) (c, d) (i, j) (f1, f2) (g1, g2).
                reflexivity.
Defined.

Lemma Fpi2 (A B: Category): Functor (ProductCategory A B) B.
Proof.   unshelve econstructor.
            +++ intros (a, b). exact b.
            +++ intros (a, b) (c, d) (f, g). exact g.
            +++ repeat intro. now subst.
            +++ intros (a, b). reflexivity.
            +++ intros (a, b) (c, d) (i, j) (f1, f2) (g1, g2).
                reflexivity.
Defined.

Definition DualFunctor {C D: Category} (F: Functor C D): Functor (DualCategory C) (DualCategory D).
Proof. unshelve econstructor.
       - intro a. exact (fobj F a).
       - intros a b f. simpl.
         exact (fmap F _ _ f).
       - repeat intro. now subst.
       - intros. simpl.
         now rewrite preserve_id.
       - intros. simpl.
         now rewrite preserve_comp.
Defined.

Class Full {C D: Category} (F : Functor C D): Type :=
{
  fmap_surj: forall {x y} (f g: arrow (fobj F y) (fobj F x)),
    exists (f: arrow y x), fmap F _ _ f = g
}.

Class Faithful {C D: Category} (F : Functor C D): Type :=
{
  fmap_inj: forall {x y} (f g: arrow y x), fmap F _ _ f = fmap F _ _ g -> f = g
}.

Lemma PC1 (A B C: Category) (F: Functor C A) (G: Functor C B): Functor C (ProductCategory A B).
Proof.      destruct A, B, C, F, G.
            unshelve econstructor.
            +++ simpl in *.
                intro a.
                exact ((fobj0 a), (fobj1 a)).
            +++ simpl in *.
                intros a b f.
                exact ((fmap0 a b f), (fmap1 a b f)).
            +++ repeat intro. now subst.
            +++ simpl in *.
                intro a.
                rewrite preserve_id0, preserve_id1.
                reflexivity.
            +++ simpl in *. intros a b c f g.
                rewrite preserve_comp0, preserve_comp1.
                reflexivity.
Defined.

Definition pco (A B: Category) (a: @obj A) (b: @obj B): @obj (ProductCategory A B).
Proof. exact (a, b). Defined.

Definition pca (A B: Category) (a b: @obj A) (c d: @obj B) (f: arrow b a) (g: arrow d c): @arrow (ProductCategory A B) (b, d) (a, c).
Proof. exact (f, g). Defined.

Lemma Afst: forall (A B: Category) (a b: @obj A) (c d: @obj B) (f h: arrow b a) (g: arrow d c),
  fmap (Fpi1 A B) (a, c) (b, d) (f, g) = fmap (Fpi1 A B) (a, c) (b, d) (h, g) -> f = h.
Proof. unfold Fpi1.
       intros.
       simpl in H.
       easy.
Defined.

Lemma Fpi1_id: forall (A B: Category) (a b: @obj A) (c d: @obj B) (f h: arrow b a) (g: arrow d c),
  fmap (Fpi1 A B) (a, c) (b, d) (f, g) = f.
Proof. unfold Fpi1.
       intros.
       simpl.
       easy.
Defined.

Lemma fst_snd: forall (A B: Category) (a b: @obj A) (c d: @obj B)  (f h: @arrow (ProductCategory A B) (b, d) (a, c)),
  fmap (Fpi1 A B) (a, c) (b, d) f = fmap (Fpi1 A B) (a, c) (b, d) h ->
  fmap (Fpi2 A B) (a, c) (b, d) f = fmap (Fpi2 A B) (a, c) (b, d) h -> f = h.
Proof. unfold Fpi1, Fpi2.
       intros.
       simpl in *.
       simpl in H, H0.
       destruct f.
       destruct h.
       subst.
       easy.
Defined.

Arguments fmap {_} {_} _ {_} {_} _.
Lemma hasProductsCat: hasProducts Cat.
Proof. unshelve econstructor.
       - simpl. intros C D.
         exact (ProductCategory C D).
       - simpl. intros.
         unshelve econstructor.
         ++ simpl.
            exact (Fpi1 A B).
         ++ simpl.
            exact (Fpi2 A B).
         ++ simpl. intros C F G.
            exact (PC1 A B C F G).
         ++ simpl. intros C F G.
            destruct A, B, C, F, G.
            simpl in *.
            apply F_split.
            +++ simpl. reflexivity.
            +++ apply eq_dep_id_JMeq, EqdepFacts.eq_sigT_iff_eq_dep,
                eq_existT_uncurried; cbn.
                exists eq_refl.
                simpl.
                reflexivity.
         ++ simpl. intros C F G.
            destruct A, B, C, F, G.
            apply F_split.
            +++ simpl. reflexivity.
            +++ apply eq_dep_id_JMeq, EqdepFacts.eq_sigT_iff_eq_dep,
                eq_existT_uncurried; cbn.
                exists eq_refl.
                simpl. reflexivity.
         ++ simpl. intros C F G H K L.
Admitted.