From Hammer Require Import Hammer.

Require Export Classical.
Require Import ChoiceFacts.

Set Implicit Arguments.

Axiom constructive_indefinite_description :
forall (A : Type) (P : A->Prop),
(exists x, P x) -> { x : A | P x }.

Lemma constructive_definite_description :
forall (A : Type) (P : A->Prop),
(exists! x, P x) -> { x : A | P x }.
Proof. hammer_hook "ClassicalEpsilon" "ClassicalEpsilon.constructive_definite_description".
intros; apply constructive_indefinite_description; firstorder.
Qed.

Theorem excluded_middle_informative : forall P:Prop, {P} + {~ P}.
Proof. hammer_hook "ClassicalEpsilon" "ClassicalEpsilon.excluded_middle_informative".
apply
(constructive_definite_descr_excluded_middle
constructive_definite_description classic).
Qed.

Theorem classical_indefinite_description :
forall (A : Type) (P : A->Prop), inhabited A ->
{ x : A | (exists x, P x) -> P x }.
Proof. hammer_hook "ClassicalEpsilon" "ClassicalEpsilon.classical_indefinite_description".
intros A P i.
destruct (excluded_middle_informative (exists x, P x)) as [Hex|HnonP].
apply constructive_indefinite_description
with (P:= fun x => (exists x, P x) -> P x).
destruct Hex as (x,Hx).
exists x; intros _; exact Hx.
assert {x : A | True} as (a,_).
apply constructive_indefinite_description with (P := fun _ : A => True).
destruct i as (a); firstorder.
firstorder.
Defined.

Definition epsilon (A : Type) (i:inhabited A) (P : A->Prop) : A
:= proj1_sig (classical_indefinite_description P i).

Definition epsilon_spec (A : Type) (i:inhabited A) (P : A->Prop) :
(exists x, P x) -> P (epsilon i P)
:= proj2_sig (classical_indefinite_description P i).

Lemma epsilon_inh_irrelevance :
forall (A:Type) (i j : inhabited A) (P:A->Prop),
(exists x, P x) -> epsilon i P = epsilon j P.
Proof. hammer_hook "ClassicalEpsilon" "ClassicalEpsilon.epsilon_inh_irrelevance".
intros.
unfold epsilon, classical_indefinite_description.
destruct (excluded_middle_informative (exists x : A, P x)) as [|[]]; trivial.
Qed.

Opaque epsilon.

Theorem choice :
forall (A B : Type) (R : A->B->Prop),
(forall x : A, exists y : B, R x y) ->
(exists f : A->B, forall x : A, R x (f x)).
Proof. hammer_hook "ClassicalEpsilon" "ClassicalEpsilon.choice".
intros A B R H.
exists (fun x => proj1_sig (constructive_indefinite_description _ (H x))).
intro x.
apply (proj2_sig (constructive_indefinite_description _ (H x))).
Qed.


(*
Load Repeats.
Load Repeats_List.
Load Pigeonhole_vector.
*)

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

(** Conversion fuer Listen *)

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

(* Vorbereitung *)
(** [to_list] und [of_list] sind aus der Vector Bibliothek und wandeln Vektoren in Listen
 um und anders herum. *)

(** Umwandlung von Vektoren in Listen. *)

Lemma cons_commute_to_list {A} {n} (v : Vector.t A n) (a : A) :
      List.cons a (to_list v) = to_list (Vector.cons A a n v).
Proof.
  dependent induction v; compute; reflexivity.
Defined.

(** [to_list] und [of_list] sind zueinander inverse Isomorphismen. *)

Lemma to_list_of_list : forall{A} (l : list A), (l = to_list (of_list l)).
Proof.
  induction l.
  - compute.
    reflexivity.
  - simpl.
    rewrite IHl.
    pose (cons_commute_to_list (of_list l) a) as cons_comm.
    rewrite <- IHl in *.
    exact cons_comm.
Defined.

(** [Appears] von Vektoren auf Listen uebertragen. *)

Fixpoint Appears_to_Appears_l {A} {n} (v : Vector.t A n) (x : A) (ap_v : Appears_in x v) :
         Appears_l x (to_list v).
Proof.
  dependent destruction ap_v.
  - pose (cons_commute_to_list v x) as cons_comm.
    rewrite <- cons_comm.
    apply ai_here_l.
  - pose (cons_commute_to_list v b) as cons_comm.
    rewrite <- cons_comm.
    apply ai_later_l.
    apply Appears_to_Appears_l.
    exact ap_v.
Defined.

(** [Repeats] von Vektoren auf Listen uebertragen. *)

Fixpoint Repeats_to_Repeats_l {A} {n} (v : Vector.t A n) (rep_v : Repeats v) :
         Repeats_l (to_list v).
Proof.
  dependent destruction rep_v.
  - pose (cons_commute_to_list v x) as cons_comm.
    rewrite <- cons_comm.
    apply rp_ext_l.
    apply Repeats_to_Repeats_l.
    exact rep_v.
  - pose (cons_commute_to_list v x) as cons_comm.
    rewrite <- cons_comm.
    apply rp_intr_l.
    apply Appears_to_Appears_l.
    exact a.
Defined.

(** Pigeonhole fuer Listen. *)

Lemma pigeonhole_l: forall {n} (l : list (@Fin.t n)), length l > n ->
      Repeats_l l.
Proof.
  intros n l gt_length_q.
  pose (of_list l) as v.
  unfold gt in gt_length_q.
  pose (pigeon_hole_Repeats n (length l) gt_length_q v) as rp.
  pose (to_list v) as l'.
  pose (to_list_of_list l) as l_v_l.
  rewrite l_v_l.
  apply Repeats_to_Repeats_l.
  exact rp.
Defined.

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

(** Conversion fuer Woerter *)

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

(* Vorbereitung *)

(** Umwandlung zwischen Vektoren und Woertern. *)

Definition to_word {A} {n} (v : Vector.t A n) := list_to_word (to_list v).

Definition of_word {A} (w : @Word A) := of_list (word_to_list w).

(** [to_word] und [of_word] sind zueinander inverse Isomorphismen. *)

Lemma to_word_of_word : forall {A} (w : @Word A),
      (w = to_word (of_word w)).
Proof.
  unfold of_word in *.
  unfold to_word in *.
  intros A w.
  pose (to_list_of_list (word_to_list w)) as tl_ol.
  rewrite <- tl_ol.
  apply eq_sym.
  apply word_list_word.
Defined.

(** Aus einem Beweis aus [Repeats_l] kann ein Beweis fuer [Repeats_w]
 abgeleitet werden. Dies ist sowohl fuer die Eingabe von Listen als auch fuer Woerter
 der Fall, was in den Lemmata [lw_pres_repeats] und [wl_pres_repeats] gezeigt
 wird. *)

Lemma lw_pres_repeats {A} (l : list A) :
      Repeats_l l -> Repeats_w (list_to_word l).
Proof.
  intro rp_l.

  apply Repeats_l_decomp in rp_l as split_l.
  destruct split_l as [a split_l'].
  destruct split_l' as [l1 [l2 [l3 l_eq_l1al2al3]]].

  rewrite <- list_word_list in l_eq_l1al2al3.
  repeat rewrite list_to_word_hom in l_eq_l1al2al3.

  rewrite l_eq_l1al2al3.
  rewrite word_list_word.
  rewrite <- concat_word_associative.

  pose (lw_concat l1 l2 a) as ex_l1al2.
  destruct ex_l1al2 as [w1 [w2 l1al2_eq_w1aw2]].

  rewrite l1al2_eq_w1aw2.
  rewrite concat_word_associative.
  rewrite <- (word_list_word w2).

  pose (lw_concat (word_to_list w2) l3 a) as ex_w2al3.
  destruct ex_w2al3 as [w2' [w3 w2al3_eq_w2'aw3]].

  rewrite w2al3_eq_w2'aw3.
  rewrite <- concat_word_associative.

  apply Repeats_decomp_rev_w.
  exists a.
  exists w1.
  exists w2'.
  exists w3.

  reflexivity.
Defined.

Lemma wl_pres_repeats {A} (w : @Word A) :
      Repeats_l (word_to_list w) -> Repeats_w w.
Proof.
  rewrite <- (word_list_word w).
  rewrite list_word_list.
  apply lw_pres_repeats.
Defined.

(** Pigeonhole fuer Woerter. *)

Lemma pigeonhole_w: forall {n} (w : @Word (@Fin.t n)),
      word_length w > n -> Repeats_w w.
Proof.
  intros n w w_len.
  pose (word_to_list w) as w_as_l.
  pose (wl_pres_length w) as w_as_l_len.
  pose w_len as l_len.
  rewrite <- w_as_l_len in l_len.
  pose (pigeonhole_l w_as_l l_len) as rp_l.
  apply wl_pres_repeats.
  exact rp_l.
Defined.


Require Import Coq.Lists.List.
Require Import Coq.Arith.PeanoNat.

From QuickChick Require Import QuickChick.

(* should be in QuickChick library: *)
Global Instance Dec_iff {P Q} {H : Dec P} {I : Dec Q} : Dec (P <-> Q).
Proof.
  constructor. unfold ssrbool.decidable.
  destruct H as [D]; destruct D;
    destruct I as [D]; destruct D; intuition auto.
Defined.

(** List Sets *)

(* this would normally be kept abstract as a section variable,
   but for testing, we make it concrete *)
Definition E := nat.
Definition eeq: forall (e1 e2: E), {e1 = e2} + {e1 <> e2} := Nat.eq_dec.

Definition set: Type -> Type := list.

Definition contains(A: set E)(e: E): Prop := List.In e A.


(**********************************************************************************
 * Categories.v                                                                   *
 * Formalizing Domains, Ultrametric Spaces and Semantics of Programming Languages *
 * Nick Benton, Lars Birkedal, Andrew Kennedy and Carsten Varming                 *
 * Jan 2012                                                                      *
 * Build with Coq 8.3pl2 plus SSREFLECT                                           *
 **********************************************************************************)

Require Export ssreflect Coq.Setoids.Setoid.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(** printing T0 %\ensuremath{T_0}% *)
(** printing T1 %\ensuremath{T_1}% *)
(** printing T2 %\ensuremath{T_2}% *)
(** printing T3 %\ensuremath{T_3}% *)
(** printing T4 %\ensuremath{T_4}% *)
(** printing T5 %\ensuremath{T_5}% *)
(** printing T6 %\ensuremath{T_6}% *)

Inductive Empty : Set := .

(*=Setoid *)
Module Setoid.
  Definition axiom (T:Type) (e:T -> T -> Prop) := equiv _ e.
  Record mixin_of T := Mixin
  { set_eq : T -> T -> Prop; set_equiv : axiom set_eq }.
  Notation class_of := mixin_of (only parsing).

  Section ClassDef.
  Structure type := Pack {sort; _:class_of sort; _:Type}.
  Local Coercion sort : type >-> Sortclass.
  Definition class cT := let: Pack _ c _ := cT return class_of cT in c.
  Definition unpack K (k : forall T (c : class_of T), K T c) cT :=
    let: Pack T c _ := cT return K _ (class cT) in k _ c. (*CLEAR*)
  Definition repack cT : _ -> Type -> type := let k T c p := p c in unpack k cT. (*CLEARED*)
  Definition pack T c := @Pack T c T.
  End ClassDef.

  Module Import Exports.
  Coercion sort : type >-> Sortclass.
  Notation setoidType := type.
  Notation SetoidMixin := Mixin.
  Notation SetoidType := pack.
  End Exports.

End Setoid.
Export Setoid.Exports.

Definition tset_eq := fun T => Setoid.set_eq (Setoid.class T). (*CLEAR*)

Bind Scope S_scope with Setoid.sort.
Delimit Scope S_scope with SET.
Open Scope S_scope.

(** printing =-= %\ensuremath{\equiv}% *)
(*CLEARED*)
Infix "=-=" := tset_eq (at level 70). (*CLEAR*)

Arguments Scope tset_eq [S_scope _ _].
(*CLEARED*)
Lemma tset_refl (T:setoidType) (x:T) : x =-= x. (*CLEAR*)
unlock tset_eq. apply (proj1 (Setoid.set_equiv (Setoid.class T)) x).
Qed.

Arguments Scope tset_refl [S_scope _].
Hint Resolve tset_refl.
(*CLEARED*)
Lemma tset_trans (T:setoidType) (x y z:T) : x =-= y -> y =-= z -> x =-= z. (*CLEAR*)
unlock tset_eq. apply (proj1 (proj2 (Setoid.set_equiv (Setoid.class T))) x y z).
Qed.

Arguments Scope tset_trans [S_scope _ _ _].

Hint Immediate tset_trans. (*CLEARED*)
Lemma tset_sym (T:setoidType) (x y:T) : x =-= y -> y =-= x. (*CLEAR*)
unlock tset_eq. apply (proj2 (proj2 (Setoid.set_equiv (Setoid.class T))) x y).
Qed.

Arguments Scope tset_sym [S_scope _ _].

Hint Immediate tset_sym. (*CLEARED*)
Add Parametric Relation (T:setoidType) : T (@tset_eq T)
 reflexivity proved by (@tset_refl T) symmetry proved by (@tset_sym T)
 transitivity proved by (@tset_trans T) as tset_eqrel.
(*=End *)

