(*
The technique for universal quantifier elimination is apply <term>
*)

Section E1.
Variable U  : Set.
Variable A B: U -> Prop.
Variable P Q: Prop.
Variable R S: U -> U -> Prop.

Theorem e11 : (forall x:U, A(x)) -> forall y:U, A(y).
Proof.

Qed.

Theorem e12 : (forall x y:U, (R x y)) -> forall x y:U, (R y x).
Proof.

Qed.

Theorem e13 : (forall x: U, ((A x)->(B x)))
                        -> (forall y:U, (A y))
                          -> (forall z:U, (B z)).
Proof.

Qed.

End E1.

Section E2.

Variable U  : Set.
Variable A B: U -> Prop.
Variable P Q: Prop.
Variable R S: U -> U -> Prop.

Theorem e21 : (forall x:U, ((A x)-> ~(forall x:U, ~ (A x)))).
Proof.

Qed.

Theorem e22 : (forall x y:U, ((R x y)))-> (forall x:U, (R x x)).
Proof.

Qed.

Theorem e23 : (forall x:U, ((P -> (A x))))
                        -> (P -> (forall x: U, (A x))).
Proof.

Qed.

Theorem e24 : (forall x:U, ((A x) /\ (B x)))
                        -> (forall x:U, (A x))
                          -> (forall x:U, (B x)).
Proof.

Qed.

End E2.

Section Ejercicio5.

Variable nat      : Set.
Variable S        : nat -> nat.
Variable a b c    : nat.
Variable odd even : nat -> Prop.
Variable P Q      : nat -> Prop.
Variable f        : nat -> nat.

Theorem e51: forall x:nat, exists y:nat, (P(x)->P(y)).
Proof.

Qed.

Theorem e52: exists x:nat, (P x)
                            -> (forall y:nat, (P y)->(Q y))
                               -> (exists z:nat, (Q z)).
Proof.

Qed.

Theorem e53: even(a) -> (forall x:nat, (even(x)->odd (S(x)))) -> exists y: nat, odd(y).
Proof.

Qed.

Theorem e54: (forall x:nat, P(x) /\ odd(x) ->even(f(x)))
                            -> (forall x:nat, even(x)->odd(S(x)))
                            -> even(a)
                            -> P(S(a))
                            -> exists z:nat, even(f(z)).
Proof.

Qed.

End Ejercicio5.


(***************************************************************************
* A lambda-term evaluator for terminating terms, defined in Coq            *
* Arthur Charguéraud, March 2009                                           *
***************************************************************************)

Set Implicit Arguments.
Require Import LibTactics.

(* ********************************************************************** *)
(** ** Grammar of pre-terms *)

Inductive trm : Set :=
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_abs  : trm -> trm
  | trm_app  : trm -> trm -> trm.

(* ********************************************************************** *)
(** ** Operation to open up abstractions. *)

Fixpoint open_rec (k : nat) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => if k === i then u else (trm_bvar i)
  | trm_fvar x    => trm_fvar x
  | trm_app t1 t2 => trm_app (open_rec k u t1) (open_rec k u t2)
  | trm_abs t1    => trm_abs (open_rec (S k) u t1)
  end.

Definition open t u := open_rec 0 u t.

Notation "t ^^ u" := (open t u) (at level 67).
Notation "t ^ x" := (open t (trm_fvar x)).

(* ********************************************************************** *)
(** ** Definition of well-formedness of a term *)

Inductive term : trm -> Prop :=
  | term_var : forall x,
      term (trm_fvar x)
  | term_app : forall t1 t2,
      term t1 -> term t2 -> term (trm_app t1 t2)
  | term_abs : forall L t1,
      (forall x, x \notin L -> term (t1 ^ x)) ->
      term (trm_abs t1).

(* ********************************************************************** *)
(** ** Definition of the body of an abstraction *)

Definition body t :=
  exists L, forall x, x \notin L -> term (t ^ x).

(* ********************************************************************** *)
(** ** Definition of the small-step semantics *)

Inductive value : trm -> Prop :=
  | value_abs : forall t1,
      term (trm_abs t1) -> value (trm_abs t1).

