Require Import Group Subgroup
  WildCat Colimits.Coeq
  Truncations.SeparatedTrunc.

Local Open Scope mc_scope.
Local Open Scope mc_mult_scope.

(** Free groups are defined in Group.v. In this file we construct and prove properties of free groups. *)

(** In this file we construct the free group on a type [A] as a higher inductive type. This construction is due to Kraus-Altenkirch 2018 arXiv:1805.02069. Their construction is actually more general, but we set truncate it to suit our needs which is the free group as a set. This is a very simple HIT in a similar manner to the abelianization HIT used in Algebra.AbGroup.Abelianization. *)

Section Reduction.

  Universe u.
  Context (A : Type@{u}).

  (** We define words (with inverses) on A to be lists of marked elements of A *)
  Local Definition Words : Type@{u} := list (A + A).

  (** Given a marked element of A we can change its mark *)
  Local Definition change_sign : A + A -> sum@{u u} A A
    := fun x => match x with
                | inl a => inr a
                | inr a => inl a
                end.

  (** We introduce a local notation for [change_sign]. It is only defined in this section however. *)
  Local Notation "x ^" := (change_sign x).

  (** Changing sign is an involution *)
  Local Definition change_sign_inv a : a^^ = a.
  Proof.
    by destruct a.
  Defined.

  (** We can concatenate words using list concatenation *)
  Local Definition word_concat : Words -> Words -> Words := @app _.

  (** We introduce a local notation for word_concat. *)
  Local Infix "@" := word_concat.

  Local Definition word_concat_w_nil x : x @ nil = x.
  Proof.
    induction x; trivial.
    cbn; f_ap.
  Defined.

  Local Definition word_concat_w_ww x y z : x @ (y @ z) = (x @ y) @ z.
  Proof.
    revert x z.
    induction y; intros x z.
    { f_ap; symmetry.
      apply word_concat_w_nil. }
    simpl; revert z y IHy.
    induction x; trivial.
    intros z y IHy.
    simpl; f_ap.
    apply IHx, IHy.
  Defined.

  (** Singleton word *)
  Local Definition word_sing (x : A + A) : Words := (cons x nil).

  Local Notation "[ x ]" := (word_sing x).

  (** We define an inductive family [Red] on [Words] which expresses whether a given word can be reduced to the empty list *)
  Inductive Red : Words -> Type :=
    | red_zero : Red nil
    | red_step (y z : Words) (a : A + A)
      : Red (y @ z) -> Red (y @ [a] @ [a^] @ z).

  (** Now we wish to define the free group on A as the following HIT:

    HIT N(A) : hSet
     | eta : Words -> N(A)
     | tau (x : Words) (a : A + A) (y : Words)
         : eta (x @ [a] @ [a^] @ y) = eta (x @ y).

    Since we cannot write our HITs directly like this (without resorting to private inductive types), we will construct this HIT out of HITs we know. In fact, we can define N(A) as a coequalizer. *)

  Local Definition map1 : Words * (A + A) * Words -> Words.
  Proof.
    intros [[x a] y].
    exact (x @ [a] @ [a^] @ y).
  Defined.

  Local Definition map2 : Words * (A + A) * Words -> Words.
  Proof.
    intros [[x a] y].
    exact (x @ y).
  Defined.

  (** Now we can define the underlying type of the free group as the 0-truncated coequalizer of these two maps *)
  Definition freegroup_type : Type := Tr 0 (Coeq map1 map2).

  (** This is the point constructor *)
  Definition freegroup_eta : Words -> freegroup_type := tr o coeq.

  (** This is the path constructor *)
  Definition freegroup_tau (x : Words) (a : A + A) (y : Words)
    : freegroup_eta (x @ [a] @ [a^] @ y) = freegroup_eta (x @ y).
  Proof.
    apply path_Tr, tr.
    exact ((cglue (x, a, y))).
  Defined.

  (** The group operation *)
  Global Instance sgop_freegroup : SgOp freegroup_type.
  Proof.
    intros x y.
    strip_truncations.
    revert x; snrapply Coeq_rec.
    { intros x; revert y.
      snrapply Coeq_rec.
      { intros y.
        exact (freegroup_eta (x @ y)). }
      intros [[y a] z]; cbn.
      refine (concat (ap _ _) _).
      { refine (concat (word_concat_w_ww _ _ _) _).
        rapply (ap (fun t => t @ _)).
        refine (concat (word_concat_w_ww _ _ _) _).
        rapply (ap (fun t => t @ _)).
        refine (word_concat_w_ww _ _ _). }
      refine (concat _ (ap _ _^)).
      2: apply word_concat_w_ww.
      apply freegroup_tau. }
    intros [[c b] d].
    simpl.
    revert y.
    snrapply Coeq_ind.
    { simpl.
      intro a.
      rewrite <- word_concat_w_ww.
      rewrite <- (word_concat_w_ww _ _ a).
      rapply (freegroup_tau c b (d @ a)). }
    intro; rapply path_ishprop.
  Defined.

  (** The unit of the free group is the empty word *)
  Global Instance monunit_freegroup_type : MonUnit freegroup_type.
  Proof.
    apply freegroup_eta.
    exact nil.
  Defined.

  (** We can change the sign of all the elements in a word and reverse the order. This will be the inversion in the group *)
  Fixpoint word_change_sign (x : Words) : Words.
  Proof.
    destruct x as [|x xs].
    1: exact nil.
    exact (word_change_sign xs @ [change_sign x]).
  Defined.

  (** Changing the sign changes the order of word concatenation *)
  Definition word_change_sign_ww (x y : Words)
    : word_change_sign (x @ y) = word_change_sign y @ word_change_sign x.
  Proof.
    induction x.
    { symmetry.
      apply word_concat_w_nil. }
    simpl.
    refine (concat _ (inverse (word_concat_w_ww _ _ _))).
    f_ap.
  Defined.

  (** This is also involutive *)
  Lemma word_change_sign_inv x : word_change_sign (word_change_sign x) = x.
  Proof.
    induction x.
    1: reflexivity.
    simpl.
    rewrite word_change_sign_ww.
    cbn; f_ap.
    apply change_sign_inv.
  Defined.

  (** Changing the sign gives us left inverses *)
  Lemma word_concat_Vw x : freegroup_eta (word_change_sign x @ x) = mon_unit.
  Proof.
    induction x.
    1: reflexivity.
    cbn.
    set (a' := a^).
    rewrite <- (change_sign_inv a).
    change a^ with a'.
    change (freegroup_eta ((word_change_sign x @ [a']) @ ([a'^] @ x)) = mon_unit).
    rewrite word_concat_w_ww.
    rewrite freegroup_tau.
    apply IHx.
  Defined.

  (** And since changing the sign is involutive we get right inverses from left inverses *)
  Lemma word_concat_wV x : freegroup_eta (x @ word_change_sign x) = mon_unit.
  Proof.
    set (x' := word_change_sign x).
    rewrite <- (word_change_sign_inv x).
    change (freegroup_eta (word_change_sign x' @ x') = mon_unit).
    apply word_concat_Vw.
  Defined.

  (** Negation is defined by changing the order of a word that appears in eta. Most of the work here is checking that it is agreeable with the path constructor. *)
  Global Instance negate_freegroup_type : Negate freegroup_type.
  Proof.
    intro x.
    strip_truncations.
    revert x; srapply Coeq_rec.
    { intro x.
      apply freegroup_eta.
      exact (word_change_sign x). }
    intros [[b a] c].
    unfold map1, map2.
    refine (concat _ (ap _ (inverse _))).
    2: apply word_change_sign_ww.
    refine (concat (ap _ _) _).
    { refine (concat (word_change_sign_ww _ _) _).
      apply ap.
      refine (concat (ap _ (inverse (word_concat_w_ww _ _ _))) _).
      refine (concat (word_change_sign_ww _ _) _).
      rapply (ap (fun t => t @ word_change_sign b)).
      apply word_change_sign_ww. }
    refine (concat _ (freegroup_tau _ a _)).
    apply ap.
    refine (concat (word_concat_w_ww _ _ _) _); f_ap.
    refine (concat (word_concat_w_ww _ _ _) _); f_ap.
    f_ap; cbn; f_ap.
    apply change_sign_inv.
  Defined.

  (** Now we can start to prove the group laws. Since these are hprops we can ignore what happens with the path constructor. *)

  (** Our operation is associative *)
  Global Instance associative_freegroup_type : Associative sg_op.
  Proof.
    intros x y z.
    strip_truncations.
    revert x; snrapply Coeq_ind; intro x; [ | apply path_ishprop].
    revert y; snrapply Coeq_ind; intro y; [ | apply path_ishprop].
    revert z; snrapply Coeq_ind; intro z; [ | apply path_ishprop].
    rapply (ap (tr o coeq)).
    apply word_concat_w_ww.
  Defined.

  (** Left identity *)
  Global Instance leftidentity_freegroup_type : LeftIdentity sg_op mon_unit.
  Proof.
    rapply Trunc_ind.
    srapply Coeq_ind; intro x; [ | apply path_ishprop].
    reflexivity.
  Defined.

  (** Right identity *)
  Global Instance rightidentity_freegroup_type : RightIdentity sg_op mon_unit.
  Proof.
    rapply Trunc_ind.
    srapply Coeq_ind; intro x; [ | apply path_ishprop].
    apply (ap tr), ap.
    apply word_concat_w_nil.
  Defined.

  (** Left inverse *)
  Global Instance leftinverse_freegroup_type : LeftInverse sg_op negate mon_unit.
  Proof.
    rapply Trunc_ind.
    srapply Coeq_ind; intro x; [ | apply path_ishprop].
    apply word_concat_Vw.
  Defined.

  (** Right inverse *)
  Global Instance rightinverse_freegroup_type : RightInverse sg_op negate mon_unit.
  Proof.
    rapply Trunc_ind.
    srapply Coeq_ind; intro x; [ | apply path_ishprop].
    apply word_concat_wV.
  Defined.

  (** Finally we have defined the free group on [A] *)
  Definition FreeGroup : Group.
  Proof.
    snrapply (Build_Group freegroup_type); repeat split; exact _.
  Defined.

  Definition words_rec (G : Group) (s : A -> G) : Words -> G.
  Proof.
    intro x.
    induction x as [|x xs].
    1: exact mon_unit.
    refine (_ * IHxs).
    destruct x as [x|x].
    1: exact (s x).
    exact (- s x).
  Defined.

  Lemma words_rec_pp (G : Group) (s : A -> G)  (x y : Words)
    : words_rec G s (x @ y) = words_rec G s x * words_rec G s y.
  Proof.
    induction x.
    1: symmetry; apply left_identity.
    cbn; rewrite <- simple_associativity.
    f_ap.
  Defined.

  Lemma words_rec_coh (G : Group) (s : A -> G) (a : A + A) (b c : Words)
    : words_rec G s (map1 (b, a, c)) = words_rec G s (map2 (b, a, c)).
  Proof.
    unfold map1, map2.
    refine (concat _ (words_rec_pp G s _ _)^).
    refine (concat (words_rec_pp G s _ _) _); f_ap.
    refine (concat _ (right_identity _)).
    refine (concat (ap _ (word_concat_w_ww _ _ _)^) _).
    refine (concat (words_rec_pp G s _ _) _); f_ap.
    refine (concat (concat (simple_associativity _ _ _) _) (left_identity mon_unit)).
    destruct a; simpl; f_ap.
    + apply right_inverse.
    + apply left_inverse.
  Defined.

  (** Given a group [G] we can construct a group homomorphism [FreeGroup A -> G] if we have a map [A -> G] *)
  Definition FreeGroup_rec (G : Group) (s : A -> G)
    : GroupHomomorphism FreeGroup G.
  Proof.
    snrapply Build_GroupHomomorphism.
    { rapply Trunc_rec.
      srapply Coeq_rec.
      1: apply words_rec, s.
      intros [[b a] c].
      apply words_rec_coh. }
    intros x y; strip_truncations.
    revert x; snrapply Coeq_ind; hnf; intro x; [ | apply path_ishprop ].
    revert y; snrapply Coeq_ind; hnf; intro y; [ | apply path_ishprop ].
    simpl.
    apply words_rec_pp.
  Defined.

  (** Now we need to prove that the free group satisifes the unviersal property of the free group. *)
  (** TODO: remove funext from here and universal property of free group *)
  Global Instance isfreegroupon_freegroup `{Funext}
    : IsFreeGroupOn A FreeGroup (freegroup_eta o word_sing o inl).
  Proof.
    intros G f.
    snrapply Build_Contr.
    { srefine (_;_); simpl.
      1: apply FreeGroup_rec, f.
      intro x; simpl.
      apply right_identity. }
    intros [g h].
    nrapply path_sigma_hprop; [ exact _ |].
    simpl.
    apply equiv_path_grouphomomorphism.
    intro x.
    rewrite <- (path_forall _ _ h).
    strip_truncations; revert x.
    snrapply Coeq_ind; intro x; [|apply path_ishprop].
    hnf; symmetry.
    induction x.
    1: apply (grp_homo_unit g).
    refine (concat (grp_homo_op g (freegroup_eta [a]) (freegroup_eta x)) _).
    simpl.
    f_ap.
    destruct a.
    1: reflexivity.
    exact (grp_homo_inv g (freegroup_eta [inl a])).
  Defined.

  (** Typeclass search can already find this but we leave it here as a definition for reference. *)
  Definition isfreegroup_freegrup `{Funext} : IsFreeGroup FreeGroup := _.

  Definition freegroup_in : A -> FreeGroup
    := freegroup_eta o word_sing o inl.

  Lemma FreeGroup_rec_beta {G : Group} (f : A -> G)
    : FreeGroup_rec _ f o freegroup_in == f.
  Proof.
    intros x.
    apply grp_unit_r.
  Defined.

  Coercion freegroup_in : A >-> group_type.

End Reduction.

Arguments freegroup_eta {A}.
Arguments freegroup_in {A}.

(** Properties of free groups *)

(* Given a function on the generators, there is an induced group homomorphism from the free group. *)
Definition isfreegroupon_rec {S : Type} {F_S : Group}
  {i : S -> F_S} `{IsFreeGroupOn S F_S i}
  {G : Group} (f : S -> G) : F_S $-> G
  := (center (FactorsThroughFreeGroup S F_S i G f)).1.

(* The propositional computation rule for the recursor. *)
Definition isfreegroupon_rec_beta
  {S : Type} {F_S : Group} {i : S -> F_S} `{IsFreeGroupOn S F_S i}
  {G : Group} (f : S -> G)
  : isfreegroupon_rec f o i == f
  := (center (FactorsThroughFreeGroup S F_S i G f)).2.

(* Two homomorphisms from a free group are equal if they agree on the generators. *)
Definition path_homomorphism_from_free_group {S : Type}
  {F_S : Group} {i : S -> F_S} `{IsFreeGroupOn S F_S i}
  {G : Group} (f g : F_S $-> G) (K : f o i == g o i)
  : f = g.
Proof.
  (* By assumption, the type [FactorsThroughFreeGroup S F_S i G (g o i)] of factorizations of [g o i] through [i] is contractible.  Therefore the two elements we have are equal.  Therefore, their first components are equal. *)
  exact (path_contr (f; K) (g; fun x => idpath))..1.
Defined.

Global Instance isequiv_isfreegroupon_rec `{Funext} {S : Type}
  {F_S : Group} {i : S -> F_S} `{IsFreeGroupOn S F_S i} {G : Group}
  : IsEquiv (@isfreegroupon_rec S F_S i _ G).
Proof.
  apply (isequiv_adjointify isfreegroupon_rec (fun f => f o i)).
  - intro f.
    apply path_homomorphism_from_free_group.
    apply isfreegroupon_rec_beta.
  - intro f.
    (* here we need [Funext]: *)
    apply path_arrow, isfreegroupon_rec_beta.
Defined.

(** The universal property of a free group. *)
Definition equiv_isfreegroupon_rec `{Funext} {G F : Group} {A : Type}
  {i : A -> F} `{IsFreeGroupOn A F i}
  : (A -> G) <~> (F $-> G) := Build_Equiv _ _ isfreegroupon_rec _.

(** The above theorem is true regardless of the implementation of free groups. This lets us state the more specific theorem about the canonical free groups. This can be read as [FreeGroup] is left adjoint to the forgetful functor [group_type]. *)
Definition equiv_freegroup_rec `{Funext} (G : Group) (A : Type)
  : (A -> G) <~> (FreeGroup A $-> G)
  := equiv_isfreegroupon_rec.

Global Instance ishprop_isfreegroupon `{Funext} (F : Group) (A : Type) (i : A -> F)
  : IsHProp (IsFreeGroupOn A F i).
Proof.
  unfold IsFreeGroupOn.
  apply istrunc_forall.
Defined.

(** Both ways of stating the universal property are equivalent. *)
Definition equiv_isfreegroupon_isequiv_precomp `{Funext}
  (F : Group) (A : Type) (i : A -> F)
  : IsFreeGroupOn A F i <~> forall G, IsEquiv (fun f : F $-> G => f o i).
Proof.
  srapply equiv_iff_hprop.
  1: intros ? ?; exact (equiv_isequiv (equiv_isfreegroupon_rec)^-1).
  intros k G g.
  specialize (k G).
  snrapply contr_equiv'.
  1: exact (hfiber (fun f x => grp_homo_map F G f (i x)) g).
  { rapply equiv_functor_sigma_id.
    intro y; symmetry.
    apply equiv_path_forall. }
  exact _.
Defined.

(** ** Subgroups of free groups *)

(* We say that a group [G] is generated by a subtype [X] if the natural map from the subgroup generated by [X] to [G] is a surjection.  One could equivalently say [IsEquiv (subgroup_incl (subgroup_generated X))], [forall g, subgroup_generated X g], or [subgroup_generated X = maximal_subgroup], but the definition using surjectivity is convenient later. *)
Definition isgeneratedby (G : Group) (X : G -> Type)
  := IsSurjection (subgroup_incl (subgroup_generated X)).

Section FreeGroupGenerated.
  (* In this Section, we prove that the free group [F_S] on a type [S] is generated in the above sense by the image of [S].  We conclude that the inclusion map is an equivalence, and that the free group is isomorphic as a group to the subgroup. We show that the inclusion is a surjection by showing that it is split epi in the category of groups. *)

  Context {S : Type} {F_S : Group} {i : S -> F_S} `{IsFreeGroupOn S F_S i}.

  (* We define a group homomorphism from [F_S] to the subgroup [G] generated by [S] by sending a generator [s] to "itself".  This map will be a section of the inclusion map. *)
  Local Definition to_subgroup_generated
    : F_S $-> subgroup_generated (hfiber i).
  Proof.
    apply isfreegroupon_rec.
    intro s.
    snrapply subgroup_generated_gen_incl.
    - exact (i s).
    - exact (s; idpath).
  Defined.

  (* We record the computation rule that [to_subgroup_generated] satisfies. *)
  Local Definition to_subgroup_generated_beta (s : S)
    : to_subgroup_generated (i s) = subgroup_generated_gen_incl (i s) (s; idpath)
    := isfreegroupon_rec_beta _ _.

  (* It follows that [to_subgroup_generated] is a section of the inclusion map from [G] to [F_S]. *)
  Local Definition is_retraction
    : (subgroup_incl _) $o to_subgroup_generated = grp_homo_id.
  Proof.
    apply path_homomorphism_from_free_group; cbn.
    intro s.
    exact (ap pr1 (to_subgroup_generated_beta s)).
  Defined.

  (* It follows that the inclusion map is a surjection, i.e., that [F_S] is generated by the image of [S]. *)
  Definition isgenerated_isfreegroupon
    : isgeneratedby F_S (hfiber i).
  Proof.
    snrapply issurj_retr.
    - apply to_subgroup_generated.
    - apply ap10; cbn.
      exact (ap (grp_homo_map F_S F_S) (is_retraction)).
  Defined.

  (* Therefore, the inclusion map is an equivalence, since it is known to be an embedding. *)
  Definition isequiv_subgroup_incl_freegroupon
    : IsEquiv (subgroup_incl (subgroup_generated (hfiber i))).
  Proof.
    apply isequiv_surj_emb.
    - apply isgenerated_isfreegroupon.
    - exact _.
  Defined.

  (* Therefore, the subgroup is isomorphic to the free group. *)
  Definition iso_subgroup_incl_freegroupon
    : GroupIsomorphism (subgroup_generated (hfiber i)) F_S.
  Proof.
    nrapply Build_GroupIsomorphism.
    apply isequiv_subgroup_incl_freegroupon.
  Defined.

End FreeGroupGenerated.


Require Import List.

Require Import bigstep.
Require Import coinduction.
Require Import datatypes.

(**************** DITHER Machine ***************)

(*
Implementation: 0 1 -> 1 R
                1 B -> 0 L
                1 1 -> 2 L
*)

Definition Dither: Spec := (0, one, 1, R) ::
                           (1, B  , 0, L) ::
                           (1, one, 2, L) :: nil.

(************************ Divergence proof ************************)

Lemma Dither_loops:
      bi Dither (pair Bs (Cons one Bs)) 0.
cofix co_hp; apply biR with 1; auto; simpl.
apply biL with 0; auto.
Qed.

(************************ Convergence proof ************************)

Lemma Dither_stops:
      bf Dither (pair Bs (Cons one (Cons one Bs))) 0
                (pair Bs (Cons one (Cons one Bs))) 2.
apply bfR with 1; auto; simpl.
apply bfL with 2; auto; simpl.
apply bfH; unfold is_value; auto.
Qed.


Require Import HoTT.
Open Scope type_scope.
(*Most of these definitions and lemmas are redundant.  The goal is to reformulate this using built in commands.

 The induction principles need to be ammended to reflect the points made in the HoTT Library's STYLE.md file, Higher Inductive Types, 4. This is only necessary for the circle' induction type.*)
Definition homotopy {A B : Type} (f g : A -> B) : Type := forall x : A, f x = g x.
Definition isEquiv {A B : Type} (f : A -> B): Type := exists (g : B -> A), (homotopy (g o f) (idmap)) * (homotopy (idmap) (f o g)).
Definition Equiv (A B : Type) : Type := exists (f : A -> B), isEquiv f.
Axiom Univalence' : forall (A B : Type), Equiv (Equiv A B) (A = B).

Module Export Circle.
  Private Inductive circle : Type := base : circle.
  Axiom loop : base = base.
  Definition circle_dep_ind (P : circle -> Type) (b : P base) (p : transport P loop b = b) : forall x : circle, P x :=
  fun y => (match y with
         | base => fun _ => b
         end) p.
  Axiom circle_dep_comp : forall (P : circle -> Type) (b : P base) (p : transport P loop b = b), apD (circle_dep_ind P b p) loop = p.
  Definition circle_ind (B : Type) (b : B) (l : b = b): circle -> B :=
    fun y => (match y with
           | base => fun _ => b
          end) l.
  Axiom circle_comp : forall (B : Type) (b : B) (l : b = b), ap (circle_ind B b l) loop = l.
End Circle.

Module Export Circle'.
Private Inductive circle' : Type := east : circle' | west : circle'.
Axiom p1 : east = west.
Axiom p2 : west = east.
Definition circle'_dep_ind (P : circle' -> Type) (a : P east) (b : P west) (s : transport P p1 a = b) (t : transport P p2 b = a) : forall x : circle', P x := fun y => (match y with
                                                                                | east => a
                                                                                | west => b
                                                                                end).

Axiom circle'comp1 : forall (P : circle' -> Type) (a : P east) (b : P west) (s : transport P p1 a = b) (t : transport P p2 b = a), apD (circle'_dep_ind P a b s t) p1 = s.

Axiom circle'comp2 : forall (P : circle' -> Type) (a : P east) (b : P west) (s : transport P p1 a = b) (t : transport P p2 b = a), apD (circle'_dep_ind P a b s t) p2 = t.

Definition circle'_ind (B : Type) (a : B) (b : B) (l : a = b) (m : b = a): circle' -> B :=
  fun y : circle' => (match y with
                  | east => a
                  | west => b
                             end).

Axiom circle'_comp1 : forall (B : Type) (a : B) (b : B) (l : a = b) (m : b = a), ap (circle'_ind B a b l m) p1 = l.
Axiom circle'_comp2 : forall (B : Type) (a : B) (b : B) (l : a = b) (m : b = a), ap (circle'_ind B a b l m) p2 = m.
End Circle'.

Theorem concat_id : forall {A : Type} {a b : A} (p : a = b), 1 @ p = p.
  intros A a b p.
  induction p.
  reflexivity.
Defined.

Lemma lem0 : forall {A B C : Type} {a b : A} (f : A -> B) (g :B -> C) (p : a = b), ap (g o f) p = ap g (ap f p).
Proof.
  intros A B C a b f g p.
  induction p. simpl.
  reflexivity.
Defined.

Theorem thm2_11_3 : forall {A B : Type} {a a' : A} (f g : A -> B) (p : a = a') (q : f a = g a), transport (fun x : A => f x = g x) p q = (ap f p)^ @ q @ (ap g p).
Proof.
  intros A B a a' f g p q.
  induction p. simpl.
  induction q.
  reflexivity.
Defined.

Goal forall (A : Type) (a : A) (P : A -> Type) (y : P a), exists (x : A), P x.
Proof.
  intros A a P y.
  refine (ex_intro _ a _).
  exact y.
Defined.

Lemma f : circle -> circle'.
Proof.
  apply (circle_ind circle' east).
  exact (p1 @ p2).
Defined.

Lemma g : circle' -> circle.
Proof.
  apply (circle'_ind circle base base).
  + exact loop.
  + reflexivity.
Defined.

Lemma lem1 : ap g p1 = loop.
Proof.
  apply circle'_comp1.
Defined.

Lemma lem2  : ap g p2 = idpath.
Proof.
  apply circle'_comp2.
Defined.

Lemma lem3 : ap f loop = p1 @ p2.
Proof.
  apply circle_comp.
Defined.

Lemma lem4 : forall {A : Type} {a b c : A} (p : a = b) (q : b = c), (p@q)^ = q^ @ p^.
Proof.
  intros A a b c p q.
  induction p.
  induction q.
  reflexivity.
Defined.

Lemma lem5 : f (g east) = east.
Proof.
  simpl.
  reflexivity.
Defined.

Lemma lem6 : f (g west) = west.
Proof.
  simpl.
  exact p1.
Defined.

Lemma lem7 : forall {A: Type} {a b : A} (p : a = b), ap idmap p = p.
Proof.
  intros A a b p.
  induction p.
  simpl. reflexivity.
Defined.

Lemma lem8 : forall {A : Type} {a b : A} (p : a = b), p @ idpath = p.
Proof.
  intros A a b p.
  induction p.
  reflexivity.
Defined.

Lemma lem8' : forall {A : Type} {a b : A} (p : a = b), idpath @ p = p.
Proof.
  intros A a b p.
  induction p.
  reflexivity.
Defined.

Lemma lem9 : forall {A : Type} {a b c d : A} (p : a = b) (q : b = c) (r : c = d), (p @ q) @ r = p @ (q @ r).
Proof.
  intros A a b c d p q r.
  induction p. induction q. induction r.
  reflexivity.
Defined.

Lemma lem10 : forall {A : Type} {a b : A} (p : a = b), p^ @ p = idpath.
Proof.
  intros A a b p.
  induction p.
  reflexivity.
Defined.

Lemma lem11 : (ap (f o g) p1)^ @ idpath @ (ap idmap p1) = p2^.
Proof.
  rewrite (lem0 g f p1).
  rewrite lem1.
  rewrite lem3.
  rewrite (lem4 p1 p2).
  rewrite (lem7 p1).
  rewrite (lem8 (p2^ @ p1^)).
  rewrite (lem9 p2^ p1^ p1).
  rewrite (lem10 p1).
  rewrite (lem8 p2^).
  reflexivity.
Defined.

Lemma lem12 : forall x : circle',  f (g x) = x.
Proof.
  apply (circle'_dep_ind (fun x : circle' => f (g x) = x) (idpath) (p2^)).
  + rewrite <- lem11.
    exact (thm2_11_3 (f o g) (idmap) p1 idpath).
  + rewrite (thm2_11_3 (f o g) idmap p2 p2^).
    rewrite (lem7 p2).
    rewrite (lem0 g f p2).
    rewrite lem2. simpl.
    rewrite lem8'.
    rewrite (lem10 p2).
    reflexivity.
Defined.

Lemma lem13 : forall {A B: Type} {x y z : A} (f : A -> B) (p : x = y) (q : y = z), ap f (p @ q) = (ap f p) @ (ap f q).
Proof.
  intros A B x y z f p q.
  induction p. induction q.
  reflexivity.
Defined.

Lemma lem14 : forall x : circle, g (f x) = x.
Proof.
  apply (circle_dep_ind (fun x : circle => g (f x) = x) idpath).
  rewrite (thm2_11_3 (g o f) idmap loop idpath).
  rewrite (lem7 loop).
  rewrite (lem0 f g loop).
  rewrite lem3.
  rewrite (lem13 g p1 p2).
  rewrite lem1.
  rewrite lem2.
  repeat rewrite lem8.
  rewrite lem10.
  reflexivity.
Defined.

Lemma f_isEquiv : isEquiv f.
  exists g.
  split.
  + exact lem14.
  + unfold homotopy. intro x.
    symmetry.
    exact (lem12 x).
Defined.

Theorem circles_are_equal : circle = circle'.
Proof.
  apply Univalence'.
  exists f.
  exact f_isEquiv.
Defined.

Theorem circles_are_equal' `{Univalence} : circle = circle'.
Proof.
  apply equiv_path_universe.
  apply (equiv_adjointify f g).
  + exact lem12.
  + exact lem14.
Defined.


(*Inductive eq2 (A:Type) (x:A) : A -> Prop :=
    eq_refl2 : eq2 A x x.*)

Inductive eq2 (A:Type) : A -> A -> Prop :=
    eq_refl2 : forall (x:A), eq2 A x x.

Definition eq_symm (A:Type) (x y:A) (H:eq x y) : eq y x :=
match H in eq _ z return eq z x with
| eq_refl _ => eq_refl x
end.

Print eq_ind.
Print eq_sym.

Print eq.


Require Import Coq.ZArith.ZArith
        Coq.Reals.Rdefinitions
        Coq.Reals.Raxioms.

Inductive A : Type :=
  | NegOne : A
  | Zero : A
  | PosOne : A.

Definition eq (a:A) (b:A) : Prop :=
  match a,b with
  | NegOne , NegOne => True
  | PosOne , PosOne => True
  | Zero, Zero => True
  | _ , _ => False
  end.

Definition neq (a:A) (b:A) : Prop :=
  not ( eq a b ) .

Definition f (a:A) (b:A) : A :=
  match a , b with
  | NegOne , NegOne => PosOne
  | PosOne , PosOne => NegOne
  | NegOne , PosOne => PosOne
  | PosOne , NegOne => NegOne
  | Zero , Zero => NegOne
  | Zero , _ => PosOne
  | _ , _ => PosOne
  end.

Notation "x != y" := (neq x y) (at level 20).
Notation "x ^ 2" := (f x x) (at level 20).
Notation "x $ y" := (f x y) (at level 20).

(* Constradicting example f not being distrubutive under function composition *)
(* (a $ b)^2 != a^2 $ b^2  *)
Definition a := NegOne.
Definition b := PosOne.
Compute (a $ b)^2 = a^2 $ b^2.

(* Theorem proving f is not distrubutive  under function composition *)
(* (a $ b)^2 != a^2 $ b^2  *)
Theorem f_funcomp_not_distrubutive :
  exists a b : A,
   (a $ b)^2 != (a^2 $ b^2).
Proof.
  exists a, b. unfold neq,not. trivial.
Qed.

(* Is the following operation assosicative *)
Definition g (a:R) (b:R) : R := 1%R + (Rmult a b).

Theorem g_assosicative :
  forall a b c : R,
    g a (g b c) = g (g a b) c.
Proof.
  intros a b c. unfold g.
  admit.
Admitted.

Inductive B : Type := | nil : B .

Definition f1 (a:B) (b:B) : B := a.
Definition g1 (a:B) (b:B) : B := a.

Theorem function_comp_associative:
  forall A  (f : A -> A ) (g : A -> A),
  forall x : A,
    f ( g x ) = g ( f x ).
Proof.
  intros A f g x. admit.
Admitted.


Require Import rt.util.all.
Require Import rt.model.arrival.basic.job rt.model.arrival.basic.task rt.model.priority rt.model.arrival.basic.task_arrival.
Require Import rt.model.schedule.global.basic.schedule.
Require Import rt.model.schedule.apa.interference rt.model.schedule.apa.affinity rt.model.schedule.apa.platform.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype bigop.

Module ConstrainedDeadlines.

  Import Job SporadicTaskset ScheduleOfSporadicTask SporadicTaskset
         TaskArrival Interference Priority Affinity Platform.

  Section Lemmas.

    Context {sporadic_task: eqType}.
    Variable task_cost: sporadic_task -> time.
    Variable task_period: sporadic_task -> time.
    Variable task_deadline: sporadic_task -> time.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_deadline: Job -> time.
    Variable job_task: Job -> sporadic_task.

    (* Assume any job arrival sequence ... *)
    Variable arr_seq: arrival_sequence Job.

    (* ... and any schedule of this arrival sequence. *)
    Context {num_cpus: nat}.
    Variable sched: schedule Job num_cpus.
    Hypothesis H_jobs_come_from_arrival_sequence:
      jobs_come_from_arrival_sequence sched arr_seq.

    (* Assume that every task has a processor affinity alpha. *)
    Variable alpha: task_affinity sporadic_task num_cpus.

    (* Assume all jobs have valid parameters, ...*)
    Hypothesis H_valid_job_parameters:
      forall j,
        arrives_in arr_seq j ->
        valid_sporadic_job task_cost task_deadline job_cost job_deadline job_task j.

    (* In this section we prove the absence of multiple jobs of the same
       task when constrained deadlines are assumed.  *)
    Section NoMultipleJobs.

      (* Assume any work-conserving priority-based scheduler. *)
      Variable higher_eq_priority: JLDP_policy Job.
      Hypothesis H_work_conserving:
        apa_work_conserving job_arrival job_cost job_task arr_seq sched alpha.
      Hypothesis H_respects_JLDP_policy:
        respects_JLDP_policy_under_weak_APA job_arrival job_cost job_task arr_seq
                                            sched alpha higher_eq_priority.

      (* Consider task set ts. *)
      Variable ts: taskset_of sporadic_task.

      (* Assume that all jobs come from the taskset. *)
      Hypothesis H_all_jobs_from_taskset:
        forall j, arrives_in arr_seq j -> job_task j \in ts.

      (* Suppose that jobs are sequential, ...*)
      Hypothesis H_sequential_jobs: sequential_jobs sched.
      (* ... jobs only execute after they arrive, ... *)
      Hypothesis H_jobs_must_arrive_to_execute: jobs_must_arrive_to_execute job_arrival sched.
      (* ... and jobs do not execute after completion. *)
      Hypothesis H_completed_jobs_dont_execute: completed_jobs_dont_execute job_cost sched.

      (* Assume that the schedule satisfies the sporadic task model ...*)
      Hypothesis H_sporadic_tasks:
        sporadic_task_model task_period job_arrival job_task arr_seq.

      (* Consider a valid task tsk, ...*)
      Variable tsk: sporadic_task.
      Hypothesis H_valid_task: is_valid_sporadic_task task_cost task_period task_deadline tsk.

      (*... whose job j ... *)
      Variable j: Job.
      Hypothesis H_j_arrives: arrives_in arr_seq j.
      Hypothesis H_job_of_tsk: job_task j = tsk.

      (*... is backlogged at time t. *)
      Variable t: time.
      Hypothesis H_j_backlogged: backlogged job_arrival job_cost sched j t.

      (* Assume that any previous jobs of tsk have completed by the period. *)
      Hypothesis H_all_previous_jobs_completed :
        forall j_other tsk_other,
          arrives_in arr_seq j_other ->
          job_task j_other = tsk_other ->
          job_arrival j_other + task_period tsk_other <= t ->
          completed job_cost sched j_other (job_arrival j_other + task_period (job_task j_other)).

      Let scheduled_task_other_than (tsk tsk_other: sporadic_task) :=
        task_is_scheduled job_task sched tsk_other t && (tsk_other != tsk).

      (* Then, there can be at most one pending job of each task at time t. *)
      Lemma platform_at_most_one_pending_job_of_each_task :
        forall j1 j2,
          arrives_in arr_seq j1 ->
          arrives_in arr_seq j2 ->
          pending job_arrival job_cost sched j1 t ->
          pending job_arrival job_cost sched j2 t ->
          job_task j1 = job_task j2 ->
          j1 = j2.
      Proof.
        rename H_sporadic_tasks into SPO, H_all_previous_jobs_completed into PREV.
        intros j1 j2 ARR1 ARR2 PENDING1 PENDING2 SAMEtsk.
        apply/eqP; rewrite -[_ == _]negbK; apply/negP; red; move => /eqP DIFF.
        move: PENDING1 PENDING2 => /andP [ARRIVED1 /negP NOTCOMP1] /andP [ARRIVED2 /negP NOTCOMP2].
        destruct (leqP (job_arrival j1) (job_arrival j2)) as [BEFORE1 | BEFORE2].
        {
          specialize (SPO j1 j2 DIFF ARR1 ARR2 SAMEtsk BEFORE1).
          assert (LEt: job_arrival j1 + task_period (job_task j1) <= t).
          {
            by apply leq_trans with (n := job_arrival j2); first by done.
          }
          exploit (PREV j1 (job_task j1)); try (by done).
          intros COMP1; apply NOTCOMP1.
          by apply completion_monotonic with (t0 := job_arrival j1 + task_period (job_task j1)).
        }
        {
          apply ltnW in BEFORE2.
          exploit (SPO j2 j1); try (by done); [by red; ins; subst | intro SPO'].
          assert (LEt: job_arrival j2 + task_period (job_task j2) <= t).
          {
            by apply leq_trans with (n := job_arrival j1); first by done.
          }
          exploit (PREV j2 (job_task j2)); try (by done).
          intros COMP2; apply NOTCOMP2.
          by apply completion_monotonic with (t0 := job_arrival j2 + task_period (job_task j2)).
        }
      Qed.

    End NoMultipleJobs.

    (* In this section we also prove the absence of multiple jobs of the same
       task when constrained deadlines are assumed, but in the specific case
       of fixed-priority scheduling.  *)
    Section NoMultipleJobsFP.

      (* Assume any work-conserving priority-based scheduler. *)
      Variable higher_eq_priority: FP_policy sporadic_task.
      Hypothesis H_work_conserving: apa_work_conserving job_arrival job_cost job_task
                                                        arr_seq sched alpha.
      Hypothesis H_respects_JLDP_policy:
        respects_FP_policy_under_weak_APA job_arrival job_cost job_task arr_seq
                                          sched alpha higher_eq_priority.

      (* Consider any task set ts. *)
      Variable ts: taskset_of sporadic_task.

      (* Assume that all jobs come from the taskset. *)
      Hypothesis H_all_jobs_from_taskset:
        forall j, arrives_in arr_seq j -> job_task j \in ts.

      (* Suppose that jobs are sequential, ...*)
      Hypothesis H_sequential_jobs: sequential_jobs sched.
      (* ... jobs only execute after the jitter, ... *)
      Hypothesis H_jobs_must_arrive_to_execute:
        jobs_must_arrive_to_execute job_arrival sched.
      (* ... and jobs do not execute after completion. *)
      Hypothesis H_completed_jobs_dont_execute:
        completed_jobs_dont_execute job_cost sched.

      (* Assume that the schedule satisfies the sporadic task model ...*)
      Hypothesis H_sporadic_tasks:
        sporadic_task_model task_period job_arrival job_task arr_seq.

      (* Consider a valid task tsk, ...*)
      Variable tsk: sporadic_task.
      Hypothesis H_valid_task: is_valid_sporadic_task task_cost task_period task_deadline tsk.

      (*... whose job j ... *)
      Variable j: Job.
      Hypothesis H_j_arrives: arrives_in arr_seq j.
      Variable H_job_of_tsk: job_task j = tsk.

      (*... is backlogged at time t <= job_arrival j + task_period tsk. *)
      Variable t: time.
      Hypothesis H_j_backlogged: backlogged job_arrival job_cost sched j t.
      Hypothesis H_t_before_period: t < job_arrival j + task_period tsk.

      (* Recall the definition of a higher-priority task in affinity (alpha' tsk). *)
      Let hp_task_in alpha' := higher_priority_task_in alpha higher_eq_priority tsk alpha'.

      (* Assume that any jobs of higher-priority tasks complete by their period. *)
      Hypothesis H_all_previous_jobs_completed :
        forall j_other tsk_other,
          arrives_in arr_seq j_other ->
          job_task j_other = tsk_other ->
          hp_task_in (alpha tsk) tsk_other ->
          completed job_cost sched j_other (job_arrival j_other + task_period tsk_other).

      (* Assume that any jobs of tsk prior to j complete by their period. *)
      Hypothesis H_all_previous_jobs_of_tsk_completed :
        forall j0,
          arrives_in arr_seq j0 ->
          job_task j0 = tsk ->
          job_arrival j0 < job_arrival j ->
          completed job_cost sched j0 (job_arrival j0 + task_period tsk).

      Definition scheduled_task_with_higher_eq_priority (tsk tsk_other: sporadic_task) :=
        task_is_scheduled job_task sched tsk_other t &&
        hp_task_in (alpha tsk) tsk_other.

      (* Then, there can be at most one pending job of higher-priority tasks at time t. *)
      Lemma platform_fp_no_multiple_jobs_of_interfering_tasks :
          forall j1 j2,
            arrives_in arr_seq j1 ->
            arrives_in arr_seq j2 ->
            pending job_arrival job_cost sched j1 t ->
            pending job_arrival job_cost sched j2 t ->
            job_task j1 = job_task j2 ->
            hp_task_in (alpha tsk) (job_task j1) ->
            j1 = j2.
      Proof.
        unfold sporadic_task_model in *.
        rename H_sporadic_tasks into SPO, H_all_previous_jobs_of_tsk_completed into PREVtsk,
               H_all_previous_jobs_completed into PREV.
        intros j1 j2 ARR1 ARR2 PENDING1 PENDING2 SAMEtsk INTERF.
        apply/eqP; rewrite -[_ == _]negbK; apply/negP; red; move => /eqP DIFF.
        move: PENDING1 PENDING2 => /andP [ARRIVED1 /negP NOTCOMP1] /andP [ARRIVED2 /negP NOTCOMP2].
        destruct (leqP (job_arrival j1) (job_arrival j2)) as [BEFORE1 | BEFORE2].
        {
          specialize (SPO j1 j2 DIFF ARR1 ARR2 SAMEtsk BEFORE1).
          assert (LEt: job_arrival j1 + task_period (job_task j1) <= t).
            by apply leq_trans with (n := job_arrival j2).
          exploit (PREV j1 (job_task j1) ARR1); [by done | by apply INTERF | intros COMP1].
          apply NOTCOMP1.
          by apply completion_monotonic with (t0 := job_arrival j1 + task_period (job_task j1)).
        }
        {
          apply ltnW in BEFORE2.
          exploit (SPO j2 j1); try (by done); [by red; ins; subst j2 | intro SPO'].
          assert (LEt: job_arrival j2 + task_period (job_task j2) <= t).
            by apply leq_trans with (n := job_arrival j1).
          exploit (PREV j2 (job_task j2) ARR2);
            [by done | by rewrite -SAMEtsk | intro COMP2 ].
          apply NOTCOMP2.
          by apply completion_monotonic with (t0 := job_arrival j2 + task_period (job_task j2)).
        }
      Qed.

      (* Also, there can be at most one pending job of tsk at time t. *)
      Lemma platform_fp_no_multiple_jobs_of_tsk :
        forall j',
          arrives_in arr_seq j' ->
          pending job_arrival job_cost sched j' t ->
          job_task j' = tsk ->
          j' = j.
      Proof.
        unfold sporadic_task_model in *.
        rename H_sporadic_tasks into SPO,
               H_valid_task into PARAMS,
               H_all_previous_jobs_of_tsk_completed into PREVtsk,
               H_all_previous_jobs_completed into PREV,
               H_j_backlogged into BACK, H_job_of_tsk into JOBtsk.
        intros j' ARR' PENDING' SAMEtsk.
        apply/eqP; rewrite -[_ == _]negbK; apply/negP; red; move => /eqP DIFF.
        move: BACK PENDING' => /andP [/andP [ARRIVED /negP NOTCOMP] NOTSCHED]
                               /andP [ARRIVED' /negP NOTCOMP'].
        destruct (leqP (job_arrival j') (job_arrival j)) as [BEFORE | BEFORE'].
        {
          exploit (SPO j' j DIFF ARR' H_j_arrives); [by rewrite JOBtsk | by done | intro SPO'].
          assert (LEt: job_arrival j' + task_period tsk <= t).
            by apply leq_trans with (n := job_arrival j); first by rewrite -SAMEtsk.
          apply NOTCOMP'.
          apply completion_monotonic with (t0 := job_arrival j' + task_period tsk); [by done | by done |].
          apply PREVtsk; try (by done).
          apply leq_trans with (n := job_arrival j' + task_period tsk); last by rewrite -SAMEtsk.
          rewrite -addn1; apply leq_add; first by done.
          by unfold is_valid_sporadic_task in *; des.
        }
        {
          unfold has_arrived in *.
          rewrite leqNgt in ARRIVED'; move: ARRIVED' => /negP BUG; apply BUG.
          apply leq_trans with (n := job_arrival j + task_period tsk); first by done.
          by rewrite -JOBtsk; apply SPO; try (by done);
            [by red; ins; subst j' | by rewrite SAMEtsk | by apply ltnW].
        }
      Qed.

    End NoMultipleJobsFP.

  End Lemmas.

End ConstrainedDeadlines.


Require Import MathClasses.interfaces.abstract_algebra.
Require MathClasses.theory.setoids.

Section functor_class.
  Context `{Category C} `{Category D} (M: C → D).

  Class Fmap: Type := fmap: ∀ {v w: C}, (v ⟶ w) → (M v ⟶ M w).

  Class Functor `(Fmap): Prop :=
    { functor_from: Category C
    ; functor_to: Category D
    ; functor_morphism:> ∀ a b: C, Setoid_Morphism (@fmap _ a b)
    ; preserves_id: `(fmap (cat_id: a ⟶ a) = cat_id)
    ; preserves_comp `(f: y ⟶ z) `(g: x ⟶ y): fmap (f ◎ g) = fmap f ◎ fmap g }.
End functor_class.

Set Warnings "-unsupported-attributes". (* FIXME: remove when minimal Coq version is enough *)

#[global]
Typeclasses Transparent Fmap.

Set Warnings "+unsupported-attributes".

(* The usual notational convention for functor application is to use the
name of the functor to refer to both its object map and its arrow map, relying
on additional conventions regarding object/arrow names for disambiguation
(i.e. "F x" and "F f" map an object and an arrow, respectively, because
"x" and "f" are conventional names for objects and arrows, respectively.

In Coq, for a term F to function as though it had two different types
simultaneously (namely the object map and the arrow map), there must
either (1) be coercions from the type of F to either function, or (2) F must
be (coercible to) a single function that is able to consume both object and
arrow arguments. The following snippet shows that (1) doesn't appear to be
supported in Coq:

  Section test.
    Context (A B: Type).
    Record R := { Ra:> A → unit; Rb:> B → unit }.
    Variables (r: R) (a: A) (b: B).
    Check (r a). (* ok so far *)
    Check (r b). (* Error: The term "b" has type "B" while it is expected to have type "A". *)
  End test.

And even if this /did/ work, we could not use it, because leaving
computational components unbundled is a key aspect of our approach.

For (2), if it could be made to work at all (which is not clear at all), F would need
a pretty egregious type considering that arrow types are indexed by objects,
and that the type of the arrow map (namely "∀ x y, (x ⟶ y) → (F x ⟶ F y)")
must refer to the object map.

We feel that these issues are not limitations of the Coq system, but merely
reflect the fact that notationally identifying these two different and interdependent
maps is a typical example of an "abus de notation" that by its very nature
is ill-suited to a formal development where software engineering concerns apply.

Hence, we do not adopt this practice, and use "fmap F" (name taken from the Haskell
standard library) to refer to the arrow map of a functor F.

TODO: Sharpen. *)

Section id_functor.
  Context `{Category C}.

  Global Instance: Fmap id := λ _ _, id.

  Global Instance id_functor: Functor (id: C → C) _.
  Proof.
   constructor; try reflexivity; try apply _.
  Qed.

End id_functor.

Section compose_functors.
  Context
    A B C
    `{!Arrows A} `{!Arrows B} `{!Arrows C}
    `{!CatId A} `{!CatId B} `{!CatId C}
    `{!CatComp A} `{!CatComp B} `{!CatComp C}
    `{∀ x y: A, Equiv (x ⟶ y)}
    `{∀ x y: B, Equiv (x ⟶ y)}
    `{∀ x y: C, Equiv (x ⟶ y)}
    `{!Functor (f: B → C) f'} `{!Functor (g: A → B) g'}.

  Global Instance comp_Fmap: Fmap (f ∘ g) := λ _ _, fmap f ∘ fmap g.

  Global Instance compose_functors: Functor (f ∘ g) _.
  Proof with intuition; try apply _.
   pose proof (functor_from g).
   pose proof (functor_to g).
   pose proof (functor_to f).
   constructor; intros; try apply _.
     apply (@setoids.compose_setoid_morphism _ _ _ _ _ _)...
     apply (@functor_morphism _ _ _ _ _ _ _ _ _ _ f _)...
     (* todo: this part really should be automatic *)
    change (fmap f (fmap g (cat_id: a ⟶ a)) = cat_id).
    repeat try rewrite preserves_id...
   change (fmap f (fmap g (f0 ◎ g0)) = fmap f (fmap g f0) ◎ fmap f (fmap g g0)).
   repeat try rewrite preserves_comp...
  Qed.
End compose_functors.

(** The Functor class is nice and abstract and theory-friendly, but not as convenient
 to use for regular programming as Haskell's Functor class. The reason for this is that
 our Functor is parameterized on two Categories, which by necessity bundle setoid-
 ness and setoid-morphism-ness into objects and arrows, respectively.
 The Haskell Functor class, by contrast, is essentially specialized for endofunctors on
 the category of Haskell types and functions between them. The latter corresponds to our
 setoid.Object category.

 To recover convenience, we introduce a second functor type class tailored specifically to
 functors of this kind. The specialization allows us to forgo bundling, and lets us recover
 the down-to-earth Type→Type type for the type constructor, and the (a→b)→(F a→F b)
 type for the function map, with all setoid/morphism proofs hidden in the structure class
 in Prop.

 To justify this definition, in theory/functors we show that instances of this new functor
 class do indeed give rise to instances of the original nice abstract Functor class. *)

Class SFmap (M : Type → Type) := sfmap: ∀ `(A → B), (M A → M B).

Class SFunctor (M : Type → Type)
     `{∀ `{Equiv A}, Equiv (M A)} `{SFmap M} : Prop :=
  { sfunctor_setoid `{Setoid A} :> Setoid (M A)
  ; sfmap_proper `{Setoid A} `{Setoid B} :>
      Proper (((=) ==> (=)) ==> ((=) ==> (=))) (@sfmap M _ A B)
  ; sfmap_id `{Setoid A} : sfmap id = id
  ; sfmap_comp `{Equiv A} `{Equiv B} `{Equiv C} `{!Setoid_Morphism (f : B → C)} `{!Setoid_Morphism (g : A → B)} :
      sfmap (f ∘ g) = sfmap f ∘ sfmap g }.


Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat. Import DispBicat.Notations.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.DisplayedCatToBicat.

Local Open Scope cat.

Section DispTwoInserter.
  Context {B C : bicat}
          {F G : psfunctor B C}
          (α β : pstrans F G).

  Definition disp_two_inserter_disp_cat
    : disp_cat_ob_mor B.
  Proof.
    use make_disp_cat_ob_mor.
    - exact (λ x , α x ==> β x).
    - exact (λ x y θ τ f, (θ ▹ #G f) • psnaturality_of β f
                          =
                          psnaturality_of α f • (#F f ◃ τ)).
  Defined.

  Definition disp_two_inserter_disp_cat_id_comp
    : disp_cat_id_comp _ disp_two_inserter_disp_cat.
  Proof.
    use tpair ; simpl.
    - intros x xx.
      rewrite !pstrans_id_alt.
      etrans.
      {
        rewrite !vassocr.
        rewrite vcomp_whisker.
        apply idpath.
      }
      rewrite !vassocl.
      apply maponpaths.
      rewrite vcomp_whisker.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite vcomp_runitor.
      rewrite !vassocl.
      apply maponpaths.
      rewrite linvunitor_natural.
      rewrite <- lwhisker_hcomp.
      apply idpath.
    - intros x y z f g xx yy zz p q.
      rewrite !pstrans_comp_alt.
      etrans.
      {
        rewrite !vassocr.
        rewrite vcomp_whisker.
        apply idpath.
      }
      rewrite !vassocl.
      apply maponpaths.
      etrans.
      {
        rewrite !vassocr.
        rewrite <- rwhisker_rwhisker.
        rewrite !vassocl.
        apply idpath.
      }
      apply maponpaths.
      rewrite vcomp_whisker.
      rewrite !vassocr.
      apply maponpaths_2.
      refine (!_).
      etrans.
      {
        rewrite !vassocl.
        rewrite <- lwhisker_lwhisker.
        rewrite !vassocr.
        apply idpath.
      }
      apply maponpaths_2.
      rewrite !vassocl.
      rewrite lwhisker_vcomp.
      rewrite <- q.
      rewrite <- lwhisker_vcomp.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !vassocl.
      rewrite rwhisker_lwhisker_rassociator.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !rwhisker_vcomp.
      apply maponpaths.
      rewrite p.
      apply idpath.
  Qed.

  Definition disp_two_inserter_disp_cat_data
    : disp_cat_data B.
  Proof.
    use tpair.
    - exact disp_two_inserter_disp_cat.
    - exact disp_two_inserter_disp_cat_id_comp.
  Defined.

  Definition disp_two_inserter_prebicat : disp_prebicat B
    := disp_cell_unit_bicat disp_two_inserter_disp_cat_data.

  Definition disp_two_inserter_bicat : disp_bicat B
    := disp_cell_unit_bicat disp_two_inserter_disp_cat_data.

  Definition disp_two_inserter_univalent_2_1
    : disp_univalent_2_1 disp_two_inserter_bicat.
  Proof.
    use disp_cell_unit_bicat_univalent_2_1.
    intros.
    apply C.
  Defined.

  Definition disp_two_inserter_univalent_2_0
             (HB : is_univalent_2_1 B)
    : disp_univalent_2_0 disp_two_inserter_bicat.
  Proof.
    use disp_cell_unit_bicat_univalent_2_0.
    - exact HB.
    - intros ; apply C.
    - simpl ; intro.
      apply C.
    - simpl ; intros x xx yy p.
      induction p as [p₁ p₂].
      rewrite !pstrans_id_alt in p₁.
      rewrite !vassocr in p₁.
      rewrite vcomp_whisker in p₁.
      rewrite !vassocl in p₁.
      assert (H : is_invertible_2cell (α x ◃ (psfunctor_id G x) ^-1)) by is_iso.
      assert (q₁ := vcomp_lcancel _ H p₁) ; clear p₁ H.
      cbn -[psfunctor_id] in q₁.
      rewrite vcomp_whisker in q₁.
      rewrite !vassocr in q₁.
      assert (H : is_invertible_2cell (psfunctor_id F x ▹ β x)).
      {
        is_iso.
        apply psfunctor_id.
      }
      assert (q₁' := vcomp_rcancel _ H q₁) ; clear q₁ H.
      rewrite vcomp_runitor in q₁'.
      rewrite !vassocl in q₁'.
      assert (H : is_invertible_2cell (runitor (α x))) by is_iso.
      assert (q₁'' := vcomp_lcancel _ H q₁') ; clear H q₁'.
      rewrite lwhisker_hcomp in q₁''.
      rewrite <- linvunitor_natural in q₁''.
      assert (H : is_invertible_2cell (linvunitor (β x))) by is_iso.
      assert (q₁''' := vcomp_rcancel _ H q₁'') ; clear H q₁''.
      exact q₁'''.
  Qed.

  Definition disp_two_inserter_cells_isaprop
    : disp_2cells_isaprop disp_two_inserter_bicat.
  Proof.
    intro; intros; exact isapropunit.
  Qed.

  Definition disp_two_inserter_locally_groupoid
    : disp_locally_groupoid disp_two_inserter_bicat.
  Proof.
    use make_disp_locally_groupoid.
    - intro ; intros.
      exact tt.
    - exact disp_two_inserter_cells_isaprop.
  Qed.
End DispTwoInserter.


Require Import FunctionalExtensionality.
Require Import PeanoNat.

Section Heap.
  (* Entries in the heap can be of arbitrary type 'S': *)
  Inductive hentry := he : forall {S : Set}, S -> hentry.

  (* We model heaps as partial maps: *)
  Definition heap := nat -> option hentry.

  Definition htype : heap -> (nat -> option Set) :=
    fun h p => match h p with
                 | Some (@he T _) => Some T
                 | None => None
               end.

  Definition empty : heap := fun _ => None.

  Definition single {S : Set} (p : nat) (v : S) :=
    fun q => if (q =? p) then Some (he v) else None.

  Definition disjoint (h1 h2 : heap) : Prop :=
    (forall n, (exists x, h1 n = Some x) -> h2 n = None) /\
    (forall n, (exists x, h2 n = Some x) -> h1 n = None).

  Definition union (h1 h2 : heap) : heap :=
    fun p => match (h1 p) with None => h2 p | _ => h1 p end.

  Definition hext {S : Set} (h : heap) (p : nat) (v : S) : heap :=
    fun q => if (q =? p) then Some (he v) else h q.
End Heap.

Notation "(| h | p -> v |)" := (hext _ h p v)
                               (left associativity, at level 30)
                               : heap_scope.

(* We prove a few simple lemmata to convince ourselves
   that the definitions of our heap operations make sense: *)
Section heap_lemmata.
  Lemma disj_comm' : forall (h1 h2 : heap),
    disjoint h1 h2 -> disjoint h2 h1.
  Proof with auto.
    unfold disjoint; intuition.
  Qed.

  Lemma disj_comm : forall (h1 h2 : heap),
    disjoint h1 h2 <-> disjoint h2 h1.
  Proof with auto.
    intuition; apply disj_comm'...
  Qed.

  Lemma disj_empty_neutral_left : forall (h : heap), disjoint empty h.
  Proof with auto.
    intro h; unfold disjoint, empty; intuition.
    destruct H. inversion H.
  Qed.

  Lemma disj_empty_neutral_right : forall (h : heap), disjoint h empty.
  Proof with auto.
    intro h; unfold disjoint, empty; intuition.
    destruct H. inversion H.
  Qed.

  (* Because of our choice to represent heaps as partial maps, equality
     between heaps is not decidable. Moreover, for proving heaps equal,
     we have to rely on functional extensionality in the following:     *)

  Lemma union_empty_neutral_left : forall (h : heap), union empty h = h.
  Proof with auto.
    intuition; apply functional_extensionality.
  Qed.

  Lemma union_empty_neutral_right : forall (h : heap), union h empty = h.
  Proof with auto.
    intuition; apply functional_extensionality. intro n.
    unfold union. unfold empty. destruct (h n)...
  Qed.

  Lemma union_assoc_1 : forall (h1 h2 h3 : heap),
    disjoint h1 h2 -> disjoint (union h1 h2) h3 ->
      union (union h1 h2) h3 = union h1 (union h2 h3).
  Proof with auto.
    intuition; apply functional_extensionality; intro n; unfold union.
    destruct (h1 n) eqn:?...
  Qed.

  Lemma union_assoc_2 : forall (h1 h2 h3 : heap),
    disjoint h2 h3 -> disjoint h1 (union h2 h3) ->
      union h1 (union h2 h3) = union (union h1 h2) h3.
  Proof with auto.
    intuition; apply functional_extensionality; intro n; unfold union.
    destruct (h1 n) eqn:?...
  Qed.

  Lemma union_comm : forall (h1 h2 : heap),
    disjoint h1 h2 -> union h1 h2 = union h2 h1.
  Proof with auto.
    intuition; apply functional_extensionality; intro n; unfold union.
    destruct (h1 n) eqn:?, (h2 n) eqn:?...
    destruct H.
    assert(exists x, h1 n = Some x) by (exists h; auto).
    apply H in H1; rewrite H1 in Heqo0; inversion Heqo0...
  Qed.

  Lemma disj_union_disj_1 : forall (h1 h2 h3 : heap),
    disjoint h1 h2 -> disjoint (union h1 h2) h3 -> disjoint h1 h3.
  Proof with auto.
    intros h1 h2 h3 H H'. unfold disjoint. split; intros n [x Hex].
    + assert(exists x, union h1 h2 n = Some x)
        by (exists x; unfold union; rewrite Hex; auto).
      apply H' in H0...
    + destruct (union h1 h2 n) eqn:?.
      - assert(exists x, union h1 h2 n = Some x) by (exists h; auto).
        apply H' in H0; rewrite Hex in H0; inversion H0.
      - destruct (h1 n) eqn:?...
        * unfold union in Heqo; rewrite Heqo0 in Heqo; inversion Heqo.
  Qed.

  Lemma disj_union_disj_2 : forall (h1 h2 h3 : heap),
    disjoint h1 h2 -> disjoint (union h1 h2) h3 -> disjoint h2 h3.
  Proof with auto.
    intros h1 h2 h3 H. rewrite union_comm...
    apply disj_union_disj_1; apply disj_comm...
  Qed.

  Lemma disj_union_disj_3 : forall (h1 h2 h3 : heap),
    disjoint h2 h3 -> disjoint h1 (union h2 h3) -> disjoint h1 h3.
  Proof with auto.
    intros h1 h2 h3 H H'.
    apply disj_comm in H'.
    rewrite disj_comm.
    apply disj_union_disj_2 with (h1:=h2)...
  Qed.

  Lemma disj_assoc_1 : forall (h1 h2 h3 : heap),
    disjoint h1 h2 -> disjoint (union h1 h2) h3 -> disjoint h1 (union h2 h3).
  Proof with auto.
    intuition; unfold disjoint; intuition.
    + assert(exists x, union h1 h2 n = Some x)
        by (destruct H1 as [x H']; exists x; unfold union; rewrite H'; auto).
      apply H in H1.
      apply H0 in H2.
      unfold union; rewrite H1; rewrite H2...
    + destruct (h1 n) eqn:?...
      assert(exists x, h1 n = Some x) by (exists h; auto).
      apply H in H2.
      unfold union in H1. rewrite H2 in H1.
      apply H0 in H1. unfold union in H1. rewrite Heqo in H1. inversion H1.
  Qed.

  Lemma disj_assoc_2 : forall (h1 h2 h3 : heap),
    disjoint h2 h3 -> disjoint h1 (union h2 h3) -> disjoint (union h1 h2) h3.
  Proof with auto.
    intuition; unfold disjoint; intuition.
    + destruct (h1 n) eqn:?...
      - assert(exists x, h1 n = Some x) by (exists h; auto).
        apply H0 in H2.
        unfold union in H2.
        destruct (h2 n) eqn:?...
        inversion H2.
      - destruct (h2 n) eqn:?...
        * assert(exists x, h2 n = Some x) by (exists h; auto).
          apply H in H2...
        * destruct H1 as [x H1].
          unfold union in H1. rewrite Heqo in H1. rewrite Heqo0 in H1.
          inversion H1.
    + assert(h2 n = None) by (apply H in H1; auto).
      destruct H1 as [x H1].
      assert(exists x, union h2 h3 n = Some x)
        by (exists x; unfold union; rewrite H2; rewrite H1; auto).
      apply H0 in H3.
      unfold union. rewrite H3...
  Qed.

  Lemma union_empty_empty : forall (h1 h2 : heap),
   union h1 h2 = empty -> (h1 = empty /\ h2 = empty).
  Proof with auto.
    intros h1 h2 H.
    split; apply functional_extensionality; intro p;
      assert(H1: union h1 h2 p = empty p) by (rewrite H; auto);
      unfold union in H1;
      destruct (h1 p).
    + inversion H1.
    + unfold empty...
    + inversion H1.
    + auto.
  Qed.

  Lemma single_not_empty : forall {S : Set} (p : nat) (a : S),
    (@single S p a) <> empty.
  Proof with auto.
    intuition.
    assert(H1: single p a p = empty p) by (rewrite H; auto).
    unfold single, empty in H1. rewrite Nat.eqb_refl in H1. inversion H1.
  Qed.
End heap_lemmata.

Section Assertions.
  (* Heap assertions: *)

  Definition hass := (heap -> Prop).

  Definition emp : hass := fun h => h = empty.

  Definition htrue : hass := fun _ => True.

  Definition hor (P Q : hass) : hass := fun h => P h \/ Q h.

  Definition singleton (p : nat) {S : Set} (v : S) : hass :=
    fun h => h = single p v.

  Definition pure (P : Prop) : hass := fun h => P /\ h = empty.

  Definition sep (P Q : hass) : hass :=
    fun h => exists h1 h2, disjoint h1 h2 /\ h = union h1 h2 /\ P h1 /\ Q h2.

  Definition ex {A} (P : A -> hass) : hass :=
    fun h => exists x, P x h.

  Definition wand (P Q : hass) : hass :=
    fun h => forall h', disjoint h h' -> P h' -> Q (union h h').

  Definition imply (P Q : hass) : Prop :=  forall h, P h -> Q h.
  Definition equiv (P Q : hass) : Prop :=  forall h, P h <-> Q h.
End Assertions.

Notation "<[ P ]>" := (pure P) : heap_scope.
Notation "P || Q" := (hor P Q )
                     (at level 50, left associativity) : heap_scope.
Notation "[[ p |-> v ]]" := (singleton p v) (at level 30) : heap_scope.
Notation "P * Q" := (sep P Q) (at level 40, left associativity) : heap_scope.
Notation "'exist' x .. y , P" := (ex (fun x => .. (ex (fun y => P)) ..))
                                 (at level 50, x binder, y binder)
                                 : heap_scope.
Notation "P ==> Q" := (imply P Q) (no associativity, at level 70)
                                  : heap_scope.
Notation "P === Q" := (equiv P Q) (no associativity, at level 70)
                                  : heap_scope.

(* We prove a few simple lemmata to convince ourselves that our
   heap assertions and some of their combinations make sense:   *)
Section assertions_lemmata.

  Open Scope heap_scope.

  Lemma sep_comm : forall (P Q : hass),
    P * Q === Q * P.
  Proof with auto.
    unfold equiv. intros P Q h.
    unfold sep; intuition;
      destruct H as [h1 [h2 [Hdis [Hun [HP HQ] ] ] ] ];
      exists h2, h1; intuition; auto;
      try (apply disj_comm; auto);
      try (rewrite Hun; apply union_comm)...
  Qed.

  Lemma hass_ex_falso : forall (P : hass), <[False]> ==> P.
  Proof.
    unfold imply. intros p h H.
    inversion H; contradiction.
  Qed.

  Lemma hass_ex_falso_framed_left : forall (P Q : hass), P * <[False]> ==> Q.
  Proof.
    unfold sep, imply. intuition.
    destruct H as [h1 [h2 [Hdisj [Hun [_ HFalse] ] ] ] ].
    destruct HFalse; contradiction.
  Qed.

  Lemma hass_ex_falso_framed_right : forall (P Q : hass), <[False]> * P ==> Q.
  Proof.
    unfold sep, imply. intuition.
    destruct H as [h1 [h2 [Hdisj [Hun [HFalse _] ] ] ] ].
    destruct HFalse; contradiction.
  Qed.

  Lemma hass_imply_taut : forall (P : hass), P ==> P.
  Proof. unfold imply; auto. Qed.

  Lemma hass_singleton_exclusive :
    forall {S1 S2 : Set} p (v : S1) (w : S2) (P : hass),
      [[p |-> v]] * [[p |-> w]] ==> P.
  Proof.
    destruct 1 as [h1 [h2 [Hdis [Hun [Hpv Hpw] ] ] ] ]; intuition.
    unfold singleton in *. subst.
    inversion Hdis.
    assert(exists x, single p v p = Some x)
      by (exists (he v); unfold single; rewrite Nat.eqb_refl; auto).
    apply H in H1.
    unfold single in H1; rewrite Nat.eqb_refl in H1; inversion H1.
  Qed.

  Lemma hass_pure_contraction : forall (P : Prop),
    <[P]> * <[P]> ==> <[P]>.
  Proof.
    destruct 1 as [h1 [h2 H] ].
    firstorder; subst; auto.
  Qed.

  Lemma hass_pure_conj_equiv_sep : forall (P Q : Prop),
    <[P /\ Q]> === <[P]> * <[Q]>.
  Proof.
    unfold equiv, pure, sep.
    firstorder; subst; auto.
    exists empty, empty; intuition; firstorder.
  Qed.

  Lemma hass_imply_trans : forall (P Q R : hass),
    P ==> Q -> Q ==> R -> P ==> R.
  Proof. firstorder. Qed.

  Lemma hass_imply_imply_equiv : forall (P Q : hass),
    (P ==> Q /\ Q ==> P) <-> P === Q.
  Proof. firstorder. Qed.

  Lemma hass_equiv_imply : forall (P Q : hass),
    (P === Q) -> P ==> Q.
  Proof. firstorder. Qed.

  Lemma hass_equiv_trans : forall (P Q R : hass),
    P === Q -> Q === R -> P === R.
  Proof. firstorder. Qed.

  Lemma hass_equiv_symm : forall (P Q : hass),
    (P === Q) <-> (Q === P).
  Proof with auto.
    unfold equiv; intuition; apply H...
  Qed.

  Lemma hass_imply_framed_right : forall (P Q R : hass),
    P ==> Q -> P * R ==> Q * R.
  Proof. firstorder. Qed.

  Lemma hass_equiv_framed_right : forall (P Q R : hass),
    P === Q -> P * R === Q * R.
  Proof. firstorder. Qed.

  Lemma hass_imply_framed_left : forall (P Q R : hass),
    P ==> Q -> R * P ==> R * Q.
  Proof. firstorder. Qed.

  Lemma hass_equiv_framed_left : forall (P Q R : hass),
    P === Q -> R * P === R * Q.
  Proof. firstorder. Qed.

  Lemma sep_assoc_1 : forall (P Q R : hass),
    (P * Q) * R ==> P * (Q * R).
  Proof with auto.
    unfold imply. intros P Q R h. unfold sep; intuition.
    destruct H  as [h1 [h2 [Hdis  [Hun  [H' HR] ] ] ] ].
    destruct H' as [h3 [h4 [Hdis' [Hun' [HP HQ] ] ] ] ].
    exists h3, (union h4 h2); intuition; rewrite Hun' in Hdis.
    - apply disj_assoc_1...
    - rewrite Hun' in Hun; rewrite Hun.
      apply union_assoc_1...
    - exists h4, h2; intuition.
      eapply disj_union_disj_2. apply Hdis'. exact Hdis.
  Qed.

  Lemma sep_assoc_2 : forall (P Q R : hass),
    P * (Q * R) ==> (P * Q) * R.
  Proof with auto.
    unfold imply. intros P Q R h. unfold sep; intuition.
    destruct H  as [h1 [h2 [Hdis  [Hun  [HP H'] ] ] ] ].
    destruct H' as [h3 [h4 [Hdis' [Hun' [HQ HR] ] ] ] ].
    exists (union h1 h3), h4; intuition; rewrite Hun' in Hdis.
    - apply disj_assoc_2...
    - rewrite Hun' in Hun; rewrite Hun.
      apply union_assoc_2...
    - exists h1, h3; intuition.
      eapply disj_union_disj_3 with (h2:=h4).
      apply disj_comm...
      rewrite union_comm... apply disj_comm...
  Qed.

  Lemma sep_assoc : forall (P Q R : hass),
    (P * Q) * R === P * (Q * R).
  Proof with auto.
    intros P Q R. apply hass_imply_imply_equiv. intuition.
    apply sep_assoc_1. apply sep_assoc_2.
  Qed.

  Lemma sep_empty_neutral_left : forall (P : hass), emp*P === P.
  Proof with auto.
    unfold sep, emp, equiv. intuition.
    + destruct H as [h1 [h2 [_ [Hun [Hemp HP] ] ] ] ].
      subst. rewrite union_empty_neutral_left...
    + exists empty, h. intuition...
      apply disj_empty_neutral_left.
  Qed.

  Lemma sep_empty_neutral_right : forall (P : hass), P*emp === P.
  Proof with auto.
    unfold sep, emp, equiv. intuition.
    + destruct H as [h1 [h2 [_ [Hun [HP Hemp] ] ] ] ].
      subst. rewrite union_empty_neutral_right...
    + exists h, empty. intuition...
      apply disj_empty_neutral_right.
      rewrite union_empty_neutral_right...
  Qed.

  Lemma sep_pure_left : forall (P : hass) (Q : Prop),
    Q -> forall h, P h -> (sep <[Q]> P) h.
  Proof with auto.
    unfold sep; intuition.
    exists empty, h; firstorder.
    inversion H1.
  Qed.

  Lemma sep_pure_right : forall (P : hass) (Q : Prop),
    Q -> forall h, P h -> (sep P <[Q]>) h.
  Proof with auto.
    unfold sep; intuition.
    exists h, empty; firstorder.
    + inversion H1.
    + rewrite union_empty_neutral_right...
  Qed.

  Close Scope heap_scope.
End assertions_lemmata.


From Hammer Require Import Hammer.

From Topology Require Export TopologicalSpaces.
From Topology Require Export OpenBases.
From ZornsLemma Require Export FiniteTypes.
From ZornsLemma Require Export EnsemblesSpec.

Section Subbasis.

Variable X:TopologicalSpace.
Variable SB:Family (point_set X).

Record subbasis : Prop := {
subbasis_elements: forall U:Ensemble (point_set X),
In SB U -> open U;
subbasis_cover: forall (U:Ensemble (point_set X)) (x:point_set X),
In U x -> open U ->
exists A:Type, FiniteT A /\
exists V:A->Ensemble (point_set X),
(forall a:A, In SB (V a)) /\
In (IndexedIntersection V) x /\
Included (IndexedIntersection V) U
}.

Lemma open_basis_is_subbasis: open_basis SB -> subbasis.
Proof. hammer_hook "Subbases" "Subbases.open_basis_is_subbasis".
intros.
destruct H.
constructor.
exact open_basis_elements.
intros.
destruct (open_basis_cover x U); trivial.
destruct H1 as [? [? ?]].
exists True.
split.
apply True_finite.
exists (True_rect x0).
repeat split; intros.
destruct a.
simpl.
assumption.
destruct a.
simpl.
assumption.
red; intros.
destruct H4.
apply H2.
exact (H4 I).
Qed.

Lemma finite_intersections_of_subbasis_form_open_basis:
subbasis ->
open_basis [ U:Ensemble (point_set X) |
exists A:Type, FiniteT A /\
exists V:A->Ensemble (point_set X),
(forall a:A, In SB (V a)) /\
U = IndexedIntersection V ].
Proof. hammer_hook "Subbases" "Subbases.finite_intersections_of_subbasis_form_open_basis".
constructor.
intros.
destruct H0.
destruct H0 as [A [? [V' [? ?]]]].
rewrite H2.
apply open_finite_indexed_intersection; trivial.
intros.
apply H; trivial.

intros.
pose proof (subbasis_cover H U x).
destruct H2 as [A [? [V [? [? ?]]]]]; trivial.
exists (IndexedIntersection V).
repeat split; trivial.
exists A; split; trivial.
exists V; trivial.
split; trivial.
destruct H4.
exact H4.
Qed.

End Subbasis.

Arguments subbasis {X}.

From ZornsLemma Require Import FiniteIntersections.

Section build_from_subbasis.

Variable X:Type.
Variable S:Family X.

Definition Build_TopologicalSpace_from_subbasis : TopologicalSpace.
refine (Build_TopologicalSpace_from_open_basis
(finite_intersections S) _ _).
red; intros.
exists (Intersection U V); repeat split; trivial.
apply intro_intersection; trivial.
destruct H1; assumption.
destruct H1; assumption.
destruct H2; assumption.
destruct H2; assumption.

red; intro.
exists Full_set.
split; constructor.
Defined.

Lemma Build_TopologicalSpace_from_subbasis_subbasis:
@subbasis Build_TopologicalSpace_from_subbasis S.
Proof. hammer_hook "Subbases" "Subbases.Build_TopologicalSpace_from_subbasis_subbasis".
assert (@open_basis Build_TopologicalSpace_from_subbasis
(finite_intersections S)).
apply Build_TopologicalSpace_from_open_basis_basis.
constructor.
intros.
simpl in U.
apply open_basis_elements with (finite_intersections S); trivial.
constructor; trivial.

intros.
destruct (@open_basis_cover _ _ H x U) as [V]; trivial.
destruct H2 as [? [? ?]].
simpl.

pose proof (finite_intersection_is_finite_indexed_intersection
_ _ H2).
destruct H5 as [A [? [W [? ?]]]].
exists A; split; trivial.
exists W; repeat split; trivial.

rewrite H7 in H4; destruct H4; apply H4.
rewrite H7 in H3; assumption.
Qed.

End build_from_subbasis.