Require Import MSets OrdSet CustomTactics Eqdep_dec Bool
        FunctionalExtensionality ProofIrrelevance.

(** One usefull lemma to prove properties of permutations *)
Lemma happly {A B : Type} {f g : A -> B} : f = g -> forall x, f x = g x.
Proof.
  intros.
  destruct H. reflexivity.
Qed.

Module Type Atom.
  Declare Module V : SetExtT.
  Axiom eq_dec : forall (a1 a2 : V.elt), {a1 = a2} + {a1 <> a2}.
  Axiom Atom_inf : forall (X : V.t), {x : V.elt | ~ V.In x X}.
End Atom.

Module Nominal (A : Atom).
  Module Atom := A.
  Import A.
  Module SetFacts := WFacts V.
  Module SetProperties := OrdProperties V.

  Notation Atom := Atom.V.elt.
  Notation FinSetA := Atom.V.t.

  Open Scope program_scope.

  Definition is_inj  {A B : Type} (f : A -> B) : Prop :=
    forall (x y : A), f x = f y -> x = y.
  Definition is_surj {A B : Type} (f : A -> B) : Prop :=
    forall (y : B), exists (x : A), f x = y.

  Hint Unfold is_inj is_surj.

  Lemma inj_comp_inj {A B C: Type} (f : A -> B) (g : B -> C) :
    is_inj f -> is_inj g -> (is_inj (g ∘ f)).
  Proof.
    unfold is_inj. intros. auto.
  Qed.

  Lemma surj_comp_surj {A B C: Type} (f : A -> B) (g : B -> C) :
    is_surj f -> is_surj g -> (is_surj (g ∘ f)).
  Proof.
    autounfold. intros H H1 c.
    destruct (H1 c) as [b Hb].
    destruct (H b) as [a Ha].
    exists a; congruence.
  Qed.

  Lemma eq_leibniz_1 x y :  x = y -> V.E.eq x y.
  Proof.
    intros. subst.
    destruct (V.E.eq_equiv).
    apply Equivalence_Reflexive.
  Qed.

  Hint Resolve V.E.eq_leibniz eq_leibniz_1.

  Lemma eq_leibniz_iff x y : V.E.eq x y <-> x=y.
  Proof.
    split;auto.
  Qed.

  (* ----------------------------------- *)
  (* Definition of finitary permutations *)
  (* ----------------------------------- *)

  Definition is_biject {A B} (f : A -> B) :=
    (is_inj f) /\ (is_surj f).

  Definition has_fin_supp f := exists S, (forall t, ~ V.In t S -> f t = t).

  Record Perm :=
    { perm : Atom -> Atom;
      perm_inv : Atom -> Atom;
      l_inv : (perm_inv ∘ perm) = id ;
      r_inv : (perm ∘ perm_inv) = id ;
      fin_supp : has_fin_supp perm}.

  Coercion perm : Perm >-> Funclass.

  Lemma perm_is_biject (p : Perm) : is_biject p.
  Proof.
    destruct p as [p q l r ?].
    simpl. split.
    + intros x y f.
      assert ((q ∘ p) x = (q ∘ p) y) by (unfold compose;now rewrite f).
      rewrite l in H. assumption.
    + intros x. exists (q x). change ((p ∘ q) x = x). now rewrite r.
  Qed.

  Notation "- p" := (perm_inv p).

  Lemma perm_eq (p1 p2 : Perm) :
    perm p1 = perm p2 ->
    perm_inv p1 = perm_inv p2 ->
    p1 = p2.
  Proof.
    intros.
    destruct p1 as [f g l r f_s].
    destruct p2 as [f' g' l' r' f_s'].
    simpl in *. subst. f_equal; apply proof_irrelevance.
  Qed.

  Definition id_perm : Perm.
    refine ({| perm:=id; perm_inv := id;
               l_inv := eq_refl; r_inv := eq_refl;
               fin_supp := _|}).
      + exists V.empty;intros;auto.
  Defined.

  Definition perm_comp (p p' : Perm) : Perm.
    refine ({| perm:= (perm p) ∘ (perm p');
               perm_inv := (perm_inv p') ∘ (perm_inv p);
               l_inv := _;
               r_inv := _;
               fin_supp := _ |}).
    + destruct p as [f g l r f_s].
      destruct p' as [f' g' l' r' f_s'].
      simpl.
      change ((g' ∘ (g ∘ f) ∘ f') = id).
      rewrite l.
      change (g' ∘ f' = id).
      rewrite l'. reflexivity.
    + destruct p as [f g l r f_s].
      destruct p' as [f' g' l' r' f_s'].
      simpl.
      change (f ∘ (f' ∘ g') ∘ g = id).
      rewrite r'.
      change (f ∘ g = id).
      rewrite r. reflexivity.
    + destruct p as [f g l r f_s].
      destruct p' as [f' g' l' r' f_s'].
      simpl. destruct f_s as [x Hx]. destruct f_s' as [x' Hx'].
      exists (V.union x x'). intros. unfold compose.
      rewrite Hx';auto with set.
  Defined.

  Notation "p ∘p p'" := (perm_comp p p') (at level 40).

  Lemma perm_comp_assoc p1 p2 p3 :
    (p1 ∘p p2) ∘p p3 = p1 ∘p (p2 ∘p p3).
  Proof.
    apply perm_eq;auto.
  Qed.

  (* -------------- *)
  (* Swapping atoms *)
  (* -------------- *)

  (* Swapping two atoms is a simpliest permutation *)
  Definition swap_fn (a b c : V.elt) : V.elt :=
    if (V.E.eq_dec a c) then b
      else (if (V.E.eq_dec b c) then a
        else c).

  Lemma swap_fn_involution {a b} : (swap_fn a b) ∘ (swap_fn a b) = id.
  Proof.
    apply functional_extensionality.
    intros x. unfold compose,swap_fn.
    destruct (V.E.eq_dec a x),( V.E.eq_dec b x),
    (V.E.eq_dec a b),(V.E.eq_dec b b),(V.E.eq_dec a a),(V.E.eq_dec b a);
      rewrite eq_leibniz_iff in *;
      tryfalse;auto;
    destruct (V.E.eq_dec a x),( V.E.eq_dec b x);rewrite eq_leibniz_iff in *;
      tryfalse;auto.
  Qed.

  Hint Unfold swap_fn.

  Lemma id_swap_fn a b c :
    ~ V.In c (V.union (V.singleton a) (V.singleton b)) -> swap_fn a b c = c.
  Proof.
    intros Hc. autounfold.
      destruct (V.E.eq_dec a c); destruct (V.E.eq_dec b c);auto with set;
        exfalso; auto with set.
  Qed.

  Lemma has_fin_supp_swap_fn a b : has_fin_supp (swap_fn a b).
  Proof.
    autounfold.
    exists (V.union (V.singleton a) (V.singleton b)).
    apply id_swap_fn.
  Qed.

  Definition swap (a b : V.elt) : Perm :=
    {| perm := swap_fn a b;
       perm_inv := swap_fn a b;
       l_inv := swap_fn_involution;
       r_inv := swap_fn_involution;
       fin_supp  := has_fin_supp_swap_fn a b|}.

  Lemma is_biject_swap a b : is_biject (swap a b).
  Proof. apply perm_is_biject. Qed.

  Lemma swap_involution a b : (swap a b) ∘p (swap a b) = id_perm.
  Proof.
    apply perm_eq;
      simpl; rewrite swap_fn_involution; reflexivity.
  Qed.

  Import ListNotations.

  Fixpoint zip {A B} (xs : list A) (ys : list B) : list (A * B) :=
    match xs, ys with
    | (x::xs'), (y::ys') => (x, y) :: zip xs' ys'
    | _, _ => []
    end.

  (* Swapping bunch of atoms as a composition of primitive swaps *)
  Definition swap_iter_fn (vs : list (Atom * Atom)) : Atom -> Atom :=
    fold_right (fun (e' : (Atom * Atom)) (f : Atom -> Atom) =>
                  let (e1,e2) := e' in f ∘ (swap_fn e1 e2)) id vs.

  (* After we changed the definition of a permutation to contatin the inverse
     permutation it has become trickier to define the iterated permutation
     TODO : fix prove this and finish the definition of [swap_iter] *)
  (* Lemma swap_iter_fn_involution {xs} : (swap_iter_fn xs) ∘ (swap_iter_fn xs) = id. *)
  (* Proof. *)
  (*   induction xs as [| x]. *)
  (*   - reflexivity. *)
  (*   - simpl. destruct x as [x1 x2]. *)
  (*     change (swap_iter_fn xs ∘ (swap_fn x1 x2 ∘ swap_iter_fn xs) ∘ swap_fn x1 x2 = id). *)

  Hint Resolve inj_comp_inj.

  Lemma swap_iter_fn_inj vs : is_inj (swap_iter_fn vs).
  Proof.
    induction vs;autounfold;intros x y H.
    + auto.
    + destruct a;simpl in *.
      destruct (is_biject_swap e e0).
      assert (is_inj (swap_iter_fn vs ∘ swap_fn e e0));auto.
  Qed.

  Hint Resolve surj_comp_surj.

  Lemma swap_iter_fn_surj vs : is_surj (swap_iter_fn vs).
  Proof.
    induction vs;autounfold;intros x.
    + eexists. reflexivity.
    + destruct a;simpl in *.
      destruct (is_biject_swap e e0).
      assert (is_surj (swap_iter_fn vs ∘ swap_fn e e0));auto.
  Qed.

  Lemma union_not_in A A' e : ~ V.In e (V.union A A') -> ~ V.In e A /\ ~ V.In e A'.
  Proof.
    intros H. auto with set.
  Qed.

  Import SetProperties.

  Hint Resolve P.Dec.F.singleton_1 P.Dec.F.singleton_2 V.E.eq_leibniz : set.

  Lemma is_biject_swap_iter vs vs' : is_biject (swap_iter_fn (zip vs vs')).
  Proof.
    split.
    + apply swap_iter_fn_inj.
    + apply swap_iter_fn_surj.
  Qed.

  Lemma has_fin_supp_swap_iter vs vs' :
    has_fin_supp (swap_iter_fn (zip vs vs')).
  Proof.
    exists (V.union (P.of_list vs) (P.of_list vs')). intros.
    generalize dependent vs'.
    induction vs;destruct vs';simpl;auto.
    simpl in *. unfold compose.
    intros H.

    (* Needed to apply IH *)
    assert (~ V.In t (V.union (P.of_list vs) (P.of_list vs'))).
    { apply union_not_in in H. destruct H; auto with set. }

    (* Needed to show that swap_n is the identity function outside of support *)
    assert (Ha : t <> a) by (apply union_not_in in H; destruct H; auto with set).
    assert (He : t <> e) by (apply union_not_in in H; destruct H; auto with set).

    assert (Ht : swap_fn a e t = t).
    { apply id_swap_fn. apply union_not_in in H.
      apply P.not_in_union;unfold not; intro Hin.
      * apply Ha; symmetry; auto with set.
      * apply He; symmetry; auto with set. }
    rewrite Ht. auto.
  Qed.

  (* Definition swap_iter (vs vs' : V.t) : Perm := *)
  (*   {| perm := swap_iter_fn (zip (V.elements vs) (V.elements vs')); *)
  (*      is_biject_perm := is_biject_swap_iter _ _; *)
  (*      has_fin_supp_perm := has_fin_supp_swap_iter _ _|}. *)

  Class NomSet :=
    { Carrier : Type;
      action : Perm -> Carrier -> Carrier;
      supp : Carrier -> FinSetA;
      action_id : forall (x : Carrier), action id_perm x = x;
      action_compose : forall (x : Carrier) (p p' : Perm),
          action p (action p' x) = action (p ∘p p') x;
      support_spec : forall  (p : Perm)  (x : Carrier),
          (forall (a : Atom), V.In a (supp x) -> p a = a) ->
          action p x = x}.

  Coercion Carrier : NomSet >-> Sortclass.

  Notation "r @ x" := (action r x) (at level 100).

  Definition equivar_fn {X Y : NomSet} (f : X -> Y) :=
    forall x p, f (p @ x) = (p @ (f x)).

  Definition equivar_fn2 {X Y Z : NomSet} (f : X -> Y -> Z) :=
    forall x y p, f (p @ x) (p @ y) = (p @ (f x y)).

  Definition equivar_rel {X Y : NomSet} (R : X -> Y -> Prop) :=
    forall (x : X) (y : Y) (p : Perm), R x y -> R (p @ x) (p @ y).

  Module NomAtom.

    Instance NomAtom : NomSet.
    refine (
        {| Carrier := Atom;
           action := fun p a => (perm p) a;
           supp := fun a => V.singleton a;
           action_id := fun a => eq_refl _;
           action_compose := fun a p1 p2 => eq_refl;
           support_spec := _
        |}).
    - (* support_spec *) intros. apply H. eauto with set.
    Defined.
  End NomAtom.

  Module PFin.

    Import V.

    Hint Resolve V.set_map_spec_1 V.set_map_spec V.set_map_iff : set.

    Instance PFin : NomSet.
    refine ({| Carrier := V.t;
      action := fun p x => V.set_map (perm p) x;
      supp := fun x => x;
      action_id := _;
      action_compose := _;
      support_spec := _|}).
    - (* action_id*)
      intros x. unfold action.
      apply V.set_extensionality. intros x'.
      split.
      + intros Hx. rewrite V.set_map_iff in *. destruct Hx as [y H]. destruct H;subst;auto.
      + intros Hx. eauto with set.
    - (* action_compose *)
      intros x r r'. unfold action. apply V.set_extensionality. intros x'.
        split.
        + intros Hx. rewrite V.set_map_iff in *. destruct Hx.
          intuition;subst;auto. rewrite V.set_map_iff in *.
          destruct H1. intuition. subst.
          exists x1;split;auto.
        + intros Hx. rewrite V.set_map_iff in *. destruct Hx as [x1 H].
          destruct H.
          exists ((perm r') x1). subst; split;auto with set.
    - (* support_spec *)
      intros. unfold action.
      apply set_extensionality. intro y. split.
      + intros H'. auto with set.
        rewrite set_map_iff in *. destruct H' as [y' Hy']. destruct Hy'.
        subst. rewrite H;auto.
      + intros H'. eapply set_map_spec_1;try symmetry;eauto.
    Defined.

    Module Dec := DecidableEqDep BoolDec.

  End PFin.

  (* ---------------------------------------------- *)
  (* Freshness conditions and fresh name generators *)
  (* ---------------------------------------------- *)

  Import NomAtom.
  Import PFin.

  Definition fresh {X Y : NomSet} : X -> Y -> Prop :=
    fun (x : X) (y :Y) => V.Disjoint (supp x) (supp y).

  Infix "#" := fresh (at level 40).

  Import V.

  Lemma disjoint_not_in_1 {X e} : ~ In e X -> Disjoint (singleton e) X.
  Proof.
    intros H.
    apply Disjoint_spec.
    intros. unfold not. intros H1. destruct H1. simpl in *.
    rewrite P.Dec.F.singleton_iff in *.
    rewrite eq_leibniz_iff in *. tryfalse.
  Qed.

  Lemma disjoint_not_in_2 {X e} : Disjoint (singleton e) X -> ~ In e X.
  Proof.
    intros H.
    rewrite Disjoint_spec in *.
    intros. unfold not. intros H1. apply (H e).
    auto with set.
  Qed.

  Lemma disjoint_not_in {X e}: ~ In e X <-> Disjoint (singleton e) X.
  Proof.
    split.
    - apply disjoint_not_in_1.
    - apply disjoint_not_in_2.
  Qed.

  Lemma not_in_set_fresh (a : NomAtom) (A : PFin) : ~ In a A <-> a # A.
  Proof.
    unfold fresh. apply disjoint_not_in.
  Qed.

  (** Type of a function with a property, that generated atom is fresh for the set [a] *)
  Definition FreshFn (a : V.t) := {f : V.t -> NomAtom | forall x, (f x) # a}.

  (** Function that generates a fresh atom using [Atom_inf] property *)
  Definition fresh_fn : forall a, FreshFn a :=
    fun a => let H := Atom.Atom_inf a in
            exist (fun f : t -> NomAtom => forall x : t, ((f x) # a))
                    (fun _ : t => proj1_sig H)
                    (fun _ : t => disjoint_not_in_1 (proj2_sig H)).

    (** Set of fresh atoms (wrt the set [a]) of cardinality [n] *)
  Definition AllFresh a n := { b : V.t | (b # a) /\ V.cardinal b = n }.

  (** Computational part of a function that generates set of fresh atoms *)
  Fixpoint get_freshs_internal (X : V.t) (n : nat) : V.t :=
    match n with
    | O => empty
    | S n' => let fatom := (proj1_sig (fresh_fn X)) X in
              add fatom (get_freshs_internal (add fatom X) n')
    end.

  Lemma get_freshs_internal_all_fresh : forall n a, (get_freshs_internal a n) # a.
  Proof.
    induction n;intros.
    + simpl. compute. apply Disjoint_spec. intros k.
      unfold not. intros H. destruct H as [L R]. rewrite P.Dec.F.empty_iff in *. inversion L.
    + simpl. unfold fresh. rewrite Disjoint_spec. unfold not. intros.
      simpl in *.
      rewrite SetProperties.P.Dec.F.add_iff in *.
      intuition.
      * rewrite eq_leibniz_iff in *. subst. apply (proj2_sig (Atom.Atom_inf a));auto.
      * unfold fresh in *.
        assert (HH := IHn (add (proj1_sig (Atom.Atom_inf a)) a)).
        rewrite Disjoint_spec in *.
        apply (HH k). clear IHn HH. split;auto.
        simpl. rewrite SetProperties.P.Dec.F.add_iff in *. intuition;auto.
  Qed.

  Lemma get_freshs_cardinality : forall n a, V.cardinal (get_freshs_internal a n) = n.
  Proof.
    induction n;intros.
    + simpl. auto with set.
    + simpl. rewrite SetProperties.P.add_cardinal_2;auto.
      remember (proj1_sig (Atom.Atom_inf a)) as b.
      assert (H := get_freshs_internal_all_fresh n (add b a)).
      unfold not. intros. unfold fresh in *.
      rewrite Disjoint_spec in *.
      apply (H b). simpl. rewrite SetProperties.P.Dec.F.add_iff in *.
      split;auto with set.
  Qed.

  (** Function that generates set of fresh atoms along with *)
  (*     the proof of freshness *)
  Definition get_freshs (X : V.t) (n : nat) : AllFresh X n :=
    exist _ (get_freshs_internal X n)
            (conj (get_freshs_internal_all_fresh n X)
                  (get_freshs_cardinality n X)).

  Module NomFacts.

    (* An alternative characterisation of support in terms of swap  *)
    Lemma supp_spec_swap {X : NomSet}:
      forall (a b : Atom) (x : X),
        ~ In a (supp x) -> ~ In b (supp x) ->
        ((swap a b) @ x) = x.
    Proof.
      intros a b x Ha Hb.
      apply support_spec.
      intros a' Ha'. simpl. autounfold.
      destruct (SetProperties.P.FM.eq_dec a a');
        destruct (SetProperties.P.FM.eq_dec b a');
        rewrite eq_leibniz_iff in *; congruence.
    Qed.

    Hint Resolve SetProperties.P.Dec.F.singleton_1 SetProperties.P.Dec.F.singleton_2 : set.

    Lemma action_singleton : forall r e, (r @ (singleton e)) = singleton ((perm r) e).
    Proof.
      intros.
      apply set_extensionality.
      intros. unfold action. split.
      + intros H. simpl in *. rewrite V.set_map_iff in *.
        destruct H as [e' He']. destruct He'. subst.
        rewrite SetProperties.P.Dec.F.singleton_iff in *.
        rewrite eq_leibniz_iff in *. subst. reflexivity.
      + intros H. simpl in *. rewrite V.set_map_iff in *.
        rewrite SetProperties.P.Dec.F.singleton_iff in *.
        rewrite eq_leibniz_iff in H. subst.
        exists e;auto with set.
    Qed.

    Lemma equivar_union : equivar_fn2 union.
    Proof.
      unfold equivar_fn2.
      intros x y p.
      apply V.set_extensionality.
      intros z. split.
      + intros H. unfold action in *. rewrite union_spec in *.
        simpl in *. rewrite set_map_iff in *.
        destruct H.
        * destruct H. exists x0; destruct H; split; auto with set.
        * rewrite set_map_iff in *. destruct H as [x0 Hx0]. destruct Hx0.
          exists x0;split;auto. rewrite union_spec in *. auto.
      + intros H. unfold action in *. rewrite union_spec in *.
        simpl in *. rewrite set_map_iff in *.
        destruct H. destruct H; subst.
        rewrite union_spec in *.
        destruct H0;auto with set.
        left. exists x0;auto.
    Qed.

    Lemma equivar_inter : equivar_fn2 inter.
    Proof.
      intros x y p.
      apply V.set_extensionality.
      intros z. split.
      + intros H. unfold action in *. simpl in *.
        rewrite inter_spec in *. rewrite set_map_iff in *.
        destruct H as [He' Hz]. destruct He' as [e' Htl].
        destruct Htl; subst.
        rewrite set_map_iff in *.
        destruct Hz as [e'' Htl]. destruct Htl.
        exists e''.
        destruct p as [f g l r Hsupp]. simpl in *.
        assert (Heq : e' = e'') by
            (replace (e') with (g (f e')) by apply (happly l);
             replace (e'') with (g (f e'')) by apply (happly l);
             congruence).
        subst. auto with set.
      + intros H. unfold action in *.
        simpl in *. rewrite set_map_iff in *.
        destruct H. destruct H; subst.
        rewrite inter_spec in *.
        destruct H0;auto with set.
    Qed.

    Lemma equivar_fresh_set : equivar_rel (fun (x y : PFin) => x # y).
    Proof.
      unfold equivar_rel.
      intros x y p. destruct p as [f g l r Hsupp].
      intros. rewrite Disjoint_spec in *. intros k.
      unfold action in *. simpl. intros H1. rewrite set_map_iff in *.
      destruct H1. destruct H0. destruct H0. subst.
      apply (H x0). split;auto.
      rewrite set_map_iff in *.
      destruct H1. destruct H0.
      (* NOTE : here we use the property that permutation is injective.
         We prove injectivity using the left inverse property*)
      assert (x0 = x1) by
            (replace (x0) with (g (f x0)) by apply (happly l);
             replace (x1) with (g (f x1)) by apply (happly l);
             congruence).
      subst;auto.
    Qed.

  End NomFacts.

  Lemma swap_fresh {X : NomSet} {a b : NomAtom} {x : X} :
  a # x -> b # x -> ((swap a b) @ x) = x.
  Proof.
    intros Ha Hb.
    apply NomFacts.supp_spec_swap;
    apply not_in_set_fresh; auto.
  Qed.

End Nominal.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** * Typeclass-based setoids. Definitions on [Equivalence].

   Author: Matthieu Sozeau
   Institution: LRI, CNRS UMR 8623 - University Paris Sud
*)

Require Import Coq.Program.Basics.
Require Import Coq.Program.Tactics.

Require Import Coq.Classes.Init.
Require Import Relation_Definitions.
Require Export Coq.Classes.CRelationClasses.
Require Import Coq.Classes.CMorphisms.

Set Implicit Arguments.
Unset Strict Implicit.

Generalizable Variables A R eqA B S eqB.
Local Obligation Tactic := try solve [simpl_crelation].

Local Open Scope signature_scope.

Definition equiv `{Equivalence A R} : crelation A := R.

(** Overloaded notations for setoid equivalence and inequivalence.
    Not to be confused with [eq] and [=]. *)

Notation " x === y " := (equiv x y) (at level 70, no associativity) : equiv_scope.

Notation " x =/= y " := (complement equiv x y) (at level 70, no associativity) : equiv_scope.

Local Open Scope equiv_scope.

(** Overloading for [PER]. *)

Definition pequiv `{PER A R} : crelation A := R.

(** Overloaded notation for partial equivalence. *)

Infix "=~=" := pequiv (at level 70, no associativity) : equiv_scope.

(** Shortcuts to make proof search easier. *)

Program Instance equiv_reflexive `(sa : Equivalence A) : Reflexive equiv.

Program Instance equiv_symmetric `(sa : Equivalence A) : Symmetric equiv.

Program Instance equiv_transitive `(sa : Equivalence A) : Transitive equiv.

  Next Obligation.
  Proof. intros A R sa x y z Hxy Hyz.
         now transitivity y.
  Qed.

(** Use the [substitute] command which substitutes an equivalence in every hypothesis. *)

Ltac setoid_subst H :=
  match type of H with
    ?x === ?y => substitute H ; clear H x
  end.

Ltac setoid_subst_nofail :=
  match goal with
    | [ H : ?x === ?y |- _ ] => setoid_subst H ; setoid_subst_nofail
    | _ => idtac
  end.

(** [subst*] will try its best at substituting every equality in the goal. *)

Tactic Notation "subst" "*" := subst_no_fail ; setoid_subst_nofail.

(** Simplify the goal w.r.t. equivalence. *)

Ltac equiv_simplify_one :=
  match goal with
    | [ H : ?x === ?x |- _ ] => clear H
    | [ H : ?x === ?y |- _ ] => setoid_subst H
    | [ |- ?x =/= ?y ] => let name:=fresh "Hneq" in intro name
    | [ |- ~ ?x === ?y ] => let name:=fresh "Hneq" in intro name
  end.

Ltac equiv_simplify := repeat equiv_simplify_one.

(** "reify" relations which are equivalences to applications of the overloaded [equiv] method
   for easy recognition in tactics. *)

Ltac equivify_tac :=
  match goal with
    | [ s : Equivalence ?A ?R, H : ?R ?x ?y |- _ ] => change R with (@equiv A R s) in H
    | [ s : Equivalence ?A ?R |- context C [ ?R ?x ?y ] ] => change (R x y) with (@equiv A R s x y)
  end.

Ltac equivify := repeat equivify_tac.

Section Respecting.

  (** Here we build an equivalence instance for functions which relates respectful ones only,
     we do not export it. *)

  Definition respecting `(eqa : Equivalence A (R : crelation A),
                          eqb : Equivalence B (R' : crelation B)) : Type :=
    { morph : A -> B & respectful R R' morph morph }.

  Program Instance respecting_equiv `(eqa : Equivalence A R, eqb : Equivalence B R') :
    Equivalence (fun (f g : respecting eqa eqb) =>
                   forall (x y : A), R x y -> R' (projT1 f x) (projT1 g y)).

  Solve Obligations with unfold respecting in * ; simpl_crelation ; program_simpl.

  Next Obligation.
  Proof.
    intros. intros f g h H H' x y Rxy.
    unfold respecting in *. program_simpl. transitivity (g y); auto. firstorder.
  Qed.

End Respecting.

(** The default equivalence on function spaces, with higher-priority than [eq]. *)

Instance pointwise_reflexive {A} `(reflb : Reflexive B eqB) :
  Reflexive (pointwise_relation A eqB) | 9.
Proof. firstorder. Qed.
Instance pointwise_symmetric {A} `(symb : Symmetric B eqB) :
  Symmetric (pointwise_relation A eqB) | 9.
Proof. firstorder. Qed.
Instance pointwise_transitive {A} `(transb : Transitive B eqB) :
  Transitive (pointwise_relation A eqB) | 9.
Proof. firstorder. Qed.
Instance pointwise_equivalence {A} `(eqb : Equivalence B eqB) :
  Equivalence (pointwise_relation A eqB) | 9.
Proof. split; apply _. Qed.


Require Import List.
Import ListNotations.

Require Import LC.Util.Fin.
Require Import LC.Util.Vec.
Require Import LC.Util.Star.

Inductive Term : nat -> Type :=
  | Var : forall {n}, Fin n -> Term n
  | App : forall {n}, Term n -> Term n -> Term n
  | Lam : forall {n}, Term (S n) -> Term n.

Infix "#" := App (left associativity, at level 40).

Definition var {n} (i : nat) : Term (i + S n) :=
  Var (Fin_of_nat i).

Fixpoint weaken {n} (t : Term n) : Fin (S n) -> Term (S n) :=
  match t with
  | Var j => fun i => Var (shift i j)
  | t1 # t2 => fun i => weaken t1 i # (weaken t2 i)
  | Lam t' => fun i => Lam (weaken t' (inr i))
  end.

Fixpoint subst {n} (t : Term (S n)) : Fin (S n) -> Term n -> Term n :=
  match t in Term m
    return S n = m -> Fin (S n) -> Term n -> Term n with
  | Var j => fun pf i u =>
    match pf with
    | eq_refl => fun j' =>
      match avoid i j' with
      | Some k => Var k
      | None => u
      end
    end j
  | t1 # t2 => fun pf i u =>
    match pf with
    | eq_refl => fun s1 s2 =>
      subst s1 i u # subst s2 i u
    end t1 t2
  | Lam t' => fun pf i u =>
    match pf with
    | eq_refl => fun s =>
      Lam (@subst (S n) s (inr i) (weaken u i))
    end t'
  end eq_refl.

Lemma subst_weaken {n} : forall (M N : Term n) (i : Fin (S n)),
  subst (weaken M i) i N = M.
Proof.
  induction M; intros; simpl.
  - now rewrite avoid_shift.
  - now rewrite IHM1, IHM2.
  - now rewrite IHM.
Qed.

Inductive red : forall {n}, Term n -> Term n -> Prop :=
  | beta_red : forall {n} (t : Term (S n)) (u : Term n),
    red (Lam t # u) (subst t (inl tt) u)
  | app_red_l : forall {n} (t t' u : Term n),
    red t t' -> red (t # u) (t' # u)
  | app_red_r : forall {n} (t u u' : Term n),
    red u u' -> red (t # u) (t # u')
  | lam_red : forall {n} (t t' : Term (S n)),
    red t t' -> red (Lam t) (Lam t').

Definition reds {n} : Term n -> Term n -> Prop :=
  star red.

Lemma app_reds_l : forall {n} (t t' u : Term n),
  reds t t' -> reds (t # u) (t' # u).
Proof.
  intros n t t' u r.
  induction r.
  { apply star_refl. }
  { eapply R_star.
    { apply app_red_l; eauto. }
    { auto. }
  }
Qed.

Lemma app_reds_r : forall {n} (t u u' : Term n),
  reds u u' -> reds (t # u) (t # u').
Proof.
  intros n t t' u r.
  induction r.
  { apply star_refl. }
  { eapply R_star.
    { apply app_red_r; eauto. }
    { auto. }
  }
Qed.

Lemma lam_reds : forall {n} (t t' : Term (S n)),
  reds t t' -> reds (Lam t) (Lam t').
Proof.
  intros n t t' r.
  induction r.
  { apply star_refl. }
  { eapply R_star.
    { apply lam_red; eauto. }
    { auto. }
  }
Qed.

Definition not_lam {n} (t : Term n) : Prop :=
  match t with
  | Lam _ => False
  | _ => True
  end.

Fixpoint normal {n} (t : Term n) : Prop :=
  match t with
  | Var _ => True
  | App t1 t2 =>
         not_lam t1
      /\ normal t1
      /\ normal t2
  | Lam t' => normal t'
  end.

Lemma normal_no_red : forall {n} (t t' : Term n),
  normal t -> ~ red t t'.
Proof.
  intros n t t' norm_t red_tt'.
  induction red_tt';
  simpl in norm_t; tauto.
Qed.

Lemma no_red_normal : forall {n} (t : Term n),
  (forall t', ~ red t t') -> normal t.
Proof.
  intros n t.
  induction t; intros.
  - exact I.
  - simpl; repeat split.
    + destruct t1; [exact I|exact I|].
      eapply H.
      apply beta_red.
    + apply IHt1.
      intros t' Hr.
      eapply H.
      apply app_red_l; eauto.
    + apply IHt2.
      intros t' Hr.
      eapply H.
      apply app_red_r; eauto.
  - apply IHt.
    intros t' Hr.
    eapply H.
    apply lam_red; eauto.
Qed.

Class Const (T : forall n, Term n) : Prop := {
  weaken_const : forall n i, weaken (T n) i = T (S n)
  }.

Lemma subst_const {T} `{Const T} :
  forall n i U, subst (T (S n)) i U = T n.
Proof.
  intros.
  rewrite <- (weaken_const _ i).
  now rewrite subst_weaken.
Qed.

Ltac beta :=
  match goal with
  | [ |- red (Lam _ # _) _ ] =>
    apply beta_red;
    simpl
  | [ |- red (Lam _) _ ] =>
    apply lam_red;
    beta
  | [ |- red (_ # _) _ ] =>
    first
    [ apply app_red_l; beta
    | apply app_red_r; beta
    ]
  | _ => fail
  end.

Ltac normal_order :=
  match goal with
  | [ |- reds _ _ ] => unfold reds; normal_order
  | [ |- star red _ _ ] => apply star_refl
  | [ |- context [ avoid ?t ?t ] ] =>
      rewrite avoid_refl; normal_order
  | [ |- star red _ _ ] =>
      eapply R_star;
      [ beta
      | simpl;
        repeat rewrite subst_const;
        repeat rewrite weaken_const;
        repeat rewrite subst_weaken
      ]; normal_order
  | _ => idtac
  end.


(* Copyright (c) 2012-2015, Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
(** This file implements sets as functions into Prop. *)
From prelude Require Export collections.

Record set (A : Type) : Type := mkSet { set_car : A → Prop }.
Add Printing Constructor set.
Arguments mkSet {_} _.
Arguments set_car {_} _ _.
Notation "{[ x | P ]}" := (mkSet (λ x, P))
  (at level 1, format "{[  x  |  P  ]}") : C_scope.

Instance set_elem_of {A} : ElemOf A (set A) := λ x X, set_car X x.

Instance set_top {A} : Top (set A) := {[ _ | True ]}.
Instance set_empty {A} : Empty (set A) := {[ _ | False ]}.
Instance set_singleton {A} : Singleton A (set A) := λ y, {[ x | y = x ]}.
Instance set_union {A} : Union (set A) := λ X1 X2, {[ x | x ∈ X1 ∨ x ∈ X2 ]}.
Instance set_intersection {A} : Intersection (set A) := λ X1 X2,
  {[ x | x ∈ X1 ∧ x ∈ X2 ]}.
Instance set_difference {A} : Difference (set A) := λ X1 X2,
  {[ x | x ∈ X1 ∧ x ∉ X2 ]}.
Instance set_collection : Collection A (set A).
Proof. split; [split | |]; by repeat intro. Qed.

Lemma elem_of_top {A} (x : A) : x ∈ ⊤ ↔ True.
Proof. done. Qed.
Lemma elem_of_mkSet {A} (P : A → Prop) x : x ∈ {[ x | P x ]} ↔ P x.
Proof. done. Qed.
Lemma not_elem_of_mkSet {A} (P : A → Prop) x : x ∉ {[ x | P x ]} ↔ ¬P x.
Proof. done. Qed.
Lemma top_subseteq {A} (X : set A) : X ⊆ ⊤.
Proof. done. Qed.
Hint Resolve top_subseteq.

Instance set_ret : MRet set := λ A (x : A), {[ x ]}.
Instance set_bind : MBind set := λ A B (f : A → set B) (X : set A),
  mkSet (λ b, ∃ a, b ∈ f a ∧ a ∈ X).
Instance set_fmap : FMap set := λ A B (f : A → B) (X : set A),
  {[ b | ∃ a, b = f a ∧ a ∈ X ]}.
Instance set_join : MJoin set := λ A (XX : set (set A)),
  {[ a | ∃ X, a ∈ X ∧ X ∈ XX ]}.
Instance set_collection_monad : CollectionMonad set.
Proof. by split; try apply _. Qed.

Instance set_unfold_set_all {A} (x : A) : SetUnfold (x ∈ (⊤ : set A)) True.
Proof. by constructor. Qed.
Instance set_unfold_mkSet {A} (P : A → Prop) x Q :
  SetUnfoldSimpl (P x) Q → SetUnfold (x ∈ mkSet P) Q.
Proof. intros HPQ. constructor. apply HPQ. Qed.

Global Opaque set_elem_of set_top set_empty set_singleton.
Global Opaque set_union set_intersection set_difference.
Global Opaque set_ret set_bind set_fmap set_join.


Set Implicit Arguments.
From TLC Require Import LibTactics LibLogic LibFun LibProd LibContainer LibSet
     LibRelation LibPer.
Local Notation path := rtclosure.
From iris_time.union_find.math Require Import LibNatExtra TLCBuffer
     UnionFind01Data UnionFind03Link UnionFind11Rank.

(* Linking by rank. *)

(** TEMPORARY migration *)

Ltac by_cases_on_fupdate ::=
  rewrite fupdate_eq; case_if; subst.

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

Section LinkByRank.

Variable V : Type.
Variable D : set V.
Variable F : binary V.
Variable K : V -> nat.

(* Linking by rank means that a link must be established from [x] to [y]
   if [x] has lower rank, and from [y] to [x] otherwise. If [x] and [y]
   have the same rank, then an arbitrary choice can be made, and the rank
   of the new root must be increased by one. *)

Definition link_by_rank_F (x y : V) :=
  If K x < K y then
    link F x y
  else
    link F y x.

Definition link_by_rank_K (x y : V) :=
  If K x = K y then
    fupdate K x (1 + K x)
  else
    K.

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

(* Linking cannot cause a rank to decrease. *)

Lemma link_cannot_decrease_rank:
  forall x y v,
  K v <= link_by_rank_K x y v.
Proof using.
  unfold link_by_rank_K. intros. cases_if.
    { by_cases_on_fupdate; lia. }
    { lia. }
Qed.

(* Linking preserves the ranks of non-roots. *)

Lemma link_preserves_rank_of_non_roots:
  forall x y v,
  is_root F x ->
  ~ is_root F v ->
  K v = link_by_rank_K x y v.
Proof using.
  unfold link_by_rank_K. intros.
  (* The only case where the rank of [v] might change is when [x] and [y]
     have the same rank and [v] is [x]. But [x] is a root, and [v] is not
     a root, so this case cannot arise. *)
 cases_if; [ | reflexivity ].
 by_cases_on_fupdate. eauto.
Qed.

(* Linking by rank preserves [is_rdsf]. *)

Lemma is_rdsf_link:
  forall x y,
  is_rdsf D F K ->
  x \in D ->
  y \in D ->
  is_root F x ->
  is_root F y ->
  x <> y ->
  is_rdsf D (link_by_rank_F x y) (link_by_rank_K x y).
Proof using.
  unfold is_rdsf. introv (?&hRIAE&hNF&hFD&hZR). intros. splits.

  (* The disjoint set forest is preserved. *)
  { unfold link_by_rank_F. cases_if; eauto using is_dsf_link. }

  (* Rank increases along edges. *)
  { unfold link_by_rank_F, link_by_rank_K. intros v w ?.
    three_ways (K x) (K y).
    (* Case [K x = K y]. The link is from [y] to [x]. *)
    { by_cases_on_link.
      forwards: hRIAE. eassumption.
      (* Subcase: a pre-existing edge of [v] to [w]. The goal holds when [w]
         is [x] because the rank of [x] has increased (which is harmless).
         The goal holds when [w] is not [x] because nothing has changed. *)
      { case_if; subst; lia. }
      (* Subcase: the new edge of [y] to [x]. The goal holds because the
         rank of [x] has increased (which was necessary in this case). *)
      { case_if; subst; lia. }
    }
    (* Case [K x < K y]. No rank has changed, and the new link, from [x] to
       [y], respects the existing ranks. *)
    { by_cases_on_link; eauto. }
    (* Case [K x > K y]. Symmetric. *)
    { by_cases_on_link; eauto with lia. }
  }

  (* Numerous family. *)
  { unfold link_by_rank_F, link_by_rank_K. intros r ?.
    three_ways (K x) (K y).
    (* Case [K x = K y]. The link is from [y] to [x]. *)
    { by_cases_on_fupdate.
      (* Subcase: [r = x]. The rank of [x] has increased by one, so we
         have to prove that [x] has at least [2 * 2^(K x)] descendants.
         This works because the descendants of [x] now include the
         former descendants of [y]. *)
      { simpl.
        erewrite descendants_link_1 by eauto.
        rewrite card_disjoint_union by eauto using finite_descendants, disjoint_descendants.
        forwards hdx: hNF x. eauto.
        forwards hdy: hNF y. eauto.
        match goal with h: K x = K y |- _ => rewrite h in * end.
        lia. }
      (* Subcase: [r <> x]. The rank of [r] is unchanged, and its
         descendants are unchanged as well. *)
      { erewrite descendants_link_2 by eauto.
        eauto using is_root_link_converse. }}
    (* Case [K x < K y]. No rank has changed, and every vertex has at least
       as many descendants as before the link, so the goal holds. *)
    { transitivity (card (descendants F r)).
        eauto using is_root_link_converse.
        eauto using card_descendants_link_2_le. }
    (* Case [K x > K y]. Same argument. *)
    { transitivity (card (descendants F r)).
        eauto using is_root_link_converse.
        eauto using card_descendants_link_2_le. }
  }

  (* Finite domain. *)
  { eauto. }

  (* Rank is zero outside domain. *)
  { intros z ?.
    unfold link_by_rank_K. cases_if.
    { by_cases_on_fupdate. eauto. }
    { eauto. }
  }

Qed.

(* The effect of the new link on [dsf_per] is to fuse the equivalence classes
   of [x] and [y]. *)

Lemma dsf_per_add_edge_by_rank:
  forall x y,
  is_rdsf D F K ->
  x \in D ->
  y \in D ->
  is_root F x ->
  is_root F y ->
  x <> y ->
  dsf_per D (link_by_rank_F x y) =
  per_add_edge (dsf_per D F) x y.
Proof using.
  intros. unfold link_by_rank_F. cases_if;
  rewrite dsf_per_add_edge by eauto with is_dsf.
  { reflexivity. }
  { eapply per_add_edge_symmetric. }
Qed.

End LinkByRank.

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

(* If one wishes to reason in terms of the function [R], which maps every
   vertex to its representative, here is how to describe linking by rank. *)

(* The new representative. *)

Definition new_repr_by_rank V K (x y : V) :=
  If K x < K y then y else x.

(* The new [R] is obtained by updating [R] with the new representative.
   We update the classes of both [x] and [y], so as to obtain a symmetric
   formulation. (Thus, we do not build on [link_R].) [z] stands for the
   new representative. *)

Definition link_by_rank_R V R (x y z : V) :=
  fun t => If R t = R x \/ R t = R y
  then z
  else R t.

(* Because [link_by_rank_R] was not defined in terms of [link_R], we must
   prove an explicit connection with [link_R]. *)

Lemma link_by_rank_R_case_1:
  forall V R K (x y : V),
  R y = y ->
  K x < K y ->
  link_by_rank_R R x y (new_repr_by_rank K x y) = link_R R x y.
Proof using.
  extens. intros w.
  unfold link_by_rank_R, new_repr_by_rank, link_R.
  cases_if; unpack.
  { branches; do 2 cases_if; congruence. }
  { cases_if; tauto. }
Qed.

Lemma link_by_rank_R_case_2:
  forall V R K (x y : V),
  R x = x ->
  ~ K x < K y ->
  link_by_rank_R R x y (new_repr_by_rank K x y) = link_R R y x.
Proof using.
  extens. intros w.
  unfold link_by_rank_R, new_repr_by_rank, link_R.
  cases_if; unpack.
  { branches; do 2 cases_if; congruence. }
  { cases_if; tauto. }
Qed.

(* The agreement between [R] and [is_repr F] is preserved when one applies
   [link_by_rank_R] and [link_by_rank_F] to [R] and [F], respectively. *)

Lemma link_by_rank_R_link_by_rank_F_agree:
  forall V (D : set V) R F K x y,
  is_rdsf D F K ->
  fun_in_rel R (is_repr F) ->
  x \in D ->
  y \in D ->
  is_root F x ->
  is_root F y ->
  x <> y ->
  fun_in_rel
    (link_by_rank_R R x y (new_repr_by_rank K x y) )
    (is_repr (link_by_rank_F F K x y)).
Proof using.
  intros.
  assert (R x = x). { eauto using is_root_R_self with is_dsf. }
  assert (R y = y). { eauto using is_root_R_self with is_dsf. }
  unfold link_by_rank_F. cases_if.
  (* Case: [K x < K y]. *)
  { rewrite link_by_rank_R_case_1 by eauto.
    eauto using link_R_link_agree with is_dsf. }
  (* Case: [K x >= K y]. *)
  { rewrite link_by_rank_R_case_2 by eauto.
    eauto using link_R_link_agree with is_dsf. }
Qed.


Require Import rt.util.all.
Require Import rt.model.jitter.job rt.model.jitter.task rt.model.jitter.arrival_sequence.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

(* Definition, properties and lemmas about schedules. *)
Module ScheduleWithJitter.

  (* We import the original schedule module and redefine whatever is required. *)
  Require Export rt.model.basic.schedule.
  Export ArrivalSequence Schedule.

  (* We need to redefine the properties of a job that depend on the arrival time. *)
  Section ArrivalDependentProperties.

    Context {Job: eqType}.
    Variable job_cost: Job -> time.
    Variable job_jitter: Job -> time.

    (* Given an arrival sequence, ... *)
    Context {arr_seq: arrival_sequence Job}.

    (* ... we define the following properties for job j in schedule sched. *)
    Context {num_cpus: nat}.
    Variable sched: schedule num_cpus arr_seq.

    Section JobProperties.

      Variable j: JobIn arr_seq.

      (* The actual arrival of job j occurs after the jitter. *)
      Definition actual_arrival := job_arrival j + job_jitter j.

      (* Whether job j's jitter has passed by time t. *)
      Definition jitter_has_passed (t: time) := actual_arrival <= t.

      (* Whether job j actually arrived before time t. *)
      Definition actual_arrival_before (t: time) := actual_arrival < t.

      (* Job j is pending at time t iff the jitter has passed but j has not completed. *)
      Definition pending (t: time) := jitter_has_passed t && ~~ completed job_cost sched j t.

      (* Job j is backlogged at time t iff it is pending and not scheduled. *)
      Definition backlogged (t: time) := pending t && ~~ scheduled sched j t.

      (* Job j is carry-in in interval [t1, t2) iff it arrives before t1 and is
         not complete at time t1 *)
      Definition carried_in (t1: time) := actual_arrival_before t1 && ~~ completed job_cost sched j t1.

      (* Job j is carry-out in interval [t1, t2) iff it arrives after t1 and is
         not complete at time t2 *)
      Definition carried_out (t1 t2: time) := actual_arrival_before t2 && ~~ completed job_cost sched j t2.

    End JobProperties.

    Section ScheduleProperties.

      (* A job can only be scheduled after the jitter has passed. *)
      Definition jobs_execute_after_jitter :=
        forall j t,
          scheduled sched j t -> jitter_has_passed j t.

    End ScheduleProperties.

    Section BasicLemmas.

      (* Assume that jobs can only execute after the jitter. *)
      Hypothesis H_jobs_execute_after_jitter:
        jobs_execute_after_jitter.

      Section Pending.

        (* Assume that completed jobs do not execute. *)
        Hypothesis H_completed_jobs:
          completed_jobs_dont_execute job_cost sched.

        (* Then, if job j is scheduled, it must be pending. *)
        Lemma scheduled_implies_pending:
          forall j t,
            scheduled sched j t ->
            pending j t.
        Proof.
          rename H_jobs_execute_after_jitter into JITTER,
                 H_completed_jobs into COMP.
          unfold jobs_execute_after_jitter, completed_jobs_dont_execute in *.
          intros j t SCHED.
          unfold pending; apply/andP; split; first by apply JITTER.
          apply/negP; unfold not; intro COMPLETED.
          have BUG := COMP j t.+1.
          rewrite leqNgt in BUG; move: BUG => /negP BUG; apply BUG.
          unfold service; rewrite -addn1 big_nat_recr // /=.
          apply leq_add;
            first by move: COMPLETED => /eqP COMPLETED; rewrite -COMPLETED.
          rewrite lt0n; apply/eqP; red; move => /eqP NOSERV.
          rewrite -not_scheduled_no_service in NOSERV.
          by rewrite SCHED in NOSERV.
        Qed.

      End Pending.

      Section Service.

        (* If a job only executes after the jitter, it also only
           executes after its arrival time. *)
        Lemma arrival_before_jitter :
          jobs_must_arrive_to_execute sched.
          Proof.
            unfold jobs_execute_after_jitter, jobs_must_arrive_to_execute.
            intros j t SCHED; unfold ArrivalSequence.has_arrived.

            rewrite -(leq_add2r (job_jitter j)).
            by apply leq_trans with (n := t);
              [by apply H_jobs_execute_after_jitter | by apply leq_addr].
          Qed.

        Lemma service_before_jitter_zero :
          forall j t,
            t < job_arrival j + job_jitter j ->
            service_at sched j t = 0.
        Proof.
          rename H_jobs_execute_after_jitter into AFTER; intros j t LT.
          apply/eqP; rewrite -not_scheduled_no_service; apply/negP; red; intro SCHED.
          by apply AFTER, (leq_trans LT) in SCHED; rewrite ltnn in SCHED.
        Qed.

        Lemma cumulative_service_before_jitter_zero :
          forall j t1 t2,
            t2 <= job_arrival j + job_jitter j ->
            \sum_(t1 <= t < t2) service_at sched j t = 0.
        Proof.
          intros j t1 t2 LE.
          apply/eqP; rewrite -leqn0.
          apply leq_trans with (n := \sum_(t1 <= t < t2) 0);
            last by rewrite big_const_nat iter_addn mul0n addn0.
          rewrite big_nat_cond [\sum_(_ <= _ < _)_]big_nat_cond.
          apply leq_sum; move => t /andP [/andP [_ LT] _].
          rewrite leqn0; apply/eqP; apply service_before_jitter_zero.
          by apply (leq_trans LT).
        Qed.

      End Service.

    End BasicLemmas.

  End ArrivalDependentProperties.

End ScheduleWithJitter.

(* Specific properties of a schedule of sporadic jobs. *)
Module ScheduleOfSporadicTaskWithJitter.

  Import SporadicTask Job.
  Export ScheduleWithJitter.

  Section ScheduledJobs.

    Context {sporadic_task: eqType}.
    Context {Job: eqType}.
    Variable job_task: Job -> sporadic_task.

    (* Consider any schedule. *)
    Context {arr_seq: arrival_sequence Job}.
    Context {num_cpus: nat}.
    Variable sched: schedule num_cpus arr_seq.

    (* Given a task tsk, ...*)
    Variable tsk: sporadic_task.

    (* ..., we we can state that tsk is scheduled on cpu at time t as follows. *)
    Definition task_scheduled_on (cpu: processor num_cpus) (t: time) :=
      if (sched cpu t) is Some j then
        (job_task j == tsk)
      else false.

    (* Likewise, we can state that tsk is scheduled on some processor. *)
      Definition task_is_scheduled (t: time) :=
        [exists cpu, task_scheduled_on cpu t].

    (* We also define the list of jobs scheduled during [t1, t2). *)
    Definition jobs_of_task_scheduled_between (t1 t2: time) :=
      filter (fun (j: JobIn arr_seq) => job_task j == tsk)
             (jobs_scheduled_between sched t1 t2).

  End ScheduledJobs.

  Section ScheduleProperties.

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

    (* Consider any schedule. *)
    Context {arr_seq: arrival_sequence Job}.
    Context {num_cpus: nat}.
    Variable sched: schedule num_cpus arr_seq.

    (* Next we define intra-task parallelism, ... *)
    Definition jobs_of_same_task_dont_execute_in_parallel :=
      forall (j j': JobIn arr_seq) t,
        job_task j = job_task j' ->
        scheduled sched j t -> scheduled sched j' t -> j = j'.

    (* ... and task precedence constraints. *)
    Definition task_precedence_constraints :=
      forall (j j': JobIn arr_seq) t,
        job_task j = job_task j' ->
        job_arrival j < job_arrival j' ->
        pending job_cost job_jitter sched j t -> ~~ scheduled sched j' t.

  End ScheduleProperties.

  Section BasicLemmas.

    (* Assume the job cost and task are known. *)
    Context {sporadic_task: eqType}.
    Variable task_cost: sporadic_task -> time.
    Variable task_deadline: sporadic_task -> time.

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

    (* Then, in a valid schedule of sporadic tasks ...*)
    Context {arr_seq: arrival_sequence Job}.
    Context {num_cpus: nat}.
    Variable sched: schedule num_cpus arr_seq.

    (* ...such that jobs do not execute after completion, ...*)
    Hypothesis jobs_dont_execute_after_completion :
       completed_jobs_dont_execute job_cost sched.

    Variable tsk: sporadic_task.

    Variable j: JobIn arr_seq.
    Hypothesis H_job_of_task: job_task j = tsk.
    Hypothesis valid_job:
      valid_sporadic_job task_cost task_deadline job_cost job_deadline job_task j.

    (* Remember that for any job of tsk, service <= task_cost tsk *)
    Lemma cumulative_service_le_task_cost :
        forall t t',
          service_during sched j t t' <= task_cost tsk.
    Proof.
      rename valid_job into VALID; unfold valid_sporadic_job in *; ins; des.
      apply leq_trans with (n := job_cost j);
        last by rewrite -H_job_of_task; apply VALID0.
      by apply cumulative_service_le_job_cost.
    Qed.

  End BasicLemmas.

End ScheduleOfSporadicTaskWithJitter.


(** * kat_tac: decision tactics for KA, KAT, and KAT with Hoare hypotheses *)

Require Import boolean ugregex_dec kat_reification kat_untyping kat_completeness.

(** * corollary of kat_untyping and kat_completeness:
    one can decide typed KAT by reasoning about untyped languages *)

Section j.
Notation Sigma := positive.
Variable Pred: nat.
Variables src tgt: Sigma -> positive.

Corollary kat_untype_weq n m (e f: gregex Pred src tgt n m): gerase e ≡ gerase f <-> e ≡ f.
Proof.
  split.
   intro H. apply kat_complete_weq.
   rewrite 2untype_glang.
   now apply traces.restrict_weq.
  apply gerase_weq.
Qed.

End j.

(** we can thus refine the reification lemma provided in [kat_reification] *)
Corollary kat_weq_dec `{L: laws} f' fs fp n m (e f: @kat_expr X f' fs n m):
  e_level e + e_level f ≪ BKA ->
  (let v := vars (e_pls e f) in
    eqb_kat (gerase (to_gregex v n m e)) (gerase (to_gregex v n m f)) = Some true) ->
  eval fp n m e ≡ eval fp n m f.
Proof.
  intros Hl H. apply to_gregex_weq. assumption.
  apply kat_untype_weq, eqb_kat_correct, H.
Qed.

(** * [kat] tactic, for Kleene algebra with tests *)

(** the [kat] tactic solves KAT (in)equalities; it proceeds as follows:

   0. possibly convert inequalities into equalities, using
      [leq_iff_cup];
   1. look for the kat structure and laws, by calling typeclass
      resolution using ([catch_kat_weq]);
   2. call the ML reification tactic
      -> the equivalence will be checked in OCaml, an a
         counter-example will be displayed if it does not hold
      -> this will otherwise produce a sequence of let-in's for the
         various reification ingredients
   3. introduce those ingredients and apply the above reification lemma
   4. close the two generated subgoals by reflexivity (the first one
      corresponds to checking that reified terms did no include
      forbidden constructions - it should never fail unless there is a
      bug in reification; the second one corresponds to the
      execution of the Coa KAT decision algorithm - it should never fail
      since the equation was already checked in OCaml) *)

Lemma catch_kat_weq {X} {L: laws X} n m (x y: X n m):
  (let L:=L in x ≡ y) -> x ≡ y.
Proof. trivial. Qed.

(** parametrised tactic to do the work share by [ka], [kat], and [hkat]
    [b] indicates whether we are in KAT (true) or KA (false) *)
Ltac pre_dec b :=
  let L := fresh "L" in intro L; (* L is the kat laws instance *)
  let tenv := fresh "tenv" in
  let env := fresh "env" in
  let penv := fresh "penv" in
  let lhs := fresh "lhs" in
  let rhs := fresh "rhs" in
  ra_kat_reify b; intros tenv env penv ? ? lhs rhs;
  apply (@kat_weq_dec _ L tenv env penv _ _ lhs rhs); [
    (reflexivity || fail 1 "Bug in KAT reification, please report") |
    (close_by_reflection (Some true) ||
        fail 1 "Not a KAT theorem, but no counter-example can be displayed. Please report.") ].

(** [kat] tactic *)
Ltac kat :=
  intros; rewrite ?leq_iff_cup;
    (apply catch_kat_weq || fail "could not find a KAT structure");
    pre_dec true.

(** * [ka] tactic, for Kleene algebra *)

(** we use the fact that any Kleene algebras with bottom faithfully
   embed into KAT, using trivial tests *)
(* TODO: sync with conservativity once we got it *)
Module bka_to_kat.
Definition ops (X: monoid.ops) := mk_ops X (fun _ => bool_lattice_ops) (fun _ => ofbool).
Lemma laws `{monoid.laws} `{BKA ≪ l}: kat.laws (ops X).
Proof.
  constructor.
  apply lower_laws.
  intro. apply lower_lattice_laws.
  intro. constructor; try discriminate.
  apply ofbool_leq.
  apply op_leq_weq_1.
  intros _ ? ?. apply orb_pls.
  intros _. reflexivity.
  intros ?. reflexivity.
  intros ? ? ?. apply andb_dot.
Qed.
End bka_to_kat.

(** the tactic is really similar to [kat], except that we catch the
   KAT laws using the lemma below, exploiting the above embedding *)
Lemma catch_ka_weq {X l} {L: monoid.laws l X} {Hl: BKA ≪ l} n m (x y: X n m):
  (let L:=@bka_to_kat.laws l X L Hl in @weq (@kar (bka_to_kat.ops X) n m) x y) -> x ≡ y.
Proof. trivial. Qed.

Ltac ka :=
  intros; rewrite ?leq_iff_cup;
    (apply catch_ka_weq || fail "could not find a KA structure");
    pre_dec false.

(** * [hkat] tactic, for KAT with Hoare hypotheses *)

(** Hypotheses of the shape [x ≡ 0], called "Hoare hypotheses", can
   be eliminated in KAT.

   In other words, the Horn theory of KAT restricted to the clauses
   wher all hypotheses have the above shape, reduces to the equational
   theory of KAT, and is thus decidable.

   Moreover, some other kinds of hypotheses can be transformed into
   Hoare ones, and hypotheses of the shape [[c];p ≡ [c]] can also be
   eliminated.

   All in all, a non-trivial class of hypotheses can be handled in
   practice.

   We perform such an elimination of hypotheses to obtain the [hkat]
   tactic below.

   For more details, see Chris Hardin and Dexter Kozen. "On the
   elimination of hypotheses in Kleene algebra with tests".
   TR2002-1879, Computer Science Department, Cornell University, October 2002

 *)

(** converting various kinds of hypotheses to Hoare ones *)
Lemma ab_to_hoare `{L: laws} {n} (b c: tst n): b ≡ c -> [b ⊓ !c ⊔ !b ⊓ c] ≦ 0.
Proof. intro H. rewrite H. kat. Qed.

Lemma ab'_to_hoare `{L: laws} {n} (b c: tst n): b ≦ c -> [b ⊓ !c] ≦ 0.
Proof. intro H. rewrite H. kat. Qed.

(* note: les quatre implications suivantes ne sont complètes que pour p=q *)
Lemma bpqc_to_hoare `{L: laws} {n m} (b: tst n) (c: tst m) p q:
  [b]⋅p ≦ q⋅[c] -> [b]⋅p⋅[!c] ≦ 0.
Proof. intro H. rewrite H. kat. Qed.

Lemma pbcq_to_hoare `{L: laws} {n m} (b: tst n) (c: tst m) p q:
  p⋅[b] ≦ [c]⋅q -> [!c]⋅p⋅[b] ≦ 0.
Proof. rewrite <-dotA. dual @bpqc_to_hoare. Qed.

Lemma qpc_to_hoare `{L: laws} {n m} (c: tst m) (p q: X n m):
  q ≦ p⋅[c] -> q⋅[!c] ≦ 0.
Proof. intro H. rewrite H. kat. Qed.

Lemma qcp_to_hoare `{L: laws} {n m} (c: tst m) (p q: X m n):
  q ≦ [c]⋅p -> [!c]⋅q ≦ 0.
Proof. dual @qpc_to_hoare. Qed.

(* TOTHINK: comprendre modulo A, et peut-être revenir aux cas complets
   (note: les deux dernières sont équivalentes aux deux premières,
          mais pas prises dans le cas complet) *)

Lemma cp_c `{L: laws} {n} (c: tst n) (p: X n n):
  [c]⋅p ≡ [c] -> p ≡ [!c]⋅p+[c].
Proof. intro H. rewrite <-H. kat. Qed.

Lemma pc_c `{L: laws} {n} (c: tst n) (p: X n n):
  p⋅[c] ≡ [c] -> p ≡ p⋅[!c]+[c].
Proof. dual @cp_c. Qed.

(** merging Hoare hypotheses *)
Lemma join_leq `{lattice.laws} `{CUP ≪ l} (x y z: X):  x ≦z -> y ≦z -> x ⊔ y ≦z.
Proof. rewrite cup_spec. tauto. Qed.

(** eliminating Hoare hypotheses ; [u] and [v] are intended to be the
   universal expressions of the appropriate type *)
Lemma elim_hoare_hypotheses_weq `{L: laws} {n m p q} (u: X n p) (v: X q m) (z: X p q) (x y: X n m):
  z ≦ 0 -> x+u⋅z⋅v ≡ y+u⋅z⋅v -> x ≡y.
Proof. rewrite leq_xb_iff. intro Hz. now rewrite Hz, dotx0, dot0x, 2cupxb. Qed.

Lemma elim_hoare_hypotheses_leq `{L: laws} {n m p q} (u: X n p) (v: X q m) (z: X p q) (x y: X n m):
  z ≦ 0 -> x ≦ y+u⋅z⋅v -> x ≦y.
Proof. intro Hz. now rewrite Hz, dotx0, dot0x, cupxb. Qed.

(** tactic used to aggregate Hoare hypotheses: convert hypotheses into
   Hoare ones using the above lemas, then merge them into a single one *)
Ltac aggregate_hoare_hypotheses :=
  repeat
    match goal with
      | H: _ ≡ _ |- _ =>
        apply ab_to_hoare in H ||
        (rewrite (cp_c _ _ H); clear H) ||
        (rewrite (pc_c _ _ H); clear H) ||
        apply weq_spec in H as [? ?]
    end;
  repeat
    match goal with
      | H: _ ≦ _ |- _ =>
        apply ab'_to_hoare in H ||
        apply bpqc_to_hoare in H ||
        apply pbcq_to_hoare in H ||
        apply qcp_to_hoare in H ||
        apply qpc_to_hoare in H
      | H: _ ≦ 0,  H': _ ≦ 0 |- _ =>
        apply (join_leq _ _ _ H') in H; clear H'
    end.

(** final [hkat] tactic: aggregate Hoare hypotheses, possibly
   transform inequalities into equalities, get the alphabet to
   construct the universal expression, eliminate Hoare hypotheses
   using the above lemma, and finally call the [kat] tactic *)
Ltac hkat :=
  intros; aggregate_hoare_hypotheses; rewrite ?leq_iff_cup;
  (apply catch_kat_weq || fail "could not find a KAT structure");
  let L := fresh "L" in intro L;
  let u := fresh "u" in
  ((ra_get_kat_alphabet; intro u;
    eapply (elim_hoare_hypotheses_weq (u^*) (u^*)); [eassumption|])
  || fail "typed hkat is not supported yet");
  subst u; revert L; pre_dec true.


Require Import init.

Require Import order_minmax.
Require Import mult_div.
Require Import nat_domain.

Require Export topology_base.
Require Export topology_basis.
Require Import topology_axioms.
Require Import topology_closure.
Require Import topology_subspace.

(* begin hide *)
Unset Keyed Unification.

Open Scope set_scope.

(* end hide *)
Definition limit_point {U} `{Topology U} A x := ∀ S, open S → S x →
    intersects (A - ❴x❵) S.

Definition seq_lim {U} `{Topology U} (f : sequence U) x :=
    ∀ S, open S → S x → ∃ N, ∀ n, N ≤ n → S (f n).
Definition seq_converges {U} `{Topology U} (f : sequence U) := ∃ x, seq_lim f x.

Definition f_seq_lim {U V} `{Topology U, Topology V} (fn : sequence (U → V)) f:=
    ∀ x, seq_lim (λ n, (fn n x)) (f x).
Definition f_seq_converges {U V} `{Topology U, Topology V}
    (fn : sequence (U → V)) := ∃ f, f_seq_lim fn f.

(* begin hide *)
Section LimitPoint.

Context {U} `{Topology U}.
(* end hide *)
Theorem closure_limit_points : ∀ A, closure A = A ∪ limit_point A.
Proof.
    intros A.
    apply predicate_ext; intros x; split.
    -   intros CAx.
        classic_case (A x) as [Ax|Ax].
        +   left; exact Ax.
        +   right.
            intros S S_open Sx.
            rewrite in_closure in CAx.
            specialize (CAx S S_open Sx).
            assert (A - ❴x❵ = A) as eq.
            {
                apply predicate_ext; intros y; split.
                -   intros [Ay C0]; exact Ay.
                -   intros Ay.
                    split; try exact Ay.
                    rewrite singleton_eq; intro contr; subst.
                    contradiction.
            }
            rewrite eq.
            exact CAx.
    -   intros [Ax|x_lim].
        +   apply closure_sub.
            exact Ax.
        +   rewrite in_closure.
            intros S S_open Sx.
            specialize (x_lim S S_open Sx).
            apply empty_neq in x_lim.
            apply empty_neq.
            destruct x_lim as [y y_in].
            exists y.
            split; apply y_in.
Qed.

Theorem closed_limit_points : ∀ A, closed A ↔ (∀ x, limit_point A x → A x).
Proof.
    intros A.
    rewrite closed_if_closure.
    rewrite closure_limit_points.
    split.
    -   intros eq x x_lim.
        rewrite eq.
        right; exact x_lim.
    -   intros x_lims.
        apply predicate_ext; intros x; split.
        +   intros Ax; left; exact Ax.
        +   intros [Ax|x_lim].
            *   exact Ax.
            *   apply x_lims.
                exact x_lim.
Qed.

Theorem seq_closure :
    ∀ (A : U → Prop) x f, (∀ n, A (f n)) → seq_lim f x → closure A x.
Proof.
    intros A x f Af lim.
    rewrite in_closure.
    intros S S_open Sx.
    specialize (lim S S_open Sx) as [N lim].
    specialize (lim N (refl _)).
    apply empty_neq.
    exists (f N).
    split.
    -   apply Af.
    -   exact lim.
Qed.

Theorem limit_point_closure : ∀ A x, limit_point A x → closure A x.
Proof.
    intros A x x_lim.
    rewrite closure_limit_points.
    right.
    exact x_lim.
Qed.

Theorem limit_point_sub : ∀ A B x,
    (A - ❴x❵) ⊆ B → limit_point A x → limit_point B x.
Proof.
    intros A B x sub A_lim S S_open Sx.
    specialize (A_lim S S_open Sx).
    apply empty_neq in A_lim.
    destruct A_lim as [y [[Ay yx] Sy]].
    apply empty_neq.
    exists y.
    repeat split.
    -   exact (sub y (make_and Ay yx)).
    -   exact yx.
    -   exact Sy.
Qed.

Existing Instance subspace_topology.

Theorem subspace_limit_point : ∀ X A x, A ⊆ X →
    limit_point A [x|] → limit_point (to_set_type X A) x.
Proof.
    intros X A x sub lim S S_open Sx.
    unfold limit_point in lim.
    destruct S_open as [T [T_open S_eq]].
    pose proof Sx as Tx.
    rewrite S_eq in Tx.
    specialize (lim _ T_open Tx).
    apply empty_neq in lim.
    destruct lim as [y [[Ay y_neq] Ty]].
    apply empty_neq.
    exists [y|sub y Ay].
    repeat split.
    -   exact Ay.
    -   rewrite singleton_eq; cbn.
        rewrite singleton_eq in y_neq; cbn in y_neq.
        intro contr.
        subst x.
        contradiction.
    -   subst S.
        exact Ty.
Qed.

Theorem constant_seq_lim : ∀ x, seq_lim (λ _, x) x.
Proof.
    intros x S S_open Sx.
    exists 0.
    intros n n_ge.
    exact Sx.
Qed.

Theorem constant_seq_converges : ∀ x, seq_converges (λ _, x).
Proof.
    intros x.
    exists x.
    apply constant_seq_lim.
Qed.

Theorem subsequence_lim_eq :
    ∀ a b x, seq_lim a x → subsequence a b → seq_lim b x.
Proof.
    intros a b x a_lim [f [f_sub ab_eq]].
    intros S S_open Sx.
    specialize (a_lim S S_open Sx) as [N a_lim].
    exists N.
    intros n n_ge.
    rewrite <- ab_eq.
    pose proof (subsequence_seq_leq f f_sub n) as f_leq.
    exact (a_lim (f n) (trans n_ge f_leq)).
Qed.

(* begin hide *)
Close Scope set_scope.
(* end hide *)
Theorem seq_lim_even_odd : ∀ a x,
    seq_lim (λ n, a (2*n)) x → seq_lim (λ n, a (2*n + 1)) x → seq_lim a x.
Proof.
    intros a x x1 x2 S S_open Sx.
    specialize (x1 S S_open Sx) as [N1 x1].
    specialize (x2 S S_open Sx) as [N2 x2].
    exists (max (2*N1) (2*N2 + 1)).
    intros n' n_max.
    classic_case (even n') as [n_even|n_odd].
    -   destruct n_even as [n eq]; subst n'.
        rewrite mult_comm.
        apply x1.
        rewrite (mult_comm n 2) in n_max.
        pose proof (trans (lmax _ _) n_max) as leq.
        apply nat_le_mult_lcancel in leq; [>|intros contr; inversion contr].
        exact leq.
    -   apply nat_odd_plus_one in n_odd as [n eq]; subst n'.
        apply x2.
        pose proof (trans (rmax _ _) n_max) as leq.
        apply le_plus_rcancel in leq.
        apply nat_le_mult_lcancel in leq; [>|intros contr; inversion contr].
        exact leq.
Qed.

Theorem seq_lim_part : ∀ a n x, seq_lim a x ↔ seq_lim (λ m, a (m + n)) x.
Proof.
    intros a n x.
    split.
    -   intros x_lim S S_open Sx.
        specialize (x_lim S S_open Sx) as [N x_lim].
        exists N.
        intros m m_ge.
        apply x_lim.
        apply (trans m_ge).
        apply nat_le_self_rplus.
    -   intros x_lim S S_open Sx.
        specialize (x_lim S S_open Sx) as [N x_lim].
        exists (N + n).
        intros m m_ge.
        apply nat_le_ex in m_ge as [c m_eq]; subst m.
        rewrite <- plus_assoc, (plus_comm n c), plus_assoc.
        apply x_lim.
        apply nat_le_self_rplus.
Qed.

Theorem seq_converges_part : ∀ a n,
    seq_converges a ↔ seq_converges (λ m, a (m + n)).
Proof.
    intros a n.
    split.
    -   intros [x a_lim].
        exists x.
        apply seq_lim_part.
        exact a_lim.
    -   intros [x a_lim].
        exists x.
        apply seq_lim_part in a_lim.
        exact a_lim.
Qed.

(* begin hide *)
Open Scope set_scope.

End LimitPoint.
(* end hide *)
Section HausdorffLimit.

Context {U} `{HausdorffSpace U}.

(* begin hide *)
Local Open Scope card_scope.
(* end hide *)
Theorem limit_point_inf : ∀ A x,
    limit_point A x ↔ ∀ S, open S → S x → infinite (|set_type (A ∩ S)|).
Proof.
    intros A x.
    split.
    -   intros x_lim S S_open Sx.
        classic_contradiction fin.
        unfold infinite in fin.
        rewrite nle_lt in fin.
        pose (X := (A - ❴x❵) ∩ S).
        assert (finite (|set_type X|)) as X_fin.
        {
            apply (le_lt_trans2 fin).
            unfold X.
            unfold le; equiv_simpl.
            pose (f (a : set_type ((A - ❴x❵) ∩ S)) := [[a|] |
                make_and (land (land [|a])) (rand [|a])] : set_type (A ∩ S)).
            exists f.
            unfold f; clear f.
            split.
            intros a b eq.
            inversion eq as [eq2].
            apply set_type_eq; exact eq2.
        }
        apply finite_point_closed in X_fin.
        unfold closed in X_fin.
        rename X_fin into X'_open.
        pose (Y := S ∩ 𝐂 X).
        assert (open Y) as Y_open.
        {
            unfold Y.
            apply inter_open2; assumption.
        }
        assert (Y x) as Yx.
        {
            split.
            -   exact Sx.
            -   intros [[C0 contr] C1].
                rewrite singleton_eq in contr.
                contradiction.
        }
        specialize (x_lim Y Y_open Yx).
        apply empty_neq in x_lim.
        destruct x_lim as [a [[Aa nax] Ya]].
        unfold Y, X in Ya.
        unfold 𝐂, intersection, set_minus in Ya.
        rewrite singleton_eq in Ya.
        rewrite not_and, not_and, not_not in Ya.
        destruct Ya as [Sa [[Aa'|ax]|Sa']]; contradiction.
    -   intros all_S S S_open Sx.
        apply empty_neq.
        specialize (all_S S S_open Sx).
        unfold infinite in all_S.
        apply (lt_le_trans (nat_is_finite 2)) in all_S as [all_S C0]; clear C0.
        unfold nat_to_card, le in all_S; equiv_simpl in all_S.
        destruct all_S as [f f_inj].
        assert ((zero (U := nat)) < 2) as z_lt.
        {
            rewrite <- (plus_rid 0).
            apply lt_lrplus; apply nat_lt_suc.
        }
        pose (n2_type := nat_to_set_type 2).
        pose (n0 := [0|z_lt] : n2_type).
        pose proof (nat_lt_suc 0) as o_lt.
        apply lt_rplus with one in o_lt.
        rewrite plus_lid in o_lt.
        pose (n1 := [1|o_lt] : n2_type).
        classic_case ([f n0|] = x) as [eq|neq].
        +   exists [f n1|].
            repeat split; try apply [|f n1].
            rewrite singleton_eq; intros contr.
            subst.
            apply set_type_eq in contr.
            apply f_inj in contr.
            unfold n0, n1 in contr.
            inversion contr.
        +   exists [f n0|].
            repeat split; try apply [|f n0].
            rewrite singleton_eq; intros contr.
            subst.
            contradiction.
Qed.

Theorem seq_lim_unique : ∀ f x y, seq_lim f x → seq_lim f y → x = y.
Proof.
    intros f x y x_lim y_lim.
    classic_contradiction neq.
    pose proof (hausdorff_space x y neq)
        as [S1 [S2 [S1_open [S2_open [S1x [S2y dis]]]]]].
    specialize (x_lim S1 S1_open S1x) as [N1 x_lim].
    specialize (y_lim S2 S2_open S2y) as [N2 y_lim].
    specialize (x_lim (max N1 N2) (lmax N1 N2)).
    specialize (y_lim (max N1 N2) (rmax N1 N2)).
    apply (land (empty_eq _) dis (f (max N1 N2))).
    split; assumption.
Qed.

End HausdorffLimit.

(* begin hide *)
Section BasisLimit.

Context {U} `{TopologyBasis U}.
(* end hide *)
Theorem basis_seq_lim : ∀ f x, seq_lim f x ↔
    ∀ S, top_basis S → S x → ∃ N, ∀ n, N ≤ n → S (f n).
Proof.
    intros f x.
    split.
    -   intros f_lim S S_basis Sx.
        apply basis_open in S_basis.
        exact (f_lim S S_basis Sx).
    -   intros all_S S S_open Sx.
        specialize (S_open x Sx) as [B [B_basis [Bx sub]]].
        specialize (all_S B B_basis Bx) as [N lim].
        exists N.
        intros n n_gt.
        apply sub.
        apply lim.
        exact n_gt.
Qed.
(* begin hide *)
End BasisLimit.

Close Scope set_scope.
(* end hide *)


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

 Strong monads

 In this file, we define the notion of strong monad on a monoidal
 category.

 ********************************************************************)
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.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.Monoidal.Categories.

Local Open Scope cat.
Local Open Scope moncat.
Import MonoidalNotations.

Section LeftStrength.
  Context {V : monoidal_cat}.

  Definition left_strength_data
             (F : V ⟶ V)
    : UU
    := ∏ (x y : V), x ⊗ F y --> F(x ⊗ y).

  Definition left_strength_laws
             {F : V ⟶ V}
             (tF : left_strength_data F)
    : UU
    := (∏ (x₁ x₂ y₁ y₂ : V)
          (f : x₁ --> x₂)
          (g : y₁ --> y₂),
        f #⊗ #F g· tF x₂ y₂
        =
        tF x₁ y₁ · #F(f #⊗ g))
       ×
       (∏ (x : V),
        tF I_{V} x · #F(mon_lunitor x)
        =
        mon_lunitor (F x))
       ×
       (∏ (x y z : V),
        tF (x ⊗ y) z · #F(mon_lassociator x y z)
        =
        mon_lassociator x y (F z) · identity x #⊗ tF y z · tF x (y ⊗ z)).

  Proposition isaprop_left_strength_laws
              {F : V ⟶ V}
              (tF : left_strength_data F)
    : isaprop (left_strength_laws tF).
  Proof.
    repeat (use isapropdirprod) ; repeat (use impred ; intro) ; apply homset_property.
  Qed.

  Definition left_strength
             (F : V ⟶ V)
    : UU
    := ∑ (tF : left_strength_data F), left_strength_laws tF.

  Definition left_strength_to_data
             {F : V ⟶ V}
             (tF : left_strength F)
             (x y : V)
    : x ⊗ F y --> F(x ⊗ y)
    := pr1 tF x y.

  Coercion left_strength_to_data : left_strength >-> Funclass.

  Section LeftStrengthLaws.
    Context {F : V ⟶ V}
            (tF : left_strength F).

    Proposition left_strength_natural
                {x₁ x₂ y₁ y₂ : V}
                (f : x₁ --> x₂)
                (g : y₁ --> y₂)
      : f #⊗ #F g· tF x₂ y₂
        =
        tF x₁ y₁ · #F(f #⊗ g).
    Proof.
      exact (pr12 tF x₁ x₂ y₁ y₂ f g).
    Qed.

    Proposition left_strength_mon_lunitor
                (x : V)
      : tF I_{V} x · #F(mon_lunitor x)
        =
        mon_lunitor (F x).
    Proof.
      exact (pr122 tF x).
    Qed.

    Proposition left_strength_mon_lassociator
                (x y z : V)
      : tF (x ⊗ y) z · #F(mon_lassociator x y z)
        =
        mon_lassociator x y (F z) · identity x #⊗ tF y z · tF x (y ⊗ z).
    Proof.
      exact (pr222 tF x y z).
    Qed.
  End LeftStrengthLaws.

  Definition left_strong_monad_laws
             {M : Monad V}
             (tM : left_strength M)
    : UU
    := (∏ (x y : V),
        identity x #⊗ η M y · tM x y
        =
        η M (x ⊗ y))
       ×
       (∏ (x y : V),
        identity x #⊗ μ M y · tM x y
        =
        tM x (M y) · #M (tM x y) · μ M (x ⊗ y)).

  Proposition isaprop_left_strong_monad_laws
              {M : Monad V}
              (tM : left_strength M)
    : isaprop (left_strong_monad_laws tM).
  Proof.
    use isapropdirprod ; repeat (use impred ; intro) ; apply homset_property.
  Qed.

  Definition left_strong_monad
             (M : Monad V)
    : UU
    := ∑ (tM : left_strength M), left_strong_monad_laws tM.

  Coercion left_strong_monad_strength
           {M : Monad V}
           (tM : left_strong_monad M)
    : left_strength M
    := pr1 tM.

  Section LeftStrongMonadLaws.
    Context {M : Monad V}
            (tM : left_strong_monad M).

    Proposition left_strong_monad_unit
                (x y : V)
      : identity x #⊗ η M y · tM x y
        =
        η M (x ⊗ y).
    Proof.
      exact (pr12 tM x y).
    Qed.

    Proposition left_strong_monad_mu
                (x y : V)
      : identity x #⊗ μ M y · tM x y
        =
        tM x (M y) · #M (tM x y) · μ M (x ⊗ y).
    Proof.
      exact (pr22 tM x y).
    Qed.
  End LeftStrongMonadLaws.
End LeftStrength.


(************************************************************************************)
(**                                                                                *)
(**                             The SQLEngines Library                              *)
(**                                                                                *)
(**            LRI, CNRS & Université Paris-Sud, Université Paris-Saclay            *)
(**                                                                                *)
(**                        Copyright 2016-2019 : FormalData                         *)
(**                                                                                *)
(**         Authors: Véronique Benzaken                                             *)
(**                  Évelyne Contejean                                              *)
(**                                                                                *)
(************************************************************************************)

Set Implicit Arguments.

Require Import Relations SetoidList List String Ascii Bool ZArith NArith.

Require Import ListFacts OrderedSet FiniteSet.

Section Sec.

Hypothesis All : Type.
Hypothesis OAll : Oeset.Rcd All.

Inductive tree : Type :=
  | Leaf : All -> tree
  | Node : N -> list tree -> tree.

Fixpoint tree_compare (t1 t2 : tree) : comparison :=
  match t1, t2 with
  | Leaf a1, Leaf a2 => Oeset.compare OAll a1 a2
  | Leaf _, Node _ _ => Lt
  | Node _ _, Leaf _ => Gt
  | Node n1 l1, Node n2 l2 =>
    compareAB (Oset.compare ON) (comparelA tree_compare) (n1, l1) (n2, l2)
  end.

Lemma tree_compare_unfold :
  forall t1 t2, tree_compare t1 t2 =
  match t1, t2 with
  | Leaf a1, Leaf a2 => Oeset.compare OAll a1 a2
  | Leaf _, Node _ _ => Lt
  | Node _ _, Leaf _ => Gt
  | Node n1 l1, Node n2 l2 =>
    compareAB (Oset.compare ON) (comparelA tree_compare) (n1, l1) (n2, l2)
  end.
Proof.
intros t1 t2; destruct t1; destruct t2; apply refl_equal.
Qed.

Close Scope N_scope.

Fixpoint tree_size (t : tree) : nat :=
  match t with
  | Leaf _ => 1
  | Node _ l => 1 + list_size tree_size l
  end.

Lemma tree_size_unfold :
  forall t,
    tree_size t =
  match t with
  | Leaf _ => 1
  | Node _ l => 1 + list_size tree_size l
  end.
Proof.
intro t; destruct t; apply refl_equal.
Qed.

Notation suitable_x n size_a a_compare x1 :=
  (size_a x1 <= n ->
      a_compare x1 x1 = Eq /\
      forall x2, (a_compare x1 x2 = CompOpp (a_compare x2 x1)) /\
      forall x3,
      (a_compare x1 x2 = Eq -> a_compare x2 x3 = Eq -> a_compare x1 x3 = Eq) /\
      (a_compare x1 x2 = Eq -> a_compare x2 x3 = Lt -> a_compare x1 x3 = Lt) /\
      (a_compare x1 x2 = Lt -> a_compare x2 x3 = Eq -> a_compare x1 x3 = Lt) /\
      (a_compare x1 x2 = Lt -> a_compare x2 x3 = Lt -> a_compare x1 x3 = Lt)).

Notation suitable n size_a a_compare :=
  (forall x1, suitable_x n size_a a_compare x1).

Lemma all_suitable_tree_rec1 :
   forall n, suitable n tree_size tree_compare ->
   forall a, suitable_x (S n) tree_size tree_compare (Leaf a).
Proof.
intros n IHt a1 _.
split; [ | intro t2; split; [ | intro t3; split; [ | split; [ | split]]]].
- (* 1/6 *)
  simpl; (trivial || discriminate || oeset_compare_tac).
- (* 1/5 *)
  case t2; simpl; intros; (trivial || discriminate || oeset_compare_tac).
- (* 1/4 *)
  case t2; clear t2; try discriminate.
  intro a2; case t3; simpl; intros; (trivial || discriminate || oeset_compare_tac).
- (* 1/3 *)
  case t2; clear t2; try discriminate.
  intro a2; case t3; simpl; intros; (trivial || discriminate || oeset_compare_tac).
- (* 1/2 *)
  case t2; clear t2; try discriminate;
  intro a2; case t3; simpl; intros; (trivial || discriminate || oeset_compare_tac).
- (* 1/1 *)
  case t2; clear t2; try discriminate;
  intro a2; case t3; simpl; intros; (trivial || discriminate || oeset_compare_tac).
Qed.

Lemma all_suitable_tree_rec2 :
   forall n, suitable n tree_size tree_compare ->
   forall m l, suitable_x (S n) tree_size tree_compare (Node m l).
Proof.
intros n IHt m l L.
assert (Sl : forall t, List.In t l -> tree_size t <= n).
{
 intros t Ht; apply le_trans with (list_size tree_size l).
 - apply in_list_size; apply Ht.
 - apply le_S_n; apply L.
}
assert (IH := fun t (h : List.In t l) => IHt t (Sl t h)).
split; [ | intro t2; split; [ | intro t3; split; [ | split; [ | split]]]].
- (* 1/6 *)
  rewrite tree_compare_unfold; compareAB_tac.
  apply comparelA_eq_refl.
  intros t Ht; apply (proj1 (IH t Ht)).
- (* 1/5 *)
  destruct t2 as [a2 | m2 l2]; [simpl; apply refl_equal | ].
  rewrite 2 tree_compare_unfold; compareAB_tac.
  + oset_compare_tac.
  + comparelA_tac.
    apply (proj1 (proj2 (IH _ H) _)).
- (* 1/4 *)
  destruct t2 as [a1 | m2 l2]; [intro H1; discriminate H1 | ].
  destruct t3 as [a3 | m3 l3]; [intros H1 H2; discriminate H2 | ].
  rewrite 3 tree_compare_unfold; compareAB_tac.
  + oset_compare_tac.
  + comparelA_tac.
    apply (proj1 (proj2 (proj2 (IH _ H) _) _)).
- (* 1/3 *)
  destruct t2 as [a2 | m2 l2]; [intro H1; discriminate H1 | ].
  destruct t3 as [a3 | m3 l3]; [intros H1 H2; discriminate H2 | ].
  rewrite 3 tree_compare_unfold; compareAB_tac; (oset_compare_tac || comparelA_tac).
  + apply (proj1 (proj2 (proj2 (IH _ H) _) _)).
  + apply (proj1 (proj2 (proj2 (proj2 (IH _ H) _) _))).
- (* 1/2 *)
  destruct t2 as [a2 | m2 l2]; [intro H1; discriminate H1 | ].
  destruct t3 as [a3 | m3 l3]; [intros H1 H2; discriminate H2 | ].
  rewrite 3 tree_compare_unfold; compareAB_tac; (oset_compare_tac || comparelA_tac).
  + apply (proj1 (proj2 (proj2 (IH _ H) _) _)).
  + apply (proj1 (proj2 (proj2 (proj2 (proj2 (IH _ H) _) _)))).
- (* 1/1 *)
  destruct t2 as [a2 | m2 l2]; [intro H1; discriminate H1 | ].
  destruct t3 as [a3 | m3 l3]; [intros H1 H2; discriminate H2 | ].
  rewrite 3 tree_compare_unfold; compareAB_tac; (oset_compare_tac || comparelA_tac).
  + apply (proj1 (proj2 (proj2 (IH _ H) _) _)).
  + apply (proj1 (proj2 (proj2 (proj2 (IH _ H) _) _))).
  + apply (proj1 (proj2 (proj2 (proj2 (proj2 (IH _ H) _) _)))).
  + apply (proj2 (proj2 (proj2 (proj2 (proj2 (IH _ H) _) _)))).
Qed.

Lemma all_suitable_tree :
  forall x1,
      tree_compare x1 x1 = Eq /\
      forall x2, (tree_compare x1 x2 = CompOpp (tree_compare x2 x1)) /\
      forall x3,
      (tree_compare x1 x2 = Eq -> tree_compare x2 x3 = Eq -> tree_compare x1 x3 = Eq) /\
      (tree_compare x1 x2 = Eq -> tree_compare x2 x3 = Lt -> tree_compare x1 x3 = Lt) /\
      (tree_compare x1 x2 = Lt -> tree_compare x2 x3 = Eq -> tree_compare x1 x3 = Lt) /\
      (tree_compare x1 x2 = Lt -> tree_compare x2 x3 = Lt -> tree_compare x1 x3 = Lt).
Proof.
intro x1.
set (n := tree_size x1).
assert (Sx : tree_size x1 <= n).
apply le_n.
clearbody n.
revert x1 Sx; induction n as [ | n].
intros x1 Sx; destruct x1; simpl in Sx; inversion Sx.
intro x1; case x1.
apply all_suitable_tree_rec1; assumption.
apply all_suitable_tree_rec2; assumption.
Qed.

Lemma tree_compare_lt_gt :
  forall x1 x2, tree_compare x1 x2 = CompOpp (tree_compare x2 x1).
Proof.
intros x1 x2.
destruct (all_suitable_tree x1) as [_ H]; apply (proj1 (H x2)).
Qed.

Lemma tree_compare_eq_refl :
  forall x1, tree_compare x1 x1 = Eq.
Proof.
intros x1.
destruct (all_suitable_tree x1) as [H _]; apply H.
Qed.

Lemma tree_compare_size_eq :
  forall t1 t2, tree_compare t1 t2 = Eq -> tree_size t1 = tree_size t2.
Proof.
intro t1; set (n := tree_size t1).
assert (Hn := le_n n); unfold n at 1 in Hn.
unfold n; clearbody n.
revert t1 Hn; induction n as [ | n];
intros [a1 | f1 l1] Hn [a2 | f2 l2] Ht; simpl; simpl in Hn;
try (trivial || discriminate Ht).
- inversion Hn.
- subst; apply f_equal.
  rewrite tree_compare_unfold in Ht; unfold compareAB in Ht.
  case_eq (Oset.compare ON f1 f2);
    intro Hl; rewrite Hl in Ht; try discriminate Ht.
  generalize (le_S_n _ _ Hn); clear Hn; intro Hn.
  clear Hl.
  assert (IH : forall t1 : tree, List.In t1 l1 ->
                                 forall t2 : tree,
                                   tree_compare t1 t2 = Eq -> tree_size t1 = tree_size t2).
    {
      intros t1 Ht1 t2; apply IHn.
      clear Ht.
      refine (le_trans _ _ _ _ Hn).
      apply in_list_size; assumption.
    }
    clear IHn.
    revert l2 Ht; induction l1 as [ | t1 l1]; intros [ | t2 l2] Ht.
    * apply refl_equal.
    * discriminate Ht.
    * discriminate Ht.
    * simpl in Ht; simpl.
      case_eq (tree_compare t1 t2);
        intro Kt; rewrite Kt in Ht; try discriminate Ht.
      apply f_equal2; [apply (IH t1 (or_introl _ (refl_equal _)) t2 Kt) | ].
      {
        apply IHl1.
        - refine (le_trans _ _ _ _ Hn).
          simpl; apply le_plus_r.
        - do 3 intro; apply IH; right; assumption.
        - assumption.
      }
Qed.

Lemma tree_rec3 :
  forall (P : tree -> Type),
    (forall a, P (Leaf a)) ->
    (forall m l, (forall t, In t l -> P t) -> P (Node m l)) -> forall t, P t.
Proof.
intros P IH1 IH2 t.
set (n := tree_size t).
assert (Hn := le_n n).
unfold n at 1 in Hn; clearbody n.
revert t Hn; induction n as [ | n].
- intros t Hn; destruct t; simpl in Hn; (assert (H : False); [inversion Hn | contradiction H]).
- intros t Hn; destruct t as [a | m l]; [apply IH1 | ].
  apply IH2; intros t Ht; apply IHn.
  simpl in Hn.
  refine (le_trans _ _ _ _ (le_S_n _ _ Hn)).
  apply in_list_size; assumption.
Qed.

End Sec.

Section Equality.

Hypothesis All : Type.
Hypothesis OAll : Oset.Rcd All.

Definition OTree : Oset.Rcd (tree All).
set (AST := all_suitable_tree (oeset_of_oset OAll)).
split with (tree_compare (oeset_of_oset OAll)).
- intros x1; pattern x1; apply tree_rec3; clear x1.
  + intros a1 [a2 | m2 l2]; simpl; [ | discriminate].
    oset_compare_tac.
  + intros m1 l1 IH1 [a1 | m2 l2]; [simpl; discriminate | ].
    rewrite tree_compare_unfold.
    unfold compareAB.
    generalize (Oset.eq_bool_ok ON m1 m2).
    case (Oset.compare ON m1 m2).
    * intros H1; subst m2.
      {
        case_eq (comparelA (tree_compare (oeset_of_oset OAll)) l1 l2); intro H2.
        - apply f_equal.
          revert l2 H2; induction l1 as [ | a1 l1]; intros [ | a2 l2] H2;
          try (trivial || discriminate H2).
          simpl in H2.
          case_eq (tree_compare (oeset_of_oset OAll) a1 a2);
            intro Ha; rewrite Ha in H2; try discriminate H2.
          apply f_equal2.
          + assert (IHa1 := IH1 a1 (or_introl _ (refl_equal _)) a2).
            rewrite Ha in IHa1; apply IHa1.
          + apply IHl1; [ | assumption].
            do 2 intro; apply IH1; right; assumption.
        - intro H; injection H; clear H; intro; subst l2.
          induction l1 as [ | a1 l1]; [discriminate H2 | ].
          simpl in H2.
          assert (IHa1 := IH1 a1 (or_introl _ (refl_equal _)) a1).
          case_eq (tree_compare (oeset_of_oset OAll) a1 a1); intro Ha1; rewrite Ha1 in IHa1, H2.
          + refine (IHl1 _ H2).
            do 2 intro; apply IH1; right; assumption.
          + apply False_rec; apply IHa1; apply refl_equal.
          + apply False_rec; apply IHa1; apply refl_equal.
        - intro H; injection H; clear H; intro; subst l2.
          induction l1 as [ | a1 l1]; [discriminate H2 | ].
          simpl in H2.
          assert (IHa1 := IH1 a1 (or_introl _ (refl_equal _)) a1).
          case_eq (tree_compare (oeset_of_oset OAll) a1 a1); intro Ha1; rewrite Ha1 in IHa1, H2.
          + refine (IHl1 _ H2).
            do 2 intro; apply IH1; right; assumption.
          + apply False_rec; apply IHa1; apply refl_equal.
          + apply False_rec; apply IHa1; apply refl_equal.
      }
    * intros H1 H2; injection H2; clear H2; do 2 intro; subst; apply H1; apply refl_equal.
    * intros H1 H2; injection H2; clear H2; do 2 intro; subst; apply H1; apply refl_equal.
- intros x1 x2 x3.
  destruct (AST x1) as [_ H]; apply (proj2 (proj2 (proj2 (proj2 (H x2) x3)))).
- intros x1 x2.
  destruct (AST x1) as [_ H]; apply (proj1 (H x2)).
Defined.

End Equality.

Section Equivalence.

Hypothesis All : Type.
Hypothesis OEAll : Oeset.Rcd All.

Definition OETree : Oeset.Rcd (tree All).
set (AST := all_suitable_tree OEAll).
split with (tree_compare OEAll).
- intros x1 x2 x3; destruct (AST x1) as [_ H].
  apply (proj1 ((proj2 (H x2)) x3)).
- intros x1 x2 x3; destruct (AST x1) as [_ H].
  apply (proj1 (proj2 ((proj2 (H x2)) x3))).
- intros x1 x2 x3; destruct (AST x1) as [_ H].
  apply (proj1 (proj2 (proj2 ((proj2 (H x2)) x3)))).
- intros x1 x2 x3; destruct (AST x1) as [_ H].
  apply (proj2 (proj2 (proj2 ((proj2 (H x2)) x3)))).
- intros x1 x2.
  destruct (AST x1) as [_ H]; apply (proj1 (H x2)).
Defined.

End Equivalence.


Require Import Morphisms Setoid Coq.Vectors.Fin.
Require Import Utf8.

Add LoadPath "../theories" as CatQ.
From CatQ.Structures Require Import Structures.
From CatQ.Categories Require Import FunCat Concrete.
From CatQ.Functors Require Import Bifunctor Concrete.
Require Import CatQ.UniversalArrow.

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

Set Universe Polymorphism.

Structure Adjoint {C D} (F : Functor C D) (G : Functor D C) :=
  {
    adjunction : Nat (homFunctor ∘f ⟨ProductF: opf F , idFunctor⟩) (homFunctor ∘f ⟨ProductF: idFunctor , G⟩);
    is_adjoint : natiso adjunction;
  }.

Notation "[adjoint: F , G 'as' C 'to' D ]" := (@Adjoint C D F G) (at level 0, G at next level).
Notation "F ⊣ G" := [adjoint: F , G as _ to _] (at level 10).

Definition adj_iso {C D F G} (ψ: [adjoint: F,G as C to D]) : forall {c d}, morphism (F c) d ≃ morphism c (G d) in Setoids
  := fun c d => invertible_to_iso (is_adjoint ψ (c,d)).

Definition adj_r {C D F G} (ψ: [adjoint: F,G as C to D]) : forall {c d}, morphism (F c) d ⟶ morphism c (G d) in Setoids
  := fun c d => iso_right (adj_iso ψ (c:=c) (d:=d)).

Definition adj_l {C D F G} (ψ: [adjoint: F,G as C to D]) : forall {c d}, morphism c (G d) ⟶ morphism (F c) d in Setoids
  := fun c d => iso_left (adj_iso ψ (c:=c) (d:=d)).

Notation "[adj: f 'of' p ]" := (adj_r p f).
Notation "[adj: f ]" := [adj: f of _].
Notation "[adj⁻¹: f 'of' p ]" := (adj_l p f).
Notation "[adj⁻¹: f ]" := [adj⁻¹: f of _].

Lemma adj_isomorphic {C D F G} (ψ : [adjoint: F,G as C to D]) :
  forall {c d} (u : F c ⟶ d), [adj⁻¹: [adj: u of ψ] of ψ] == u.
Proof.
  intros.
  unfold adj_r, adj_l.
  rewrite setiso_left_at.
  reflexivity.
Qed.

Lemma adj_inv_isomorphic {C D F G} (ψ : [adjoint: F,G as C to D]) :
  forall {c d} (u : c ⟶ G d), [adj: [adj⁻¹: u of ψ] of ψ] == u.
Proof.
  intros.
  unfold adj_r, adj_l.
  rewrite setiso_right_at.
  reflexivity.
Qed.

Lemma adj_natural_L
      {C D F G} (ψ : [adjoint: F,G as C to D]) {c c' d} (f : c ⟶ c') (u : F c' ⟶ d) :
  [adj: u ∘ fmap F f of ψ] == [adj: u of ψ] ∘ f.
Proof.
  unfold adj_r.
  simpl.
  destruct (adjunction ψ).
  destruct is_nat.
  generalize (mapoid_apply u (naturality (c',d) (c,d) (f,identity))).
  simpl.
  intro.
  symmetry.

  refine
    (`begin
      component (c',d) u ∘ f
     =⟨ hom_refl ⟩
      component (c',d) u ∘ fmap idFunctor f
     =⟨ _ ⟩
      (identity ∘ component (c',d) u) ∘ fmap idFunctor f
     =⟨ _ ⟩
      (fmap G identity ∘ component (c',d) u) ∘ fmap idFunctor f
     =⟨ H ⟩
      component (c,d) ((fmap idFunctor identity ∘ u) ∘ fmap (opf F) f)
     =⟨ hom_refl ⟩
      component (c,d) ((identity ∘ u) ∘ fmap (opf F) f)
     =⟨ mapoid_cong (component (c,d)) _ ⟩
      component (c,d) (u ∘ fmap (opf F) f)
     =⟨ hom_refl ⟩
      component (c,d) (u ∘ fmap F f)
     `end).

  - unfold opf, op_trf; simpl.
    unfold fmap; simpl.
    unfold opop_invf; simpl.
    unfold fmap; simpl.
    unfold opposite_hom, opposite_hom_to.
    rewrite left_id_of.
    reflexivity.
  - rewrite left_id_of.
    rewrite fmap_identity.
    rewrite left_id_of.
    reflexivity.
  - rewrite left_id_of.
    reflexivity.
Qed.

Lemma adj_natural_R
      {C D F G} (ψ : [adjoint: F,G as C to D]) {c d d'} (g : d ⟶ d') (u : F c ⟶ d) :
  [adj: g ∘ u of ψ] == fmap G g ∘ [adj: u of ψ].
Proof.
  unfold adj_r.
  simpl.
  destruct (adjunction ψ).
  destruct is_nat.
  generalize (naturality (c,d) (c,d') (identity,g) u).
  simpl.
  intro.

  refine
    (`begin
      component (c,d') (g ∘ u)
     =⟨ _ ⟩
      component (c,d') ((g ∘ u) ∘ identity)
     =⟨ _ ⟩
      component (c,d') ((g ∘ u) ∘ fmap (opf F) identity)
     =⟨ _ ⟩
      component (c,d') ((fmap idFunctor g ∘ u) ∘ fmap (opf F) identity)
     ↑⟨ H ⟩
      (fmap G g ∘ component (c,d) u) ∘ fmap idFunctor identity
     =⟨ ltac: (rewrite fmap_identity; reflexivity) ⟩
      (fmap G g ∘ component (c,d) u) ∘ identity
     =⟨ ltac: (rewrite right_id_of; reflexivity) ⟩
      fmap G g ∘ component (c,d) u
     `end).

  - apply mapoid_cong.
    unfold opf.
    unfold op_trf, opop_invf.
    simpl.
    unfold fmap; simpl.
    unfold fmap; simpl.
    unfold opposite_hom_to, opposite_hom.
    reflexivity.
  - apply mapoid_cong.
    unfold opf.
    unfold op_trf, opop_invf.
    simpl.
    unfold fmap; simpl.
    unfold fmap; simpl.
    unfold opposite_hom_to, opposite_hom.
    rewrite fmorphism_identity.
    reflexivity.
  - rewrite right_id_of.
    reflexivity.
Qed.

Lemma adj_inv_natural_L
      {C D F G} (ψ : [adjoint: F,G as C to D]) {c c' d} (f : c ⟶ c') (u : c' ⟶ G d) :
  [adj⁻¹: u of ψ] ∘ fmap F f == [adj⁻¹: u ∘ f of ψ].
Proof.
  refine
    (`begin
      [adj⁻¹: u of ψ] ∘ fmap F f
     ↑⟨ ltac: (rewrite (setiso_left_at (adj_iso ψ)); reflexivity) ⟩
      [adj⁻¹: [adj: [adj⁻¹: u of ψ] ∘ fmap F f]]
     =⟨ ltac: (rewrite (adj_natural_L ψ); reflexivity) ⟩
      [adj⁻¹: [adj: [adj⁻¹: u of ψ]] ∘ f]
     =⟨ ltac: (rewrite adj_inv_isomorphic; reflexivity) ⟩
      [adj⁻¹: u ∘ f of ψ]
      `end).
Qed.

Lemma adj_inv_natural_R
      {C D F G} (ψ : [adjoint: F,G as C to D]) {c d d'} (g : d ⟶ d') (u : c ⟶ G d) :
  [adj⁻¹: fmap G g ∘ u of ψ] == g ∘ [adj⁻¹: u of ψ].
Proof.
  refine
    (`begin
      [adj⁻¹: fmap G g ∘ u of ψ]
     ↑⟨ ltac: (rewrite (adj_inv_isomorphic ψ u); reflexivity) ⟩
      [adj⁻¹: fmap G g ∘ [adj: [adj⁻¹: u of ψ]]]
     =⟨ ltac: (rewrite <- (adj_natural_R ψ); reflexivity) ⟩
      [adj⁻¹: [adj: g ∘ [adj⁻¹: u of ψ]]]
     =⟨ ltac: (rewrite (adj_isomorphic ψ); reflexivity) ⟩
      g ∘ [adj⁻¹: u of ψ]
     `end).
Qed.

Lemma adj_comm {C D F G} (ψ : [adjoint: F , G as C to D]) {c c' d d'}
      {f : F c ⟶ d} {h : F c' ⟶ d'} {p : c ⟶ c'} {q : d ⟶ d'} :
  h ∘ fmap F p == q ∘ f → [adj: h of ψ] ∘ p == fmap G q ∘ [adj: f of ψ].
Proof.
  intro hyp.
  refine
    (`begin
      [adj:h] ∘ p
     =⟨ ltac: (rewrite <- (adj_natural_L ψ p h); reflexivity) ⟩
      [adj:h ∘ fmap F p]
     =⟨ ltac: (rewrite hyp; reflexivity) ⟩
      [adj:q ∘ f]
     =⟨ ltac: (rewrite (adj_natural_R ψ q f); reflexivity) ⟩
      fmap G q ∘ [adj:f]
     `end).
Qed.

Program Definition unit {C D F G} (ψ : [adjoint: F,G as C to D]) : idFunctor ⟶ (G ∘f F) in [C,C]
  := [Nat: fun c => [adj: @identity _ (F c) of ψ] ].
Next Obligation.
  constructor.
  intros.

  refine
    (`begin
      fmap G (fmap F f) ∘ [adj: identity of ψ]
     ↑⟨ ltac: (rewrite (adj_natural_R ψ); reflexivity) ⟩
      [adj: fmap F f ∘ identity]
     =⟨ ltac: (rewrite right_id_of; reflexivity) ⟩
      [adj: fmap F f]
     ↑⟨ ltac: (rewrite (@left_id_of D); reflexivity) ⟩
      [adj: identity ∘ fmap F f]
     =⟨ ltac: (rewrite (adj_natural_L ψ); reflexivity) ⟩
      [adj: identity of ψ] ∘ f
     =⟨ hom_refl ⟩
      [adj: identity of ψ] ∘ fmap idFunctor f
     =⟨ hom_refl ⟩
      (adjunction ψ (b,F b)) identity ∘ fmap idFunctor f
     `end).
Defined.

Program Definition unit_universality {C D F G} (ψ : [adjoint: F,G as C to D]) : forall c, UniversalArrow c G
  := fun c => [universal: F c with unit ψ c].
Next Obligation.
  exists [adj⁻¹: f of ψ].
  constructor.
  - refine
      (`begin
        fmap G [adj⁻¹: f] ∘ [adj: identity]
       =⟨ ltac: (rewrite <- (adj_natural_R ψ); reflexivity) ⟩
        [adj: [adj⁻¹: f] ∘ identity]
       =⟨ ltac: (rewrite right_id_of; reflexivity) ⟩
        [adj: [adj⁻¹: f]]
       =⟨ ltac: (rewrite (adj_inv_isomorphic ψ); reflexivity) ⟩
        f
        `end).
  - intros.
    refine
      (`begin
        [adj⁻¹: f]
       =⟨ ltac: (rewrite <- H; reflexivity) ⟩
        [adj⁻¹: fmap G g ∘ [adj: identity]]
       =⟨ ltac: (rewrite <- adj_natural_R; reflexivity) ⟩
        [adj⁻¹: [adj: g ∘ identity]]
       =⟨ ltac: (rewrite right_id_of; reflexivity) ⟩
        [adj⁻¹: [adj: g]]
       =⟨ ltac: (rewrite (adj_isomorphic ψ); reflexivity) ⟩
        g
       `end).
Defined.

Program Definition counit {C D F G} (ψ : [adjoint: F,G as C to D]) : (F ∘f G) ⟶ idFunctor in [D,D]
  := [Nat: fun d => [adj⁻¹: @identity _ (G d) of ψ] ].
Next Obligation.
  constructor.
  intros.

  refine
    (`begin
      fmap idFunctor f ∘ [adj⁻¹: identity]
     =⟨ hom_refl ⟩
      f ∘ [adj⁻¹: identity]
     ↑⟨ ltac: (rewrite (adj_inv_natural_R ψ); reflexivity) ⟩
      [adj⁻¹: fmap G f ∘ identity]
     =⟨ ltac: (rewrite right_id_of; reflexivity) ⟩
      [adj⁻¹: fmap G f]
     ↑⟨ ltac: (rewrite (@left_id_of C); reflexivity) ⟩
      [adj⁻¹: identity ∘ fmap G f]
     ↑⟨ ltac: (rewrite (adj_inv_natural_L ψ); reflexivity) ⟩
      [adj⁻¹: identity] ∘ fmap F (fmap G f)
     =⟨ hom_refl ⟩
      [adj⁻¹: identity] ∘ fmap (F ∘f G) f
     `end).
Defined.

Proposition triangular_R {C D F G} (ψ : [adjoint: F,G as C to D]) : rightIdFunctor ∘n ((G f⋆ counit ψ) ∘n assocFunctor ∘n (unit ψ ⋆f G)) == @identity [D,C] G ∘n leftIdFunctor in [D,C].
Proof.
  simpl.
  intro.

  refine
    (`begin
      identity ∘ ((fmap G [adj⁻¹: identity] ∘ identity) ∘ [adj: identity])
     =⟨ ltac: (rewrite right_id_of; reflexivity) ⟩
      identity ∘ (fmap G [adj⁻¹: identity] ∘ [adj: identity])
     =⟨ ltac: (rewrite <- (adj_natural_R ψ); reflexivity) ⟩
      identity ∘ [adj: [adj⁻¹: identity] ∘ identity]
     =⟨ ltac: (rewrite right_id_of; reflexivity) ⟩
      identity ∘ [adj: [adj⁻¹: identity]]
     =⟨ ltac: (rewrite (adj_inv_isomorphic ψ (d:=A)); reflexivity) ⟩
      identity ∘ identity
     `end).
Defined.

Proposition triangular_L {C D F G} (ψ : [adjoint: F,G as C to D]) : leftIdFunctor ∘n ((counit ψ ⋆f F) ∘n assocInvFunctor ∘n (F f⋆ unit ψ)) == @identity [C,D] F ∘ rightIdFunctor in [C,D].
Proof.
  simpl.
  intro.

  refine
    (`begin
      identity ∘ (([adj⁻¹:identity] ∘ identity) ∘ fmap F [adj:identity])
     =⟨ ltac: (rewrite right_id_of; reflexivity) ⟩
      identity ∘ ([adj⁻¹: identity] ∘ fmap F [adj: identity])
     =⟨ ltac: (rewrite (adj_inv_natural_L ψ (d:=F A)); reflexivity) ⟩
      identity ∘ [adj⁻¹: identity ∘ [adj:identity] ]
     =⟨ ltac: (rewrite (@left_id_of C); reflexivity) ⟩
      identity ∘ [adj⁻¹: [adj:identity] ]
     =⟨ ltac: (rewrite (adj_isomorphic ψ (c:=A)); reflexivity) ⟩
      identity ∘ identity
     `end).
Defined.

(*
Section left_adjoint_from_unit_proof.
  Variable (C D : Category) (G : Functor D C).
  Variable (ηt : forall c, UniversalArrow_Type c G).

  Program Definition left_adj : Functor C D :=
    [fmap: fun c c' p => proj1_sig (ua_UMP (ηt c) (f:=ua_map (ηt c') ∘ p)) with fun c => ua_object (ηt c)].
  Next Obligation.
    unfold Proper, respectful; simpl.
    intros.
    destruct (ηt a) as [ηtobj ηtmap ηtprop].
    simpl.
    destruct (ηtprop (ua_object (ηt b)) (ua_map (ηt b) ∘ x)).
    simpl.
    destruct (ηtprop (ua_object (ηt b)) (ua_map (ηt b) ∘ y)).
    simpl.
    destruct u.
    destruct u0.
    rewrite (H1 x1).
    reflexivity.
    rewrite H2.
    rewrite H.
    reflexivity.
  Defined.
  Next Obligation.
    destruct (ηt a).
    simpl.
    destruct (ua_UMP ua_object).
    simpl.
    destruct u.
    apply (H0 identity).
    rewrite fmap_identity.
    rewrite right_id_of.
    rewrite left_id_of.
    reflexivity.
  Defined.
  Next Obligation.
  Admitted.

  Program Definition φ {c d} : (morphism (left_adj c) d) ≃ (morphism c (G d)) at Setoids :=
    {|
      iso_right := [mapoid: fun g => fmap G g ∘ ua_map (ηt c)];
    |}.
  Next Obligation.
    solve_proper.
  Defined.
  Next Obligation.

Lemma left_adjoint_from_unit {C D} {G : Functor D C} {η : forall c, UniversalArrow c G} : {F : Functor C D & F ⊣ G}.
Proof.
  refine (existT (fun F => F ⊣ G) [fmap: fun c c' p => proj1_sig (ua_UMP (Destruct_UniversalArrow_Type (η c)) (f:=ua_map (Destruct_UniversalArrow_Type (η c')) ∘ p)) with fun c => ua_object (Destruct_UniversalArrow_Type (η c))] _).
  {
    simpl.
    refine {| adjunction := _ |}.
    {
      intros.
      unfold fmap; simpl.
    }
  }

*)


Require Import ssreflect ssrfun ssrbool.

(** some simple lemmas about bool *)

Lemma degen_bool : forall P, is_true false -> P.
Proof.
  intros; discriminate.
Qed.

Lemma ab_bool_lr : forall a b, a && b -> a /\ b.
Proof.
  intros a b; case a; case b; intros H; inversion H; split; assumption.
Qed.

Lemma ab_bool : forall a b, a && b <-> a /\ b.
Proof.
  intros a b; split.
  apply ab_bool_lr.
  case a;case b; intros (ha,hb); solve [inversion ha | inversion hb | reflexivity].
Qed.

Lemma circ2 : forall a b, a&&b -> b&&a.
Proof.
  intros a b; destruct a; destruct b; intros H;inversion H; assumption.
Qed.

Lemma circ3: forall A B C: bool, B && C && A -> A && B &&C.
Proof.
  intros a b c; case a; case b; case c; intros; assumption.
Qed.

Lemma circ6: forall A B C D E F : bool,
       B && C && D && E &&F && A -> A && B && C && D && E && F.
Proof.
  intros a b c d e f; case a; case b; case c; case d; case e; case f; intros; assumption.
Qed.

Lemma bool6 : forall a b c d e f, a && b && c && d && e && f -> a && e && d && c && b && f.
Proof.
  intros a b c d e f; case a; case b; case c; case d; case e; case f; intros; assumption.
Qed.

Lemma comm12L: forall A B C:bool, B && A && C -> A && B && C.
   Proof.
     intros a b c; case a; case b; case c; intros; assumption.
   Qed.

Lemma comm12P: forall A B C D E F :bool,
       B && A && C && D &&E && F -> A && B && C && D && E && F.
Proof.
  intros a b c d e f; case a; case b; case c; case d; case e; case f; intros; assumption.
Qed.

(* Local Variables: *)
(* coq-prog-name: "/Users/magaud/.opam/4.06.0/bin/coqtop" *)
(* coq-load-path: (("." "Top") ) *)
(* suffixes: .v *)
(* End: *)


Require Import Reals.
From Interval Require Import Tactic Basic.

Open Scope R_scope.

Lemma h_54_ln_2  h :
  -53 <= h <= 0 ->
  -  Rnearbyint rnd_DN (h * ln 2 / ln 5) * ln 5 <= 54 * ln 2.
Proof.
intros.
interval.
Qed.


Require Import HoTT.
From GR.bicategories Require Import
     bicategory.bicategory
     bicategory.examples.full_sub
     lax_functor.lax_functor
     lax_functor.examples.identity.

Section FactorFullSub.
  Context {C D :BiCategory}.
  Variable (F : LaxFunctor C D)
           (P : D -> hProp)
           (FP : forall (X : C), P (F X)).

  Definition lax_factor_d : LaxFunctor_d C (full_sub D P).
  Proof.
    make_laxfunctor.
    - exact (fun X => (Fobj F X;FP X)).
    - intros ; apply (Fmor F).
    - intros X Y Z g f ; simpl in *.
      exact (Fcomp₁ F g f).
    - intros ; apply (Fid F).
  Defined.

  Definition is_lax_factor : is_lax lax_factor_d.
  Proof.
    make_is_lax ; intros ; apply F.
  Defined.

  Definition lax_factor : LaxFunctor C (full_sub D P)
    := Build_LaxFunctor lax_factor_d is_lax_factor.
End FactorFullSub.

Global Instance lax_factor_is_pseudo
           `{Univalence}
           {C D :BiCategory}
           (F : LaxFunctor C D)
           `{is_pseudo _ _ F}
           (P : D -> hProp)
           (FP : forall (X : C), P (F X))
  : is_pseudo (lax_factor F P FP).
Proof.
  split ; cbn ; apply _.
Defined.

Definition pseudo_factor
           `{Univalence}
           {C D :BiCategory}
           (F : PseudoFunctor C D)
           (P : D -> hProp)
           (FP : forall (X : C), P (F X))
  : PseudoFunctor C (full_sub D P).
Proof.
  make_pseudo_functor_lax.
  - exact (lax_factor F P FP).
  - exact (lax_factor_is_pseudo F P FP).
Defined.