Inductive beta : trm -> trm -> Prop :=
  | beta_red : forall t1 t2,
      body t1 ->
      value t2 ->
      beta (trm_app (trm_abs t1) t2) (t1 ^^ t2)
  | beta_app1 : forall t1 t1' t2,
      term t2 ->
      beta t1 t1' ->
      beta (trm_app t1 t2) (trm_app t1' t2)
  | beta_app2 : forall t1 t2 t2',
      value t1 ->
      beta t2 t2' ->
      beta (trm_app t1 t2) (trm_app t1 t2').

Inductive beta_star : trm -> trm -> Prop :=
  | beta_star_refl : forall t,
      term t ->
      beta_star t t
  | beta_star_step : forall t2 t1 t3,
      beta t1 t2 ->
      beta_star t2 t3 ->
      beta_star t1 t3.

(* ********************************************************************** *)
(** ** Definition of the big-step semantics *)

Inductive reds : trm -> trm -> Prop :=
  | reds_val : forall t1,
      value t1 ->
      reds t1 t1
  | reds_red : forall t3 v2 v3 t1 t2,
      reds t1 (trm_abs t3) ->
      reds t2 v2 ->
      reds (t3 ^^ v2) v3 ->
      reds (trm_app t1 t2) v3.

(* ********************************************************************** *)
(** ** Definition of the big-step semantics *)

Definition equivalence := forall t v,
  reds t v <-> beta_star t v /\ value v.

Set Implicit Arguments.
Require Import LibTactics BigStep LibClosure.

Definition terminates t :=
  exists v, reds t v.

Definition returns_of t :=
  { v | reds t v }.

Lemma reds_deterministic : forall v v' t,
  reds t v -> reds t v' -> v = v'.
Proof.
  introv R1 R2. gen v'. induction R1; intros.
  inversions R2.
    auto.
    inverts_false.
  inversions R2.
    inverts_false.
    lets E: IHR1_1 H1. inversions E.
    lets E: IHR1_2 H2. inversions E.
    lets E: IHR1_3 H4. inversions E.
    auto.
Defined.

Lemma terminates_bvar_not : forall i,
  ~ terminates (trm_bvar i).
Proof.
  introv H. inversions H. inversions H0. inverts_false.
Defined.

Lemma terminates_fvar_not : forall x,
  ~ terminates (trm_fvar x).
Proof.
  introv H. inversions H. inversions H0. inverts_false.
Defined.

Lemma terminates_abs : forall t,
  terminates (trm_abs t) ->
  reds (trm_abs t) (trm_abs t).
Proof.
  introv H. inversions H. inversions H0. apply~ reds_val.
Defined.

Lemma terminates_app_1 : forall t2 t1,
  terminates (trm_app t1 t2) ->
  terminates t1.
Proof.
  introv [v H]. inversions H. inverts_false. exists__*.
Defined.

Lemma terminates_app_2 : forall t1 t2,
  terminates (trm_app t1 t2) ->
  terminates t2.
Proof.
  introv [v H]. inversions H. inverts_false. exists__*.
Defined.

Lemma terminates_app_3 : forall t3 v2 t1 t2,
  terminates (trm_app t1 t2) ->
  reds t1 (trm_abs t3) ->
  reds t2 v2 ->
  terminates (t3 ^^ v2).
Proof.
  introv [v H] R1' R2'. inverts H as R1 R2 R3.
  inverts_false.
  lets E: (reds_deterministic R1' R1). inversions E.
  lets E: (reds_deterministic R2 R2'). inversions E.
  exists__*.
Defined.

Lemma terminates_app_bvar_not : forall t1 t2 i,
  terminates (trm_app t1 t2) ->
  reds t1 (trm_bvar i) -> False.
Proof.
  introv [v T] R. inversions T.
  inversions R; inverts_false.
  lets E: (reds_deterministic R H1). inversions E.
Defined.

Lemma terminates_app_fvar_not : forall t1 t2 x,
  terminates (trm_app t1 t2) ->
  reds t1 (trm_fvar x) -> False.
Proof.
  introv [v T] R. inversions T.
  inversions R; inverts_false.
  lets E: (reds_deterministic R H1). inversions E.
Defined.

Lemma terminates_app_app_not : forall t1 t2 v1 v2,
  terminates (trm_app t1 t2) ->
  reds t1 (trm_app v1 v2) -> False.
Proof.
  introv [v T] R. inversions T.
  inversions R; inverts_false.
  lets E: (reds_deterministic R H1). inversions E.
Defined.

Inductive ends (t:trm) : Prop :=
  | ends_intro :
     (forall t1, t = trm_abs t1 -> True) ->
     (forall t1 t2, t = trm_app t1 t2 -> ends t1) ->
     (forall t1 t2, t = trm_app t1 t2 -> ends t2) ->
     (forall t1 t2 t3 v2, t = trm_app t1 t2 ->
        reds t1 (trm_abs t3) ->
        reds t2 v2 ->
        ends (t3 ^^ v2)) ->
     ends t.

Lemma terminates_ends : forall t,
  terminates t -> ends t.
Proof.
  introv [v H]. induction H.
  inversions H. constructor; introv Eq; inversions Eq.
   auto.
  constructor; introv Eq; inversions Eq.
  auto.
  auto.
  introv R2 R3.
  lets E: (reds_deterministic R2 H). inversions E.
  lets E: (reds_deterministic R3 H0). inversions E.
  auto.
Defined.

Definition eval_core :
  forall (t:trm) (H:terminates t), (returns_of t).
Proof.
introv H.
lets H': (terminates_ends H). gen H.
induction H' as [t H0 H1 IH1 H2 IH2 H3 IH3].
introv H. destruct t.
false* terminates_bvar_not.
false* terminates_fvar_not.
constructors. apply~ terminates_abs.
destruct~ (IH1 t1 t2) as [v1 R1]. apply* terminates_app_1.
destruct~ (IH2 t1 t2) as [v2 R2]. apply* terminates_app_2.
destruct v1.
  false* terminates_app_bvar_not.
  false* terminates_app_fvar_not.
  destruct~ (IH3 t1 t2 v1 v2) as [v3 R3].
   apply* terminates_app_3.
   constructors. apply* reds_red.
    false* terminates_app_app_not.
Defined.

Definition eval (t:trm) (H:terminates t) :=
  proj1_sig (eval_core H).

Require Import Metatheory.

Hint Constructors term.

Definition test :=
  trm_app (trm_abs (trm_bvar 0)) (trm_abs (trm_bvar 0)).

Lemma terminates_test : terminates test.
Proof.
  exists (trm_abs (trm_bvar 0)).
  unfold test.
  constructors.
  apply reds_val. apply value_abs. apply (@term_abs {}).
   intros. unfold open. simple~.
  apply reds_val. apply value_abs. apply (@term_abs {}).
   intros. unfold open. simple~.
  unfold open. simpl. apply reds_val.
  apply value_abs. apply (@term_abs {}).
   intros. unfold open. simple~.
Defined.

Eval compute in (eval terminates_test).
(* It works !! *)


Load "4_bag_functions".

Fixpoint count' (v:nat) (s:bag) : nat :=
  match s with
  | []        => 0
  | cons x s' => match (Nat.eqb x v) with
                | true  => 1 + (count' x s') (* this is the only difference with original count. *)
(* The reason for this change is when we case on Nat.eqb n v in the theorem below, it's using different tricks to prove *)
                | false => count' v s'
                end
  end.

Example cool_example_1 : count' 1 (sum [ 1 ; 2 ; 3 ] [ 1; 2; 3 ] ) = 2 * count' 1 [ 1 ; 2 ; 3 ].
Proof.
  simpl.
  reflexivity.
Qed.

Require Import PeanoNat.

Lemma really_fancy : forall (s : bag) (v : nat), S (count' v s) = count' v (cons v s).
Proof.
  intros s v.
  simpl.
  rewrite Nat.eqb_refl.
  reflexivity.
Qed.

SearchAbout ((_ =? _) = true).
Check Nat.eqb_eq.
Axiom woot : forall (v n : nat), Nat.eqb v n = true <-> v = n.

Lemma some_lemma : forall (s1 s2 : bag) (v n : nat), Nat.eqb n v = true -> S (count' n s1) + count' v s2 = S (count' v s1 + count' v s2).
Proof.
  intros s1 s2 v n.
  intros n_eqb_v.
  assert (n = v).
  rewrite <- Nat.eqb_eq.
  exact n_eqb_v.
  rewrite H.
  reflexivity.
Qed.

Theorem my_cool_theorem : forall (s1 s2 : bag) (v : nat), count' v s1 + count' v s2 = count' v (sum s1 s2).
Proof.
  intros s1 s2 v.
  induction s1.
  - (* base *) simpl. reflexivity.
  - (* i.h. *) case (Nat.eqb n v) eqn:Hn.
    + (* v == n *)
      (* Nat.eqb is boolean, let's first convert it to = *)
      assert (n = v). rewrite <- Nat.eqb_eq. exact Hn.
      (* At this point we have H : n = v. Just rewrite *)
      simpl. rewrite Hn.
      (* Use our fancy lemma just for demo purposes, we can just rewrite H instead *)
      rewrite (some_lemma s1 s2 v n Hn). rewrite IHs1. rewrite H. reflexivity.
    + (* v != n *) simpl. rewrite Hn. exact IHs1.
Qed.

Theorem my_cool_theorem_simpl : forall (s1 s2 : bag) (v : nat), count v s1 + count v s2 = count v (sum s1 s2).
Proof.
  intros s1 s2 v.
  induction s1.
  - (* base *) simpl. reflexivity.
  - (* i.h. *) case (Nat.eqb n v) eqn:Hn.
    + (* v == n *) simpl. rewrite Hn. simpl. rewrite IHs1. reflexivity.
    + (* v != n *) simpl. rewrite Hn. exact IHs1.
Qed.


Require Import ZArith.
Require Import Psatz.
Require Import Coq.Classes.RelationClasses.
Require Import TLC.LibTactics.
Require Import TLC.LibOrder.
Require Import LibFunOrd LibZExtra.
Require Import Filter.

(* todo: move *)
Lemma preorder_of_PreOrder A (R : A -> A -> Prop) :
  PreOrder R ->
  preorder R.
Proof.
  intros (HR & HT). constructor.
  - apply HR.
  - intros y x z H1 H2. apply HT with (y := y); assumption.
Qed.

Section General_facts.
Context {A} (leA : A -> A -> Prop) {OA : preorder leA}.
Context {B} (leB : B -> B -> Prop) {OB : preorder leB}.
Context {C} (leC : C -> C -> Prop) {OC : preorder leC}.

Lemma monotonic_eq : forall f g,
  monotonic leA leB f ->
  (forall a, f a = g a) ->
  monotonic leA leB g.
Proof.
  introv M E.
  intros a1 a2 H. rewrite <-!E. apply M. auto.
Qed.

Lemma monotonic_id :
  monotonic leA leA (fun (x: A) => x).
Proof. intros a1 a2. auto. Qed.

Lemma monotonic_comp : forall (f : B -> C) (g : A -> B),
  monotonic leB leC f ->
  monotonic leA leB g ->
  monotonic leA leC (fun x => f (g x)).
Proof. introv Hf Hg. intros a1 a2 ?. auto. Qed.

Lemma monotonic_cst : forall b,
  monotonic leA leB (fun (_ : A) => b).
Proof. intros b a1 a2 ?. applys OB. Qed.

Lemma monotonic_after_of_monotonic : forall (f : A -> B),
  monotonic leA leB f ->
  (forall (a : A), monotonic (le_after a leA) leB f).
Proof.
  intros f fmon a.
  intros a1 a2 H. apply fmon. apply H.
Qed.

Lemma monotonic_of_monotonic_after : forall (f : A -> B),
  (forall a, monotonic (le_after a leA) leB f) ->
  monotonic leA leB f.
Proof.
  intros f fmon.
  intros a1 a2 H. eapply fmon.
  splits; try (apply preorder_refl; typeclass); assumption.
Qed.

Lemma monotonic_after_weaken : forall (f : A -> B) (a1 a2 : A),
  leA a1 a2 ->
  monotonic (le_after a1 leA) leB f ->
  monotonic (le_after a2 leA) leB f.
Proof.
  intros f a1 a2 H fmon.
  intros x y Hxy. apply fmon.
  splits; try apply Hxy;
  eapply (preorder_trans a2); first [apply H | apply Hxy].
  Unshelve. typeclass. typeclass.
Qed.

End General_facts.

Lemma ultimately_monotonic_of_monotonic :
  forall (A : filterType) B
         (leA : A -> A -> Prop) (leB : B -> B -> Prop)
         (f : A -> B),
  monotonic leA leB f ->
  ultimately A (fun a => monotonic (le_after a leA) leB f).
Proof.
  introv fmon. applys filter_universe_alt.
  eapply monotonic_after_of_monotonic. apply fmon.
Qed.

Section Z_facts.
Local Open Scope Z.

Context {A} (leA: A -> A -> Prop) {OA: preorder leA}.

Lemma monotonic_sum : forall (f g : A -> Z),
  monotonic leA Z.le f ->
  monotonic leA Z.le g ->
  monotonic leA Z.le (fun x => f x + g x).
Proof.
  introv Hf Hg. intros a1 a2 ?.
  forwards~: Hf a1 a2. forwards~: Hg a1 a2. lia.
Qed.

Lemma monotonic_max : forall (f g : A -> Z),
  monotonic leA Z.le f ->
  monotonic leA Z.le g ->
  monotonic leA Z.le (fun x => Z.max (f x) (g x)).
Proof.
  introv Hf Hg. intros a1 a2 ?.
  forwards~: Hf a1 a2. forwards~: Hg a1 a2. lia.
Qed.

Lemma monotonic_mul : forall (f g : A -> Z),
  (forall x, 0 <= f x) ->
  (forall x, 0 <= g x) ->
  monotonic leA Z.le f ->
  monotonic leA Z.le g ->
  monotonic leA Z.le (fun x => f x * g x).
Proof.
  introv Pf Pg Hf Hg. intros a1 a2 ?.
  forwards~: Pf a1. forwards~: Pf a2. forwards~: Pg a1. forwards~: Pg a2.
  forwards~: Hf a1 a2. forwards~: Hg a1 a2. nia.
Qed.

Lemma monotonic_mul_cst_l : forall (f : A -> Z) (c : Z),
  0 <= c ->
  monotonic leA Z.le f ->
  monotonic leA Z.le (fun x => c * f x).
Proof.
  introv cpos Hf. intros a1 a2 H.
  forwards~: Hf a1 a2. nia.
Qed.

Lemma monotonic_mul_cst_r : forall (f : A -> Z) (c : Z),
  0 <= c ->
  monotonic leA Z.le f ->
  monotonic leA Z.le (fun x => f x * c).
Proof.
  introv cpos Hf.
  intros a1 a2 H. forwards~: Hf a1 a2. nia.
Qed.

Lemma monotonic_log2 : monotonic Z.le Z.le Z.log2.
Proof.
  intros a1 a2 H. apply~ Z.log2_le_mono.
Qed.

Lemma monotonic_pow_l : forall e,
  monotonic (le_after 0 Z.le) Z.le (fun b => b ^ e).
Proof.
  intros e a1 a2 H. apply~ Z.pow_le_mono_l. splits; apply H.
Qed.

Lemma monotonic_pow_r : forall b,
  0 < b ->
  monotonic Z.le Z.le (Z.pow b).
Proof.
  intros b a1 a2 H. apply~ Z.pow_le_mono_r.
Qed.

Lemma monotonic_Z_to_ZZ : forall f g,
  monotonic Z.le Z.le f ->
  monotonic Z.le Z.le g ->
  monotonic Z.le ZZle (fun x => (f x, g x)).
Proof.
  intros f g Hf Hg x y H. unfold ZZle. auto.
Qed.

End Z_facts.

Section Ultimately_Z_facts.
Local Open Scope Z.

Lemma ultimately_monotonic_mul :
  forall (A : filterType) (leA : A -> A -> Prop)
         {OA: preorder leA}
         (f g : A -> Z),
  ultimately A (fun x => 0 <= f x) ->
  ultimately A (fun x => 0 <= g x) ->
  ultimately A (fun a => monotonic (le_after a leA) Z.le f) ->
  ultimately A (fun a => monotonic (le_after a leA) Z.le g) ->
  ultimately A (fun a => monotonic (le_after a leA) Z.le (fun x => f x * g x)).
Proof.
  introv OA. introv. filter_closed_under_intersection.
  introv (Pf & Pg & Hf & Hg). intros a1 a2 (a_le_a1 & a_le_a2 & a1_le_a2).
  forwards~: Hf a a1; forwards~: Hg a a1;
  forwards~: Hf a1 a2; forwards~: Hg a1 a2;
  try (splits; first [apply OA | assumption]).
  nia.
Qed.

End Ultimately_Z_facts.

(******************************************************************************)
(* Add lemmas to a [monotonic] hint base. *)

Hint Resolve monotonic_cst : monotonic.
Hint Resolve monotonic_id : monotonic.
Hint Resolve monotonic_sum : monotonic.
Hint Extern 1 (monotonic _ _ (fun _ => Z.sub _ ?y)) =>
  apply monotonic_sum : monotonic.
Hint Extern 1 (monotonic _ _ (Z.sub ?y)) =>
  apply monotonic_sum : monotonic.
Hint Resolve monotonic_max : monotonic.
Hint Resolve monotonic_mul : monotonic.
Hint Resolve monotonic_mul_cst_l : monotonic.
Hint Resolve monotonic_mul_cst_r : monotonic.
Hint Resolve monotonic_log2 : monotonic.
Hint Resolve monotonic_pow_l : monotonic.
Hint Resolve monotonic_pow_r : monotonic.
Hint Extern 1 (monotonic _ _ (fun _ => Z.log2 _)) =>
  apply monotonic_comp with (leB := Z.le);
  [ apply monotonic_log2 | ] : monotonic.
Hint Extern 2 (monotonic _ _ (fun _ => Z.pow ?b _)) =>
  apply monotonic_comp with (leB := Z.le);
  [ apply monotonic_pow_r | ].
Hint Extern 2 (monotonic _ _ (Z.pow ?b)) =>
  apply monotonic_comp with (leB := Z.le);
  [ apply monotonic_pow_r | ].
(* todo: Z.pow _ ?e *)
Hint Resolve monotonic_Z_to_ZZ : monotonic.

Hint Extern 1 (monotonic _ _ (fun _ => ?f _)) =>
  match goal with
  | H: monotonic ?le _ f |- _ =>
    apply monotonic_comp with (leB := le); [ apply H | ]
  end : monotonic.

Hint Extern 0 (preorder _) =>
  first [ typeclass
        | apply preorder_of_PreOrder; typeclass ]
  : monotonic.

Hint Extern 100 => try (intros; omega) : monotonic_sidegoals.

Hint Extern 999 (monotonic _ _ _) => shelve : monotonic_fallback.
Hint Extern 999 (preorder _) => shelve : monotonic_fallback.

(******************************************************************************)

(* TODO: make the search depth customisable *)

Ltac monotonic :=
  unshelve (auto 20 with zarith typeclass_instances
                         monotonic
                         monotonic_sidegoals
                         monotonic_fallback).

Ltac monotonic_trysolve :=
  auto 20 with zarith typeclass_instances
               monotonic_sidegoals
               monotonic.

(* TODO: extend monotonic_Z to handle monotonic (le_after ..) .., and ultimately
   (fun a => monotonic (le_after a ..) ..) *)

(* Ltac monotonic_Z_auto_step := *)
(*   match goal with *)
(*   | |- @monotonic _ _ _ _ _ => *)
(*     let a := fresh "a" in *)
(*     apply monotonic_of_monotonic_after; [ *)
(*         eauto; typeclass *)
(*       | intro a; *)
(*         monotonic_after_Z_auto; *)
(*         try apply monotonic_after_of_monotonic ] *)
(*   | |- @monotonic_after _ _ _ _ _ _ => *)
(*     eapply monotonic_after_of_monotonic; eauto *)
(*   | |- context [ @monotonic_after _ _ _ _ _ ] => *)
(*     eapply ultimately_monotonic_of_monotonic; *)
(*     eauto; try typeclass *)
(*   end. *)


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Functor Functor.Functor_Ops.
From Categories Require Import Coq_Cats.Type_Cat.Type_Cat.
From Categories Require Import Ext_Cons.Prod_Cat.Prod_Cat.
From Categories Require Import Cat.Cat.
From Categories Require Import NatTrans.NatTrans NatTrans.Operations NatTrans.Func_Cat
        NatTrans.NatIso.

Local Open Scope isomorphism_scope.
Local Open Scope morphism_scope.
Local Open Scope object_scope.

(** If two categories are isomorphic, then so are their duals. *)
Section Opposite_Cat_Iso.
  Context {C D : Category} (I : C ≃≃ D ::> Cat).

  Program Definition Opposite_Cat_Iso :
    (C^op)%category ≃≃ (D^op)%category ::> Cat
    :=
      {|
        iso_morphism := ((iso_morphism I)^op)%functor;
        inverse_morphism := ((inverse_morphism I)^op)%functor
      |}.

  Next Obligation.
    change (I ⁻¹ ^op ∘ (iso_morphism I) ^op)%functor
    with (((inverse_morphism I) ∘ (iso_morphism I))^op)%functor.
    cbn_rewrite (left_inverse I).
    trivial.
  Qed.

  Next Obligation.
    change ((iso_morphism I) ^op ∘ I ⁻¹ ^op)%functor
    with (((iso_morphism I) ∘ (inverse_morphism I))^op)%functor.
    cbn_rewrite (right_inverse I).
    trivial.
  Qed.

End Opposite_Cat_Iso.

(** Conversion from a category to another isomorphic category. *)
Section Cat_IConv.
  Context {C D : Category} (I : C ≃≃ D ::> Cat).

  (** Object conversion through an isomorphism and its inverse isomorphism
      gives back the same object. *)
  Definition Cat_Iso_Obj_conv (c : C) :
    c = (((inverse_morphism I) _o) (((iso_morphism I) _o) c))%object.
  Proof.
    change (I ⁻¹ _o ((iso_morphism I) _o c))
    with ((I ⁻¹ ∘ I)%morphism _o c)%object;
    rewrite (left_inverse I); trivial.
  Qed.

  (** Homomorphism types remain the smae after object conversion through an
      isomorphism and its inverse isomorphism. *)
  Definition Cat_Iso_Hom_conv (c c' : C) :
    ((((inverse_morphism I) _o) (((iso_morphism I) _o) c))
      –≻
      (((inverse_morphism I) _o) (((iso_morphism I) _o) c')))%morphism
    = (c –≻ c').
  Proof.
    do 2 rewrite <- Cat_Iso_Obj_conv; trivial.
  Defined.

  (** Type conversion to the original hom type after conversion with
      an isomorphism and its inverse. *)
  Definition Cat_Iso_conv_inv {c c' : C}
             (h :
                (((inverse_morphism I) _o) (((iso_morphism I) _o) c))
                  –≻ (((inverse_morphism I) _o) (((iso_morphism I) _o) c')))
    : c –≻ c' :=
    match Cat_Iso_Hom_conv c c' in _ = Y return Y with
      eq_refl => h
    end.

  (** Heterogenous equality of type conversion to the original hom type after
      conversion with an isomorphism and its inverse. *)
  Theorem Cat_Iso_conv_inv_JMeq {c c' : C}
          (h :
             (((inverse_morphism I) _o) (((iso_morphism I) _o) c))
               –≻ (((inverse_morphism I) _o) (((iso_morphism I) _o) c')))
    : Cat_Iso_conv_inv h ~= h.
  Proof.
    unfold Cat_Iso_conv_inv.
    destruct Cat_Iso_Hom_conv.
    trivial.
  Qed.

  (** Type conversion to the original hom type after conversion with the
      inverse of an isomorphism and that isomorphism. *)
  Definition Cat_Iso_conv {c c' : C} (h : c –≻ c') :
    (((inverse_morphism I) _o) (((iso_morphism I) _o) c))
      –≻ (((inverse_morphism I) _o) (((iso_morphism I) _o) c'))
    :=
    match eq_sym (Cat_Iso_Hom_conv c c') in _ = Y return Y with
      eq_refl => h
    end.

  (** Heterogenous equality of type conversion to the original hom type after
      conversion with the inverse of an isomorphism and that isomorphism. *)
  Theorem Cat_Iso_conv_JMeq {c c' : C} (h : c –≻ c') : Cat_Iso_conv h ~= h.
  Proof.
    unfold Cat_Iso_conv.
    destruct Cat_Iso_Hom_conv.
    trivial.
  Qed.

  (** Conversion once through an isomrphism and its inverse and once through
      its inverse and it gives back the same arrow as we strated with. *)
  Theorem Cat_Iso_conv_inv_Cat_Iso_conv {c c' : C} (h : c –≻ c')
    : Cat_Iso_conv_inv (Cat_Iso_conv h) = h.
  Proof.
    unfold Cat_Iso_conv_inv, Cat_Iso_conv.
    destruct Cat_Iso_Hom_conv; trivial.
  Qed.

  (** Conversion once through the inverse of an isomrphism and that isomorphism
      and once through that isomorphism and its inverse gives back the same
      arrow as we strated with. *)
  Theorem Cat_Iso_conv_Cat_Iso_conv_inv {c c' : C}
          (h :
             (((inverse_morphism I) _o) (((iso_morphism I) _o) c))
               –≻ (((inverse_morphism I) _o) (((iso_morphism I) _o) c')))
    :
      Cat_Iso_conv (Cat_Iso_conv_inv h) = h.
  Proof.
    unfold Cat_Iso_conv_inv, Cat_Iso_conv.
    destruct Cat_Iso_Hom_conv; trivial.
  Qed.

  (** Conversion of an arrow through an isomorphism and its inverse (after
      correcting the homorphism type) is the same arrow as we started with. *)
  Theorem Cat_Iso_conv_inv_I_inv_I {c c' : C} (h : c –≻ c') :
    Cat_Iso_conv_inv (((inverse_morphism I) _a) (((iso_morphism I) _a) h)) = h.
  Proof.
    match goal with
      [|- ?A = ?B] =>
      let H := fresh "H" in
      cut (A ~= B); [intros H; rewrite H; trivial|]
    end.
    unfold Cat_Iso_conv_inv.
    destruct Cat_Iso_Hom_conv.
    change (I ⁻¹ _a ((iso_morphism I) _a h)) with ((I ⁻¹ ∘ I)%morphism _a h).
    apply (@JMeq_trans _ _ _ _ ((Functor_id _) _a h) _); trivial.
    cbn_rewrite <- (left_inverse I).
    trivial.
  Qed.

  (** Morphism composition commutes with conversion. *)
  Theorem Cat_Iso_conv_inv_compose {c c' c'' : C}
          (h :
             (((inverse_morphism I) _o) (((iso_morphism I) _o) c))
               –≻ (((inverse_morphism I) _o) (((iso_morphism I) _o) c'))
          )
          (h' :
             (((inverse_morphism I) _o) (((iso_morphism I) _o) c'))
               –≻ (((inverse_morphism I) _o) (((iso_morphism I) _o) c''))
          )
    :
      Cat_Iso_conv_inv (compose C h h')
      = compose C (Cat_Iso_conv_inv h) (Cat_Iso_conv_inv h').
  Proof.
    unfold Cat_Iso_conv_inv, Cat_Iso_Hom_conv.
    do 3 destruct Cat_Iso_Obj_conv; trivial.
  Qed.

End Cat_IConv.

Section Cat_Iso_inv.
  Context {C D : Category} (I : C ≃≃ D ::> Cat).

  (** The main theorem of this module. Given an isomorphism I between
      categories C and D, for each morphism h: Hom (I _o c) (I _o c')
      in D, there is a morphism g in C such that the conversion of h
      through I (I _a g) gives back the smae arrow, i.e., h = (I _a h). *)
  Theorem Cat_Iso_inv
          {c c' : C} (h : ((iso_morphism I) _o c) –≻ ((iso_morphism I) _o c'))
    : {g : c –≻ c' | h = ((iso_morphism I) _a g)}.
  Proof.
    exists (Cat_Iso_conv_inv I ((inverse_morphism I) _a h)).
    match goal with
      [|- ?A = ?B] =>
        etransitivity;
        [apply (eq_sym (@Cat_Iso_conv_inv_I_inv_I D C (I⁻¹) _ _ A))|
         etransitivity; [|apply (@Cat_Iso_conv_inv_I_inv_I D C (I⁻¹) _ _ B)]]
    end.
    do 2 apply f_equal.
    match goal with
      [|- ?A = ?B] =>
        etransitivity;
        [apply (eq_sym (@Cat_Iso_conv_Cat_Iso_conv_inv C D I _ _ A))|
         etransitivity; [|apply (@Cat_Iso_conv_Cat_Iso_conv_inv C D I _ _ B)]]
    end.
    apply f_equal.
    rewrite Cat_Iso_conv_inv_I_inv_I; trivial.
  Qed.

End Cat_Iso_inv.

(**
Given I : C ≃ D for categories C and D and F : D -> E, F ∘ (I ∘ I⁻¹) and F are
naturally isomorphic.
*)
Section IsoCat_NatIso.
  Context {C D : Category} (I : (C ≃≃ D ::> Cat)%morphism)
          {E : Category} (F : (D –≻ E)%functor).

  Program Definition IsoCat_NatIso :
    ((F ∘ ((iso_morphism I) ∘ (I⁻¹)%morphism))%functor ≃ F)%natiso :=
    {|
      iso_morphism := IsoCat_NatTrans I F;
      inverse_morphism := IsoCat_NatTrans_back I F
    |}
  .

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    FunExt.
    cbn.
    match goal with
      [|- ((match ?e with _ => _ end) ∘ (match ?e with _ => _ end))%morphism = _] =>
      destruct e
    end.
    auto.
  Qed.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    FunExt.
    cbn.
    match goal with
      [|- ((match ?e with _ => _ end) ∘ (match ?e with _ => _ end))%morphism = _] =>
      destruct e
    end.
    auto.
  Qed.

End IsoCat_NatIso.


(**************************************************************************)
(*  This is part of ATBR, it is distributed under the terms of the        *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2009-2011: Thomas Braibant, Damien Pous.               *)
(**************************************************************************)

(** This module defines all classes of our algebraic hierarchy *)

Require Import Common.

(** * Graph : base class of the hierarchy

   a multigraph with indexed equalities on vertices. *)

(* RMK: we do not separate operators (equal) from axioms
   (equal_equivalence) for this base class. This is to be able to add
   reflexivity as a trivial hint, and symmetry as an immediate
   one. This might change in the future, if the semantics of hints for
   lemmas with maximally inserted implicit arguments changes.
   *)

Class Graph := {
  T: Type;
  X: T -> T -> Type;
  equal: forall A B, relation (X A B);
  equal_:> forall A B, Equivalence (equal A B)
}.

(*Arguments equal : simpl never.*)

Set Implicit Arguments.

Bind Scope A_scope with X.

Section Ops.
(** * Operations

   All operations are parametrised by the [Graph] base-class

*)
  Context (G: Graph).

  Class Monoid_Ops := {
    dot: forall A B C, X A B -> X B C -> X A C;
    one: forall A,     X A A
  }.

  Class SemiLattice_Ops := {
    plus: forall A B, X A B -> X A B -> X A B;
    zero: forall A B, X A B;
    leq: forall A B: T, relation (X A B) := fun A B x y => equal A B (plus A B x y) y
  }.

  Class Star_Op := {
    star: forall A, X A A -> X A A
  }.

  Class Converse_Op := {
    conv: forall A B, X A B -> X B A
  }.

End Ops.

(** Notations for operations *)
Notation "x == y"  := (equal _ _ x y) (at level 70): A_scope.
Notation "x <== y" := (leq _ _ x y) (at level 70): A_scope.
Notation "x * y"   := (dot _ _ _ x y) (at level 40, left associativity): A_scope.
Notation "x + y"   := (plus _ _ x y) (at level 50, left associativity): A_scope.
Notation "x #"     := (star _ x) (at level 15, left associativity): A_scope.
Notation "x `"     := (conv _ _ x) (at level 15, left associativity): A_scope.
Notation "1"       := (one _): A_scope.
Notation "0"       := (zero _ _): A_scope.

Open Scope A_scope.
Delimit Scope A_scope with A.

(* Unset Implicit Arguments. *)
Unset Strict Implicit.

Section Structures.
(** * Structures

   All structures are parametrised by both the [Graph] base-class and the corresponding operations.
   *)

  Context {G: Graph}.
  Context {Mo: Monoid_Ops G} {SLo: SemiLattice_Ops G} {Ko: Star_Op G} {Co: Converse_Op G}.

  Class Monoid := {
    dot_compat:> forall A B C, Proper (equal A B ==> equal B C ==> equal A C) (dot A B C);
    dot_assoc: forall A B C D (x: X A B) y (z: X C D), x*(y*z) == (x*y)*z;
    dot_neutral_left:  forall A B (x: X A B), 1*x == x;
    dot_neutral_right:  forall A B (x: X B A), x*1 == x
  }.

  Class SemiLattice := {
    plus_compat:> forall A B, Proper (equal A B ==> equal A B ==> equal A B) (plus A B);
    plus_neutral_left: forall A B (x: X A B), 0+x == x;
    plus_idem: forall A B (x: X A B), x+x == x;
    plus_assoc: forall A B (x y z: X A B), x+(y+z) == (x+y)+z;
    plus_com: forall A B (x y: X A B), x+y == y+x
  }.

  Class IdemSemiRing := {
    ISR_Monoid :> Monoid;
    ISR_SemiLattice :> SemiLattice;
    dot_ann_left:  forall A B C (x: X B C), zero A B * x == 0;
    dot_ann_right: forall A B C (x: X C B), x * zero B A == 0;
    dot_distr_left:  forall A B C (x y: X A B) (z: X B C), (x+y)*z == x*z + y*z;
    dot_distr_right: forall A B C (x y: X B A) (z: X C B), z*(x+y) == z*x + z*y
  }.

  Class KleeneAlgebra := {
    KA_ISR :> IdemSemiRing;
    star_make_left: forall A (a:X A A), 1 + a#*a == a#;
    star_destruct_left: forall A B (a: X A A) (c: X A B), a*c <== c  ->  a#*c <== c;
    star_destruct_right: forall A B (a: X A A) (c: X B A), c*a <== c  ->  c*a# <== c
  }.

  (** Once we add the converse operation, we no longer need some
     axioms from Monoid/SemiRing/KA.  This is why we do not use direct
     inheritance *)
  (* TODO: introduce an intermediate ConverseMonoid class *)

  Class ConverseIdemSemiRing := {
    CISR_SL :> SemiLattice;
    dot_compat_c: forall A B C, Proper (equal A B ==> equal B C ==> equal A C) (dot A B C);
    dot_assoc_c: forall A B C D (x: X A B) y (z: X C D), x*(y*z) == (x*y)*z;
    dot_neutral_left_c:  forall A B (x: X A B), 1*x == x;

    conv_compat:> forall A B, Proper (equal A B ==> equal B A) (conv A B);
    conv_invol: forall A B (x: X A B), x`` == x;
    conv_dot:  forall A B C (x: X A B) (y: X B C), (x*y)` == y`*x`;
    conv_plus:  forall A B (x y: X A B), (x+y)` == y`+x`;
    dot_ann_left_c:  forall A B C (x: X B C), zero A B * x == 0;
    dot_distr_left_c:  forall A B C (x y: X A B) (z: X B C), (x+y)*z == x*z + y*z
  }.

  Class ConverseKleeneAlgebra := {
    CKA_CISR :> ConverseIdemSemiRing;
    star_make_left_c: forall A (a:X A A), 1 + a#*a == a#;
    star_destruct_left_c: forall A B (a: X A A) (c: X A B), a*c <== c  ->  a#*c <== c
  }.

End Structures.

(** we want to keep the graph explicit, for better readability, (but
   we still want the graph to be maximally implicit in projections
   like [dot_assoc]. *)
Arguments Monoid G {Mo}.
Arguments SemiLattice G {SLo}.
Arguments IdemSemiRing G {Mo SLo}, G Mo SLo.
Arguments ConverseIdemSemiRing G {Mo} {SLo} {Co}.
Arguments KleeneAlgebra G {Mo} {SLo} {Ko}.
Arguments ConverseIdemSemiRing G {Mo} {SLo} {Co}.
Arguments ConverseKleeneAlgebra G {Mo} {SLo} {Ko} {Co}.

(** * Dual structures

   These structures are obtained by reversing all arrows; they make it
   possible to factorise several proofs, by symmetry.
   *)

Module Dual. Section Protect.

  Local Transparent equal.

  Context (G: Graph).
  Context {Mo: Monoid_Ops G} {SLo: SemiLattice_Ops G} {Ko: Star_Op G} {Co: Converse_Op G}.

  Instance Graph: Graph := {
    T := T;
    X A B := X B A;
    equal A B := equal B A;
    equal_ A B := equal_ B A
  }.

  Instance Monoid_Ops: Monoid_Ops Graph := {
    dot A B C x y := @dot _ Mo C B A y x;
    one := @one _ Mo
  }.

  Instance SemiLattice_Ops: SemiLattice_Ops Graph := {
    plus A B := @plus _ SLo B A;
    zero A B := @zero _ SLo B A
  }.

  Instance Star_Op: Star_Op Graph := {
    star := @star _ Ko
  }.

  Instance Converse_Op: Converse_Op Graph := {
    conv A B := @conv _ Co B A
  }.

  Program Instance Monoid {M: Monoid G}: Monoid Graph := {
    dot_neutral_left := @dot_neutral_right _ _ M;
    dot_neutral_right := @dot_neutral_left _ _ M;
    dot_compat A B C x x' Hx y y' Hy := @dot_compat _ _ M C B A _ _ Hy _ _ Hx
  }.
  Obligation 1.
    intros. symmetry. simpl. apply dot_assoc.
  Defined.

  Instance SemiLattice {SL: SemiLattice G}: SemiLattice Graph := {
    plus_com A B := @plus_com _ _ SL B A;
    plus_idem A B := @plus_idem _ _ SL B A;
    plus_assoc A B := @plus_assoc _ _ SL B A;
    plus_compat A B := @plus_compat _ _ SL B A;
    plus_neutral_left A B := @plus_neutral_left _ _ SL B A
  }.

  Instance IdemSemiRing {ISR: IdemSemiRing G}: IdemSemiRing Graph.
  Proof.
    intros.
    constructor.
    exact Monoid.
    exact SemiLattice.
    exact (@dot_ann_right _ _ _ ISR).
    exact (@dot_ann_left _ _ _ ISR).
    exact (@dot_distr_right _ _ _ ISR).
    exact (@dot_distr_left _ _ _ ISR).
  Defined.

End Protect. End Dual.