(*=Category *)
Module Category.
  Section Axioms.
    Variable Ob:Type.
    Variable Morph : Ob -> Ob -> setoidType.
    Variable tcomp : forall T0 T1 T2, Morph T1 T2 -> Morph T0 T1 -> Morph T0 T2.
    Variable tid : forall T0, Morph T0 T0.
    Definition tid_left := forall T0 T1 (f:Morph T0 T1), tcomp (tid T1) f =-= f.
    Definition tid_right := forall T0 T1 (f:Morph T0 T1), tcomp f (tid T0) =-= f.
    Definition tcomp_assoc := forall T0 T1 T2 T3 (f:Morph T2 T3) (g:Morph T1 T2)
              (h:Morph T0 T1), (tcomp f (tcomp g h)) =-= (tcomp (tcomp f g) h).
    Definition tcomp_respect := forall T0 T1 T2 (f f' : Morph T1 T2)
          (g g' : Morph T0 T1), f =-= f' -> g =-= g' -> tcomp f g =-= tcomp f' g'.
  End Axioms.
  Definition axiom O M c i :=
    @tid_left O M c i /\ tid_right c i /\ tcomp_assoc c /\ tcomp_respect c.
  Record mixin_of T (Morph : T -> T -> setoidType) := Mixin
  { tcomp : forall T0 T1 T2, Morph T1 T2 -> Morph T0 T1 -> Morph T0 T2;
    tid : forall T0, Morph T0 T0;
    tcategory : axiom tcomp tid }.
  Notation class_of := mixin_of.
  Section ClassDef.
  Structure cat := Pack {object;
    morph : object -> object -> setoidType ; _:class_of morph; _:Type}.
  Local Coercion object : cat >-> Sortclass.
  Local Coercion morph : cat >-> Funclass.
  Definition class cT := let: Pack _ _ c _ := cT return class_of cT in c.
  Definition unpack (K:forall O (M:O -> O -> setoidType) (c:class_of M), Type)
    (k : forall O (M: O -> O -> setoidType) (c:class_of M), K _ _ c) (cT:cat) :=
    let: Pack _ M c _ := cT return @K _ _ (class cT) in k _ _ c. (*CLEAR*)
  Definition repack cT : _ -> Type -> cat :=
                                  let k T M c p := p c in unpack k cT.
  (*CLEARED*)
  Definition pack T M c := @Pack T M c T.
  Definition comp (cT:cat) : forall (A B C:cT),
                morph B C -> morph A B -> morph A C := tcomp (class cT).
  Definition id (cT:cat) : forall (A:cT), morph A A := tid (class cT). (*CLEAR*)
  Implicit Arguments id [cT A].
  (*CLEARED*)
  End ClassDef.

  Module Import Exports.
  Coercion object : cat >-> Sortclass.
  Coercion morph : cat >-> Funclass.
  Notation catType := cat. (*CLEAR*)
  Notation CatMixin := Mixin.
  Notation CatType := pack.
  Implicit Arguments id [cT A].
  Notation morph := Category.morph.
  Notation object := Category.object.
  End Exports.
(*CLEARED*)

End Category.
Export Category.Exports. (*CLEAR*)
Bind Scope C_scope with Category.object.
Delimit Scope C_scope with CAT.
Open Scope C_scope.
(*CLEARED*)
Infix "=->" := Category.morph (at level 55, right associativity) (*CLEAR*) : C_scope.

Arguments Scope Category.morph [_ C_scope C_scope].
(*CLEARED*)
Infix "<<" := Category.comp (at level 35) (*CLEAR*) : C_scope.

Arguments Scope Category.comp [_ C_scope C_scope C_scope S_scope S_scope].
(*CLEARED*)
Notation Id := Category.id. (*CLEAR*)
Lemma comp_respect (C:catType) (X Y Z : C) (f f' : Y =-> X) (g g' : Z =-> Y)
        : f =-= f' -> g =-= g' -> f << g =-= f' << g'.
Proof.
unfold Category.comp.
case: (Category.class C). move => c i. case => Il. case => ir. case => A R.
simpl. by apply R.
Qed.
(*CLEARED*)
Add Parametric Morphism (C:catType) X Y Z : (@Category.comp C X Y Z)
  with signature (@tset_eq (C Y Z)) ==> (@tset_eq (C X Y)) ==> (@tset_eq (C X Z))
  as comp_eq_compat. (*CLEAR*)
move => x y e f g e'.
by apply: comp_respect.
Qed.
(*CLEARED*)
Lemma comp_assoc (C:catType) (W X Y Z : C) (f:W =-> X) (g : X =-> Y)
    (h : Y =-> Z) :  h << (g << f) =-= h << g << f. (*CLEAR*)
unfold Category.comp.
case: (Category.class C). by move => c i [AA [BB A]] ; apply A.
Qed.
(*CLEARED*)
Lemma comp_idR (C:catType) (X Y : C) (f : X =-> Y) : f << Id =-= f. (*CLEAR*)
unfold Category.comp, Category.id.
case: (Category.class C). by move => c i [AA [BB A]] ; apply BB.
Qed.

Lemma comp_idL (C:catType) (X Y : C) (f : X =-> Y) : Id << f =-= f.
unfold Category.comp, Category.id.
case: (Category.class C). simpl. by move => c i [AA [BB A]] ; apply AA.
Qed.
(*CLEARED*)
(*=End *)

Definition iso (C:catType) X Y (f:C X Y) (f':C Y X) : Prop := f << f' =-= Id /\ f' << f =-= Id.

Module CatTerminal.

Definition axiom (C:catType) (T:C) := forall T' (m m' : T' =-> T), m =-= m'.

Record mixin_of (C:catType) : Type := Mixin
{
  tto : C;
  tto_exists : forall C', morph C' tto;
  tto_unique : axiom tto
}.

Section ClassDef.
Record class_of (T:Type) (M:T -> T -> setoidType) : Type :=
  Class { base : Category.class_of M ; terminal : mixin_of (CatType base) }.

Local Coercion base : class_of >-> Category.class_of.
Local Coercion terminal : class_of >-> mixin_of.

Structure cat : Type := Pack {object; morph : object -> object -> setoidType ; _ : class_of morph; _ : Type}.
Local Coercion object : cat >-> Sortclass.
Local Coercion morph : cat >-> Funclass.
Definition class cT := let: Pack _ _ c _ := cT return class_of cT in c.
Definition unpack (K:forall O (M:O -> O -> setoidType) (c:class_of M), Type)
            (k : forall O (M: O -> O -> setoidType) (c : class_of M), K _ _ c) (cT:cat) :=
  let: Pack _ M c _ := cT return @K _ _ (class cT) in k _ _ c.
Definition repack cT : _ -> Type -> cat := let k T M c p := p c in unpack k cT.
Definition pack := let k T M c m := Pack (@Class T M c m) T in Category.unpack k.
Definition catType cT := Category.pack (class cT).

End ClassDef.

Module Import Exports.
Coercion base : class_of >-> Category.class_of.
Coercion terminal : class_of >-> mixin_of.
Coercion catType : cat >-> Category.cat.

Canonical Structure catType.
Notation terminalCat := cat.
Notation terminalCatMixin := Mixin.
Notation terminalCatType := pack.
End Exports.

End CatTerminal.
Export CatTerminal.Exports.

Definition terminal (C:terminalCat) : C := CatTerminal.tto (CatTerminal.class C).
Implicit Arguments terminal [C].

Notation "'One'" := terminal : C_scope.

Definition terminal_morph (C:terminalCat) (X:C) : X =-> One := CatTerminal.tto_exists (CatTerminal.class C) X.

Lemma terminal_unique (C:terminalCat) (X : C) (m m' : X =-> One) : m =-= m'.
move: m m'. unfold terminal. case: (CatTerminal.class C). simpl. move => B [T mm A]. simpl.
move => m m'. by apply A.
Qed.

Module CatInitial.

Definition axiom (C:catType) (T:C) := forall T' (m m' : morph T T'), m =-= m'.

Record mixin_of (C:catType) : Type := Mixin
{
  init : C;
  init_exists : forall C', morph init C';
  init_unique : axiom init
}.

Section ClassDef.
Record class_of (T:Type) (M:T -> T -> setoidType) : Type :=
  Class { base : Category.class_of M ; initial : mixin_of (CatType base) }.
Local Coercion base : class_of >-> Category.class_of.
Local Coercion initial : class_of >-> mixin_of.

Structure cat : Type := Pack {object : Type; morph : object -> object -> setoidType ; _ : class_of morph; _ : Type}.
Local Coercion object : cat >-> Sortclass.
Local Coercion morph : cat >-> Funclass.
Definition class cT := let: Pack _ _ c _ := cT return class_of cT in c.
Definition unpack (K:forall O (M:O -> O -> setoidType) (c:class_of M), Type)
            (k : forall O (M: O -> O -> setoidType) (c : class_of M), K _ _ c) (cT:cat) :=
  let: Pack _ M c _ := cT return @K _ _ (class cT) in k _ _ c.
Definition repack cT : _ -> Type -> cat := let k T M c p := p c in unpack k cT.
Definition pack := let k T M c m := Pack (@Class T M c m) T in Category.unpack k.
Definition catType cT := Category.pack (class cT).
End ClassDef.
Module Import Exports.
Canonical Structure catType.
Coercion base : class_of >-> Category.class_of.
Coercion initial : class_of >-> mixin_of.
Coercion object : cat >-> Sortclass.
Coercion morph : cat >-> Funclass.

Notation initialCat := CatInitial.cat.
Notation initialCatMixin := CatInitial.Mixin.
Notation initialCatType := CatInitial.pack.

End Exports.

End CatInitial.

Export CatInitial.Exports.

Definition initial (C:initialCat) : C := CatInitial.init (CatInitial.class C).
Implicit Arguments initial [C].

Notation "'Zero'" := initial : C_scope.

Definition initial_morph (C:initialCat) X : Zero =-> X := CatInitial.init_exists (CatInitial.class C) X.

Lemma initial_unique (C:initialCat) X (m m': C Zero X): m =-= m'.
by apply (CatInitial.init_unique m m').
Qed.

(*=Products *)
Module CatProduct.
  Definition prod_diagram (C : catType) (A B P : C) (pi1 : C P A) (pi2 : C P B)
                              (X : C) (f : C X A) (g : C X B) (h : C X P) :=
                          pi1 << h =-= f /\ pi2 << h =-= g.
  Definition axiom (C:catType) (prod : C -> C -> C) (pi1 : forall A B, C (prod A B) A)
     (pi2 : forall A B, C (prod A B) B) (h: forall A B Z, C Z A -> C Z B -> C Z (prod A B)) :=
    forall A B X f g,
        @prod_diagram C A B (prod A B) (pi1 _ _) (pi2 _ _) X f g (h A B X f g) /\
          forall m, prod_diagram (pi1 _ _) (pi2 _ _) f g m -> m =-= (h A B X f g).
  Record mixin_of (C:catType) := Mixin
  { prod : C -> C -> C;
    pi1 : forall A B, C (prod A B) A;
    pi2 : forall A B, C (prod A B) B;
    prod_ex : forall A B Z, C Z A -> C Z B -> C Z (prod A B); _ : axiom pi1 pi2 prod_ex}.

  Section ClassDef.

  Record class_of T (M:T -> T -> setoidType) : Type :=
    Class { base : Category.class_of M ; ext : mixin_of (Category.Pack base T)}.
  Local Coercion base : class_of >-> Category.class_of.
  Local Coercion ext : class_of >-> mixin_of.

  Structure cat := Pack {object;
         morph : object -> object -> setoidType ; _ : class_of morph; _ : Type}.
  Local Coercion object : cat >-> Sortclass.
  Local Coercion morph : cat >-> Funclass.

  Definition class cT := let: Pack _ _ c _ := cT return class_of cT in c. (*CLEAR*)
  Definition unpack (K:forall O (M:O -> O -> setoidType) (c:class_of M), Type)
              (k : forall O (M: O -> O -> setoidType) (c : class_of M), K _ _ c) (cT:cat) :=
    let: Pack _ M c _ := cT return @K _ _ (class cT) in k _ _ c.
  Definition repack cT : _ -> Type -> cat := let k T M c p := p c in unpack k cT.
(*CLEARED*)
  Definition pack := let k T M c m := Pack (@Class T M c m) T in Category.unpack k.
  Definition catType (cT:cat) := Category.pack (class cT).
  End ClassDef.
  Module Import Exports.
  Coercion catType : cat >-> Category.cat.
  Coercion base : class_of >-> Category.class_of.
  Coercion ext : class_of >-> mixin_of.
  Coercion object : cat >-> Sortclass.
  Coercion morph : cat >-> Funclass.
  Notation prodCat := cat. (*CLEAR*)
  Notation prodCatMixin := Mixin.
  Notation prodCatType := pack.
Canonical Structure catType.
  End Exports.
End CatProduct.
Export CatProduct.Exports.

(*CLEARED*)
Definition prod (C:prodCat) (A B:C) : C :=
                   (CatProduct.prod (CatProduct.class C) A B).
Definition pi1 (C:prodCat) (A B:C) : morph (prod A B) A :=
                   (CatProduct.pi1 (CatProduct.class C) A B).
Definition pi2 (C:prodCat) (A B:C) : morph (prod A B) B :=
                   (CatProduct.pi2 (CatProduct.class C) A B).
Definition prod_fun (C:prodCat) (Z A B:C) (f:C Z A) (g:C Z B) :
  morph Z (prod A B) := (CatProduct.prod_ex (CatProduct.class C) f g).
Infix "*" := prod (*CLEAR*) : C_scope.
Implicit Arguments pi1 [C A B].
Implicit Arguments pi2 [C A B]. (*CLEARED*)
Notation "'<|' f , g '|>'" := (prod_fun f g) (at level 30) (*CLEAR*) : C_scope. (*CLEARED*)
Notation "f '><' g" := (prod_fun (f << pi1) (g << pi2)) (at level 30) (*CLEAR*) : C_scope.
(* Notation "'(|' f , g '|)'" := (prod_fun (f << pi1) (g << pi2)) (at level 30) : C_scope.*)

Arguments Scope prod_fun [_ C_scope C_scope C_scope S_scope S_scope].
(*CLEARED*)
Lemma prod_fun_fst (C:prodCat) (X Y Z:C) (f:Z =-> Y) (g:Z =-> X) :
                                                pi1 << <|f , g|> =-= f. (*CLEAR*)
move: C X Y Z f g.
unfold prod_fun. case. simpl. move => OO MM. case. simpl. move => B. case. simpl. move => P pia pib pie A XX X Y Z f g.
by apply (proj1 (A Y X Z f g)).
Qed.
(*CLEARED*)
Lemma prod_fun_snd (C:prodCat) (X Y Z:C) (f:Z =-> Y) (g:Z =-> X) :
                                                pi2 << <|f , g|> =-= g. (*CLEAR*)
move: C X Y Z f g.
unfold prod_fun. case. simpl. move => OO MM. case. simpl. move => B. case. simpl. move => P pia pib pie A XX X Y Z f g.
by apply (proj1 (A Y X Z f g)).
Qed.

Lemma prod_fun_unique (C:prodCat) (X Y Z : C) (f:Z =-> X) (g:Z =-> Y) (h:Z =-> X * Y) :
    pi1 <<  h =-= f -> pi2 << h =-= g -> h =-= prod_fun f g.
move: C X Y Z f g h.
unfold prod_fun. case. simpl. move => OO MM. case. simpl. move => B. case. simpl.
move => P pia pib pie A XX X Y Z f g h Q Q'.
apply: ((proj2 (A _ _ _ f g) _ _)). by split.
Qed.
(*CLEARED*)
Lemma prod_unique (C:prodCat) (X Y Z : C) (h h':Z =-> X * Y) :
  pi1 << h =-= pi1 << h' -> pi2 << h =-= pi2 << h' -> h =-= h'. (*CLEAR*)
move => A B. apply (tset_trans (prod_fun_unique (tset_refl _) (tset_refl _))).
apply tset_sym. by apply prod_fun_unique ; apply tset_sym.
Qed.
(*CLEARED*)
Add Parametric Morphism (C:prodCat) X Y Z : (@prod_fun C X Y Z)
  with signature (@tset_eq (C X Y)) ==> (@tset_eq (C X Z)) ==>
                 (@tset_eq (C X (Y * Z))) as prod_fun_eq_compat. (*CLEAR*)
move => f f' e g g' e'.  apply: prod_unique.
+ by do 2 rewrite prod_fun_fst ; apply e.
+ by do 2 rewrite prod_fun_snd ; apply e'.
Qed.
(*CLEARED*)
Lemma prod_map_prod_fun (C:prodCat) (X Y Z W A : C) (f:X =-> Y) (g: Z =-> W)
                (h:A =-> _) (k:A =-> _) :  f >< g << <|h,k|> =-= <|f << h, g << k|>.
apply prod_unique; rewrite comp_assoc.
- do 2 rewrite prod_fun_fst. rewrite <- comp_assoc. by rewrite prod_fun_fst.
- do 2 rewrite prod_fun_snd. rewrite <- comp_assoc. by rewrite prod_fun_snd.
Qed.
(*=End *)

Lemma prod_fun_compl (Z:prodCat) (D E F G : Z) (f : D =-> E) (g : D =-> F) (h : G =-> D) :
        <| f, g|> << h =-= <| f << h , g << h |>.
apply prod_unique.
- rewrite comp_assoc. by do 2 rewrite prod_fun_fst.
- rewrite comp_assoc. by do 2 rewrite prod_fun_snd.
Qed.

Lemma prod_fun_compr (Z:prodCat) (D E F G H : Z) (f : H =-> D) (g : D =-> E) (h : H =-> F) (k : F =-> G) :
       <| g << f, k << h |> =-= g >< k << <| f, h |>.
apply prod_unique.
rewrite comp_assoc. do 2 rewrite prod_fun_fst. rewrite <- comp_assoc. by rewrite prod_fun_fst.
rewrite comp_assoc. do 2 rewrite prod_fun_snd. rewrite <- comp_assoc. by rewrite prod_fun_snd.
Qed.

Lemma prod_fun_prod_fun (C:prodCat) (X Y Z W W':C) (h:X =-> Y) (k:X =-> Z) (f:Y * Z =-> W) (g:Y * Z =-> W') :
     <| f, g |> << <| h, k|> =-= <| f << <| h, k|>, g << <| h, k|> |>.
apply: prod_unique ; rewrite comp_assoc.
- by do 2 rewrite prod_fun_fst.
- by do 2 rewrite prod_fun_snd.
Qed.

Definition prod_assoc (C:prodCat) (D E F:C) : (D * E * F) =-> (D * (E * F)) := <| pi1 << pi1, <| pi2 << pi1, pi2|>|>.

Definition prod_assocI (C:prodCat) (D E F:C) : (D * (E * F)) =-> (D * E * F) := <| <| pi1, pi1 << pi2|>, pi2 << pi2|>.

Lemma prodAAI_id (C:prodCat) (D E F:C) : prod_assoc D E F << prod_assocI D E F =-= Id.
unfold prod_assoc. unfold prod_assocI.
apply prod_unique ; rewrite comp_assoc ; [rewrite -> prod_fun_fst | rewrite -> prod_fun_snd] ; rewrite comp_idR.
- rewrite <- comp_assoc. by do 2 rewrite prod_fun_fst.
- apply prod_unique ; rewrite comp_assoc ; [rewrite -> prod_fun_fst | by do 2 rewrite -> prod_fun_snd].
  rewrite <- comp_assoc. rewrite prod_fun_fst. by rewrite prod_fun_snd.
Qed.

Lemma prodAIA_id (C:prodCat) (D E F:C) : prod_assocI D E F << prod_assoc D E F =-= Id.
unfold prod_assoc. unfold prod_assocI.
apply prod_unique ; rewrite comp_assoc ; [rewrite -> prod_fun_fst | rewrite -> prod_fun_snd] ; rewrite comp_idR.
- apply prod_unique ; rewrite comp_assoc; [by do 2rewrite -> prod_fun_fst | rewrite -> prod_fun_snd].
  rewrite <- comp_assoc. rewrite prod_fun_snd. by rewrite prod_fun_fst.
- rewrite <- comp_assoc. by do 2 rewrite prod_fun_snd.
Qed.

Lemma prod_eta (C:prodCat) (X Y Z : C) (f: X =-> Y * Z) : <| pi1 << f, pi2 << f|> =-= f.
apply: prod_unique.
- by rewrite prod_fun_fst.
- by rewrite prod_fun_snd.
Qed.

Lemma prod_id (C:prodCat) (D E : C) : <| pi1, pi2 |> =-= @Id _ (D * E).
rewrite <- (comp_idR pi1). rewrite <- (comp_idR pi2).
by apply prod_eta.
Qed.

Module Sums.

Section P.
Variable C:catType.
Variable A B P : C.
Variable in1 : morph A P.
Variable in2 : morph B P.

Definition axiom X (f:morph A X) g h := h << in1 =-= f /\ h << in2 =-= g.

End P.

End Sums.

Module CatSum.

Definition axiom (C:catType) (sum : C -> C -> C) (in1 : forall A B, C A (sum A B))
   (in2 : forall A B, C B (sum A B)) (h: forall A B Z, C A Z -> C B Z -> C (sum A B) Z) :=
  forall A B X f g, @Sums.axiom C A B (sum A B) (in1 _ _) (in2 _ _) X f g (h A B X f g) /\
        forall m, Sums.axiom (in1 _ _) (in2 _ _) f g m -> m =-= (h A B X f g).

Record mixin_of (C:catType) : Type := Mixin
{ sum : C -> C -> C;
  in1 : forall A B, morph A (sum A B);
  in2 : forall A B, morph B (sum A B);
  sum_exists : forall A B Z, morph A Z -> morph B Z -> morph (sum A B) Z;
  _ : axiom in1 in2 sum_exists }.

Section ClassDef.
Record class_of (T:Type) (M:T -> T -> setoidType) : Type :=
  Class { base : Category.class_of M ; ext : mixin_of (Category.Pack base T) }.

  Local Coercion base : class_of >-> Category.class_of.
  Local Coercion ext : class_of >-> mixin_of.

Structure cat : Type := Pack {object; morph : object -> object -> setoidType ; _ : class_of morph; _ : Type}.

  Local Coercion object : cat >-> Sortclass.
  Local Coercion morph : cat >-> Funclass.

Definition class cT := let: Pack _ _ c _ := cT return class_of cT in c.
Definition unpack (K:forall O (M:O -> O -> setoidType) (c:class_of M), Type)
            (k : forall O (M: O -> O -> setoidType) (c : class_of M), K _ _ c) (cT:cat) :=
  let: Pack _ M c _ := cT return @K _ _ (class cT) in k _ _ c.
Definition repack cT : _ -> Type -> cat := let k T M c p := p c in unpack k cT.
Definition pack := let k T M c m := Pack (@Class T M c m) T in Category.unpack k.

Definition catType (cT:cat) := Category.pack (class cT).
  End ClassDef.
Module Import Exports.
  Coercion catType : cat >-> Category.cat.
  Coercion base : class_of >-> Category.class_of.
  Coercion ext : class_of >-> mixin_of.
  Coercion object : cat >-> Sortclass.
  Coercion morph : cat >-> Funclass.
Notation sumCat := CatSum.cat.
Notation sumCatMixin := Mixin.
Notation sumCatType := pack.
Canonical Structure catType.
End Exports.

End CatSum.
Export CatSum.Exports.

Definition sum (C:sumCat) (A B:C) : C := (CatSum.sum (CatSum.class C) A B).
Definition in1 (C:sumCat) (A B:C) : morph A (sum A B) := (CatSum.in1 (CatSum.class C) A B).
Definition in2 (C:sumCat) (A B:C) : morph B (sum A B) := (CatSum.in2 (CatSum.class C) A B).
Definition sum_fun (C:sumCat) (Z A B:C) (f:C A Z) (g:C B Z) : morph (sum A B) Z :=
  (CatSum.sum_exists (CatSum.class C) f g).

Infix "+" := sum : C_scope.

Implicit Arguments in1 [C A B].
Implicit Arguments in2 [C A B].

Notation "'[|' f , g '|]'" := (sum_fun f g) (at level 30) : C_scope.

Arguments Scope sum_fun [_ C_scope C_scope C_scope S_scope S_scope].

Lemma sum_fun_fst (C:sumCat) (X Y Z:C) (f:Y =-> Z) (g:X =-> Z) : [|f , g|] << in1 =-= f.
move: C X Y Z f g.
unfold sum_fun. case. simpl. move => OO MM. case. simpl. move => B. case. simpl. move => P pia pib pie A XX X Y Z f g.
by apply (proj1 (A Y X Z f g)).
Qed.

Lemma sum_fun_snd (C:sumCat) (X Y Z:C) (f:Y =-> Z) (g:X =-> Z) : [|f , g|] << in2 =-= g.
move: C X Y Z f g.
unfold sum_fun. case. simpl. move => OO MM. case. simpl. move => B. case. simpl. move => P pia pib pie A XX X Y Z f g.
by apply (proj1 (A Y X Z f g)).
Qed.

Lemma sum_fun_unique (C:sumCat) (X Y Z : C) (f:X =-> Z) (g:Y =-> Z) (h:X + Y =-> Z) :
    h << in1 =-= f -> h << in2 =-= g -> h =-= sum_fun f g.
move: C X Y Z f g h.
unfold sum_fun. case. simpl. move => OO MM. case. simpl. move => B. case. simpl.
move => P pia pib pie A XX X Y Z f g h Q Q'.
apply (proj2 (A _ _ _ f g)). by split.
Qed.

Lemma sum_unique (C:sumCat) (X Y Z : C) (h h':X + Y =-> Z) :
  h << in1 =-= h' << in1 -> h << in2 =-= h' << in2 -> h =-= h'.
move => A B. apply: (tset_trans (sum_fun_unique (tset_refl _) (tset_refl _))).
apply tset_sym. by apply sum_fun_unique ; apply tset_sym.
Qed.

Add Parametric Morphism (C:sumCat) (X Y Z:C) : (@sum_fun C _ _ _)
  with signature (@tset_eq (C X Y)) ==> (@tset_eq (C Z Y)) ==> (@tset_eq (C (X + Z) Y))
  as sum_fun_eq_compat.
move => f f' e g g' e'.  apply: sum_unique.
+ by do 2 rewrite sum_fun_fst ; apply e.
+ by do 2 rewrite sum_fun_snd ; apply e'.
Qed.

Lemma SUM_fun_comp :
  forall (Z:sumCat) (C D E F:Z) (f:C=->E) (g:D=->E) (h:E=->F), h << [|f, g|] =-= [|h << f, h << g|].
move => Z C D E F f g h.
by apply: sum_fun_unique ; rewrite <- comp_assoc ; [rewrite -> sum_fun_fst | rewrite -> sum_fun_snd].
Qed.

Lemma sum_eta (C:sumCat) (X Y Z : C) (f: X + Y =-> Z) : [|f << in1, f << in2|] =-= f.
apply sum_unique.
- by rewrite sum_fun_fst.
- by rewrite sum_fun_snd.
Qed.

Lemma sum_id (C:sumCat) (X Y : C) : [| in1, in2|] =-= @Id _ (X + Y).
rewrite <- (comp_idL in1).
rewrite <- (comp_idL in2).
by apply sum_eta.
Qed.

Module Exponential.

Section P.
Variable C:prodCat.
Variable X Y Z E : C.
Variable ev : C (E * X) Y.
Variable exp : C (Z * X) Y -> C Z E.

Definition axiom (h:C Z E) h' := ev << h >< Id =-= h'.

End P.

End Exponential.

Module CatExp.

Definition axiom (C:prodCat) (E:C -> C -> C)
   (ev:forall X Y, C (E X Y * X) Y) (exp:forall X Y Z, C (X * Y) Z -> C X (E Y Z)) :=
  forall X Y Z h, @Exponential.axiom C _ _ _ (E _ _) (ev Y Z) (exp X Y Z h) h /\
        forall h', Exponential.axiom (ev _ _) h' h -> h' =-= (exp X Y Z h).

Record mixin_of (C:prodCat) : Type := Mixin
{
  exp : C -> C -> C;
  ev : forall X Y, C (exp X Y * X) Y;
  exp_fun : forall X Y Z, C (X * Y) Z -> C X (exp Y Z);
  _ : axiom ev exp_fun
}.

Section ClassDef.
Record class_of (T:Type) (M:T -> T -> setoidType) : Type :=
  Class { base : CatProduct.class_of M ; ext : mixin_of (CatProduct.Pack base T) }.
  Local Coercion base : class_of >-> CatProduct.class_of.
  Local Coercion ext : class_of >-> mixin_of.

Structure cat : Type := Pack {object; morph : object -> object -> setoidType ; _ : class_of morph; _ : Type}.
  Local Coercion object : cat >-> Sortclass.
  Local Coercion morph : cat >-> Funclass.

Definition class cT := let: Pack _ _ c _ := cT return class_of cT in c.
Definition unpack (K:forall O (M:O -> O -> setoidType) (c:class_of M), Type)
            (k : forall O (M: O -> O -> setoidType) (c : class_of M), K _ _ c) (cT:cat) :=
  let: Pack _ M c _ := cT return @K _ _ (class cT) in k _ _ c.
Definition repack cT : _ -> Type -> cat := let k T M c p := p c in unpack k cT.
Definition pack := let k T M c m := Pack (@Class T M c m) T in CatProduct.unpack k.

Definition catType (cT:cat) := Category.Pack (class cT) cT.
Definition catProdType (cT:cat) := CatProduct.Pack (class cT) cT.
End ClassDef.
Module Import Exports.
  Coercion catProdType : cat >-> CatProduct.cat.
  Coercion base : class_of >-> CatProduct.class_of.
  Coercion ext : class_of >-> mixin_of.
  Coercion object : cat >-> Sortclass.
  Coercion morph : cat >-> Funclass.
Notation expCat := CatExp.cat.
Notation expCatMixin := CatExp.Mixin.
Notation expCatType := CatExp.pack.
Canonical Structure CatExp.catType.
Canonical Structure CatExp.catProdType.
End Exports.
End CatExp.
Export CatExp.Exports.

Definition exp (C:expCat) (A B : C) : C := CatExp.exp (CatExp.class C) A B.
Definition ev (C:expCat) (A B : C) : C (exp A B * A) B := CatExp.ev (CatExp.class C) A B.
Definition exp_fun (C:expCat) (X Y Z : C) (h: C (X * Y) Z) : C X (exp Y Z) := CatExp.exp_fun (CatExp.class C) h.

Implicit Arguments ev [C A B].

Arguments Scope ev [_ C_scope C_scope].
Arguments Scope exp [_ C_scope C_scope].

Infix "-=>" := exp (at level 54, right associativity) : C_scope.

Lemma exp_com (C:expCat) (X Y Z : C) (h:X * Y =-> Z) : ev << exp_fun h >< Id =-= h.
move: C X Y Z h.
unfold exp_fun. unfold ev. simpl.
case. move => OO MM. case. simpl. move => B. case. move => eexp eev eexp_fun A T X Y Z h. simpl.
by apply (proj1 (A X Y Z h)).
Qed.

Lemma exp_unique (C:expCat) (X Y Z : C) (h:X =-> Y -=> Z) h' : ev << h >< Id =-= h' -> h =-= exp_fun h'.
move: C X Y Z h h'.
unfold exp_fun. unfold ev. simpl.
case. move => OO MM. case. simpl. move => B. case. move => eexp eev eexp_fun A T X Y Z h h'. simpl.
by apply (proj2 (A X Y Z h')).
Qed.

Add Parametric Morphism (C:expCat) (X Y Z:C) : (@exp_fun C X Y Z)
  with signature (@tset_eq (C (X * Y) Z)) ==> (@tset_eq (C X (Y -=> Z)))
  as exp_fun_eq_compat.
move => f f' e. apply: exp_unique.
by rewrite exp_com.
Qed.

Lemma exp_ev (Z:expCat) : forall (C D E:Z) (f:C =-> D -=> E) , exp_fun (ev << f >< Id ) =-= f.
symmetry.
by apply: exp_unique.
Qed.

Lemma exp_comp (Z:expCat) : forall (A B C D:Z) (f:A * B =-> C) (g:D =-> A), exp_fun f << g =-= exp_fun (f << g >< Id).
intros A B C D f g.
have H:=exp_com f. rewrite <- H.
rewrite <- comp_assoc. rewrite prod_map_prod_fun. rewrite exp_ev.
rewrite comp_idL. rewrite comp_assoc. by rewrite exp_ev.
Qed.

Definition uncurry (Z:expCat) (D0 D1 D2 : Z) (f:D0 =-> D1 -=> D2) : D0 * D1 =-> D2 :=
      ev << <|f << pi1, pi2|>.

Lemma UC_id (C:expCat) (X Y Z:C) (f:X * Y =-> Z) : uncurry (exp_fun f) =-= f.
unfold uncurry.
rewrite <- (comp_idL pi2). by rewrite -> exp_com.
Qed.

Lemma CU_id (C:expCat) (X Y Z:C) (f:X =-> Y -=> Z) : exp_fun (uncurry f) =-= f.
unfold uncurry. rewrite <- (comp_idL pi2).
by rewrite -> exp_ev.
Qed.

Module ProdSumCat.

Record mixin_of (C:prodCat) : Type := Mixin {
  sumM :> CatSum.mixin_of C;
  initialM :> CatInitial.mixin_of C;
  terminalM :> CatTerminal.mixin_of C
  }.

Section ClassDef.

Record class_of (T:Type) (M:T -> T -> setoidType) : Type :=
  Class { base : CatProduct.class_of M ; ext : mixin_of (CatProduct.Pack base T) }.

  Local Coercion base : class_of >-> CatProduct.class_of.
  Local Coercion ext : class_of >-> mixin_of.

  Definition base2 (T:Type) (M:T -> T -> setoidType) (c:class_of M) : CatSum.class_of M := CatSum.Class c.
  Definition base3 (T:Type) (M:T -> T -> setoidType) (c:class_of M) : CatInitial.class_of M := CatInitial.Class c.
  Definition base4 (T:Type) (M:T -> T -> setoidType) (c:class_of M) : CatTerminal.class_of M := CatTerminal.Class c.

  Local Coercion base2 : class_of >-> CatSum.class_of.
  Local Coercion base3 : class_of >-> CatInitial.class_of.
  Local Coercion base4 : class_of >-> CatTerminal.class_of.

Structure cat : Type := Pack {object; morph : object -> object -> setoidType ; _ : class_of morph; _ : Type}.
  Local Coercion object : cat >-> Sortclass.
  Local Coercion morph : cat >-> Funclass.

Definition class cT := let: Pack _ _ c _ := cT return class_of cT in c.
Definition unpack (K:forall O (M:O -> O -> setoidType) (c:class_of M), Type)
            (k : forall O (M: O -> O -> setoidType) (c : class_of M), K _ _ c) (cT:cat) :=
  let: Pack _ M c _ := cT return @K _ _ (class cT) in k _ _ c.
Definition repack cT : _ -> Type -> cat := let k T M c p := p c in unpack k cT.
Definition pack := let k T M c m := Pack (@Class T M c m) T in CatProduct.unpack k.

Definition catType (cT:cat) := Category.Pack (class cT) cT.
Definition catProdType (cT:cat) := CatProduct.Pack (class cT) cT.
Definition catTerminalType (cT:cat) := CatTerminal.Pack (class cT) cT.
Definition catSumType (cT:cat) := CatSum.Pack (class cT) cT.
Definition catInitialType (cT:cat) := CatInitial.Pack (class cT) cT.
End ClassDef.

Module Import Exports.
  Coercion catProdType : cat >-> CatProduct.cat.
  Coercion catSumType : cat >-> CatSum.cat.
  Coercion catInitialType : cat >-> CatInitial.cat.
  Coercion catTerminalType : cat >-> CatTerminal.cat.
  Coercion base : class_of >-> CatProduct.class_of.
  Coercion base2 : class_of >-> CatSum.class_of.
  Coercion base3 : class_of >-> CatInitial.class_of.
  Coercion base4 : class_of >-> CatTerminal.class_of.
  Coercion ext : class_of >-> mixin_of.
  Coercion object : cat >-> Sortclass.
  Coercion morph : cat >-> Funclass.
Notation prodsumCat := cat.
Notation prodsumCatType := pack.
Canonical Structure catType.
Canonical Structure catProdType.
Canonical Structure catSumType.
Canonical Structure catInitialType.
Canonical Structure catTerminalType.
End Exports.

End ProdSumCat.
Export ProdSumCat.Exports.

Module Distributive.

Record mixin_of (C:prodsumCat) : Type := Mixin
 { distribS : forall (X Y Z:C), (X + Y) * Z =-> (X * Z) + (Y * Z);
   isoS : forall (X Y Z:C), iso (distribS X Y Z) ([| (in1 : C _ _) >< Id, (in2 : C _ _) >< Id|]);
   isoN : forall (X:C), iso (initial_morph (X*Zero)) pi2
}.

Section ClassDef.

Record class_of (T:Type) (M:T -> T -> setoidType) : Type :=
  Class { base : ProdSumCat.class_of M ; ext : mixin_of (ProdSumCat.Pack base T) }.
  Local Coercion base : class_of >-> ProdSumCat.class_of.
  Local Coercion ext : class_of >-> mixin_of.

Structure cat : Type := Pack {object : Type; morph : object -> object -> setoidType ; _ : class_of morph; _ : Type}.
  Local Coercion object : cat >-> Sortclass.
  Local Coercion morph : cat >-> Funclass.

Definition class cT := let: Pack _ _ c _ := cT return class_of cT in c.
Definition unpack (K:forall O (M:O -> O -> setoidType) (c:class_of M), Type)
            (k : forall O (M: O -> O -> setoidType) (c : class_of M), K _ _ c) (cT:cat) :=
  let: Pack _ M c _ := cT return @K _ _ (class cT) in k _ _ c.
Definition repack cT : _ -> Type -> cat := let k T M c p := p c in unpack k cT.
Definition pack := let k T M c m := Pack (@Class T M c m) T in ProdSumCat.unpack k.

Definition catType (cT:cat) := Category.Pack (class cT) cT.
Definition catProdType (cT:cat) := CatProduct.Pack (class cT) cT.
Definition catSumType (cT:cat) := CatSum.Pack (class cT) cT.
Definition catInitialType (cT:cat) := CatInitial.Pack (class cT) cT.
Definition catTerminalType (cT:cat) := CatTerminal.Pack (class cT) cT.
Definition catProdSumType (cT:cat) := ProdSumCat.Pack (class cT) cT.
End ClassDef.
Module Import Exports.
  Coercion catProdSumType : cat >-> ProdSumCat.cat.
  Coercion base : class_of >-> ProdSumCat.class_of.
  Coercion ext : class_of >-> mixin_of.
  Coercion object : cat >-> Sortclass.
  Coercion morph : cat >-> Funclass.
Canonical Structure catType.
Canonical Structure catProdType.
Canonical Structure catSumType.
Canonical Structure catInitialType.
Canonical Structure catTerminalType.
Notation distCat := Distributive.cat.
Notation distCatMixin := Distributive.Mixin.
Notation distCatType := Distributive.pack.
Canonical Structure catProdSumType.
End Exports.
End Distributive.
Export Distributive.Exports.

Module CatIProduct.
Section XX.
Variable C:catType.
Definition prod_diagram I (A:I -> C) (P : C) (pi : forall i, C P (A i))
                            (X : C) (f : forall i, C X (A i)) (h : C X P) :=
                        forall i, pi i << h =-= f i.
Definition axiom I (prod : (I -> C) -> C) (pi : forall A i, C (prod A) (A i))
    (h: forall A Z, (forall i, C Z (A i)) -> C Z (prod A)) :=
  forall A X f,
      @prod_diagram I A (prod A) (pi _) X f (h A _ f) /\
        forall m, prod_diagram (pi _) f m -> m =-= (h A X f).
Record mixin_of : Type := Mixin
{ prod : forall I, (I -> C) -> C;
  pi : forall I A i, C (prod A) (A i);
  prod_ex : forall I A Z, (forall i, C Z (A i)) -> C Z (@prod I A);
  _ : forall I, @axiom I _ (@pi I) (@prod_ex I)}.

End XX.

Section BiProd.
Variable C:catType.
Variable m:mixin_of C.

Lemma biAxiom : @CatProduct.axiom C (fun A B => prod m (fun x => match x with inl _ => A | inr _ => B end))
              (fun A B => pi m (fun x => match x with inl _ => A | inr _ => B end) (inl _ tt))
              (fun A B => pi m (fun x => match x with inl _ => A | inr _ => B end) (inr _ tt))
               (fun A B (Z:C) (f:Z =-> A) g => @prod_ex _ _ _ (fun x => match x with inl _ => A | inr _ => B end) Z
                (fun i => match i with inl _ => f | inr _ => g end)) .
case: m. move => P pi' ex ax.
move => A B X f g. simpl.
specialize (@ax (unit+unit)%type (fun x => match x with inl _ => A | inr _ => B end) X
                (fun i => match i with inl _ => f | inr _ => g end)).
simpl in ax. case: ax => ax0 ax1. split ; first split.
- by apply (ax0 (inl unit tt)).
- by apply (ax0 (inr unit tt)).
- move => m' ax. apply (ax1 m'). clear ax1. case ; case. by apply (proj1 ax). by apply (proj2 ax).
Qed.

Definition prodM := prodCatMixin biAxiom.
End BiProd.

Section ClassDef.

Record class_of (T:Type) (M:T -> T -> setoidType) : Type :=
  Class { base : Category.class_of M ; ext : mixin_of (Category.Pack base T)}.
  Local Coercion base : class_of >-> Category.class_of.
  Local Coercion ext : class_of >-> mixin_of.

Definition base2 (T:Type) (M:T -> T -> setoidType) (c:class_of M) := CatProduct.Class (prodM c).
  Local Coercion base2 : class_of >-> CatProduct.class_of.

Structure cat : Type := Pack {object;
       morph : object -> object -> setoidType ; _ : class_of morph; _ : Type}.
  Local Coercion object : cat >-> Sortclass.
  Local Coercion morph : cat >-> Funclass.

Definition class cT := let: Pack _ _ c _ := cT return class_of cT in c. (*CLEAR*)
Definition unpack (K:forall O (M:O -> O -> setoidType) (c:class_of M), Type)
            (k : forall O (M: O -> O -> setoidType) (c : class_of M), K _ _ c) (cT:cat) :=
  let: Pack _ M c _ := cT return @K _ _ (class cT) in k _ _ c.
Definition repack cT : _ -> Type -> cat := let k T M c p := p c in unpack k cT.
(*CLEARED*)
Definition pack := let k T M c m := Pack (@Class T M c m) T in Category.unpack k.
Definition catType (cT:cat) := Category.Pack (class cT) cT.
Definition prodCatType (cT:cat) := CatProduct.Pack (class cT) cT.
End ClassDef.
  Module Import Exports.
  Coercion catType : cat >-> Category.cat.
  Coercion base : class_of >-> Category.class_of.
  Coercion base2 : class_of >-> CatProduct.class_of.
  Coercion ext : class_of >-> mixin_of.
  Coercion object : cat >-> Sortclass.
  Coercion morph : cat >-> Funclass.
Notation prodICat := cat.
Notation prodICatMixin := Mixin.
Notation prodICatType := pack.
Canonical Structure catType.
Canonical Structure prodCatType.
  End Exports.

End CatIProduct.
Export CatIProduct.Exports.

Definition prodi (C:prodICat) I (A: I -> C) : C :=
                   (CatIProduct.prod (CatIProduct.class C) A).
Definition pi (C:prodICat) I (A: I -> C) i : C (prodi A) (A i) :=
                   (CatIProduct.pi (CatIProduct.class C) A i).
Definition prodi_fun (C:prodICat) (Z:C) I (A:I -> C) (f:forall i, C Z (A i)) :
  C Z (prodi A) := (CatIProduct.prod_ex (CatIProduct.class C) f).
Implicit Arguments pi [C I A].

Arguments Scope prodi_fun [_ _ C_scope C_scope S_scope S_scope].

Lemma prodi_fun_pi (C:prodICat) I (Z:C) (A:I -> C) (f:forall i:I,Z =-> A i) (i:I):
                                                pi i << prodi_fun f =-= f i.
move: C I Z A f i.
unfold prodi_fun. case. simpl. move => OO MM. case. simpl. move => B. case. simpl. move => P pia pie A XX X Y Z f i.
by apply (proj1 (A X Z Y f)).
Qed.

Lemma prodi_fun_unique (C:prodICat) I (Z : C) (X:I -> C) (f:forall i, Z =-> X i) (h:Z =-> prodi X) :
    (forall i, pi i <<  h =-= f i) -> h =-= prodi_fun f.
move: C I Z X f h.
unfold prodi_fun. case. simpl. move => OO MM. case. simpl. move => B. case. simpl.
move => P pia pie A XX X Y Z f g h.
apply: ((proj2 (A _ _ _ f) _ _)). by apply: h.
Qed.

Lemma prodi_unique (C:prodICat) I (Z : C) (A:I -> C) (h h':Z =-> prodi A) :
  (forall i, pi i << h =-= pi i << h') -> h =-= h'.
move => X. apply (tset_trans (prodi_fun_unique (fun i => tset_refl _))).
apply tset_sym. by apply prodi_fun_unique ; move => i ; apply tset_sym.
Qed.

Record functor (C C':catType) : Type := mk_functor
 { functor_ob :> C -> C';
   functor_morph :> forall (X Y : C), (C X Y) -> C' (functor_ob X) (functor_ob Y);
   functor_id : forall X, @functor_morph X X Id =-= Id;
   functor_comp : forall X Y Z (f:C Y Z) (g:C X Y), functor_morph (f << g) =-= functor_morph f << functor_morph g
 }.

Implicit Arguments functor_morph [C C' X Y].

(*
Module CatCountable.

Section ClassDef.
Record class_of (T:Type) (M:T -> T -> setoidType) : Type :=
  Class { base1 : Category.class_of M ; ext : Countable.mixin_of (Category.Pack base1 T)}.
  Local Coercion base1 : class_of >-> Category.class_of.
  Local Coercion ext : class_of >-> Countable.mixin_of.

  Definition base2 (T:Type) (M:T -> T -> setoidType) (c:class_of M) : Countable.class_of (Category.Pack (base1 c) T) :=
  Countable.Class (Choice.Class (Countable.EqMixin c) (Countable.ChoiceMixin c)) c.
  Local Coercion base2 : class_of >-> Countable.class_of.

Structure cat : Type := Pack {object :> Type; morph :> object -> object -> setoidType ; _ : class_of morph; _ : Type}.
Definition class cT := let: Pack _ _ c _ := cT return class_of cT in c.
Definition unpack (K:forall O (M:O -> O -> setoidType) (c:class_of M), Type)
            (k : forall O (M: O -> O -> setoidType) (c : class_of M), K _ _ c) (cT:cat) :=
  let: Pack _ M c _ := cT return @K _ _ (class cT) in k _ _ c.
Definition repack cT : _ -> Type -> cat := let k T M c p := p c in unpack k cT.
Definition pack := let k T M c m := Pack (@Class T M c m) T in Category.unpack k.

Definition catType cT := Category.Pack (class cT) cT.
Definition countType (cT:cat) := Countable.Pack (class cT) cT.
End ClassDef.
Module Import Exports.
  Coercion base1 : class_of >-> Category.class_of.
  Coercion ext : class_of >-> Countable.mixin_of.
  Coercion base2 : class_of >-> Countable.class_of.
  Coercion catType : cat >-> Category.cat.
  Coercion countType : cat >-> Countable.type.
Canonical Structure catType.
Canonical Structure countType.
Notation countCat := cat.
Notation CountCat := pack.
End Exports.
End CatCountable.
Export CatCountable.Exports.
*)

(*
Module CatLimit.

Section Cone.

Variable C C':catType.
Variable F:functor C C'.

Record Cone : Type := mk_cone
{ conet :> C';
  conem :> forall c:C, conet =-> (F c);
  conem_com : forall c0 c1 (m:C c0 c1), (functor_morph F m) << conem c0 =-= conem c1 }.

Record Limit : Type := mk_limit
{
  limitt :> Cone;
  limitm : forall (X:Cone), X =-> limitt;
  limitm_com : forall (X:Cone) (c:C), X c =-= limitt c << limitm X
}.

End Cone.

Record mixin_of (C:catType) : Type := Mixin {
  limits :> forall (C':countCat) (F:functor C' C), Limit F
}.

Record class_of (T:Type) (M:T -> T -> setoidType) : Type :=
  Class { base1 :> Category.class_of M ; ext :> mixin_of (Category.Pack base1 T) }.

Structure cat : Type := Pack {object :> Type; morph :> object -> object -> setoidType ; _ : class_of morph; _ : Type}.
Definition class cT := let: Pack _ _ c _ := cT return class_of cT in c.
Definition unpack (K:forall O (M:O -> O -> setoidType) (c:class_of M), Type)
            (k : forall O (M: O -> O -> setoidType) (c : class_of M), K _ _ c) (cT:cat) :=
  let: Pack _ M c _ := cT return @K _ _ (class cT) in k _ _ c.
Definition repack cT : _ -> Type -> cat := let k T M c p := p c in unpack k cT.
Definition pack := let k T M c m := Pack (@Class T M c m) T in Category.unpack k.

Coercion catType (cT:cat) := Category.Pack (class cT) cT.

Section Theory.

Variable cT:cat.
Variable C':countCat.
Variable F:functor C' cT.
Variable C:Cone F.

Definition limit_cone : Cone F := (limitt (class cT C' F)).
Definition limit : cT := conet limit_cone.
Definition limit_fun : cT (conet C) limit := limitm (class cT C' F) C.
Lemma limit_com c : conem C c =-= conem limit_cone c << limit_fun.
move => c. by apply limitm_com.
Qed.

End Theory.

End CatLimit.

Notation cone := CatLimit.Cone.
Notation limitCat := CatLimit.cat.
Notation LimitCatMixin := CatLimit.Mixin.
Notation LimitCat := CatLimit.pack.
Canonical Structure CatLimit.catType.

Notation limit := CatLimit.limit.

Module CatCoLimit.

Section CoCone.

Variable C C':catType.
Variable F:functor C C'.

Record CoCone : Type := mk_cocone
{ coconet :> C';
  coconem :> forall c:C, F c =-> coconet;
  coconem_com : forall c0 c1 (m:C c0 c1), coconem c1 << (functor_morph F m) =-= coconem c0 }.

Record CoLimit : Type := mk_colimit
{
  colimitt :> CoCone;
  colimitm : forall (X:CoCone), colimitt =-> X;
  colimitm_com : forall (X:CoCone) (c:C), coconem X c =-= colimitm X << colimitt c
}.

End CoCone.

Record mixin_of (C:catType) : Type := Mixin {
  colimits :> forall (C':countCat) (F:functor C' C), CoLimit F
}.

Record class_of (T:Type) (M:T -> T -> setoidType) : Type :=
  Class { base1 :> Category.class_of M ; ext :> mixin_of (Category.Pack base1 T) }.

Structure cat : Type := Pack {object :> Type; morph :> object -> object -> setoidType ; _ : class_of morph; _ : Type}.
Definition class cT := let: Pack _ _ c _ := cT return class_of cT in c.
Definition unpack (K:forall O (M:O -> O -> setoidType) (c:class_of M), Type)
            (k : forall O (M: O -> O -> setoidType) (c : class_of M), K _ _ c) (cT:cat) :=
  let: Pack _ M c _ := cT return @K _ _ (class cT) in k _ _ c.
Definition repack cT : _ -> Type -> cat := let k T M c p := p c in unpack k cT.
Definition pack := let k T M c m := Pack (@Class T M c m) T in Category.unpack k.

Coercion catType (cT:cat) := Category.Pack (class cT) cT.

Section Theory.

Variable cT:cat.
Variable C':countCat.
Variable F:functor C' cT.
Variable C:CoCone F.

Definition colimit_cone : CoCone F := (colimitt (class cT C' F)).
Definition colimit : cT := coconet colimit_cone.
Definition colimit_fun : cT colimit (coconet C) := colimitm (class cT C' F) C.
Lemma colimit_com c : @coconem _ _ F C c =-= @Category.comp cT _ _ _ colimit_fun (coconem colimit_cone c).
move => c. by apply colimitm_com.
Qed.

End Theory.

End CatCoLimit.

Notation cocone := CatCoLimit.CoCone.
Notation colimitCat := CatCoLimit.cat.
Notation CoLimitCatMixin := CatCoLimit.Mixin.
Notation CoLimitCat := CatCoLimit.pack.
Canonical Structure CatCoLimit.catType.

Notation colimit := CatCoLimit.colimit.
*)
Close Scope C_scope.
Close Scope S_scope.


(************************************************************************)
(* Copyright (c) 2017, Ajay Kumar Eeralla <ae266@mail.missouri.edu>     *)
(*                   University of Missouri-Columbia.                   *)
(*                                                                      *)
(*                                                                      *)
(*                                                                      *)
(************************************************************************)

Load "definitions".

(** This library defines indistinguishability and all morphisms *)

(*Indistinguishability Relation ~*)
(*Definition Ind_Relation := forall n , mylist n -> mylist n -> Prop.*)

(** Indistinguishability relation [EQI]:
[[

forall n, relation (mylist n).
]]

 *)

Parameter EQI : forall {n }, relation (mylist n).

Notation "ml1 '~' ml2" := (EQI  ml1 ml2) (at level 0, right associativity).

Axiom EQI_equiv: forall n, equiv (mylist n) (@EQI n).

Instance EQI_Equiv :forall n, Equivalence  (@EQI n).
Proof.
split;
repeat apply EQI_equiv.
Qed.

Theorem EQI_ref: forall {n:nat} (ml: mylist n), ml ~ ml.
Proof.
intros m.
apply EQI_equiv.
Qed.

Theorem EQI_sym: forall {n:nat} (ml1 ml2 : mylist n), ml1 ~ ml2 -> ml2 ~ ml1 .
Proof.
intros.
apply EQI_equiv.
assumption.
Qed.

Theorem EQI_trans : forall {n:nat} (ml1 ml2 ml3: mylist n), ml1 ~ ml2 -> ml2 ~ ml3 -> ml1 ~ ml3.
Proof.
  intros.  rewrite <- H in H0; auto.
Qed.

Add Parametric Relation n : (mylist n) (@EQI n)
reflexivity proved by (EQI_ref)
symmetry proved by (EQI_sym)
transitivity proved by (EQI_trans)
as EQI_rel.

(** Equivalence relation [EQm] defined on [message] type.  *)

Definition EQm : relation message := fun (m1:message)  (m2: message) =>  [bol (eqm m1 m2)] ~ [ bol TRue].

Notation "ml1 '#' ml2" := (EQm ml1 ml2) (at level 5).

Axiom EQm_equiv: equiv message EQm.

Instance EQm_Equiv : Equivalence  EQm.
Proof.
split;
repeat apply EQm_equiv.
Qed.

Theorem EQm_ref: forall m:message, m # m.
Proof.
intros m.
apply EQm_equiv.
reflexivity.
Qed.

Theorem EQm_sym: forall m1 m2: message, m1 # m2 -> m2 # m1.
Proof.
intros.
rewrite H.
reflexivity.
Qed.

Theorem EQm_trans : forall m1 m2 m3 : message, m1 # m2 -> m2 # m3 -> m1 # m3.
Proof.
  intros.  rewrite <- H in H0; auto.
Qed.

(** Equivalence relation [EQb] defined on [Bool] type.  *)

Definition EQb : relation Bool := fun (b1:Bool)  (b2: Bool) =>  [bol (eqb b1 b2)] ~ [ bol TRue].
Notation "b1 '##' b2" := (EQb b1 b2) (at level 5).

Axiom BolEQ: equiv Bool EQb.

Instance Bol_Equ_Equiv : Equivalence  EQb.
Proof.
split;
repeat apply BolEQ.
Qed.

Theorem EQb_sym: forall b1 b2:Bool, b1 ## b2 -> b2 ## b1.
Proof.
intros.
rewrite H.
reflexivity.
Qed.

Theorem EQb_ref: forall b:Bool, b ## b.
Proof.
intros.
reflexivity.
Qed.

Theorem EQb_trans : forall b1 b2 b3 : Bool, b1 ## b2 -> b2 ## b3 -> b1 ## b3.
Proof.
  intros.  rewrite <- H in H0; auto.
Qed.

(** Equivalence relation [EQos] on [oursum] type. *)

Inductive EQos :  relation oursum :=
|  eqm1: forall (m1 m2: message), m1 # m2 ->  EQos (msg m1) (msg m2)
|  eqb1: forall (b1 b2: Bool), b1 ## b2 ->  EQos (bol b1) (bol b2).

Notation "ml1 '###' ml2" := (EQos ml1 ml2) (at level 5).

Instance os_Equ_Equiv : Equivalence  EQos.
Proof.
split.
unfold Reflexive;
intros;
destruct x;
try apply eqm1; try apply eqb1;
reflexivity.
unfold Symmetric; intros; destruct H;
    try apply eqm1; try apply eqb1; symmetry; assumption.
unfold Transitive; intros.
  inversion H; subst;
  inversion H0; subst;
  try apply  eqm1; try apply eqb1;
  rewrite H1;
  apply H3.

Qed.

Theorem EQos_sym: forall b1 b2: oursum, b1 ### b2 -> b2 ### b1.
Proof.
intros.
rewrite H.
reflexivity.
Qed.

Theorem EQos_ref: forall b:oursum, b ### b.
Proof.
intros.
reflexivity.
Qed.

Theorem EQos_trans : forall b1 b2 b3 : oursum, b1 ### b2 -> b2 ### b3 -> b1 ### b3.
Proof.
  intros.  rewrite <- H in H0; auto.
Qed.

(** Equivalence relation [EQosl] is defined on [mylist n] for a natural number [n]. *)

Inductive EQosl: forall {n:nat}, relation (mylist n) :=
| eqnos :  EQosl  (Nil _) (Nil _)
| eqconos: forall (m:nat)(os1 os2:oursum)(l1 l2: mylist m), os1 ### os2 -> (EQosl  l1  l2) -> EQosl (os1 :: l1) (os2::l2).

Notation "ml1 '####' ml2" := (EQosl ml1 ml2) (at level 0).

Axiom eqlistos_ind: forall (n:nat) (l1 l2: mylist n), l1 #### l2 ->  l1 ~ l2.

Instance osl_Equ_Equiv {n}: Equivalence  (@EQosl n).
Proof.
split.
  unfold Reflexive.
  induction x.
   apply eqnos.
   apply eqconos. reflexivity. apply IHx.
 unfold Symmetric.
intros  x y H.
induction H.
apply eqnos.
apply eqconos.
rewrite H. reflexivity. apply IHEQosl.
unfold Transitive.
 intros x y z H1 H2.
 induction H1. assumption.
  + dependent destruction z.
     - apply eqconos;    inversion H2; subst. rewrite H. apply H6.
        dependent destruction H2. apply   IHEQosl . assumption.
Qed.

(** Equivalence relation [EQlm] defined on [list message] type. *)

Inductive EQlm:  relation (list message) :=
| eqnm :  EQlm nil nil
| eqconm: forall (m1 m2 : message)(l1 l2: list message),  m1 # m2 -> (EQlm  l1  l2) -> EQlm (cons m1 l1) (cons m2 l2).
Notation "ml1 '#@' ml2" := (EQlm ml1 ml2) (at level 0).
Axiom eqlistm_ind: forall  (l1 l2:  list message ), l1 #@ l2 ->  (f l1) # (f l2).
Instance EQlm_Equ_Equiv : Equivalence  (EQlm).
Proof.
split.
  unfold Reflexive.
  induction x.
   apply eqnm.
   apply eqconm. reflexivity. apply IHx.
 unfold Symmetric.
intros  x y H.
induction H.
apply eqnm.
apply eqconm.
rewrite H. reflexivity. apply IHEQlm.
unfold Transitive.
 intros x y z H1 H2.
 induction H1. assumption.
  Admitted.

Axiom EQlm_equiv:  equiv (list message) (EQlm).

Instance lm_Eqlm_Equiv : Equivalence  (EQlm ).
Proof.
split;
repeat apply EQlm_equiv.
Qed.

(** * Morhphisms *)

Axiom eq_msg_mylist_Cong :  forall  (n n1 :nat) (m1 m2: message) (l1 l2: mylist n), m1 # m2 -> l1 #### l2 ->  (submsg_mylist n1 m1 l1) ~ (submsg_mylist n1 m2 l2).

Add Parametric Morphism{n}: (@ submsg_mylist n ) with
  signature eq ==> EQm ==> EQosl ==> EQI as submsg_mor.
 Proof.   intros. apply eq_msg_mylist_Cong; assumption. Qed.

Axiom f_Cong_l : forall (l1 l2: list message) (m1 m2:message), m1 # m2 -> l1 #@ l2   -> (cons m1 l1 ) #@ (cons m2 l2).
Add Parametric Morphism : cons  with
  signature EQm ==> EQlm ==> EQlm as cons_m.
 Proof.    intros. apply f_Cong_l. assumption.  assumption. Qed.

Add Parametric Morphism : f  with
  signature EQlm ==> EQm as f_m.
 Proof.    intros. apply eqlistm_ind. assumption.   Qed.

(**split.
  unfold Reflexive.
  induction x.
   apply EQNm.

   apply EQCONSm. reflexivity. apply IHx.

 unfold Symmetric.

intros  x y H.

induction H.
apply EQNm.
apply EQCONSm.
rewrite H. reflexivity. apply IHEQlm.

unfold Transitive.
 intros x y z H1 H2.
 induction H1.
   +  apply H2.
  + dependent destruction z.
     - rewrite <- H2. apply EQCONSm;    inversion H2; subst. rewrite H. apply H6.
        dependent destruction H2. apply   IHEQosl . assumption.
Qed.

Qed.*)

(** * [message] *)

(** [exp_mor] *)
Axiom exp_Cong: forall (m1 m2 m3 m1' m2' m3' : message), m1 # m1' -> m2 # m2' -> m3 # m3' -> (exp m1 m2 m3) # (exp m1' m2' m3').
Add Parametric Morphism: (@ exp) with
  signature EQm ==> EQm ==> EQm ==> EQm as exp_mor.
 Proof.   intros. apply exp_Cong; assumption. Qed.

(** [pair_mor] *)

Axiom pair_Cong: forall (m1 m2  m1' m2'  : message), m1 # m1' -> m2 # m2'  -> (pair m1 m2) # (pair m1' m2').
Add Parametric Morphism: (@ pair) with
  signature EQm ==> EQm ==> EQm as pair_mor.
 Proof.   intros. apply pair_Cong; assumption. Qed.

(** [pi1_mor] *)

Axiom pi1_Cong: forall (m1 m1' : message), m1 # m1' -> (pi1 m1) # (pi1 m1' ).
Add Parametric Morphism: (@ pi1) with
  signature EQm ==> EQm as pi1_mor.
 Proof.   intros. apply pi1_Cong; assumption. Qed.

(** [pi2_mor] *)

Axiom pi2_Cong: forall (m1 m1' : message), m1 # m1' -> (pi2 m1) # (pi2 m1' ).
Add Parametric Morphism: (@ pi2) with
  signature EQm ==> EQm as pi2_mor.
 Proof.   intros. apply pi2_Cong; assumption. Qed.

(** [ggen_mor] *)

Axiom ggen_Cong: forall (m1 m1' : message), m1 # m1' -> (ggen m1) # (ggen m1' ).
Add Parametric Morphism: (@ ggen) with
  signature EQm ==> EQm as ggen_mor.
 Proof.   intros. apply ggen_Cong; assumption. Qed.

(** [r_mor] *)

Axiom r_Cong: forall (m1 m1' : nat), m1 = m1' -> (r m1) # (r m1' ).
Add Parametric Morphism: (@ r) with
  signature eq ==> EQm as r_mor.
Proof. intros. apply r_Cong. reflexivity. Qed.

(** [rs_mor] *)

Axiom rs_Cong: forall (m1 m1' : message), m1 # m1' -> (rs m1) # (rs m1' ).
Add Parametric Morphism: (@ rs) with
  signature EQm ==> EQm as rs_mor.
 Proof.   intros. apply rs_Cong; assumption. Qed.

(** [act_mor] *)

Axiom act_Cong: forall (m1 m1' : message), m1 # m1' -> (act m1) # (act m1' ).
Add Parametric Morphism: (@ act) with
  signature EQm ==> EQm as act_mor.
 Proof.   intros. apply act_Cong; assumption. Qed.

(** [m_mor] *)

Axiom m_Cong: forall (m1 m1' : message), m1 # m1' -> (m m1) # (m m1' ).
Add Parametric Morphism: (@ m) with
  signature EQm ==> EQm as m_mor.
 Proof.   intros. apply m_Cong; assumption. Qed.

(** [nonce_mor] *)

Axiom nonce_Cong: forall (m1 m1' : message), m1 # m1' -> (nc m1) # (nc m1' ).
Add Parametric Morphism: (@ nc) with
  signature EQm ==> EQm as nonce_mor.
Proof. intros. apply nonce_Cong. assumption.  Qed.

(** [to_mor] *)

Axiom to_Cong: forall (m1 m1' : message), m1 # m1' -> (to m1) # (to m1' ).
Add Parametric Morphism: (@ to) with
  signature EQm ==> EQm as to_mor.
 Proof.   intros. apply to_Cong; assumption. Qed.

 (** [reveal_mor] *)

Axiom reveal_Cong: forall (m1 m1' : message), m1 # m1' -> (reveal m1) # (reveal m1' ).
Add Parametric Morphism: (@ reveal) with
  signature EQm ==> EQm as reveal_mor.
 Proof.   intros. apply reveal_Cong; assumption. Qed.
(*
(******************reveal signature**********************)
Axiom revsign_Cong: forall (m1 m1' : nat), m1 = m1' -> (revsign m1) ## (revsign m1' ).
Add Parametric Morphism: (@ revsign) with
  signature eq ==> EQb as revsign_mor.
 Proof.   intros. apply revsign_Cong. reflexivity. Qed.
*)
 (** [sign_mor] *)

Axiom sign_Cong: forall (m1 m1' m2 m2' : message), m1 # m1' -> m2 # m2' -> (sign m1 m2) # (sign m1' m2' ).
Add Parametric Morphism: (@sign) with
  signature EQm ==> EQm ==> EQm as sign_mor.
 Proof.   intros. apply sign_Cong; assumption. Qed.

 (** [enc_mor] *)

Axiom enc_Cong: forall (m1 m2 m3 m1' m2' m3' : message), m1 # m1' -> m2 # m2' -> m3 # m3'  -> (enc m1 m2 m3) # (enc m1' m2' m3').
Add Parametric Morphism: (@ enc) with
  signature EQm ==> EQm ==> EQm ==> EQm as enc_mor.
Proof.   intros. apply enc_Cong; assumption. Qed.

(** [L_mor] *)

Axiom L_Cong: forall (m1  m1'  : message), m1 # m1'  -> (L m1) # (L m1').
Add Parametric Morphism: (@ L) with
  signature EQm ==> EQm as L_mor.
 Proof.   intros. apply L_Cong; assumption. Qed.

 (** [dec_mor] *)

Axiom dec_Cong: forall (m1 m2  m1' m2'  : message), m1 # m1' -> m2 # m2'  -> (dec m1 m2) # (dec m1' m2').
Add Parametric Morphism: (@ dec) with
  signature EQm ==> EQm ==> EQm as dec_mor.
 Proof.   intros. apply dec_Cong; assumption. Qed.

(** [k_mor] *)

Axiom k_Cong: forall (m1 m1' : message), m1 # m1' -> (k m1) # (k m1' ).
Add Parametric Morphism: (@ k) with
  signature EQm ==> EQm as k_mor.
 Proof.   intros. apply k_Cong; assumption. Qed.

(** [pk_mor] *)

Axiom pk_Cong: forall (m1 m1' : nat), m1 = m1' -> (pk m1) # (pk m1' ).
Add Parametric Morphism: (@ pk) with
  signature eq ==> EQm as pk_mor.
 Proof.   intros. apply pk_Cong. reflexivity. Qed.

(** [sk_mor] *)

Axiom sk_Cong: forall (m1 m1' : nat), m1 = m1' -> (sk m1) # (sk m1' ).
Add Parametric Morphism: (@ sk) with
  signature eq ==> EQm as sk_mor.
 Proof.   intros. apply sk_Cong. reflexivity. Qed.

 (** [f_mor] *)

Axiom f_Cong: forall (l1 l1' : list message), ( l1) #@ ( l1') -> (f  l1) # (f  l1' ).
Add Parametric Morphism : ( f ) with
  signature EQlm ==> EQm as f_mor.
Proof.   intros. apply f_Cong. assumption. Qed.

(** * [Bool] *)

(** [ifb_mor] *)

Axiom IFB_Cong: forall (b1 b2 b3 b1' b2' b3': Bool), b1 ## b1' -> b2 ## b2' -> b3 ## b3' -> (ifb b1 b2 b3) ## (ifb b1' b2' b3').
Add Parametric Morphism: (@ifb) with
  signature EQb ==> EQb ==> EQb ==> EQb as ifb_mor.
 Proof.   intros. apply IFB_Cong; assumption. Qed.

(** [ifm_mor] *)

 Axiom IFM_Cong: forall (b b' : Bool) ( m1 m2 m1' m2': message), (b ## b') -> m1 # m1' -> m2 # m2' -> (ifm b m1 m2) # (ifm b' m1' m2').
Add Parametric Morphism: (@ifm) with
  signature EQb ==> EQm ==> EQm ==> EQm as ifm_mor.
 Proof.   intros. apply IFM_Cong; assumption. Qed.

 (** [eqb_mor] *)

Axiom eqb_Cong: forall (b1 b2 b1' b2': Bool),  b1 ## b1' -> b2 ## b2' ->  (eqb b1 b2) ## (eqb b1' b2').
Add Parametric Morphism: (@eqb) with
signature EQb ==> EQb ==> EQb as eqb_mor.
Proof.   intros. apply eqb_Cong; assumption. Qed.

(** [eqm_mor] *)

Axiom eqm_Cong: forall (m1 m2 m1' m2' : message), m1 # m1' -> m2 # m2' -> (eqm m1 m2) ## (eqm m1' m2').

Add Parametric Morphism: (@eqm) with
  signature EQm ==> EQm ==> EQb as eqm_mor.
 Proof.   intros. apply eqm_Cong; assumption. Qed.

(** [EQ_L_mor] *)
Axiom EQL_Cong : forall (m1 m2 m1' m2' : message), m1 # m1' -> m2 # m2' -> (EQL m1 m2 ) ## (EQL m1' m2').
Add Parametric Morphism: (@EQL) with
  signature EQm ==> EQm ==> EQb as EQL_mor.
Proof.   intros. apply EQL_Cong; assumption. Qed.

(** [ver_mor] *)

Axiom ver_Cong : forall (m1 m2  m3 m1' m2' m3' : message), m1 # m1' -> m2 # m2' -> m3 # m3' -> (ver m1 m2 m3 ) ## (ver m1' m2' m3').
Add Parametric Morphism: (@ver) with
  signature EQm ==> EQm ==> EQm ==> EQb as ver_mor.
Proof.   intros. apply ver_Cong; assumption. Qed.

(** * Morphisms on substitution functions *)

(** [substbl_bl_mor] *)

Axiom substbl_bl_Cong : forall (b1 b2 b1' b2' : Bool) (n: nat), b1 ## b1' -> b2 ## b2' -> (subbol_bol n b1 b2) ## (subbol_bol n b1' b2').

Add Parametric Morphism : (@subbol_bol) with
signature eq ==> EQb ==> EQb ==> EQb as substbl_bl_mor.
Proof. intros.  apply substbl_bl_Cong. apply H. apply H0.
Qed.

(** [substbl_msg_mor] *)

Axiom substbl_msg_Cong : forall (b1 b1' : Bool)(m2 m2' : message) (n: nat), b1 ## b1' -> m2 # m2' -> (subbol_msg n b1 m2) # (subbol_msg n b1' m2').

Add Parametric Morphism : (@subbol_msg) with
signature eq ==> EQb ==> EQm ==> EQm as substbl_msg_mor.
Proof. intros.  apply substbl_msg_Cong. apply H. apply H0.
Qed.

(** [substmsg_Bool_mor] *)

Axiom substmsg_Bool_Cong : forall (m1 m1' : message) (b1 b1' : Bool) (n: nat), m1 # m1' -> b1 ## b1' -> (submsg_bol n m1 b1) ## (submsg_bol n m1' b1').

Add Parametric Morphism : (@submsg_bol) with
signature eq ==> EQm ==> EQb ==> EQb as substmsg_Bool_mor.
Proof. intros.  apply substmsg_Bool_Cong. apply H. apply H0.
Qed.

(** [substmsg_msg_mor] *)

Axiom substmsg_msg_Cong : forall (m1 m2 m1' m2' : message) (n: nat), m1 # m1' -> m2 # m2' -> (submsg_msg n m1 m2) # (submsg_msg n m1' m2').

Add Parametric Morphism : (@submsg_msg) with
signature eq ==> EQm ==> EQm ==> EQm as substmsg_msg_mor.
Proof. intros.  apply substmsg_msg_Cong. apply H. apply H0.
Qed.

(** [subbol_msg'_mor] *)

Axiom clos_subbol_cong : forall ( b1 b2 b3 b4: Bool) (t1 t2:message), b1 ## b2 -> b3 ## b4 -> t1 # t2 -> (subbol_msg' b1 b3 t1) # (subbol_msg' b2 b4 t2).

Add Parametric Morphism : subbol_msg'  with
  signature EQb ==> EQb ==> EQm ==> EQm as subbol_msg'_mor.
 Proof.   intros. apply clos_subbol_cong; try assumption. Qed.

(** * [oursum] *)
(** [msg_mor] *)

Axiom msg_Cong: forall (m1 m1'  : message), m1 # m1'  -> (msg m1 ) ### (msg m1').

Add Parametric Morphism : (@msg ) with
signature EQm ==> EQos as msg_mor.
Proof. intros. apply eqm1. apply H. Qed.

(** [bol_mor] *)

Axiom bol_Cong: forall (b1 b1'  : Bool), b1 ## b1'  -> (bol b1 ) ### (bol b1').

Add Parametric Morphism : (@bol ) with
signature EQb ==> EQos as bol_mor.
Proof.  intros. apply eqb1. apply H. Qed.

(** [Cons_mor] *)

Add Parametric Morphism {n}: (Cons oursum n) with
signature EQos ==> EQosl ==> EQosl  as Cons_mor.
Proof. intros. apply eqconos. apply H. apply H0. Qed.

(** [app_EQml_mor] *)

Axiom app_EQml_Cong : forall (n1 n2:nat)(l1 l1'  : mylist n1) (l2 l2': mylist n2), l1 #### l1' -> l2 ####l2' -> (l1 ++ l2) #### (l1' ++ l2').

Add Parametric Morphism {n1} {n2}: (@app_mylist n1 n2 ) with
signature  EQosl ==> EQosl ==> EQosl  as app_EQml_mor.
Proof. intros. apply app_EQml_Cong. apply H. apply H0. Qed.

(** [ml_EQI_mor] *)

Axiom ml_EQI_Cong: forall (n : nat) (l1 l2 : mylist n) (os1 os2 : oursum), os1 ### os2 -> l1 ####l2 -> (Cons oursum n os1 l1 ) ~ (Cons  oursum n os2 l2) .

Add Parametric Morphism {n}: (Cons oursum n) with
signature EQos ==> EQosl ==> EQI  as ml_EQI_mor.

Proof. intros. apply ml_EQI_Cong with (os1:=x) (os2:=y) (l1:= x0) (l2:= y0). apply H. apply H0. Qed.

(** [app_EQI_mor] *)

Axiom app_EQI_Cong : forall (n1 n2:nat)(l1 l1'  : mylist n1) (l2 l2': mylist n2), l1 #### l1' -> l2 ####l2' -> (l1 ++ l2) ~ (l1' ++ l2').

Add Parametric Morphism {n1} {n2}: (@app_mylist n1 n2 ) with
signature  EQosl ==> EQosl ==> EQI  as app_EQI_mor.
Proof. intros. apply app_EQI_Cong. apply H. apply H0. Qed.

(** Equivalence relation [EQml] on [ilist message n] for given [n]. *)

Definition EQml {n:nat} (l1 l1': ilist message n) :=  (EQosl (conv_mlist_mylist l1) (conv_mlist_mylist l1')).

Notation "ml1 '==' ml2" := (EQml ml1 ml2) (at level 0).

Theorem eqlistm_ind': forall (n:nat) (l1 l2: ilist message n), (l1 == l2) ->  (conv_mlist_mylist l1) ~ (conv_mlist_mylist l2).
Proof. intros. apply eqlistos_ind. apply H. Qed.

Instance ml_Equ_Equiv {n}: Equivalence  (@EQml n).
Proof.
split.
unfold EQml.
unfold Reflexive. reflexivity.
unfold EQml. unfold Symmetric. intros. rewrite H. reflexivity.
unfold EQml. unfold Transitive. intros. rewrite H, H0. reflexivity.
Qed.

(** andB_mor *)

Axiom andB_Cong: forall (b1 b2 b1' b2' : Bool), b1 ## b1' -> b2 ## b2' -> (b1 & b2) ## (b1' & b2').

Add Parametric Morphism:(@ andB) with
signature EQb ==> EQb ==> EQb as andB_mor.
Proof. intros. apply andB_Cong;assumption. Qed.

(** notb_mor *)

Axiom notb_Cong : forall (b1 b1' : Bool), b1 ## b1' -> (notb b1) ## (notb b1').

Add Parametric Morphism: (@ notb) with
signature EQb ==> EQb as notb_mor.
Proof.
intros.
apply notb_Cong.
assumption. Qed.

(** Equality of [Bool] terms using indistinguishability. *)

Definition EQI_bol (b1 b2: Bool) := [ bol (eqb b1 b2)] ~ [bol TRue].

Notation "b1 ## b2" := (EQI_bol b1 b2)(at level 5).

(** Equality of [message] terms using indistinguishability. *)

Definition EQI_msg (x y : message) :=  [ bol (eqm x y)] ~ [ bol TRue] .

Notation "m1 # m2" := (EQI_msg m1 m2)(at level 5).

(** Attacker starts new session. *)

Definition Att_new_session:= forall x:message,  (eqm (act x) new)  ## TRue .


From icl Require Export util assignments formulas.

(** * Set of all satisfying assignment *)

(* Set of all satisfying assignment must not have any duplicates (up to equivalence).  *)
Definition dupfree (vs : variables) (αs : assignments) :=
  dupfree_rel (equiv_assignments vs) αs.

(* Set of all satisfying assignment contains only satisfying assignments
   that set all the variables. For example, formula [x1 ∨ x2 ∨ T] has
   only four satisfying assignments. *)
Definition set_with_sat_assignments (ϕ : formula) (αs : assignments) :=
  set_with (fun α => sets_all_variables α ϕ /\ sat_assignment ϕ α) αs.

(* For any satisfying assignment (that sets all the variables) of
   the formula there is an equivalent assignment which is contained
   in the set of all satisfying assignments. *)
Definition set_with_all_sat_assignments (ϕ : formula) (αs : assignments) :=
  set_with_all
    (equiv_assignments (leaves ϕ))
    (fun α => sets_all_variables α ϕ /\ sat_assignment ϕ α)
    αs.

(* We define a list of all sat. assignments as conjunction of the properties above. *)
Definition list_of_all_sat_assignments (ϕ : formula) (αs : assignments) :=
  dupfree (leaves ϕ) αs /\
  set_with_sat_assignments ϕ αs /\
  set_with_all_sat_assignments ϕ αs.

(* The number of sat. assignments is the length of a list of all sat. assignments. *)
Definition number_of_sat_assignments (ϕ : formula) (n : nat) :=
  exists (αs : assignments),
    list_of_all_sat_assignments ϕ αs /\
    length αs = n.
Notation "'#sat' ϕ '≃' n" := (number_of_sat_assignments ϕ n) (at level 10).

(* Note that this number is unique. *)
Theorem number_of_sat_assignments_is_unique:
  forall (ϕ : formula) (n1 n2 : nat),
    #sat ϕ ≃ n1 ->
    #sat ϕ ≃ n2 ->
    n1 = n2.
Proof.
  intros ? ? ? N1 N2.
  decide (n1 = n2) as [EQ|NEQ]; [auto|exfalso].
  destruct N1 as [αs1 [[[ND1 DF1] [SAT1 AllSAT1]] N1]], N2 as [αs2 [[[ND2 DF2] [SAT2 AllSAT2]] N2]].
  apply not_eq in NEQ; destruct NEQ as [LT|GT].
  { rewrite <-N1, <-N2 in LT; clear N1 N2.
    eapply antipigeonhole with (R := equiv_assignments (leaves ϕ)) in LT; eauto.
    - destruct LT as [α [EL ALL]].
      specialize (SAT2 α EL); destruct SAT2 as [SET2 SAT2].
      specialize (AllSAT1 α (conj SET2 SAT2)).
      destruct AllSAT1 as [β [EQU ELβ]].
      specialize (ALL β ELβ); auto.
    - apply assignment_eq_dec.
    - apply equiv_assignments_dec.
    - apply equiv_assignments_sym.
    - apply equiv_assignments_trans.
    - split; eauto.
    - split; eauto.
  }
  { rewrite <-N1, <-N2 in GT; clear N1 N2.
    eapply antipigeonhole with (R := equiv_assignments (leaves ϕ)) in GT; eauto.
    - destruct GT as [α [EL ALL]].
      specialize (SAT1 α EL); destruct SAT1 as [SET1 SAT1].
      specialize (AllSAT2 α (conj SET1 SAT1)).
      destruct AllSAT2 as [β [EQU ELβ]].
      specialize (ALL β ELβ); auto.
    - apply assignment_eq_dec.
    - apply equiv_assignments_dec.
    - apply equiv_assignments_sym.
    - apply equiv_assignments_trans.
    - split; eauto.
    - split; eauto.
  }
Qed.


Require Import rt.util.all.
Require Import rt.implementation.uni.jitter.task.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq.

Module ConcreteJob.

  Import ConcreteTask.

  Section Defs.

    (* Definition of a concrete task. *)
    Record concrete_job :=
    {
      job_id: nat;
      job_arrival: nat;
      job_cost: nat;
      job_deadline: nat;
      job_task: concrete_task_eqType
    }.

    (* To make it compatible with ssreflect, we define a decidable
       equality for concrete jobs. *)
    Definition job_eqdef (j1 j2: concrete_job) :=
      (job_id j1 == job_id j2) &&
      (job_arrival j1 == job_arrival j2) &&
      (job_cost j1 == job_cost j2) &&
      (job_deadline j1 == job_deadline j2) &&
      (job_task j1 == job_task j2).

    (* Next, we prove that job_eqdef is indeed an equality, ... *)
    Lemma eqn_job : Equality.axiom job_eqdef.
    Proof.
      unfold Equality.axiom; intros x y.
      destruct (job_eqdef x y) eqn:EQ.
      {
        apply ReflectT; unfold job_eqdef in *.
        move: EQ => /andP [/andP [/andP [/andP [/eqP ID /eqP ARR] /eqP COST] /eqP DL] /eqP TASK].
        by destruct x, y; simpl in *; subst.
      }
      {
        apply ReflectF.
        unfold job_eqdef, not in *; intro BUG.
        apply negbT in EQ; rewrite negb_and in EQ.
        destruct x, y.
        rewrite negb_and in EQ.
        move: EQ => /orP [EQ | /eqP TASK].
        move: EQ => /orP [EQ | /eqP DL].
        rewrite negb_and in EQ.
        move: EQ => /orP [EQ | /eqP COST].
        rewrite negb_and in EQ.
        move: EQ => /orP [/eqP ID | /eqP ARR].
        by apply ID; inversion BUG.
        by apply ARR; inversion BUG.
        by apply COST; inversion BUG.
        by apply DL; inversion BUG.
        by apply TASK; inversion BUG.
      }
    Qed.

    (* ..., which allows instantiating the canonical structure. *)
    Canonical concrete_job_eqMixin := EqMixin eqn_job.
    Canonical concrete_job_eqType := Eval hnf in EqType concrete_job concrete_job_eqMixin.

   End Defs.

End ConcreteJob.


Class CompPred (U : Type) (P : U -> Prop) : Type :=
{ satisfyingness_comp : forall x, {P x} + {~P x} }.

Definition is_satisfied {U} P `{CompPred U P} x :=
    satisfyingness_comp x.

Definition satisfied {U} P `{CompPred U P} x : Prop :=
    if is_satisfied P x then True else False.

Definition subset {U : Set} (P : U -> Prop) `{CompPred U P} :=
    { x : U | satisfied P x }.
Definition subtype {U : Type} (P : U -> Prop) `{CompPred U P} :=
    { x : U | satisfied P x }.

Notation "x ? P"       := (satisfied P x)                (no associativity, at level 89).
Notation "{S? U | P }" := (@subset U P _).
Notation "{T? U | P }" := (@subtype U P _).
Notation "x ?& W"      := (exist _ x W)                  (no associativity, at level 89).
Notation "¹ x"         := (proj1_sig x)                                     (at level 0).
Notation "² x"         := (proj2_sig x)                                     (at level 0).
(* Bad without eta_CompPred :
Notation "{S? x : U | P }" := (@subset  U (fun x => P) _).
Notation "{T? x : U | P }" := (@subtype U (fun x => P) _). *)

Definition submember                                        {U : Set} P `{CompPred U P} :
    forall x, satisfied P x -> subset P :=

    fun x H => x ?& H.

Definition submemberT                                      {U : Type} P `{CompPred U P} :
    forall x, satisfied P x -> subtype P :=

    fun x H => x ?& H.

Definition witness_intro                                        {U} P `{CompPred U P} x :
    P x -> x ? P :=

    fun H0 => match is_satisfied P x as s
              return (if s then True else False) : Prop
              with
              | left _ => I
              | right notH0 => notH0 H0
              end.

Definition witness_elim                                         {U} P `{CompPred U P} x :
    x ? P -> P x :=

    fun W  => match is_satisfied P x as s
              return ((if s then True else False) : Prop) -> _
              with
              | left H      => fun _ => H
              | right notH0 => fun devil => match devil with end
              end W.

Notation "H '`as' 'witness' 'of' P x" := (witness_intro P x H)         (no associativity,
                                                              at level 73, P at level 0).
Notation "W '`as' 'proof' 'of' P x"   := (witness_elim P x W)          (no associativity,
                                                              at level 73, P at level 0).

Definition submember_by                                     {U : Set} P `{CompPred U P} :
    forall x, P x -> subset P :=

    fun x H => submember P x (H `as witness of P x).

Definition submemberT_by                                   {U : Type} P `{CompPred U P} :
    forall x, P x -> subtype P :=

    fun x H => submemberT P x (H `as witness of P _).

Instance not_CompPred                                                             {U} P :
    CompPred U P -> CompPred U (fun x => ~P x) :=

{
    satisfyingness_comp := fun x =>
        match is_satisfied P x with
        | left H  => right (fun notH => notH H)
        | right H => left H
        end
}.

Instance const_CompPred                                                     {U1} P U2 x :
    CompPred U1 P -> CompPred U2 (fun _ => P x) :=

{
    satisfyingness_comp := fun _ => is_satisfied P x
}.

(*
Instance eta_CompPred                                                             {U} P :
    CompPred U P -> CompPred U (fun x => P x) :=

    fun H => H.

Definition instantiation_loop U P (H : CompPred U P) x :=
    is_satisfied (fun x => ~P x) x.
*)

Lemma witness_unique :                                    forall {U} P `{CompPred U P} x,
      forall H1 H2 : x ? P, H1 = H2.

Proof.
  intros U P H x H1 H2.
  unfold satisfied in *.
  destruct (is_satisfied P x);
  solve [destruct H1, H2; auto].
Qed.

Lemma subset_elem_eq :                              forall {A : Set} {P} `{CompPred A P},
    forall e1 e2 : subset P, ¹e1 = ¹e2 -> e1 = e2.

Proof.
  intros A P H e1 e2 H0.
  destruct e1, e2.
  simpl in H0.
  subst.
  f_equal.
  apply witness_unique.
Qed.

Lemma subtype_elem_eq :                            forall {A : Type} {P} `{CompPred A P},
    forall e1 e2 : subtype P, ¹e1 = ¹e2 -> e1 = e2.

Proof.
  intros A P H e1 e2 H0.
  destruct e1, e2.
  simpl in H0.
  subst.
  f_equal.
  apply witness_unique.
Qed.

Hint Resolve witness_intro witness_unique subset_elem_eq subtype_elem_eq.


Require Import Iron.Language.SimpleRef.Ty.
Require Export Iron.Language.SimpleRef.Exp.

(* Substitution of expressions in expressions preserves typing.

   Inductively, we must reason about performing substitutions at any
   depth, hence we must prove a property about (subst' d x2 x1) instead
   of the weaker (subst x2 x1) which assumes the substitution is taking
   place at top level. *)
Lemma subst_exp_exp_ix
 :  forall ix te se x1 x2 t1 t2
 ,  get  ix te = Some t2
 -> TYPE te se             x1 t1
 -> TYPE (delete ix te) se x2 t2
 -> TYPE (delete ix te) se (substX ix x2 x1) t1.
Proof.
 intros. gen ix te se x2 t1.
 induction_type x1.

 Case "XVar".
  fbreak_nat_compare.
  SCase "i = ix".
   burn.

  SCase "n < ix".
   apply TyVar.
   rewrite <- H5.
    apply get_delete_above. auto.

  SCase "n > ix".
   apply TyVar.
   destruct n.
    burn.
    simpl. nnat. down. apply get_delete_below. omega.

 Case "XLam".
  apply TyLam.
  rewrite delete_rewind.
  apply IHx1; auto.
   simpl. apply type_tyenv_cons. auto.
Qed.

Theorem subst_exp_exp
 :  forall te se x1 x2 t1 t2
 ,  TYPE (te :> t2) se x1 t1
 -> TYPE te se         x2 t2
 -> TYPE te se (substX 0 x2 x1) t1.
Proof.
 intros te se x1 x2 t1 t2 Ht1 Ht2.
 lets H: subst_exp_exp_ix 0 (te :> t2).
  simpl in H. eauto.
Qed.


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Tarski_dev.Ch12_parallel.

Section tarski_euclid.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma tarski_s_euclid_implies_euclid_5 :
  tarski_s_parallel_postulate ->
  euclid_5.
Proof.
intros HT P Q R S T U HPTQ HRTS HQUR HNC HCong1 HCong2.
destruct (symmetric_point_construction R P) as [V HMid].
assert (Hc1 : Bet V P R) by (unfold Midpoint in *; spliter; Between).
assert (Hc2 : Bet Q U R) by (unfold BetS in *; spliter; Between).
destruct (inner_pasch V Q R P U) as [W [HPWQ HUWV]]; Col; clear Hc1; clear Hc2.
assert (HPW : P <> W).
  {
  intro; treat_equalities.
  assert (P <> V).
    {
    intro; treat_equalities; apply HNC; unfold BetS in *; spliter; ColR.
    }
  apply HNC; unfold BetS in *; spliter; ColR.
  }
destruct (HT P V U W Q) as [X [Y [HPVX [HPUY HXQY]]]]; Between.
assert (HPar : Par_strict Q S P R).
  {
  apply par_not_col_strict with P; Col.
  assert_diffs; unfold BetS in *; spliter;
  apply l12_17 with T; [auto|split; Cong; Between..].
  }
assert (HTS : TS Q S P Y).
  {
  apply l9_8_2 with X.

    {
    assert_diffs.
    assert (P <> R)
      by (intro; treat_equalities; apply par_strict_distinct in HPar; spliter; Col).
    assert (P <> X)
      by (intro; treat_equalities; apply par_strict_distinct in HPar; spliter; Col).
    assert (~ Col X Q S).
      {
      apply par_strict_not_col_2 with P.
      apply par_strict_symmetry; apply par_strict_col_par_strict with R; Col.
      unfold BetS in *; spliter; ColR.
      }
    repeat split; [..|exists Q]; Col.
    intro HCol.
    assert (Q = Y)
      by (apply l6_21 with Q S X Q; try (intro; treat_equalities); Col).
    treat_equalities.
    assert (Q = U).
      {
      apply BetSEq in HPTQ; apply BetSEq in HRTS; apply BetSEq in HQUR;
      spliter; apply l6_21 with Q P R Q; Col.
      apply par_strict_not_col_2 with S; Par.
      }
    treat_equalities; unfold BetS in *; spliter; Col.
    }

    {
    assert (P <> R)
      by (intro; treat_equalities; apply par_strict_distinct in HPar; spliter; Col).
    assert (P <> V)
      by (intro; treat_equalities; apply par_strict_distinct in HPar; spliter; Col).
    assert (P <> X)
      by (intro; treat_equalities; apply par_strict_distinct in HPar; spliter; Col).
    apply l12_6, par_strict_right_comm, par_strict_col_par_strict with R; ColR.
    }
  }
destruct HTS as [Hc1 [Hc2 [I [HCol HBet]]]];
clear Hc1; clear Hc2; exists I.
assert (HPUI : BetS P U I).
 {
  assert (P <> Y)  by (intro; treat_equalities; Col).
  assert (HPUI : Col P U I) by ColR.
  split.

    {
    elim HPUI; clear HPUI; intro HPUI; Col.
    elim HPUI; clear HPUI; intro HPUI; exfalso.

      {
      assert (HFalse : OS Q S P U).
        {
        apply one_side_transitivity with R; [Side|].
        apply BetSEq in HPTQ; apply BetSEq in HRTS; apply BetSEq in HQUR;
        spliter; apply l9_19 with Q; Col.
        split; [Out|].
        apply par_strict_not_col_1 with P; Par.
        }
      apply (l9_19 Q S P U I) in HFalse; Col.
      spliter.
      apply (not_bet_and_out U I P); split; Out.
      }

      {
      assert (HFalse : OS P R I U).
        {
        apply one_side_transitivity with Q.
          {
          apply l12_6; apply par_strict_right_comm;
          apply par_strict_col_par_strict with S; Par; Col.
          intro; treat_equalities;
          unfold BetS in *; spliter;
          apply HNC; ColR.
          }

          {
          assert (HPar':= HPar); apply par_strict_distinct in HPar.
          unfold BetS in *; spliter; apply l9_19 with R; Col.
          split; [Out|apply par_strict_not_col_3 with S; Par].
          }
        }
        apply col_one_side_out in HFalse.
          apply (not_bet_and_out I P U); auto.
        Col.
      }
    }

    {
    apply par_strict_not_col_3 in HPar;
    apply BetSEq in HPTQ; apply BetSEq in HRTS; apply BetSEq in HQUR; spliter.
    split; intro; treat_equalities; [apply HPar; Col|].
    assert (Q = U).
      {
      apply l6_21 with S Q R Q; Col.
      intro; apply HNC; ColR.
      }
    treat_equalities; auto.
    }
 }
split; Col.
assert (HTS : TS Q R S I).
  {
  apply l9_8_2 with P.

    {
    unfold BetS in *; spliter.
    repeat split; [..|exists U; split; Col].
    intro; apply HNC; ColR.
    intro; apply par_strict_not_col_4 in HPar; apply HPar; ColR.
    }

    {
    apply l12_6.
    apply par_not_col_strict with P; Col; [|intro; apply par_strict_not_col_3 in HPar; Col].
    apply BetSEq in HPTQ; apply BetSEq in HRTS; apply BetSEq in HQUR; spliter;
    apply l12_17 with T; try split; Cong; Between.
    }
  }
split.

  {
  elim HCol; intro HSQI; Between.
  assert (HFalse := HTS).
  apply l9_9 in HFalse; exfalso; apply HFalse.
  apply l9_19 with Q; Col.
  apply par_strict_not_col_4 in HPar; split; [|Col].
  assert_diffs; repeat split; auto; elim HSQI; Between.
  }

  {
  assert_diffs; split; auto.
  }
Qed.

End tarski_euclid.


(**
*  Notation1.v
-----------------
Defines a more natural monadic notation for the probabilistic
computation monad defined in [Comp.v].
*)

Set Implicit Arguments.

From mathcomp.ssreflect
Require Import ssreflect ssrnat seq ssrbool ssrfun fintype choice eqtype .

From ProbHash.Computation
Require Import Comp.

Lemma size_enum_equiv: forall n: nat, size(enum (ordinal n.+1)) = n.+1 -> #|ordinal_finType n.+1| = n.+1.
Proof.
    move=> n H.
    by rewrite unlock H.
Qed.

(** Draw a uniformly random integer value from the finite range 0 to n *)
Definition random n := (@Rnd (ordinal_finType n.+1) n (size_enum_equiv (size_enum_ord n.+1))).

Notation "'ret' v" := (Ret _ v) (at level 75).
Notation "[0 ... n ]" := (random n).
Notation "{ 0 , 1 } ^ n" := (random (2^n))
    (right associativity, at level 77).
Notation "{ 0 , 1 }" := (random 1)
    (right associativity, at level 75).
Notation "x <-$ c1 ; c2" := (@Bind _ _ c1 (fun x => c2))
    (right associativity, at level 81, c1 at next level).
Notation "x <- e1 ; e2" := ((fun x => e2) e1)
    (right associativity, at level 81, e1 at next level).
Notation "'P[' a '===' b ']'" := ((evalDist a) b).
Notation "'P[' a ']'" := ((evalDist a) true).
Notation "'E[' a ']'" := (expected_value a).
Notation " a '|>' b " := (w_a <-$ a; b w_a) (at level 50).
Notation " w '>>=' a '<&&>' b " := (fun w => ret (a  && b )) (at level 49).
Notation " w '>>=' a '<||>' b " := (fun w => ret (a || b )) (at level 49).

Definition example :=
    x <- 3;
    y <-$ [0 ... 3];
    ret y.


From FloatCohorts Require Import Tactics.
Require Export ZArith PArith Lia Floats.SpecFloat.

Open Scope Z.

Definition div2_opt (p : positive) : option positive :=
  match p with
  | xO p' => Some p'
  | _ => None
  end.

Lemma div2_opt_correct (p d : positive) :
  div2_opt p = Some d <-> p = (d * 2)%positive.
Proof.
  split; intros.
  - destruct p; inversion H.
    cbn.
    rewrite Pos.mul_comm.
    reflexivity.
  -
    rewrite H.
    cbn.
    rewrite Pos.mul_comm.
    reflexivity.
Qed.

Lemma Zpow_divide (b p1 p2 : Z) :
  0 < b ->
  0 <= p1 <= p2 ->
  (b ^ p1 | b ^ p2).
Proof.
  intros B P.
  rewrite <-Z.mod_divide by (apply Z.pow_nonzero; lia).
  replace p2 with ((p2 - p1) + p1) by lia.
  rewrite Z.pow_add_r by lia.
  apply Z_mod_mult.
Qed.

Lemma digits2_pos_redundant (p : positive) :
  digits2_pos p = Pos.size p.
Proof. reflexivity. Qed.

Lemma pos_size_Z_log2 (p : positive) :
  Z.pos (Pos.size p) = Z.log2 (Z.pos p) + 1.
Proof.
  destruct p; cbn; lia.
Qed.

Lemma pos_size_mul_pow_two (p q : positive) :
  Pos.size (p * 2 ^ q) = (Pos.size p + q)%positive.
Proof.
  enough (Z.pos (Pos.size (p * 2 ^ q)) = (Z.pos (Pos.size p)) + (Z.pos q)) by lia.
  repeat rewrite pos_size_Z_log2.
  rewrite Pos2Z.inj_mul, Pos2Z.inj_pow.
  remember (Z.pos p) as zp.
  remember (Z.pos q) as zq.
  rewrite Z.log2_mul_pow2; lia.
Qed.

Lemma pos_size_monotone (p1 p2 : positive) :
  (p1 <= p2)%positive ->
  (Pos.size p1 <= Pos.size p2)%positive.
Proof.
  generalize dependent p2.
  induction p1; cbn in *; [ | | lia].
  all: intros.
  all: destruct p2; cbn in *; [ | | lia].
  all: assert (p1 <= p2)%positive by lia.
  all: apply IHp1 in H0.
  all: lia.
Qed.

Lemma pos_size_monotone_inv (p1 p2 : positive) :
  (Pos.size p1 < Pos.size p2)%positive ->
  (p1 < p2)%positive.
Proof.
  intros.
  apply Pos.lt_nle.
  intros C.
  apply pos_size_monotone in C.
  lia.
Qed.