(** * Common facts about [≤] *)
Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Export Coq.micromega.Lia.
Require Import Coq.Arith.Le.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Program.Basics.

Set Implicit Arguments.

Lemma le_pred n m (H : n <= m) : pred n <= pred m.
Proof.
  induction H.
  { constructor. }
  { destruct m; simpl in *; try constructor; assumption. }
Defined.

Lemma le_SS n m (H : n <= m) : S n <= S m.
Proof.
  induction H.
  { constructor. }
  { constructor; assumption. }
Defined.

Lemma le_canonical n m : {n <= m} + {~n <= m}.
Proof.
  revert n; induction m; intro n.
  { destruct n.
    { left; constructor. }
    { right; clear.
      abstract auto with arith. } }
  { destruct (IHm n) as [IHm'|IHm'].
    { left; constructor; assumption. }
    { clear IHm'.
      specialize (IHm (pred n)).
      destruct IHm as [IHm|IHm], n; simpl in *.
      { left; constructor; assumption. }
      { left; apply le_SS; assumption. }
      { exfalso.
        abstract auto with arith. }
      { right; intro H.
        abstract (apply le_pred in H; simpl in *; auto). } } }
Defined.

Lemma le_canonical_nn {n} : le_canonical n n = left (le_n _).
Proof.
  induction n; simpl; try reflexivity.
  rewrite IHn; clear IHn.
  edestruct le_canonical; [ exfalso | reflexivity ].
  { eapply le_Sn_n; eassumption. }
Qed.

Lemma le_canonical_nS {n m pf} (H : le_canonical n m = left pf)
: le_canonical n (S m) = left (le_S _ _ pf).
Proof.
  simpl; rewrite H; reflexivity.
Qed.

Fixpoint le_proof_irrelevance_left {n m} (pf : n <= m)
: left pf = le_canonical n m.
Proof.
  destruct pf.
  { clear. rewrite le_canonical_nn; reflexivity. }
  { erewrite le_canonical_nS; [ reflexivity | ].
    symmetry.
    apply le_proof_irrelevance_left. }
Defined.

Lemma le_proof_irrelevance' {n m} (pf : {n <= m} + {~n <= m})
: le_canonical n m = match pf, le_canonical n m with
                       | left pf', _ => left pf'
                       | _, right pf' => right pf'
                       | right pf', left pf'' => match pf' pf'' with end
                     end.
Proof.
  destruct pf.
  { erewrite <- le_proof_irrelevance_left; reflexivity. }
  { edestruct le_canonical; try reflexivity.
    exfalso; eauto. }
Qed.

Lemma le_proof_irrelevance {n m} (pf pf' : n <= m) : pf = pf'.
Proof.
  transitivity (match le_canonical n m with
                  | left pf' => pf'
                  | right pf' => match pf' pf with end
                end).
  { rewrite (le_proof_irrelevance' (left pf)); reflexivity. }
  { rewrite (le_proof_irrelevance' (left pf')); reflexivity. }
Qed.

Lemma not_lt_plus {x y z} (H : ~ x < y + z) : (~ x < y) /\ (~x < z).
Proof. split; lia. Qed.

Lemma not_le_plus {x y z} (H : ~ x <= y + z) : (~ x <= y) /\ (~x <= z).
Proof. split; lia. Qed.

Lemma not_lt_add_r {a b} (H : ~a < a + b) : b = 0.
Proof. lia. Qed.

Lemma not_lt_add_l {a b} (H : ~a < b + a) : b = 0.
Proof. lia. Qed.

Global Instance le_lt_Proper : Proper (Basics.flip le ==> le ==> impl) lt.
Proof.
  repeat intro.
  eapply lt_le_trans; [ | eassumption ].
  eapply le_lt_trans; eassumption.
Qed.

Global Instance le_lt_Proper' : Proper (le ==> Basics.flip le ==> Basics.flip impl) lt.
Proof.
  repeat intro.
  eapply lt_le_trans; [ | eassumption ].
  eapply le_lt_trans; eassumption.
Qed.


From Equations Require Import Init.
From Coq Require Import Extraction CRelationClasses.

Set Warnings "-notation-overridden".

(** The polymorphic equality type used by Equations when working with equality in Type. *)

Set Universe Polymorphism.

(* Let's leave empty at Set, it can live in any higher universe. *)
Inductive Empty : Set :=.

Scheme Empty_case := Minimality for Empty Sort Type.

Definition unit_rect@{i} (P : unit -> Type@{i}) (p : P tt) (u : unit) : P u :=
  match u with tt => p end.

Definition prod (A : Type) (B : Type) := sigma (fun _ : A => B).

Notation " A * B " := (prod A B) : type_scope.

Definition BiImpl (A B : Type) : Type := (A -> B) * (B -> A).

Notation "A <-> B" := (BiImpl A B) (at level 95) : type_scope.

Cumulative Inductive Id@{i} {A : Type@{i}} (a : A) : A -> Type@{i} :=
  id_refl : Id a a.
Arguments id_refl {A a}, [A] a.

Local Open Scope equations_scope.

Module Id_Notations.
  Notation " x = y " := (@Id _ x y) : equations_scope.
  Notation " x = y " := (@Id _ x y) : type_scope.
  Notation " x <> y " := (@Id _ x y -> Empty) : equations_scope.
  Notation " x <> y " := (@Id _ x y -> Empty) : type_scope.
  Notation " 1 " := (@id_refl _ _) : equations_scope.
End Id_Notations.

Import Id_Notations.

Section IdTheory.
  Universe i.
  Context {A : Type@{i}}.

  Import Id_Notations.

  Lemma id_sym {x y : A} : x = y -> y = x.
  Proof. destruct 1. apply 1. Defined.

  Lemma id_trans {x y z : A} : x = y -> y = z -> x = z.
  Proof. destruct 1. destruct 1. apply 1. Defined.

  Definition transport (x : A) (P : A -> Type) : P x -> forall y : A, Id x y -> P y.
  Proof. intros Px y e. destruct e. exact Px. Defined.

  Definition Id_rew := transport.

  Definition Id_case (P : A -> Type) {x y : A} : Id y x -> P x -> P y.
  Proof. intros e Px. eapply (transport x _ Px y (id_sym e)). Defined.

  Definition Id_rew_r {x y : A} (P : A -> Type) : P y -> Id x y -> P x.
  Proof. intros Px e. eapply (transport y _ Px x (id_sym e)). Defined.

  Lemma Id_rect_r {x : A} (P : forall a, Id a x -> Type) (p : P x id_refl)
        {y : A} (e : Id y x) : P y e.
  Proof. destruct e. apply p. Defined.

  Import Sigma_Notations.
  Definition id_inspect (x : A) : Σ y , x = y := (x , 1).
End IdTheory.

Class HProp A := is_hprop : forall x y : A, x = y.

Class HSet A := is_hset : forall {x y : A}, HProp (x = y).

Cumulative Inductive sum@{i} (A : Type@{i}) (B : Type@{i}) :=
| inl : A -> A + B
| inr : B -> A + B
where " A + B " := (sum A B) : type_scope.

Arguments inl {A} {B} a.
Arguments inr {A} {B} b.

Definition Sect {A B : Type} (s : A -> B) (r : B -> A) :=
  forall x : A, r (s x) = x.

Definition ap {A B : Type} (f : A -> B) {x y : A} (p : x = y) : f x = f y :=
  match p with 1 => 1 end.

Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv {
  equiv_inv : B -> A ;
  eisretr : Sect equiv_inv f;
  eissect : Sect f equiv_inv;
  eisadj : forall x : A, eisretr (f x) = ap f (eissect x)
}.
Arguments eisretr {A B}%type_scope f%function_scope {_} _.
Arguments eissect {A B}%type_scope f%function_scope {_} _.
Arguments eisadj {A B}%type_scope f%function_scope {_} _.
Arguments IsEquiv {A B}%type_scope f%function_scope.

(** A record that includes all the data of an adjoint equivalence. *)
Record Equiv A B := BuildEquiv {
  equiv_fun : A -> B ;
  equiv_isequiv : IsEquiv equiv_fun
}.

Coercion equiv_fun : Equiv >-> Funclass.

Global Existing Instance equiv_isequiv.

Arguments equiv_fun {A B} _ _.
Arguments equiv_isequiv {A B} _.

Declare Scope equiv_scope.
Bind Scope equiv_scope with Equiv.

Reserved Infix "<~>" (at level 85).
Notation "A <~> B" := (Equiv A B) (at level 85) : type_scope.

Notation "f ^^-1" := (@equiv_inv _ _ f _) (at level 3).


(* Copyright (c) 2014, Robert Dockins *)

Require Import Setoid.

Require Import basics.
Require Import categories.
Require Import preord.
Require Import sets.
Require Import finsets.
Require Import atoms.
Require Import permutations.

(** * The category of nominal types
  *)

Obligation Tactic := intuition.

Require Import List.

Module Nominal.

Record mixin_of (A:Type) (eq_mixin:Eq.mixin_of A) :=
  Mixin
  { Aeq := Eq.Pack A eq_mixin
  ; papp : perm -> Aeq -> Aeq
  ; support : Aeq -> finset atom
  ; nom_ident : forall a, papp id a ≈ a
  ; nom_comp : forall a p1 p2,
       papp p1 (papp p2 a) ≈ papp (p1 ∘ p2) a
  ; papp_respects : forall p p' a a',
       p ≈ p' -> a ≈ a' -> papp p a ≈ papp p' a'
  ; support_axiom : forall (p:perm) a,
       (forall v, v ∈ support a -> v ∈ Perm.support p -> False) ->
       papp p a ≈ a
  ; support_papp : forall (p:perm) x v,
       v ∈ support x <-> p v ∈ support (papp p x)
  }.

Record ob :=
  Ob
  { carrier :> Type
  ; eq_mixin : Eq.mixin_of carrier
  ; nominal_mixin : mixin_of carrier eq_mixin
  }.

Definition papp_op (A:ob) : perm -> A -> A :=
  papp (carrier A) (eq_mixin A) (nominal_mixin A).

Definition support_op (A:ob) : A -> finset atom :=
  support (carrier A) (eq_mixin A) (nominal_mixin A).

Canonical Structure nom_support (A:ob) : supported :=
  Supported A (support_op A).

Canonical Structure ob_eq (A:ob) : Eq.type :=
  Eq.Pack (carrier A) (eq_mixin A).

Record hom (A B:ob) :=
  Hom
  { map :> carrier A -> carrier B
  ; eq_axiom : forall x y, x ≈ y -> map x ≈ map y
  ; equivariant : forall x (p:perm),
       map (papp_op A p x) ≈ papp_op B p (map x)
  }.

Program Definition ident (A:ob) :=
  Hom A A (fun x => x) _ _.

Program Definition compose (A B C:ob) (f:hom B C) (g:hom A B) :=
  Hom A C (fun x => f (g x)) _ _.
Next Obligation.
  apply eq_axiom.
  apply eq_axiom.
  auto.
Qed.
Next Obligation.
  transitivity (f (papp_op B p (g x))).
  apply eq_axiom.
  apply equivariant.
  apply equivariant.
Qed.

Definition comp_mixin : Comp.mixin_of ob hom :=
  Comp.Mixin ob hom ident compose.

Canonical Structure comp := Comp.Pack ob hom comp_mixin.

Program Definition hom_eq_mixin (A B:ob) : Eq.mixin_of (hom A B) :=
  Eq.Mixin (hom A B) (fun f g => forall x, f x ≈ g x) _ _ _.
Next Obligation.
  simpl; intros; rewrite H; auto.
Qed.

Lemma category_axioms : Category.axioms ob hom hom_eq_mixin comp_mixin.
Proof.
  constructor.
  repeat intro. simpl; auto.
  repeat intro. simpl; auto.
  repeat intro. simpl; auto.
  repeat intro. simpl; auto.
  transitivity (f (g' x)).
  apply eq_axiom. apply H0.
  apply H.
Qed.

Canonical Structure NOMINAL : category :=
  Category ob hom hom_eq_mixin comp_mixin category_axioms.

Canonical Structure eq (A:ob) : Eq.type := Eq.Pack (carrier A) (eq_mixin A).
Canonical Structure hom_eq (A B:ob) : Eq.type := Eq.Pack (hom A B) (hom_eq_mixin A B).

End Nominal.

Notation NOMINAL := Nominal.NOMINAL.
Notation nominal := Nominal.ob.
Canonical Structure NOMINAL.
Canonical Structure Nominal.nom_support.
Canonical Structure Nominal.eq.
Canonical Structure Nominal.hom_eq.
Canonical Structure Nominal.comp.
Coercion Nominal.carrier : Nominal.ob >-> Sortclass.
Coercion Nominal.map : Nominal.hom >-> Funclass.

Notation "p · x" := (Nominal.papp_op _ p x) (at level 35, right associativity).

Add Parametric Morphism (A B:nominal) :
  (Nominal.map A B)
    with signature (eq_op (Nominal.hom_eq A B)) ==>
                   (eq_op (Nominal.eq A)) ==>
                   (eq_op (Nominal.eq B))
   as nom_map_morphism.
Proof.
  intros.
  transitivity (x y0).
  apply Nominal.eq_axiom. auto.
  apply H.
Qed.

Add Parametric Morphism (A:nominal) :
  (Nominal.papp_op A)
  with signature (@eq_op (Perm.eq tt tt)) ==>
                 (@eq_op (Nominal.eq A)) ==>
                 (@eq_op (Nominal.eq A))
    as papp_morphism.
Proof.
  intros. apply Nominal.papp_respects; auto.
Qed.

Lemma nom_compose (A:nominal) (p1 p2:perm) (x:A) :
  p1 · p2 · x ≈ (p1 ∘ p2) · x.
Proof.
  apply Nominal.nom_comp.
Qed.

Lemma nom_compose' (A:nominal) (p p1 p2:perm) (x:A) :
  p1 ∘ p2 ≈ p ->
  p1 · p2 · x ≈ p · x.
Proof.
  intros. rewrite nom_compose. rewrite H. auto.
Qed.

Lemma nom_ident (A:nominal) (x:A) :
  id·x ≈ x.
Proof.
  apply Nominal.nom_ident.
Qed.

Lemma nom_ident' (A:nominal) (p:perm) (x:A) :
  p ≈ id(tt) ->
  p·x ≈ x.
Proof.
  intros. rewrite H.
  apply Nominal.nom_ident.
Qed.

Lemma support_axiom (A:nominal) (p:perm) (x:A) :
  x♯p -> p·x ≈ x.
Proof.
  intros. apply Nominal.support_axiom. auto.
Qed.

Lemma support_axiom' (A:nominal) (p:perm) (x:A) :
  x♯p -> x ≈ p·x.
Proof.
  intros. symmetry. apply support_axiom. auto.
Qed.

Lemma support_papp (A:nominal) (p:perm) (x:A) (v:atom) :
  v ∈ ‖x‖ <-> p v ∈ ‖p·x‖.
Proof.
  intros. apply Nominal.support_papp.
Qed.

Lemma papp_inj (A:nominal) (p:perm) (x y:A) :
  p·x ≈ p·y -> x ≈ y.
Proof.
  intros.
  cut ((p⁻¹ ∘ p) · x ≈ (p⁻¹ ∘ p) · y).
  intros.
  rewrite Perm.inv_id2 in H0.
  rewrite nom_ident in H0.
  rewrite nom_ident in H0.
  auto.
  rewrite <- nom_compose.
  rewrite <- nom_compose.
  rewrite H. auto.
Qed.

(** NOMINAL is an initialized category. *)

Program Definition initius_eq_mixin :=
  Eq.Mixin False (fun _ _ => False) _ _ _.

Program Definition initius_mixin :=
  Nominal.Mixin
      False initius_eq_mixin
      (fun p x => False_rect _ x)
      (fun x => False_rect _ x)
      _ _ _ _ _.
Next Obligation.
  elim x. elim x.
Qed.

Canonical Structure initius :=
  Nominal.Ob False initius_eq_mixin initius_mixin.

Program Definition initiate (A:nominal) : initius → A :=
  Nominal.Hom initius A (fun x => False_rect _ x) _ _.
Next Obligation.
  elim x.
Qed.
Next Obligation.
  elim x.
Qed.

Program Definition initialized_mixin :=
  Initialized.Mixin
    Nominal.ob Nominal.hom
    Nominal.hom_eq_mixin
    initius initiate
    _.
Next Obligation.
  hnf. intro x. elim x.
Qed.

Canonical Structure initialized_nominal : initialized :=
  Initialized
    Nominal.ob Nominal.hom
    Nominal.hom_eq_mixin
    Nominal.comp_mixin
    Nominal.category_axioms
    initialized_mixin.

(** NOMINAL has binary coproducts. *)

Section nom_sum.
  Variables A B:nominal.

  Definition nom_sum_equiv (x y:A+B) :=
    match x, y with
    | inl a, inl a' => a ≈ a'
    | inr b, inr b' => b ≈ b'
    | _, _ => False
    end.

  Definition nom_sum_papp (p:perm) (x:A+B) :=
    match x with
    | inl a => inl (p · a)
    | inr b => inr (p · b)
    end.

  Definition nom_sum_support (x:A+B) : finset atom :=
    match x with
    | inl a => ‖a‖
    | inr b => ‖b‖
    end.

  Program Definition nom_sum_eq_mixin :=
    Eq.Mixin (A+B) nom_sum_equiv _ _ _.
  Next Obligation.
    simpl. auto.
    simpl. auto.
  Qed.
  Next Obligation.
    simpl in *. destruct y; simpl in *; auto.
    destruct y; simpl in *; auto.
  Qed.
  Next Obligation.
    destruct z; simpl in *; eauto.
    destruct z; simpl in *; eauto.
    elim H.
    destruct z; simpl in *; eauto.
    elim H.
    destruct z; simpl in *; eauto.
  Qed.

  Program Definition nom_sum_mixin :=
    Nominal.Mixin (A+B) nom_sum_eq_mixin nom_sum_papp nom_sum_support
       _ _ _ _ _.
  Next Obligation.
    destruct a; red; simpl; auto.
    apply nom_ident.
    apply nom_ident.
  Qed.
  Next Obligation.
    destruct a; red; simpl; auto.
    apply nom_compose.
    apply nom_compose.
  Qed.
  Next Obligation.
    destruct a; destruct a'; simpl in *.
    red in H0; simpl in H0.
    red; simpl. apply papp_morphism; auto.
    red in H0; simpl in H0. elim H0.
    red in H0; simpl in H0. elim H0.
    red in H0; simpl in H0.
    red; simpl. apply papp_morphism; auto.
  Qed.
  Next Obligation.
    destruct a; red; simpl.
    apply support_axiom.
    red; simpl; intros. apply (H v); auto.
    apply support_axiom.
    red; simpl; intros. apply (H v); auto.
  Qed.
  Next Obligation.
    destruct x; apply support_papp; auto.
    destruct x; simpl in H;
      apply support_papp in H; auto.
  Qed.

  Canonical Structure nom_sum : nominal :=
    Nominal.Ob (A+B) nom_sum_eq_mixin nom_sum_mixin.
End nom_sum.

(** NOMINAL has colimits for directed systems. *)
Require Import directed.
Require Import cont_functors.

Section nominal_directed_colimits.
  Variable I:directed_preord.
  Variable DS:directed_system I NOMINAL.

  Record nom_colimit_type :=
    NomColim
    { nom_colim_idx : I
    ; nom_colim_elem : ds_F DS nom_colim_idx
    }.

  Definition nom_colimit_equiv (x y:nom_colimit_type) :=
    exists k
      (Hxk:nom_colim_idx x ≤ k)
      (Hyk:nom_colim_idx y ≤ k),
      ds_hom DS _ _ Hxk (nom_colim_elem x) ≈
      ds_hom DS _ _ Hyk (nom_colim_elem y).

  Program Definition nom_colimit_eq_mixin :=
    Eq.Mixin nom_colimit_type nom_colimit_equiv _ _ _ .
  Next Obligation.
    exists (nom_colim_idx x).
    exists (ord_refl I (nom_colim_idx x)).
    exists (ord_refl I (nom_colim_idx x)).
    auto.
  Qed.
  Next Obligation.
    destruct H as [k [Hxk [Hyk ?]]].
    exists k. exists Hyk. exists Hxk. symmetry.
    auto.
  Qed.
  Next Obligation.
    destruct H as [i [Hxi [Hyi ?]]].
    destruct H0 as [j [Hyj [Hzj ?]]].
    destruct (choose_ub I i j) as [k [Hik Hjk]].
    assert (Hxk : nom_colim_idx x ≤ k). etransitivity; eauto.
    assert (Hyk : nom_colim_idx y ≤ k). etransitivity; eauto.
    assert (Hzk : nom_colim_idx z ≤ k). etransitivity; eauto.
    exists k. exists Hxk. exists Hzk.
    rewrite <- (ds_compose DS (nom_colim_idx x) i k Hxi Hik Hxk).
    rewrite <- (ds_compose DS (nom_colim_idx z) j k Hzj Hjk Hzk).
    simpl.
    rewrite H. rewrite <- H0.
    change ((ds_hom DS i k Hik ∘ ds_hom DS (nom_colim_idx y) i Hyi) (nom_colim_elem y)
      ≈ ((ds_hom DS j k Hjk ∘ ds_hom DS (nom_colim_idx y) j Hyj) (nom_colim_elem y))).
    rewrite (ds_compose DS (nom_colim_idx y) i k Hyi Hik Hyk).
    rewrite (ds_compose DS (nom_colim_idx y) j k Hyj Hjk Hyk).
    auto.
  Qed.

  Definition nom_colimit_papp (p:perm) (x:nom_colimit_type) :=
    match x with
    | NomColim i x' => NomColim i (p · x')
    end.

  Program Definition nom_colimit_mixin :=
    Nominal.Mixin
      nom_colimit_type
      nom_colimit_eq_mixin
      nom_colimit_papp
      (fun x => ‖ nom_colim_elem x ‖)
      _ _ _ _ _.
  Next Obligation.
    destruct a as [i a]. exists i. simpl.
    exists (ord_refl _ _).
    exists (ord_refl _ _).
    apply Nominal.eq_axiom.
    apply nom_ident.
  Qed.
  Next Obligation.
    destruct a as [i a]. exists i. simpl.
    exists (ord_refl _ _).
    exists (ord_refl _ _).
    apply Nominal.eq_axiom.
    apply nom_compose.
  Qed.
  Next Obligation.
    destruct H0 as [k [Hk1 [Hk2 ?]]].
    destruct a as [i a].
    destruct a' as [j b].
    simpl in *.
    exists k. simpl. exists Hk1. exists Hk2.
    rewrite Nominal.equivariant.
    rewrite Nominal.equivariant.
    apply papp_morphism; auto.
  Qed.
  Next Obligation.
    destruct a as [i a]. simpl.
    exists i.
    exists (ord_refl _ _).
    exists (ord_refl _ _).
    simpl.
    apply Nominal.eq_axiom.
    apply support_axiom; auto.
  Qed.
  Next Obligation.
    destruct x as [i x]; simpl in *.
    apply support_papp. auto.
    destruct x as [i x]; simpl in *.
    apply support_papp in H. auto.
  Qed.

  Canonical Structure nom_colimit : nominal :=
    Nominal.Ob nom_colimit_type nom_colimit_eq_mixin nom_colimit_mixin.

  Program Definition nom_colimit_spoke (i:I) : ds_F DS i → nom_colimit :=
    Nominal.Hom (ds_F DS i) nom_colimit (NomColim i) _ _.
  Next Obligation.
    exists i. simpl. exists (ord_refl _ _). exists (ord_refl _ _).
    apply Nominal.eq_axiom. auto.
  Qed.

  Program Definition nom_colimit_cocone : cocone DS :=
    Cocone DS nom_colimit nom_colimit_spoke _.
  Next Obligation.
    red; simpl. intro x.
    destruct (choose_ub I i j) as [k [??]].
    exists k. simpl. exists H. exists H0.
    symmetry.
    apply (ds_compose DS i j k Hij H0 H x).
  Qed.

  Section nom_colimit_univ.
    Variable YC:cocone DS.

    Definition nom_colimit_univ_defn (x:nom_colimit) : cocone_point YC :=
      match x with
      | NomColim i x' => cocone_spoke YC i x'
      end.

    Program Definition nom_colimit_univ : nom_colimit → cocone_point YC :=
      Nominal.Hom nom_colimit (cocone_point YC) nom_colimit_univ_defn _ _.
    Next Obligation.
      destruct x as [i x].
      destruct y as [j y].
      destruct H as [k [Hk1 [Hk2 ?]]]. simpl in *.
      rewrite (cocone_commute YC i k Hk1).
      rewrite (cocone_commute YC j k Hk2).
      simpl. apply Nominal.eq_axiom. auto.
    Qed.
    Next Obligation.
      destruct x as [i x]. simpl.
      apply Nominal.equivariant.
    Qed.

    Lemma nom_colimit_commute : forall i,
      cocone_spoke YC i ≈ nom_colimit_univ ∘ nom_colimit_spoke i.
    Proof.
      intro. intro. simpl. auto.
    Qed.

    Lemma nom_colimit_uniq : forall (f:nom_colimit → YC),
      (forall i, cocone_spoke YC i ≈ f ∘ nom_colimit_spoke i) ->
      f ≈ nom_colimit_univ.
    Proof.
      simpl; intros. intro x.
      destruct x as [i x]. simpl.
      symmetry. apply H.
    Qed.
  End nom_colimit_univ.

  Definition nom_has_colimits : directed_colimit DS nom_colimit_cocone
    := DirectedColimit DS nom_colimit_cocone
         nom_colimit_univ nom_colimit_commute nom_colimit_uniq.
End nominal_directed_colimits.

(** NOMINAL has least fixpoints of continuous functors. *)
Section nominal_fixpoint.
  Variable F : functor NOMINAL NOMINAL.
  Variable HF : continuous_functor F.

  Definition fixpoint : ob NOMINAL :=
    (cont_functors.fixpoint initialized_nominal F nom_colimit_cocone).

  Definition fixpoint_initial : Alg.initial_alg NOMINAL F :=
    (cont_functors.fixpoint_initial
      initialized_nominal F nom_colimit_cocone nom_has_colimits HF).

  Definition fixpoint_iso : F fixpoint ↔ fixpoint :=
    (cont_functors.fixpoint_iso
      initialized_nominal F nom_colimit_cocone nom_has_colimits HF).

End nominal_fixpoint.

(** NOMINAL is a terminated category. *)

Program Definition nom_terminus_eq_mixin :=
  Eq.Mixin unit (fun _ _ => True) _ _ _.

Program Definition nom_terminus_mixin :=
  Nominal.Mixin unit nom_terminus_eq_mixin (fun p u => u) (fun _ => nil) _ _ _ _ _.
Next Obligation.
  apply nil_elem in H. elim H.
  apply nil_elem in H. elim H.
Qed.

Canonical Structure nom_terminus : nominal :=
  Nominal.Ob unit nom_terminus_eq_mixin nom_terminus_mixin.

Program Definition nom_terminate (A:nominal) : A → nom_terminus :=
  Nominal.Hom A nom_terminus (fun _ => tt) _ _.

Program Definition nom_terminated_mixin :=
  Terminated.Mixin
    Nominal.ob Nominal.hom
    Nominal.hom_eq_mixin
    nom_terminus nom_terminate _.
Next Obligation.
  red. simpl. intros. destruct (f x). auto.
Qed.

Canonical Structure nom_terminated :=
  Terminated
    Nominal.ob Nominal.hom
    Nominal.hom_eq_mixin
    Nominal.comp_mixin
    Nominal.category_axioms
    nom_terminated_mixin.

(**  NOMINAL is a cartesian category. *)
Program Definition nom_prod_eq_mixin (A B :nominal) :=
   Eq.Mixin (A*B) (fun x y => fst x ≈ fst y /\ snd x ≈ snd y) _ _ _.
Solve Obligations with intuition eauto.

Program Definition nom_prod_mixin (A B:nominal) :=
  Nominal.Mixin (A*B) (nom_prod_eq_mixin A B)
     (fun p xy => (p · fst xy, p · snd xy))
     (fun xy => ‖fst xy‖ ++ ‖snd xy‖)
     _ _ _ _ _.
Next Obligation.
  destruct a; split; simpl; apply nom_ident.
Qed.
Next Obligation.
  destruct a; split; simpl; apply nom_compose.
Qed.
Next Obligation.
  destruct a; destruct a'; destruct H0; split; simpl in *.
  rewrite H. rewrite H0. auto.
  rewrite H. rewrite H1. auto.
Qed.
Next Obligation.
  destruct a; split; simpl.
  apply support_axiom.
  red; simpl; intros.
  apply (H v); simpl; auto.
  apply app_elem; auto.
  apply support_axiom.
  red; simpl; intros.
  apply (H v); simpl; auto.
  apply app_elem; auto.
Qed.
Next Obligation.
  simpl.
  apply app_elem in H. apply app_elem.
  destruct H; [ left | right ].
  apply support_papp; auto.
  apply support_papp; auto.
  simpl in H.
  apply app_elem in H. apply app_elem.
  destruct H; [ left | right ].
  apply support_papp in H; auto.
  apply support_papp in H; auto.
Qed.

Canonical Structure nom_prod (A B:nominal) : nominal :=
  Nominal.Ob (A*B) (nom_prod_eq_mixin A B) (nom_prod_mixin A B).

Program Definition nom_pi1 (A B:nominal) : nom_prod A B → A :=
  Nominal.Hom (nom_prod A B) A (fun x => fst x) _ _.
Next Obligation.
  destruct H; auto.
Qed.

Program Definition nom_pi2 (A B:nominal) : nom_prod A B → B :=
  Nominal.Hom (nom_prod A B) B (fun x => snd x) _ _.
Next Obligation.
  destruct H; auto.
Qed.

Program Definition nom_pairing (C A B:nominal) (f:C → A) (g:C → B) : C → nom_prod A B
  := Nominal.Hom C (nom_prod A B) (fun c => (f c, g c)) _ _.
Next Obligation.
  split; simpl; apply Nominal.eq_axiom; auto.
Qed.
Next Obligation.
  split; simpl; apply Nominal.equivariant.
Qed.

Program Definition nom_cartesian_mixin :=
  Cartesian.Mixin
    Nominal.ob Nominal.hom
    Nominal.hom_eq_mixin
    Nominal.comp_mixin
    nom_prod nom_pi1 nom_pi2 nom_pairing
    _.
Next Obligation.
  constructor; simpl; intros.

  red; simpl; auto.
  red; simpl; auto.
  red; simpl; intro.
  split; simpl.
  rewrite <- (H x); auto.
  rewrite <- (H0 x); auto.
Qed.

Canonical Structure nom_cartesian : cartesian :=
  Cartesian
     Nominal.ob Nominal.hom
     Nominal.hom_eq_mixin
     Nominal.comp_mixin
     Nominal.category_axioms
     nom_terminated_mixin
     nom_cartesian_mixin.

(** NOMINAL is a cartesian closed category. *)

Record nom_exp_type (A B:nominal) :=
  NomExp
  { exp_map :> A -> B
  ; exp_support : finset atom
  ; exp_eq_axiom : forall x y, x ≈ y -> exp_map x ≈ exp_map y
  ; exp_support_axiom : forall (p:perm),
       (forall v, v ∈ exp_support -> v ∈ ‖p‖ -> False) ->
       (forall x, p · exp_map (p⁻¹ · x) ≈ exp_map x)
  }.

Program Definition exp_papp (A B:nominal) (p:perm) (f:nom_exp_type A B) :
  nom_exp_type A B :=
  NomExp A B
    (fun x => p · f (p⁻¹ · x))
    (List.map p (exp_support A B f))
    _ _.
Next Obligation.
  apply papp_morphism; auto.
  apply exp_eq_axiom.
  apply papp_morphism; auto.
Qed.
Next Obligation.
  cut (forall v, v ∈ (List.map p (exp_support A B f) : finset atom) -> p0 v = v).
  clear H.
  induction p0 using swap_induction'; intros.

  etransitivity. etransitivity. 2: apply IHp0.
  apply papp_morphism; auto.
  apply papp_morphism; auto.
  apply exp_eq_axiom.
  apply papp_morphism; auto.
  apply papp_morphism; auto.
  apply inv_eq; auto.
  intros. rewrite H.
  apply (H0 v); auto.
  apply papp_morphism; auto.
  rewrite nom_ident.
  apply papp_morphism; auto.
  apply exp_eq_axiom.
  rewrite nom_compose.
  apply papp_morphism; auto.
  hnf; simpl; auto.

  rewrite nom_compose.
  rewrite <- Perm.assoc.
  rewrite <- nom_compose.
  rewrite swap_commute'.
  rewrite <- nom_compose.
  set (p' := Perm.g p u ⇋ Perm.g p v).
  transitivity
    (p0 · p · p' · f (p'⁻¹ · p⁻¹ · p0⁻¹ · x)).
  apply papp_morphism. auto.
  apply papp_morphism. auto.
  apply papp_morphism. auto.
  apply exp_eq_axiom.
  rewrite (inv_compose _ _ _ _ p0).
  rewrite <- nom_compose.
  rewrite nom_compose.
  symmetry.
  rewrite nom_compose .
  apply papp_morphism; auto.
  hnf; simpl; intros.
  destruct (string_dec u x0).
  subst x0.
  destruct (string_dec (Perm.g p u) (Perm.g p u)); auto.
  elim n; auto.
  destruct (string_dec (Perm.g p u) (Perm.g p x0)); auto.
  apply Perm.g_inj in e. contradiction.
  destruct (string_dec v x0).
  destruct (string_dec (Perm.g p v) (Perm.g p x0)); auto.
  elim n1. rewrite e; auto.
  destruct (string_dec (Perm.g p v) (Perm.g p x0)); auto.
  apply Perm.g_inj in e. contradiction.

  rewrite exp_support_axiom.
  apply IHp0.
  intros.
  apply H1 in H2.
  simpl in H2.
  destruct (string_dec u v0). subst v0. auto.
  destruct (string_dec v v0). subst v0.
  rewrite H in H2. contradiction.
  auto.

  simpl; intros.
  unfold Support.support in H3. simpl in H3.
  apply cons_elem in H3.
  destruct H3.
  apply atom_strong_eq in H3.
  subst v0.
  assert (u ∈ (List.map p (exp_support A B f) : finset atom)).
    revert H2. generalize (exp_support A B f). induction c.
    intros. apply nil_elem in H2. elim H2.
    intros. apply cons_elem in H2. destruct H2.
    apply atom_strong_eq in H2. subst a.
    simpl. apply cons_elem. left.
    rewrite Perm.fg. auto.
    simpl. apply cons_elem. right.
    apply IHc; auto.

  apply H1 in H3.
  simpl in H3.
  destruct (string_dec u u).
  rewrite <- H in H3.
  apply Perm.f_inj in H3. elim H0; auto.
  elim n; auto.
  apply cons_elem in H3.
  destruct H3.
  apply atom_strong_eq in H3. subst v0.
  assert (v ∈ (List.map p (exp_support A B f) : finset atom)).
    revert H2. generalize (exp_support A B f). induction c.
    intros. apply nil_elem in H2. elim H2.
    intros. apply cons_elem in H2. destruct H2.
    apply atom_strong_eq in H2. subst a.
    simpl. apply cons_elem. left.
    rewrite Perm.fg. auto.
    simpl. apply cons_elem. right.
    apply IHc; auto.

  apply H1 in H3.
  simpl in H3.
  destruct (string_dec u v); auto.
  destruct (string_dec v v); auto.
  rewrite H in H3.
  elim n; auto.
  apply nil_elem in H3. auto.

  intros.
  destruct (Perm.support_axiom p0 v); auto.
  elim (H v); auto.
Qed.

Program Definition nom_exp_eq_mixin (A B:nominal) :=
  Eq.Mixin (nom_exp_type A B) (fun f g => forall x, f x ≈ g x) _ _ _.
Next Obligation.
  simpl; intros; rewrite H; auto.
Qed.

Canonical Structure nom_exp_eq (A B:nominal) :=
  Eq.Pack (nom_exp_type A B) (nom_exp_eq_mixin A B).

Add Parametric Morphism (A B:nominal) :
  (exp_map A B)
  with signature (eq_op (nom_exp_eq A B)) ==>
                 (eq_op (Nominal.ob_eq A)) ==>
                 (eq_op (Nominal.ob_eq B))
   as exp_map_morphism.
Proof.
  intros.
  transitivity (x y0).
  apply exp_eq_axiom. auto.
  apply H.
Qed.

Program Definition nom_exp_mixin (A B:nominal) :=
  Nominal.Mixin
  (nom_exp_type A B)
  (nom_exp_eq_mixin A B)
  (exp_papp A B)
  (exp_support A B)
  _ _ _ _ _.
Next Obligation.
  hnf. simpl; intros.
  rewrite nom_ident.
  apply exp_eq_axiom.
  transitivity (id · x).
  apply papp_morphism.
  hnf; simpl; auto. auto.
  rewrite nom_ident. auto.
Qed.
Next Obligation.
  hnf; simpl; intro; auto.
  rewrite nom_compose.
  apply papp_morphism; auto.
  apply exp_eq_axiom.
  rewrite nom_compose.
  apply papp_morphism; auto.
  symmetry. apply inv_compose.
Qed.
Next Obligation.
  hnf; simpl. intros.
  apply papp_morphism; auto.
  etransitivity.
  apply H0.
  apply exp_eq_axiom.
  apply papp_morphism; auto.
  apply inv_eq. auto.
Qed.
Next Obligation.
  hnf. simpl; intros.
  apply exp_support_axiom. auto.
Qed.
Next Obligation.
  simpl in *.
  revert H. generalize (exp_support A B x). induction c.
    intros. apply nil_elem in H. elim H.
    intros. apply cons_elem in H. destruct H.
    apply atom_strong_eq in H. subst a.
    simpl. apply cons_elem. left. auto.
    simpl. apply cons_elem. right.
    apply IHc; auto.

  simpl in *.
  revert H. generalize (exp_support A B x). induction c.
    intros. apply nil_elem in H. elim H.
    intros. apply cons_elem in H. destruct H.
    apply atom_strong_eq in H.
    apply Perm.f_inj in H. subst v.
    simpl. apply cons_elem. left. auto.
    simpl. apply cons_elem. right.
    apply IHc; auto.
Qed.

Canonical Structure nom_exp (A B:nominal) : nominal :=
  Nominal.Ob
    (nom_exp_type A B)
    (nom_exp_eq_mixin A B)
    (nom_exp_mixin A B).

Program Definition nom_curry (C A B:nominal) (f:C×A → B) : C → nom_exp A B :=
  Nominal.Hom C (nom_exp A B)
     (fun c => NomExp A B (fun a => f (c,a)) (‖c‖) _ _) _ _.
Next Obligation.
  apply Nominal.eq_axiom. split; auto.
Qed.
Next Obligation.
  rewrite <- Nominal.equivariant.
  apply Nominal.eq_axiom.
  split. simpl.
  apply support_axiom. auto.
  simpl.
  rewrite nom_compose.
  rewrite Perm.inv_id1.
  apply nom_ident.
Qed.
Next Obligation.
  hnf; simpl. intro.
  apply Nominal.eq_axiom.
  split; auto.
Qed.
Next Obligation.
  hnf; simpl. intro.
  rewrite <- Nominal.equivariant.
  apply Nominal.eq_axiom.
  split; simpl; auto.
  rewrite nom_compose.
  rewrite Perm.inv_id1.
  symmetry. apply nom_ident.
Qed.

Program Definition nom_apply (A B:nominal) : nom_exp A B × A → B :=
  Nominal.Hom (nom_exp A B × A) B (fun fx => fst fx (snd fx)) _ _.
Next Obligation.
  destruct x; destruct y; destruct H; simpl in *.
  etransitivity.
  apply H.
  apply exp_eq_axiom. auto.
Qed.
Next Obligation.
  simpl.
  apply papp_morphism. auto.
  apply exp_eq_axiom.
  rewrite nom_compose.
  rewrite Perm.inv_id2.
  apply nom_ident.
Qed.

Program Definition nom_ccc_mixin :=
  CartesianClosed.Mixin
    Nominal.ob Nominal.hom
    Nominal.hom_eq_mixin
    Nominal.comp_mixin
    Nominal.category_axioms
    nom_terminated_mixin
    nom_cartesian_mixin
    nom_exp nom_curry nom_apply
    _.
Next Obligation.
  constructor; simpl; intros.
  red; simpl; intros.
  destruct x; simpl. auto.
  red; simpl; intros.
  red. simpl. intros.
  etransitivity. 2: apply H.
  simpl. auto.
Qed.

Canonical Structure nom_ccc : cartesian_closed :=
  CartesianClosed
     Nominal.ob Nominal.hom
     Nominal.hom_eq_mixin
     Nominal.comp_mixin
     Nominal.category_axioms
     nom_cartesian_mixin
     nom_terminated_mixin
     nom_ccc_mixin.

(** Atom binding construct. *)

Inductive binding_ty (A:nominal) :=
  | bind : atom -> A -> binding_ty A.

Notation "'ν' x , t" := (bind _ x t) (at level 50, format "'ν'  x ,  t").

Definition binding_equiv (A:nominal) (x y:binding_ty A) :=
  let (v, x') := x in
  let (w, y') := y in
    exists u:atom, u ∉ (v :: w :: ‖x'‖ ++ ‖y'‖ : finset atom) /\
      u ⇋ v · x' ≈ u ⇋ w · y'.

Lemma binding_equiv_forall (A:nominal) (x y:binding_ty A) (avoid : finset atom):
  binding_equiv A x y <->
  let (v,x') := x in
  let (w,y') := y in
  forall u,
      u ∉ (v :: w :: ‖x'‖ ++ ‖y'‖ : finset atom) ->
      u ∉ avoid ->
      u ⇋ v · x' ≈ u ⇋ w · y'.
Proof.
  split; intros.
  destruct x as [v x].
  destruct y as [w y].
  intros.
  destruct H as [q [??]].
  destruct (string_dec q u). subst q.
  auto.

  rewrite <- (support_axiom A (u ⇋ q) x).
  rewrite <- (support_axiom A (u ⇋ q) y).
  rewrite (Perm.swap_swap u v).
  rewrite (Perm.swap_swap u w).
  repeat rewrite nom_compose.
  rewrite Perm.swap_swizzle; auto.
  rewrite <- nom_compose.
  rewrite Perm.swap_swizzle; auto.
  rewrite <- nom_compose.
  rewrite (Perm.swap_swap v q).
  apply papp_morphism; auto.
  rewrite (Perm.swap_swap w q).
  auto.
  intro. subst w.
  apply H0.
  apply cons_elem. right.
  apply cons_elem. auto.
  intro. subst w.
  apply H.
  apply cons_elem. right.
  apply cons_elem. auto.
  intro. subst v.
  apply H0.
  apply cons_elem. auto.
  intro. subst v.
  apply H.
  apply cons_elem. auto.
  rename H1 into Havoid.
  red. simpl; intros.
  unfold Support.support in H3. simpl in H3.
  apply cons_elem in H3. destruct H3.
  apply atom_strong_eq in H3. subst v0.
  apply H0.
  apply cons_elem. right.
  apply cons_elem. right.
  apply app_elem; auto.
  apply cons_elem in H3. destruct H3.
  apply atom_strong_eq in H3. subst v0.
  apply H.
  apply cons_elem. right.
  apply cons_elem. right.
  apply app_elem; auto.
  apply nil_elem in H3; auto.

  rename H1 into Havoid.
  red; simpl; intros.
  unfold Support.support in H3. simpl in H3.
  apply cons_elem in H3. destruct H3.
  apply atom_strong_eq in H3. subst v0.
  apply H0.
  apply cons_elem. right.
  apply cons_elem. right.
  apply app_elem; auto.
  apply cons_elem in H3. destruct H3.
  apply atom_strong_eq in H3. subst v0.
  apply H.
  apply cons_elem. right.
  apply cons_elem. right.
  apply app_elem; auto.
  apply nil_elem in H3; auto.

  red.
  destruct x as [u x].
  destruct y as [w y].
  exists (fresh_atom (u::w::‖x‖++‖y‖++ avoid)).
  split.
  apply fresh_atom_is_fresh'.
  hnf; simpl; intros.
    apply cons_elem in H0. destruct H0. apply atom_strong_eq in H0.
    subst u. apply cons_elem; auto.
    apply cons_elem; right.
    apply cons_elem in H0. destruct H0. apply atom_strong_eq in H0.
    subst w.
    apply cons_elem. auto.
    apply cons_elem; right.
    apply app_elem in H0.
    destruct H0.
    apply app_elem; auto.
    apply app_elem; right.
    apply app_elem; auto.

  apply H; apply fresh_atom_is_fresh'.
  hnf; simpl; intros.
    apply cons_elem in H0. destruct H0. apply atom_strong_eq in H0.
    subst u. apply cons_elem; auto.
    apply cons_elem; right.
    apply cons_elem in H0. destruct H0. apply atom_strong_eq in H0.
    subst w.
    apply cons_elem. auto.
    apply cons_elem; right.
    apply app_elem in H0.
    destruct H0.
    apply app_elem; auto.
    apply app_elem; right.
    apply app_elem; auto.
  hnf; simpl; intros.
    apply cons_elem; right.
    apply cons_elem; right.
    apply app_elem; right.
    apply app_elem; right.
    auto.
Qed.

Program Definition binding_eq_mixin (A:nominal) : Eq.mixin_of (binding_ty A) :=
  Eq.Mixin (binding_ty A) (binding_equiv A) _ _ _.
Next Obligation.
  apply binding_equiv_forall with nil.
  destruct x as [v x']. intros. auto.
Qed.
Next Obligation.
  apply binding_equiv_forall with nil.
  destruct x as [v x'].
  destruct y as [w y'].
  intros. clear H1.
  apply binding_equiv_forall with (avoid:=nil) in H.
  symmetry. apply H.
  intro. apply H0.
  apply cons_elem in H1. destruct H1.
  apply cons_elem. right.
  apply cons_elem. auto.
  apply cons_elem in H1. destruct H1.
  apply cons_elem. auto.
  apply app_elem in H1.
  apply cons_elem. right.
  apply cons_elem. right.
  apply app_elem; intuition.
  intro. apply nil_elem in H1; auto.
Qed.
Next Obligation.
  unfold binding_equiv in *.
  destruct x as [v x'].
  destruct y as [w y'].
  destruct z as [u z'].
  destruct H as [q1 [??]].
  destruct H0 as [q2 [??]].
  destruct (string_dec q1 q2).
  subst q2.
  exists q1. intuition.
  apply cons_elem in H3; destruct H3.
  apply H. apply cons_elem; auto.
  apply cons_elem in H3; destruct H3.
  apply H0.
  apply cons_elem. right. apply cons_elem. left. auto.
  apply app_elem in H3. destruct H3.
  apply H.
  apply cons_elem. right. apply cons_elem. right.
  apply app_elem; auto.
  apply H0.
  apply cons_elem. right. apply cons_elem. right.
  apply app_elem; auto.
  rewrite H1. auto.

  set (atoms := (q1 :: q2 :: u :: v :: w ::‖x'‖++‖y'‖++‖z'‖)).
  set (q := fresh_atom atoms).
  exists q.
  split.
  intro.
  intros.
  eapply fresh_atom_is_fresh'.
  2: unfold q in H3; apply H3.
  unfold atoms.
    hnf; simpl; intros.
    apply cons_elem in H4. destruct H4.
    apply cons_elem. right.
    apply cons_elem. right.
    apply cons_elem. right.
    apply cons_elem. auto.
    apply cons_elem in H4. destruct H4.
    apply cons_elem. right.
    apply cons_elem. right.
    apply cons_elem. auto.
    apply app_elem in H4. destruct H4.
    apply cons_elem. right.
    apply cons_elem. right.
    apply cons_elem. right.
    apply cons_elem. right.
    apply cons_elem. right.
    apply app_elem; auto.
    apply cons_elem. right.
    apply cons_elem. right.
    apply cons_elem. right.
    apply cons_elem. right.
    apply cons_elem. right.
    apply app_elem. right.
    apply app_elem. auto.

  assert (Hqu: q <> u).
    intro.
    apply (fresh_atom_is_fresh atoms).
    fold q. rewrite H3.
    unfold atoms.
    apply cons_elem. right.
    apply cons_elem. right.
    apply cons_elem. auto.
  assert (Hqq2: q <> q2).
    intro.
    apply (fresh_atom_is_fresh atoms).
    fold q. rewrite H3.
    unfold atoms.
    apply cons_elem. right.
    apply cons_elem. auto.
  assert (Huq2 : u <> q2).
    intro.
    apply H0. rewrite H3.
    apply cons_elem. right.
    apply cons_elem. auto.
  assert (Hqw: q <> w).
    intro.
    apply (fresh_atom_is_fresh atoms).
    fold q. rewrite H3.
    unfold atoms.
    apply cons_elem. right.
    apply cons_elem. right.
    apply cons_elem. right.
    apply cons_elem. right.
    apply cons_elem. auto.
  assert (Hwq2: w <> q2).
    intro. apply H0. rewrite H3.
    apply cons_elem. auto.
  assert (Hqv : q <> v).
    intro.
    apply (fresh_atom_is_fresh atoms).
    fold q. rewrite H3.
    unfold atoms.
    apply cons_elem. right.
    apply cons_elem. right.
    apply cons_elem. right.
    apply cons_elem. auto.
  assert (Hqq1 : q <> q1).
    intro.
    apply (fresh_atom_is_fresh atoms).
    fold q. rewrite H3.
    unfold atoms.
    apply cons_elem. auto.
  assert (Hvq1 : v <> q1).
    intro.
    apply H. rewrite H3.
    apply cons_elem. auto.
  assert (Hwq1 : w <> q1).
    intro. apply H. rewrite H3.
    apply cons_elem. right.
    apply cons_elem. auto.

  rewrite <- (support_axiom A (q ⇋ q1) x').
  rewrite (Perm.swap_swap q v).
  rewrite nom_compose.
  rewrite Perm.swap_swizzle; auto.
  rewrite <- nom_compose.
  rewrite (Perm.swap_swap v q1).
  rewrite H1.
  rewrite (Perm.swap_swap q1 w).
  rewrite nom_compose.
  rewrite <- Perm.swap_swizzle; auto.
  rewrite <- nom_compose.
  rewrite (support_axiom A (q ⇋ q1) y').
  rewrite <- (support_axiom A (q ⇋ q2) y').
  rewrite nom_compose.
  rewrite Perm.swap_swizzle; auto.
  rewrite <- nom_compose.
  rewrite (Perm.swap_swap w q2).
  rewrite H2.
  rewrite (Perm.swap_swap q2 u).
  rewrite nom_compose.
  rewrite <- Perm.swap_swizzle; auto.
  rewrite <- nom_compose.
  rewrite (support_axiom A (q ⇋ q2) z').
  rewrite (Perm.swap_swap u q). auto.

  red; simpl; intros.
    unfold Support.support in H4. simpl in H4.
    apply cons_elem in H4. destruct H4.
    apply atom_strong_eq in H4. subst v0.
    apply (fresh_atom_is_fresh atoms).
    fold q.
    unfold atoms.
    apply cons_elem. right.
    apply cons_elem. right.
    apply cons_elem. right.
    apply cons_elem. right.
    apply cons_elem. right.
    apply app_elem. right.
    apply app_elem. right.
    auto.
    apply cons_elem in H4. destruct H4.
    apply atom_strong_eq in H4. subst v0.
    apply H0.
    apply cons_elem. right.
    apply cons_elem. right.
    apply app_elem. right.
    auto.
    apply nil_elem in H4. auto.

  red; simpl; intros.
    unfold Support.support in H4. simpl in H4.
    apply cons_elem in H4. destruct H4.
    apply atom_strong_eq in H4. subst v0.
    apply (fresh_atom_is_fresh atoms).
    fold q.
    unfold atoms.
    apply cons_elem. right.
    apply cons_elem. right.
    apply cons_elem. right.
    apply cons_elem. right.
    apply cons_elem. right.
    apply app_elem. right.
    apply app_elem. auto.
    apply cons_elem in H4. destruct H4.
    apply atom_strong_eq in H4. subst v0.
    apply H0.
    apply cons_elem. right.
    apply cons_elem. right.
    apply app_elem. auto.
    apply nil_elem in H4. auto.

  red; simpl; intros.
    unfold Support.support in H4. simpl in H4.
    apply cons_elem in H4. destruct H4.
    apply atom_strong_eq in H4. subst v0.
    apply (fresh_atom_is_fresh atoms).
    fold q.
    unfold atoms.
    apply cons_elem. right.
    apply cons_elem. right.
    apply cons_elem. right.
    apply cons_elem. right.
    apply cons_elem. right.
    apply app_elem. right.
    apply app_elem. auto.
    apply cons_elem in H4. destruct H4.
    apply atom_strong_eq in H4. subst v0.
    apply H.
    apply cons_elem. right.
    apply cons_elem. right.
    apply app_elem. auto.
    apply nil_elem in H4. auto.

  red; simpl; intros.
    unfold Support.support in H4. simpl in H4.
    apply cons_elem in H4. destruct H4.
    apply atom_strong_eq in H4. subst v0.
    apply (fresh_atom_is_fresh atoms).
    fold q.
    unfold atoms.
    apply cons_elem. right.
    apply cons_elem. right.
    apply cons_elem. right.
    apply cons_elem. right.
    apply cons_elem. right.
    apply app_elem. auto.
    apply cons_elem in H4. destruct H4.
    apply atom_strong_eq in H4. subst v0.
    apply H.
    apply cons_elem. right.
    apply cons_elem. right.
    apply app_elem. auto.
    apply nil_elem in H4. auto.
Qed.

Canonical Structure binding_eq (A:nominal) :=
  Eq.Pack (binding_ty A) (binding_eq_mixin A).

Definition binding_papp (A:nominal) (p:perm) (x:binding_ty A) :=
  match x with
  | ν a, x' => ν (p a), (p·x')
  end.

Definition binding_support (A:nominal) (x:binding_ty A) :=
  match x with
  | ν a, x' => finset_remove atom_dec (‖x'‖) a
  end.

Program Definition binding_nominal_mixin (A:nominal) :=
  Nominal.Mixin
    (binding_ty A)
    (binding_eq_mixin A)
    (binding_papp A)
    (binding_support A)
    _ _ _ _ _.
Next Obligation.
  red; simpl.
  destruct a as [v a]; simpl.
  set (u := fresh_atom (v::‖a‖)).
  exists u. split.
  apply (fresh_atom_is_fresh').
  hnf; simpl; intros.
  apply cons_elem.
  apply cons_elem in H. destruct H; auto.
  apply cons_elem in H. destruct H; auto.
  apply app_elem in H.
  destruct H; auto.
  right.
  apply (support_papp _ id). auto.
  rewrite nom_ident. auto.
Qed.
Next Obligation.
  unfold binding_papp. destruct a; simpl.
  red. simpl.
  set (u := fresh_atom ((p1 (p2 c)) :: p1 (p2 c) ::
               ‖p1 · p2 · c0‖ ++ ‖(p1 ∘ p2) · c0‖)).
  exists u. split.
  apply fresh_atom_is_fresh.
  rewrite <- nom_compose. auto.
Qed.
Next Obligation.
  apply binding_equiv_forall with (avoid := nil).
  hnf; simpl. destruct a as [u a]. destruct a' as [v b].
  simpl.
  intros w ? _.
  rewrite <- H.
  rewrite <- H.

  destruct H0 as [q [??]].

  rewrite nom_compose.

  replace w with (p (p⁻¹ w)).
  rewrite swap_commute.
  rewrite <- nom_compose.
  symmetry.
  rewrite nom_compose.
  rewrite swap_commute.
  rewrite <- nom_compose.
  symmetry.
  destruct (string_dec (p⁻¹ w) q).
  rewrite e.
  rewrite H2; auto.

  rewrite (Perm.swap_swap (p⁻¹ w) u).
  rewrite <- (support_axiom A (p⁻¹ w ⇋ q) a).
  rewrite nom_compose.
  rewrite nom_compose.
  rewrite <- Perm.assoc.
  rewrite <- nom_compose.
  rewrite Perm.swap_swizzle; auto.

  symmetry.
  rewrite <- (support_axiom A (p⁻¹ w ⇋ q) b).
  rewrite (Perm.swap_swap (p⁻¹  w) v).
  rewrite nom_compose.
  rewrite nom_compose.
  rewrite <- Perm.assoc.
  rewrite <- nom_compose.
  rewrite Perm.swap_swizzle; auto.
  rewrite <- nom_compose.
  rewrite <- nom_compose.
  rewrite (Perm.swap_swap v q).
  rewrite (Perm.swap_swap u q).
  rewrite H2. auto.
  intro.
  apply H1.
  apply cons_elem. right.
  apply cons_elem. left.
  rewrite <- H.
  rewrite <- H3.
  simpl.
  rewrite Perm.fg. auto.
  intro. subst v.
  apply H0.
  apply cons_elem. right.
  apply cons_elem. left. auto.

  red; simpl; intros.
  unfold Support.support in H4. simpl in H4.
  apply cons_elem in H4. destruct H4.
  apply atom_strong_eq in H4. subst v0.
  apply H1.
  apply cons_elem. right.
  apply cons_elem. right.
  apply app_elem.
  right.
  rewrite <- (Perm.fg p w).
  rewrite H.
  apply support_papp.   auto.
  apply cons_elem in H4. destruct H4.
  apply atom_strong_eq in H4. subst v0.
  apply H0.
  apply cons_elem. right.
  apply cons_elem. right.
  apply app_elem; auto.
  apply nil_elem in H4; auto.

  intro.
  apply H1.
  apply cons_elem. left.
  rewrite <- H3.
  simpl.
  rewrite Perm.fg. auto.
  intro. subst q.
  apply H0.
  apply cons_elem; auto.

  red; simpl. intros.
  unfold Support.support in H4. simpl in H4.
  apply cons_elem in H4.
  destruct H4.
  apply atom_strong_eq in H4. subst v0.
  apply H1.
  apply cons_elem. right.
  apply cons_elem. right.
  apply app_elem; auto.
  left.
  rewrite <- (Perm.fg p w).
  apply support_papp. auto.
  apply cons_elem in H4.
  destruct H4.
  apply atom_strong_eq in H4. subst v0.
  apply H0.
  apply cons_elem. right.
  apply cons_elem. right.
  apply app_elem; auto.
  apply nil_elem in H4. auto.
  simpl.
  apply Perm.fg.
Qed.
Next Obligation.
  destruct a as [u a]; simpl.
  hnf; simpl.
  set (atoms := p u :: u :: ‖p·a‖ ++ ‖a‖ ++ ‖p‖).
  set (w := fresh_atom atoms).
  exists w.
  split. apply fresh_atom_is_fresh'.
  unfold atoms.
    hnf; simpl; intros.
    apply cons_elem in H0; destruct H0.
    apply cons_elem. auto.
    apply cons_elem in H0; destruct H0.
    apply cons_elem. right.
    apply cons_elem. auto.
    apply app_elem in H0. destruct H0.
    apply cons_elem. right.
    apply cons_elem. right.
    apply app_elem. auto.
    apply cons_elem. right.
    apply cons_elem. right.
    apply app_elem. right.
    apply app_elem. auto.

  rewrite nom_compose.
  assert (w = p (p⁻¹ w)).
  symmetry. apply Perm.fg.
  pattern w at 1. rewrite H0.
  rewrite swap_commute.
  simpl.
  simpl in H.
  rewrite <- nom_compose.
  destruct (Perm.support_axiom p w).
  elimtype False.
  eapply fresh_atom_is_fresh'.
  2: unfold w in H1; apply H1.
  unfold atoms.
    hnf; simpl; intros.
    apply cons_elem. right.
    apply cons_elem. right.
    apply app_elem. right.
    apply app_elem. auto.

  rewrite (support_axiom A p).
  rewrite <- H1 at 1.
  rewrite Perm.gf. auto.

  red; simpl; intros.
  rewrite <- H1 in H2.
  rewrite Perm.gf in H2.

  assert ((w ⇋ u) v ∈ ‖a‖).
  apply <- (support_papp A (w ⇋ u)).
  generalize (Perm.swap_self_inv w u v).
  simpl. intros. rewrite H4. auto.

  simpl in H4.
  destruct (string_dec w v).
  subst v.

  elimtype False.
  eapply fresh_atom_is_fresh'.
  2: unfold w in H3; apply H3.
  unfold atoms.
    hnf; simpl; intros.
    apply cons_elem. right.
    apply cons_elem. right.
    apply app_elem. right.
    apply app_elem. auto.

  destruct (string_dec u v).
  eapply fresh_atom_is_fresh'.
  2: unfold w in H4; apply H4.
  unfold atoms.
    hnf; simpl; intros.
    apply cons_elem. right.
    apply cons_elem. right.
    apply app_elem. right.
    apply app_elem. auto.

  apply (H v); auto.
  apply finset_remove_elem.
  split; auto.
  intro. apply atom_strong_eq in H5. elim n0; auto.
Qed.
Next Obligation.
  unfold binding_support in *. destruct x as [u x]; simpl in *.
  apply finset_remove_elem in H. destruct H.
  apply finset_remove_elem. split.
  apply support_papp. auto.
  intro. apply H0.
  apply atom_strong_eq in H1.
  apply Perm.f_inj in H1. subst v; auto.

  unfold binding_support in *. destruct x as [u x]; simpl in *.
  apply finset_remove_elem in H. destruct H.
  apply finset_remove_elem. split.
  apply support_papp in H. auto.
  intro. apply H0.
  apply atom_strong_eq in H1. subst v. auto.
Qed.

Canonical Structure binding (A:nominal) : nominal :=
  Nominal.Ob (binding_ty A) (binding_eq_mixin A) (binding_nominal_mixin A).

(**  [binding] induces an endofunctor on NOMINAL. *)

Definition binding_fmap_defn (A B:nominal) (f:A → B)
  (x:binding A) : binding B :=
  match x with
  | ν a, x' => ν a, (f x')
  end.

Program Definition binding_fmap (A B:nominal) (f:A → B) : binding A → binding B :=
  Nominal.Hom (binding A) (binding B) (binding_fmap_defn A B f) _ _.

Next Obligation.
  red; simpl; intros.
  destruct x as [u x].
  destruct y as [v y].

  apply binding_equiv_forall with (avoid := ‖x‖ ++ ‖y‖).
  simpl. intros w ? Havoid.

  rewrite (binding_equiv_forall A (ν u, x) (ν v, y) nil) in H.
  simpl in H.
  rewrite <- Nominal.equivariant.
  rewrite <- Nominal.equivariant.
  apply Nominal.eq_axiom.
  apply (H w). intro.
  apply cons_elem in H1. destruct H1.
  apply H0. apply cons_elem; auto.
  apply cons_elem in H1. destruct H1.
  apply H0. apply cons_elem. right. apply cons_elem; auto.
  contradiction.
  intro. apply nil_elem in H1. auto.
Qed.
Next Obligation.
  apply binding_equiv_forall with (avoid := nil).
  destruct x as [v x]. simpl. intros u ? ?.
  rewrite Nominal.equivariant. auto.
Qed.

Lemma binding_fmap_ident (A:nominal) :
  binding_fmap A A id(A) ≈ id(binding A).
Proof.
  hnf; simpl. intros [u x]; simpl. auto.
Qed.

Lemma binding_fmap_compose (A B C:nominal) f g :
  binding_fmap B C f ∘ binding_fmap A B g ≈ binding_fmap A C (f ∘ g).
Proof.
  hnf; simpl. intros [u x]; simpl. auto.
Qed.

Lemma binding_fmap_respects (A B:nominal) (f f':A → B) :
  f ≈ f' -> binding_fmap A B f ≈ binding_fmap A B f'.
Proof.
  repeat intro. destruct x as [u x]. simpl.
  apply binding_equiv_forall with (avoid := nil).
  intros. apply papp_morphism; auto.
Qed.

Program Definition bindingF : functor NOMINAL NOMINAL :=
  Functor NOMINAL NOMINAL
     binding binding_fmap _ _ _.
Next Obligation.
  etransitivity. 2: apply binding_fmap_ident.
  apply binding_fmap_respects. auto.
Qed.
Next Obligation.
  symmetry.
  etransitivity. apply binding_fmap_compose.
  apply binding_fmap_respects. auto.
Qed.
Next Obligation.
  apply binding_fmap_respects. auto.
Qed.

(*
Program Definition binding_eq_dec (A:nominal)
  (H:eq_dec (NOMINAL.ob_eq A)) : eq_dec (NOMINAL.ob_eq (binding A)) :=
  EqDec _ _.
Next Obligation.
  destruct x as [v x].
  destruct y as [w y].
  set (u := fresh_atom (v::w::support x ++ support y)).
  set (x' := PERM.swap u v · x).
  set (y' := PERM.swap u w · y).
  destruct (@eqdec _ H x' y').
  left. hnf. exists u. split; auto.
  apply fresh_atom_is_fresh.

  right.
  intros [u' [??]].
  destruct (string_dec u u').
  subst u'. elim n; auto.
  rename n0 into Huu'.

  apply n; clear n.
  subst x' y'.
  rewrite (PERM.swap_swap u v).
  rewrite (PERM.swap_swap u w).
  transitivity (PERM.swap v u · PERM.swap u u' · x).
  rewrite (support_axiom A (PERM.swap u u') x). auto.
  simpl; intros.
  destruct (string_dec u v0). subst v0.
  elimtype False.
  eapply fresh_atom_is_fresh'.
  2: unfold u in H2; apply H2.
  hnf; intros.
  apply cons_elem. right.
  apply cons_elem. right.
  apply app_elem; auto.
  destruct (string_dec u' v0). subst v0.
  elim H0.
  apply cons_elem. right.
  apply cons_elem. right.
  apply app_elem; auto.
  auto.

  assert (Huw : u <> w).
     intro.
     apply (fresh_atom_is_fresh (v::w::support x ++ support y)).
     fold u. rewrite H2.
     apply cons_elem. right.
     apply cons_elem. auto.

  assert (Hwu' : w <> u').
     intro. subst u'.
     apply H0.
     apply cons_elem. right.
     apply cons_elem. auto.

  assert (Huv : u <> v).
     intro.
     apply (fresh_atom_is_fresh (v::w::support x ++ support y)).
     fold u. rewrite H2.
     apply cons_elem. auto.

  assert (Hvu' : v <> u').
     intro.
     apply H0. subst u'.
     apply cons_elem. auto.

  rewrite nom_compose.
  rewrite PERM.swap_swizzle; auto.
  rewrite <- nom_compose.
  rewrite (PERM.swap_swap v u').
  rewrite H1.
  rewrite (PERM.swap_swap u' w).
  rewrite nom_compose.
  rewrite <- PERM.swap_swizzle; auto.
  rewrite <- nom_compose.
  rewrite (support_axiom A (PERM.swap u u') y). auto.
  simpl; intros.
  destruct (string_dec u v0).
  subst v0.
  elimtype False.
  eapply fresh_atom_is_fresh'.
  2: unfold u in H2; apply H2.
  hnf; intros.
  apply cons_elem. right.
  apply cons_elem. right.
  apply app_elem; auto.
  destruct (string_dec u' v0). subst v0.
  elim H0.
  apply cons_elem. right.
  apply cons_elem. right.
  apply app_elem; auto.
  auto.
Defined.

Program Definition atom_nom_mixin : NOMINAL.mixin_of atom (Preord.ord_eq atom) :=
  NOMINAL.Mixin atom _ PERM.perm_f (fun x => x::nil) _ _ _ _ _.
Next Obligation.
  rewrite H.
  apply atom_strong_eq in H0. subst a. auto.
Qed.
Next Obligation.
  rewrite H; auto.
  apply cons_elem; auto.
Qed.
Next Obligation.
  apply cons_elem in H.
  destruct H.
  apply atom_strong_eq in H. subst v.
  apply cons_elem; auto.
  apply nil_elem in H. elim H.
  apply cons_elem in H.
  destruct H.
  apply atom_strong_eq in H.
  apply PERM.f_inj in H. subst v.
  apply cons_elem; auto.
  apply nil_elem in H. elim H.
Qed.

Canonical Structure atom_nom : nominal :=
  NOMINAL.Ob atom _ atom_nom_mixin.

Goal (bind atom_nom "a" "a" ≈ bind atom_nom "b" "b").
Proof.
  set (x :=
    if binding_eq_dec atom_nom (PREORD_EQ_DEC _ atom_dec)
    (bind atom_nom "a" "a") (bind atom_nom "b" "b")
    then true else false).
  cut (x = true -> bind atom_nom "a" "a" ≈ bind atom_nom "b" "b").
  intros. apply H.
  reflexivity.
  unfold x.
  destruct (binding_eq_dec atom_nom (PREORD_EQ_DEC _ atom_dec)
    (bind atom_nom "a" "a") (bind atom_nom "b" "b")).
  auto. intro. discriminate H.
Qed.

Goal (bind atom_nom "a" "a" ≉ bind atom_nom "b" "c").
Proof.
  set (x :=
    if binding_eq_dec atom_nom (PREORD_EQ_DEC _ atom_dec)
    (bind atom_nom "a" "a") (bind atom_nom "b" "c")
    then true else false).
  cut (x = false -> bind atom_nom "a" "a" ≉ bind atom_nom "b" "c").
  intros. apply H.
  reflexivity.
  unfold x.
  destruct (binding_eq_dec atom_nom (PREORD_EQ_DEC _ atom_dec)
    (bind atom_nom "a" "a") (bind atom_nom "b" "c")).
  intro. discriminate.
  auto.
Qed.

Goal (bind atom_nom "a" "c" ≈ bind atom_nom "b" "c").
Proof.
  set (x :=
    if binding_eq_dec atom_nom (PREORD_EQ_DEC _ atom_dec)
    (bind atom_nom "a" "c") (bind atom_nom "b" "c")
    then true else false).
  cut (x = true -> bind atom_nom "a" "c" ≈ bind atom_nom "b" "c").
  intros. apply H.
  reflexivity.
  unfold x.
  destruct (binding_eq_dec atom_nom (PREORD_EQ_DEC _ atom_dec)
    (bind atom_nom "a" "c") (bind atom_nom "b" "c")).
  intro. auto.
  intro. discriminate.
Qed.

*)


(**********************************************************************)
(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
(**********************************************************************)

(**********************************************************************)
(*               Intensional Lambda Calculus                          *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation of            *)
(* Lambda Calculus from Project Coq                                   *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                           Cube.v                                   *)
(*                                                                    *)
(* adapted from Cube.v for Lambda Calculus                            *)
(*                                                                    *)
(*                          Barry Jay                                 *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith.
Require Import Lambda.Terms.
Require Import Lambda.General.
Require Import Lambda.Reduction.
Require Import Lambda.Redexes.
Require Import Lambda.Test.
Require Import Lambda.Substitution.
Require Import Lambda.Residuals.

(*****************)
(* Prism Theorem *)
(*****************)

(* Auxiliary notion : compat
   Used to generate the right simultaneous induction on U, V and W *)

(* (compat U V W) iff U,V,W are compatible markings, and (sub V U) *)
Inductive compat : redexes -> redexes -> redexes -> Prop :=
  | Compat_Var : forall i, compat (Var i) (Var i) (Var i)
  | Compat_Ap1 :
      forall U1 V1 W1 : redexes,
      compat U1 V1 W1 ->
      forall U2 V2 W2 : redexes,
      compat U2 V2 W2 ->
      forall (b : bool), compat (Ap false U1 U2) (Ap false V1 V2) (Ap b W1 W2)
  | Compat_Ap2 :
      forall U1 V1 W1 ,
      compat U1 V1 W1 ->
      forall U2 V2 W2 : redexes,
      compat U2 V2 W2 ->
      forall (b b' : bool),
      compat (Ap true (Fun U1) U2) (Ap b (Fun V1) V2) (Ap b' (Fun W1) W2)
  | Compat_Fun :
      forall U V W, compat U V W -> compat (Fun U) (Fun V) (Fun W)
.

Hint Resolve Compat_Var Compat_Ap1 Compat_Ap2 Compat_Fun.

Lemma compat_intro :
 forall U W WU : redexes,
 residuals W U WU ->
 forall (V WV : redexes) (R2 : residuals W V WV) (S : sub V U), compat U V W.
Proof.
(* Remark use of name R2 for uniform command below *)
simple induction 1; intros; generalize S; inversion_clear R2; intros;
 inversion_clear S; split_all; eauto.

inversion_clear S0.  eapply2 Compat_Ap1.
inversion_clear S0.
inversion_clear S0. eapply2 Compat_Fun.
inversion_clear S0.
inversion_clear H6. gen_inv H4 H8. subst. eapply2 Compat_Ap2. inversion H12; split_all. eapply2 H1.

inversion S0; subst; split_all.
inversion H11; subst.
inversion H4; subst.
eapply2 Compat_Ap2.

inversion H6; subst.
inversion S0; subst. inversion H12; subst.
eapply2 Compat_Ap2.

inversion H6; subst.
inversion S0; subst. inversion H12; subst.
eapply2 Compat_Ap2.
Qed.

Lemma prism0 :
 forall U V W : redexes,
 compat U V W ->
 forall (UV : redexes) (R1 : residuals U V UV) (WU WV : redexes)
   (R2 : residuals W U WU) (R3 : residuals W V WV),
 residuals WV UV WU.
Proof.
simple induction 1;
try (intros; inversion_clear R1; inversion_clear R2; inversion_clear R3; eauto; fail).
intros.
gen3_case R1 R2 R3 b.

inversion_clear R1; inversion_clear R2; inversion_clear R3; auto.
unfold subst_r. eapply2 residuals_subst_rec.

inversion_clear R1; inversion_clear R2; inversion_clear R3; auto.
inversion_clear H4; inversion_clear H8; auto.
Qed.

(* Remark - It should be possible to get rid of auxiliary compat
   and to combine prism0 with compat_intro in one lemma *)

(*****************************************************************)
(* Theorem prism : (U,V,W:redexes)(sub V U) ->                   *)
(*     (UV:redexes)(residuals U V UV) ->                         *)
(*     (WV:redexes)(residuals W V WV) ->                         *)
(*     (WU:redexes)(residuals W U WU) <-> (residuals WV UV WU).  *)
(*****************************************************************)

Lemma prism1 :
 forall U V W : redexes,
 sub V U ->
 forall UV : redexes,
 residuals U V UV ->
 forall WV : redexes,
 residuals W V WV ->
 forall WU : redexes, residuals W U WU -> residuals WV UV WU.
Proof.
intros; apply prism0 with U V W; auto.
apply compat_intro with WU WV; trivial.
Qed.

(* Converse of prism1 but needs regularity of U *)
Lemma prism2 :
 forall U V W : redexes,
 sub V U ->
 regular U ->
 forall UV : redexes,
 residuals U V UV ->
 forall WV : redexes,
 residuals W V WV ->
 forall WU : redexes, residuals WV UV WU -> residuals W U WU.
Proof.
intros.
elim (residuals_intro W U); trivial.
intros WU' R; elim (residuals_function WV UV WU) with WU'; trivial.
apply prism1 with U V W; trivial.
apply comp_trans with V.
apply residuals_comp with WV; trivial.
apply comp_sym; apply residuals_comp with UV; trivial.
Qed.

Theorem prism :
 forall U V W : redexes,
 sub V U ->
 forall UV : redexes,
 residuals U V UV ->
 forall WV : redexes,
 residuals W V WV ->
 forall WU : redexes, residuals W U WU <-> regular U /\ residuals WV UV WU.
Proof.
intros; unfold iff in |- *; split.
intro; split.
apply residuals_regular with W WU; trivial.
apply prism1 with U V W; trivial.
simple induction 1; intros; apply prism2 with V UV WV; trivial.
Qed.

(**************************************************************************)
(*  Levy's cube lemma :                                                   *)
(*  (U,V,UV,VU:redexes)  (residuals U V UV) -> (residuals V U VU) ->      *)
(*  (W,WU,WV,WUV:redexes)(residuals W U WU) -> (residuals WU VU WUV) ->   *)
(*                       (residuals W V WV) -> (residuals WV UV WUV).     *)
(**************************************************************************)

Lemma cube :
 forall U V UV VU : redexes,
 residuals U V UV ->
 residuals V U VU ->
 forall W WU WV WUV : redexes,
 residuals W U WU ->
 residuals WU VU WUV -> residuals W V WV -> residuals WV UV WUV.
Proof.
intros.
cut (comp U V).
2: apply residuals_comp with UV; trivial.
intro C; elim (union_defined U V C); intros T UVT.
apply prism1 with T V W; trivial.
apply union_r with U; trivial.
apply preservation with U; trivial.
apply prism2 with U VU WU; trivial.
apply union_l with V; trivial.
apply union_preserve_regular with U V; trivial.
apply residuals_regular with V VU; trivial.
apply residuals_regular with U UV; trivial.
apply preservation with V; trivial.
apply union_sym; trivial.
Qed.

(* 3-dimensional paving diagram *)
Lemma paving :
 forall U V W WU WV : redexes,
 residuals W U WU ->
 residuals W V WV ->
 exists UV : redexes,
   (exists VU : redexes,
      (exists WUV : redexes, residuals WU VU WUV /\ residuals WV UV WUV)).
Proof.
intros; elim (residuals_intro U V).
intros UV R1; exists UV.
elim (residuals_intro V U).
intros VU R2; exists VU.
elim (residuals_intro WU VU).
intros WUV R3; exists WUV.
split; trivial.
apply cube with U V VU W WU; trivial.
apply mutual_residuals_comp with U W V; trivial.
apply residuals_preserve_regular with V U; trivial.
apply residuals_regular with U UV; trivial.
apply comp_sym; apply residuals_comp with UV; trivial.
apply residuals_regular with W WU; trivial.
apply comp_trans with W.
apply comp_sym; apply residuals_comp with WU; trivial.
apply residuals_comp with WV; trivial.
apply residuals_regular with W WV; trivial.
Qed.


Require Import HoTT HoTT.hit.Truncations Connectedness Utf8_core.
Require Import colimit nat_lemmas.

Set Universe Polymorphism.
Global Set Primitive Projections.

Local Open Scope path_scope.
(* Local Open Scope equiv_scope. *)
Local Open Scope type_scope.

Module Export T.

  Private Inductive T {A B:Type} (f: A -> B) : Type :=
    | t : A -> (T f).

  Arguments t {A B f} a.

  Axiom tp : forall {A B f} (a b:A), f a = f b -> @t A B f a = @t A B f b.

  Axiom tp_1 : forall {A B f} (a:A), @tp A B f a a 1 = 1.

  Definition T_ind {A B:Type} {f:A -> B} (P : T f -> Type)
             (t' : forall a, P (t a))
             (tp' : forall a b p, transport P (tp a b p) (t' a) = t' b)
             (tp_1' : forall a, (transport2 P (tp_1 a) (t' a))^ @ tp' a a 1 = 1)
    : forall w, P w
    := fun w => match w with
                |t a => fun _ => t' a
                end tp_1'.

  Axiom T_ind_beta_tp : forall {A B:Type} {f:A -> B} (P : T f -> Type)
             (t' : forall a, P (t a))
             (tp' : forall a b p, transport P (tp a b p) (t' a) = t' b)
             (tp_1' : forall a, (transport2 P (tp_1 a) (t' a))^ @ tp' a a 1 = 1)
             a b p,
     apD (T_ind P t' tp' tp_1') (tp a b p) = tp' a b p.

End T.

Definition T_rec {A B:Type} {f:A -> B} (P:Type)
           (t': A -> P)
           (tp' : forall (a b:A) (p:f a = f b), t' a = t' b)
           (tp_1' : forall a, tp' a a 1 = 1)
  : T f -> P.
Proof.
  simple refine (T_ind _ t' (fun a b p => transport_const _ _ @ tp' a b p)  _).
  intro a.
  exact ((concat_p_pp (transport2 (λ _ : T f, P) (tp_1 a) (t' a))^  (transport_const (tp a a 1) (t' a)) (tp' a a 1))                                                                                @ whiskerR (moveR_Vp _ _ _ (transport2_const (A:=T f) (B:= P) (tp_1 a) (t' a))) (tp' a a 1)                                                                                @ concat_1p _                                                                                @ (tp_1' a)).
Defined.

Definition T_rec_beta_tp {A B:Type} {f:A -> B} (P:Type)
           (t': A -> P)
           (tp' : forall (a b:A) (p:f a = f b), t' a = t' b)
           (tp_1' : forall a, tp' a a 1 = 1)
           a b p
  : ap (T_rec P t' tp' tp_1') (tp a b p) = tp' a b p.
Proof.
Admitted.

Section Gpd.

  Definition Gpd_graph_ : graph.
  Proof.
    simple refine (Build_graph _ _).
    exact nat.
    intros n m. exact (S n = m).
  Defined.

  Definition Gpd_aux_ (X:Type) (n:nat) : Type.
  Proof.
    induction n.
    - exact X.
    - exact (T (λ x:IHn, tt)).
  Defined.

  Definition Gpd_ (X:Type) : diagram Gpd_graph_.
  Proof.
    simple refine (Build_diagram _ _ _).
    - intros i. exact (Gpd_aux_ X i).
    - intros i j q; destruct q; simpl.
      exact t.
  Defined.

End Gpd.

Section TheProof.
  (* There, we want to prove that the colimit of the sequence of iterated kernel pairs is the truncation of [X].

The proof is just a traduction of the one created by F. Van Doorn, available in Lean here : https://github.com/fpvandoorn/leansnippets/blob/master/truncation.hlean .

We first show that the colimit is [hProp].
   *)

  Lemma ap_w_const (X Y:Type) (f:X -> Y) (wconst : forall x y, f x = f y) (x y : X) (p q:x=y)
    : ap f p = ap f q.
  Proof.
    assert (H' : forall (a b:X) (r:a=b), (wconst x a)^ @ (wconst x b) = ap f r).
    { intros a b r. destruct r. simpl. apply concat_Vp. }
    transitivity ((wconst x x)^ @ wconst x y).
    symmetry; apply H'.
    apply H'.
  Defined.

  Variable (X:Type).
  Let D := @Gpd_ X.
  Let Q := colimit D.

  Instance trans_le : Transitive Peano.le.
  Proof.
    intros i j k p.
    induction p.
    exact idmap.
    intro q. apply IHp.
    exact (le_pred _ _ (le_S _ _ q)).
  Defined.

  Lemma not_ge_lt (n m:nat) (H: Peano.le n m) (H': Peano.le (m.+1) n) : Empty.
  Proof.
    assert (H0 : Peano.le n.+1 n).
    transitivity (m.+1).
    exact (le_succ _ _ H).
    exact H'.
    destruct (not_le_S _ H0).
  Qed.

  Lemma le_eq_lt {n m:nat}
    : (Peano.le n m) -> (n=m) + (Peano.lt n m).
  Proof.
    intro H.
    destruct H.
    left; reflexivity.
    right; exact (le_succ _ _ H).
  Defined.

  Lemma gt_lt_cases (n m:nat) : (Peano.le n m) + (Peano.le m n).
  Proof.
    induction n, m.
    - left; apply le_n.
    - left; apply le_0.
    - right; apply le_0.
    - destruct IHn.
      destruct (le_eq_lt l).
      destruct p.
      right; exact (le_S _ _ (le_n _)).
      left; exact l0.

      destruct (le_eq_lt l).
      destruct p.
      right; apply le_S; apply le_n.
      right. apply le_S. exact l.
  Qed.

  Lemma leS_ge : forall (i j:nat), (Peano.le i (j.+1)) -> (Peano.le j i) -> ((j.+1 = i) + (j = i)).
  Proof.
    induction i, j.
    - intros H H0. right; reflexivity.
    - intros H H0. destruct (not_lt_0 j). exact H0.
    - intros H H0. left. apply ap.
      symmetry; apply le_0_is_0.
      apply (le_pred _ _ H).
    - intros H H0.
      destruct (IHi j (le_pred _ _ H) (le_pred _ _ H0)).
      destruct p; left; reflexivity.
      destruct p; right; reflexivity.
  Qed.

  Definition eq_same (i:nat) (x y:D i) : colim x = colim y.
  Proof.
    transitivity (colim (diagram1 D (i:=i) (j:=(i.+1)) 1 x)).
    symmetry; apply pp.
    transitivity (colim (diagram1 D (i:=i) (j:=(i.+1)) 1 y)).
    apply ap. simpl.
    apply tp. reflexivity.
    apply pp.
  Defined.

  Definition HPropQ_fun_ij {i j:nat} (H : Peano.le i j) : D i -> D j.
  Proof.
    induction H.
    exact idmap.
    exact ((diagram1 D (i := m) (j:= m.+1) idpath) o IHle).
  Defined.

  Definition HPropQ_colim_ij {i j:nat} (H : Peano.le i j)
    : forall (x:D i), colim x = colim (HPropQ_fun_ij H x).
  Proof.
    induction H.
    intro; reflexivity.
    intro x.
    etransitivity; [exact (IHle x) |].
    symmetry; apply pp.
  Defined.

  Lemma HPropQ_ij_eq (i j:nat) (x:D i) (y:D j) (H : Peano.le i j) : colim x = colim y.
  Proof.
    transitivity (colim (HPropQ_fun_ij H x)).
    apply HPropQ_colim_ij.
    generalize (HPropQ_fun_ij H x); intro d.
    transitivity (colim (diagram1 D (i := j) (j:= j.+1) idpath d)).
    symmetry; apply pp.
    transitivity (colim (diagram1 D (i := j) (j:= j.+1) idpath y)).
    apply ap.
    apply tp. reflexivity.
    (* exact (@cp ((D j)*(D j)) (D j) fst snd (d,y)). *)
    apply pp.
  Defined.

  Lemma HPropQ_fun_ij_map {i j:nat} (H : Peano.le i j) (H': Peano.le (i.+1) j) (x:D i)
    : HPropQ_fun_ij H x = HPropQ_fun_ij H' (diagram1 D (i := i) (j:= i.+1) idpath x).
  Proof.
    assert (rew : le_pred _ _ (le_S _ _ H') = H) by apply (path_ishprop (H := IsHProp_le _ _)); destruct rew.
    induction H'.
    - assert (rew : le_S _ _ (le_n i) = (le_pred i.+1 i.+2 (le_S i.+1 i.+1 (le_n i.+1)))) by apply (path_ishprop (H := IsHProp_le _ _)); destruct rew; cbn. reflexivity.
    - cbn in *.
      assert (rew : le_S _ _ (le_pred _ _ (le_S _ _ H')) = (le_pred i.+1 m.+2 (le_S i.+1 m.+1 (le_S i.+1 m H')))) by apply (path_ishprop (H := IsHProp_le _ _)); destruct rew; cbn.
      unfold HPropQ_fun_ij in *. simpl in *.
      exact (ap t IHH').
  Defined.

  Lemma i_fr_step (i j:nat) (H : Peano.le i j) (x:D i)
    : (HPropQ_colim_ij (le_S _ _ H) x) = (HPropQ_colim_ij H x) @ (@pp _ D j (j.+1) 1 (HPropQ_fun_ij H x))^.
  Proof.
    induction H.
    - cbn. hott_simpl.
    - cbn. repeat rewrite inv_pp. repeat rewrite inv_V.
      reflexivity.
  Defined.

  Lemma ap_i_ap_f (i:nat) (x y : D i) (p : x = y)
    : ap colim (ap (diagram1 D (i := i) (j := i.+1) 1) p)
      = (@pp _ D i (i.+1) 1 x) @ (ap colim p) @ (@pp _ D i (i.+1) 1 y)^.
  Proof.
    destruct p; cbn. hott_simpl.
  Defined.

  Lemma ap_i_eq_ap_i_same (i:nat) (x y : D i) (p q : x=y)
    : ap colim p = ap colim q.
  Proof.
    apply ap_w_const. apply eq_same.
  Defined.

  Lemma i_fr_g (i j:nat) (H : Peano.le i j) (H': Peano.le (i.+1) j) (x:D i)
    : (pp _ D i (i.+1) 1 x)^ @ HPropQ_colim_ij H' (diagram1 D (i:=i) (j:=i.+1) 1 x) @ (ap (colim (D:=D) (i := j)) (HPropQ_fun_ij_map H H' x))^ = HPropQ_colim_ij H x.
  Proof.
    assert (rew : le_pred _ _ (le_S _ _ H') = H) by apply (path_ishprop (H := IsHProp_le _ _)); destruct rew.
    induction H'.
    - cbn. rewrite concat_p1.
      assert (rew : le_S _ _ (le_n i) = (le_pred i.+1 i.+2 (le_S i.+1 i.+1 (le_n i.+1)))) by apply (path_ishprop (H := IsHProp_le _ _)); destruct rew; cbn.
      transitivity ((pp Gpd_graph_ D i i.+1 1 x)^ @ 1).
      2:hott_simpl.
      apply whiskerL.
      assert (rew : 1 = (HPropQ_fun_ij_map (le_S i i (le_n i)) (le_n i.+1) x)).
      unfold HPropQ_fun_ij_map. simpl.
      pose (H := IsHProp_le).
      match goal with
      |[|- _ =  match ?xx with |1 => match ?yy with |1 => _ end end] => set (foo := yy); set (bar := xx)
      end.
      destruct foo.
      assert (X0 : 1 = bar).
      apply path_ishprop. destruct X0. reflexivity.
      destruct rew; cbn. reflexivity.
    - rewrite (i_fr_step _ _ H' (diagram1 D (i:=i) (j:=i.+1) 1 x)).
      assert ( rew : le_S _ _ (le_pred i.+1 m.+1 (le_S i.+1 m H')) = (le_pred i.+1 m.+2 (le_S i.+1 m.+1 (le_S i.+1 m H')))) by apply (path_ishprop (H := IsHProp_le _ _)); destruct rew.
      simpl.
      rewrite <- IHH'. clear IHH'.
      repeat rewrite concat_pp_p; apply whiskerL. apply whiskerL.
      apply moveL_Vp.
      match goal with |[|- _ = ?xx] => transitivity (xx @ 1); [| hott_simpl] end.
      apply moveL_Vp.
      repeat rewrite concat_p_pp.
      apply moveR_pV. rewrite concat_1p.
      rewrite <- (ap_i_ap_f m _ _ (HPropQ_fun_ij_map (le_pred i.+1 m.+1 (le_S i.+1 m H')) H' x)).
      apply ap_i_eq_ap_i_same.
  Defined.

  Definition eq_same_con (i:nat) (x y z:D i) (p:y=z)
    : eq_same i x y = eq_same i x z @ (ap colim p)^.
  Proof.
    destruct p; symmetry; apply concat_p1.
  Defined.

  Definition HPropQ : IsHProp Q.
  Proof.
    apply hprop_allpath.
    assert (hp: forall x:Q, IsHProp (forall y:Q, x=y)).
    { intro x. apply hprop_inhabited_contr.
      intro H.
      assert (Contr Q).
      exists x. exact H.
      apply trunc_forall. }
    simple refine (colimit_rect _ _ _ _ _).
    2:intros; apply path_ishprop.
    clear hp.
    intros i x; cbn.
    simple refine (colimit_rect _ _ _ _ _).
    - intros j y.
      cbn in *.
      destruct (gt_lt_cases i j).
      transitivity (colim (HPropQ_fun_ij l x)).
      apply HPropQ_colim_ij.
      apply eq_same.

      transitivity (colim (HPropQ_fun_ij l y)).
      apply eq_same.
      symmetry; apply HPropQ_colim_ij.

    - intros j i0 f y; destruct f; cbn.
      rewrite transport_paths_Fr.
      rewrite ap_idmap.
      destruct (gt_lt_cases i (j.+1)), (gt_lt_cases i j).
      + assert (rew : Peano.le_S i j l0 = l) by apply (path_ishprop (H := IsHProp_le _ _)); destruct rew.
        rewrite i_fr_step.
        repeat rewrite concat_pp_p; apply whiskerL.
        unfold eq_same; simpl.
        repeat rewrite concat_pp_p; apply whiskerL.
        repeat rewrite concat_p_pp; apply whiskerR.
        apply moveR_pM.
        apply moveR_Vp.
        rewrite concat_p_pp.
        match goal with
        |[|- _ = (pp _ _ _ _ _ ?xx) @ ap _ ?ppp @ (pp _ _ _ _ _ ?yy)^] =>
         etransitivity; [| exact (ap_i_ap_f (j.+1) xx yy ppp)]
        end.
        apply ap_i_eq_ap_i_same.
      + destruct (leS_ge _ _ l l0).
        destruct p.
        assert (rew : le_n (j.+1) = l) by apply (path_ishprop (H := IsHProp_le _ _)); destruct rew.
        assert (rew : le_S _ _ (le_n j) = l0) by apply (path_ishprop (H := IsHProp_le _ _)); destruct rew. unfold eq_same. cbn. hott_simpl.

        destruct p.
        assert (rew : le_n j = l0) by apply (path_ishprop (H := IsHProp_le _ _)); destruct rew.
        assert (rew : le_S _ _ (le_n j) = l) by apply (path_ishprop (H := IsHProp_le _ _)); destruct rew.
        unfold eq_same. cbn. hott_simpl.
        repeat rewrite concat_p_pp; apply whiskerR.
        repeat rewrite concat_pp_p; apply whiskerL.
        apply moveR_Vp. apply moveR_pM.
        match goal with
        |[|- _ = (pp _ _ _ _ _ ?xx) @ ap _ ?ppp @ (pp _ _ _ _ _ ?yy)^] =>
         etransitivity; [| exact (ap_i_ap_f (j.+1) xx yy ppp)]
        end.
        apply ap_i_eq_ap_i_same.
      + destruct (not_ge_lt _ _ l0 l).
      + unfold eq_same; simpl.
        apply moveR_pM. apply moveR_pV.
        assert (X0 : (ap colim (HPropQ_fun_ij_map l0 l y)) = (HPropQ_colim_ij l0 y)^ @ (pp Gpd_graph_ D j j.+1 1 y)^ @ HPropQ_colim_ij l (t y) ).
        { rewrite concat_pp_p. apply moveL_Vp. apply moveR_pM.
          exact (i_fr_g _ _ l0 l y)^. }
        repeat rewrite (concat_pp_p).
        apply moveL_Vp. apply moveL_Mp. apply moveL_Mp.
        repeat rewrite concat_p_pp.
        rewrite <- X0; clear X0.
        repeat rewrite concat_pp_p.
        apply moveR_Vp.
        apply moveR_Vp.
        rewrite concat_p_pp. rewrite concat_pV. rewrite concat_1p.
        apply moveR_pM.
        match goal with
        |[|- _ = _ @ (_ @ ap colim ?ff) @ _ ] => pose (p := ap_i_ap_f i _ _ ff)
        end. simpl in p.
        repeat rewrite concat_pp_p; repeat rewrite concat_pp_p in p.
        rewrite <- p; clear p.
        rewrite <- ap_pp.
        apply ap_i_eq_ap_i_same.
  Qed.

  Theorem VD_truncation : Q <~> Trunc -1 X.
  Proof.
    simple refine (equiv_adjointify _ _ _ _).
    3:intro; apply path_ishprop.
    3:intro; apply (path_ishprop (H:=HPropQ)).
    - simple refine (colimit_rectnd _ _ _ _ _).
      2:intros i j f x; apply path_ishprop.
      induction i.
      exact tr. simpl.
      simple refine (T_ind _ _ _ _).
      exact IHi.
      intros; apply path_ishprop.
      intros; apply path_ishprop.
    - simple refine (Trunc_rec _). exact HPropQ.
      exact (colim (D:=Gpd_ X) (i:=0)).
  Defined.

End TheProof.


Require Export Carac.
Set Implicit Arguments.
Require Arith.

Module Ycart (Univ:Universe).
(* begin hide *)
Import Univ.
Module CP := (CaracFun Univ).
Import CP.
Import CP.RP.
Import CP.RP.PP.
Import CP.RP.PP.MP.
Import CP.RP.PP.MP.UP.
(* end hide *)

Section UniformSec.
(** * Ycart.v: Axiomatisation of the uniform measure *)

(** ** Interval [[0,x]] *)
Hypothesis Ule_dec : forall a b, {a<=b}+{b<a}.

Definition inf (a : U) := carac  (fun x => Ule_dec x a).

Variable uniform : distr U.
Hypothesis uniform_inf : forall a, mu uniform (inf a) == a.

Lemma uniform_one : mu uniform (f_one U) == 1.
intros; apply Ueq_trans with (mu uniform (inf 1)); auto.
apply mu_stable_eq; red; auto.
intros; unfold inf,carac.
case (Ule_dec x 1); intros; auto.
absurd (x<=1); auto.
Qed.

Lemma uniform_inv_inf : forall a, mu uniform (finv (inf a)) == [1-] a.
intros; rewrite inv_minus_distr; auto.
rewrite uniform_inf; rewrite uniform_one; auto.
Qed.

Hint Resolve uniform_inf uniform_inv_inf uniform_one.

(** * Ycart.v: An exemple of partial termination  *)

(** ** Program giving an example of partiality
given a function F : int -> U
<<
let rec ycart x = if uniform < F x then x else ycart (x+1)
>>
The probability of termination is $1-\prod_{k=x}^{\infty}(1-F(k))$
*)
Variable F : nat -> U.

Definition FYcart (f:nat -> distr nat) n :=
    Mlet uniform (fun x => if Ule_dec x (F n) then Munit n else f (S n)).

Lemma FYcart_mon : forall f g : nat -> distr nat,
       (forall n, le_distr (f n) (g n)) -> forall n, le_distr (FYcart f n) (FYcart g n).
unfold FYcart; intros; auto.
apply Mlet_mon; intros; auto.
case (Ule_dec x (F n)); auto.
Qed.

Definition Ycart : nat -> distr nat := Mfix FYcart FYcart_mon.

(** ** Properties of Ycart *)

Lemma FYcart_val : forall q:nat->U, forall f x,
     mu (FYcart f x) q == F x * q x + [1-](F x) * mu (f (S x)) q.
intros; unfold  FYcart.
unfold Mlet; simpl.
unfold star.
apply Ueq_trans with
   (mu uniform (fplus (fmult (q x) (inf (F x))) (fmult (mu (f (S x)) q) (finv (inf (F x)))))).
apply mu_stable_eq; red; intros.
unfold fplus,fmult,finv,inf, carac.
case (Ule_dec x0 (F x)); simpl; intros; repeat Usimpl; auto.
assert (fok:fplusok (fmult (q x) (inf (F x))) (fmult (mu (f (S x)) q) (finv (inf (F x))))); auto.
rewrite (mu_stable_plus uniform fok).
rewrite (mu_stable_mult uniform (q x)).
rewrite (mu_stable_mult uniform (mu (f (S x)) q)).
rewrite uniform_inf.
apply Uplus_eq_compat; auto.
rewrite uniform_inv_inf; auto.
Qed.

Definition P (x k : nat) := prod (fun i => [1-]F (x+i)) k.

Definition p (x:nat) (n:nat) := sigma (fun k => F (x+k) * P x k) n.

Lemma P_prod : forall x k, F (x+k) * P x k == P x k - P x (S k).
intros; unfold P; rewrite prod_minus; auto.
Qed.
Hint Resolve P_prod.

Lemma p_diff : forall x n,  p x n == [1-] P x n.
unfold p; intros.
apply Ueq_trans with (sigma (fun k => P x k - P x (S k)) n).
apply sigma_eq_compat; intros; auto.
rewrite sigma_minus_decr.
unfold P; rewrite prod_0; auto.
unfold P; auto.
Qed.
Hint Resolve p_diff.

Lemma p_lub : forall x, lub (p x) == [1-] prod_inf (fun i => [1-]F (x+i)).
unfold prod_inf; intros.
apply Ueq_trans with (lub (fun n => [1-] P x n)).
apply lub_eq_stable; auto.
apply Ueq_trans with ([1-]glb (P x)); auto.
Qed.
Hint Resolve p_lub.

Lemma p_equation : forall x n,  p x (S n) == F x + [1-](F x) * p (S x) n.
unfold p; intros.
rewrite sigma_S_lift.
unfold P at 1; rewrite prod_0; Usimpl.
apply Uplus_eq_compat.
replace ((x+0)%nat) with x; auto.
rewrite <- sigma_mult; auto.
apply sigma_eq_compat; intros; auto.
unfold P; rewrite prod_S_lift.
rewrite Umult_assoc.
rewrite (Umult_sym (F (x+S k)) ([1-]F (x+0))).
rewrite <- Umult_assoc.
apply Umult_eq_compat.
replace ((x+0)%nat) with x; auto.
apply Umult_eq_compat.
replace ((x + S k)%nat) with ((S x + k)%nat); auto.
omega.
apply prod_eq_compat; intro; auto.
replace ((x + S k0)%nat) with ((S x + k0)%nat); auto.
omega.
red; intros.
apply Ule_trans with (P (S x) k); auto.
change (P (S x) k <= [1-]p (S x) k).
rewrite p_diff; auto.
Qed.
Hint Resolve p_equation.

Lemma Ycart_term1 : forall x, mu (Ycart x) (f_one nat) == [1-] prod_inf (fun i => [1-]F (x+i)).
intros; apply Ueq_trans with (lub (p x)); auto.
apply Ule_antisym.
apply (fixrule_up_lub FYcart FYcart_mon) with (p:=p) (q:=fun (x:nat) => f_one nat); red; intros.
red; rewrite FYcart_val.
unfold f_one; Usimpl.
apply Ule_trans with (F x0 + [1-] F x0 * p (S x0) i).
repeat Usimpl; auto.
apply (H (S x0)).
rewrite p_equation; auto.
apply (fixrule FYcart FYcart_mon) with (p:=p) (q:=fun (x:nat) => f_one nat); intros.
unfold p; rewrite sigma_0; auto.
repeat red; intros.
rewrite FYcart_val.
unfold f_one; Usimpl.
apply Ule_trans with (F x0 + [1-] F x0 * p (S x0) i).
rewrite p_equation; auto.
repeat Usimpl; auto.
apply (H (S x0)).
Qed.

(** A  shorter proof using mu (Ycart x) (f_one nat) = mu h. muYcart h x *)

Lemma Ycart_term2 : forall x, mu (Ycart x) (f_one nat) == [1-] prod_inf (fun i => [1-]F (x+i)).
intros; apply Ueq_trans with (mufix (fun (p:nat->U) (y:nat) => F y + [1-](F y) * p (S y)) x).
unfold Ycart; apply Ueq_sym.
apply mufix_mu with (q:=fun (y:nat) => f_one nat); intros.
red; auto.
rewrite FYcart_val; unfold f_one; repeat Usimpl; auto.
apply Ueq_trans with (lub (p x)); auto.
unfold mufix.
apply lub_eq_stable.
intro n; generalize x; induction n; simpl; intros; auto.
rewrite IHn; auto.
Qed.

Lemma le_dec : forall x, dec (fun y => le y x).
intros x y; case (le_lt_dec y x); auto with arith.
Defined.

Lemma lt_dec : forall x, dec (fun y => lt y x).
intros x y; case (le_lt_dec x y); auto with arith.
Defined.

Lemma gt_dec : forall x, dec (lt x).
intros x y; case (le_lt_dec y x); auto with arith.
Defined.

Lemma Ycart_ltx : forall x, mu (Ycart x) (carac (lt_dec x)) <= 0.
intros; apply Ule_trans with (mufix (fun (p:nat->U) (y:nat) => [1-](F y) * p (S y)) x).
unfold Ycart; apply mu_mufix_le with (q:=fun (y:nat) => carac (lt_dec y)); intros; auto.
red; intros; rewrite FYcart_val.
rewrite carac_zero; auto with arith.
repeat Usimpl.
apply mu_monotonic; apply carac_incl; red; auto with arith.
apply mufix_inv with (f:=fun y:nat => 0); auto.
Qed.

Lemma Ycart_eqx : forall x, mu (Ycart x) (carac (eq_nat_dec x)) == F x.
intros; apply Ueq_trans with (mufix (fun (p:nat->U) (y:nat) => F y) x).
unfold Ycart; apply Ueq_sym; apply mufix_mu with (q:=fun (y:nat) => carac (eq_nat_dec y)); intros; auto.
rewrite FYcart_val.
rewrite (carac_one (eq_nat_dec x0) x0); auto with arith; Usimpl.
setoid_replace (mu (f (S x0)) (carac (eq_nat_dec x0))) with 0; repeat Usimpl; auto.
apply Ule_zero_eq; apply Ule_trans with (mu (Mfix FYcart FYcart_mon (S x0)) (carac (eq_nat_dec x0))).
apply H.
apply Ule_trans with (2:=Ycart_ltx (S x0)); auto.
apply mu_monotonic; apply carac_incl; red; intros; subst; auto with arith.
exact (mufix_cte F x).
Qed.

End UniformSec.
End Ycart.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Export CoRN.model.structures.Zsec.
Require Export CoRN.algebra.CSetoidFun.

(**
** Example of a setoid: [Z]
*** [Z]
*)

Lemma ap_Z_irreflexive : irreflexive (A:=Z) ap_Z.
Proof.
 red in |- *.
 apply ap_Z_irreflexive0.
Qed.

Lemma ap_Z_symmetric : Csymmetric ap_Z.
Proof.
 red in |- *.
 apply ap_Z_symmetric0.
Qed.

Lemma ap_Z_cotransitive : cotransitive (A:=Z) ap_Z.
Proof.
 red in |- *.
 apply ap_Z_cotransitive0.
Qed.

Lemma ap_Z_tight : tight_apart (A:=Z) (eq (A:=Z)) ap_Z.
Proof.
 red in |- *.
 apply ap_Z_tight0.
Qed.

Definition ap_Z_is_apartness := Build_is_CSetoid Z (eq (A:=Z)) ap_Z
 ap_Z_irreflexive ap_Z_symmetric ap_Z_cotransitive ap_Z_tight.

Definition Z_as_CSetoid := Build_CSetoid _ _ _ ap_Z_is_apartness.
Canonical Structure Z_as_CSetoid.

(** The term [Z_as_CSetoid] is of type [CSetoid]. Hence we have proven that [Z] is a constructive setoid.
*** Addition
We will prove now that the addition on the integers is a setoid function.
*)

Lemma Zplus_wd :
 bin_fun_wd Z_as_CSetoid Z_as_CSetoid Z_as_CSetoid Zplus.
Proof.
 red in |- *.
 simpl in |- *.
 apply Zplus_wd0.
Qed.

Lemma Zplus_strext :
 bin_fun_strext Z_as_CSetoid Z_as_CSetoid Z_as_CSetoid Zplus.
Proof.
 red in |- *.
 simpl in |- *.
 apply Zplus_strext0.
Qed.

Definition Zplus_is_bin_fun := Build_CSetoid_bin_fun
 Z_as_CSetoid Z_as_CSetoid Z_as_CSetoid Zplus Zplus_strext.
Canonical Structure Zplus_is_bin_fun.

(** What's more: the addition is also associative and commutative.
*)

Lemma Zplus_is_assoc : associative Zplus_is_bin_fun.
Proof.
 red in |- *.
 intros x y z.
 simpl in |- *.
 apply Zplus_assoc.
Qed.

Lemma Zplus_is_commut : commutes Zplus_is_bin_fun.
Proof.
 red in |- *.
 simpl in |- *.
 intros x y.
 apply Zplus_comm.
Qed.

(**
*** Opposite
Taking the opposite of an integer is a setoid function.
*)

Lemma Zopp_wd : fun_wd (S1:=Z_as_CSetoid) (S2:=Z_as_CSetoid) Z.opp.
Proof.
 red in |- *.
 simpl in |- *.
 intros x y H.
 apply (f_equal Z.opp H).
Qed.

Lemma Zopp_strext :
 fun_strext (S1:=Z_as_CSetoid) (S2:=Z_as_CSetoid) Z.opp.
Proof.
 red in |- *.
 simpl in |- *.
 unfold ap_Z in |- *.
 intros x y H.
 intro H0.
 apply H.
 exact (f_equal Z.opp H0).
Qed.

Definition Zopp_is_fun :=
  Build_CSetoid_fun Z_as_CSetoid Z_as_CSetoid Z.opp Zopp_strext.
Canonical Structure Zopp_is_fun.

(**
*** Multiplication
Finally the multiplication is a setoid function and is associative and commutative.
*)

Lemma Zmult_wd :
 bin_fun_wd Z_as_CSetoid Z_as_CSetoid Z_as_CSetoid Zmult.
Proof.
 red in |- *.
 simpl in |- *.
 intros x1 x2 y1 y2 H H0.
 apply (f_equal2 Zmult (x1:=x1) (y1:=x2) (x2:=y1) (y2:=y2)).
  assumption.
 assumption.
Qed.

Lemma Zmult_strext :
 bin_fun_strext Z_as_CSetoid Z_as_CSetoid Z_as_CSetoid Zmult.
Proof.
 red in |- *.
 simpl in |- *.
 apply Zmult_strext0.
Qed.

Definition Zmult_is_bin_fun := Build_CSetoid_bin_fun
 Z_as_CSetoid Z_as_CSetoid Z_as_CSetoid Zmult Zmult_strext.
Canonical Structure Zmult_is_bin_fun.

Lemma Zmult_is_assoc : associative Zmult_is_bin_fun.
Proof.
 red in |- *.
 intros x y z.
 simpl in |- *.
 apply Zmult_assoc.
Qed.

Lemma Zmult_is_commut : commutes Zmult_is_bin_fun.
Proof.
 red in |- *.
 simpl in |- *.
 intros x y.
 apply Zmult_comm.
Qed.

(**
*** Zero
*)

Lemma is_nullary_operation_Z_0 : (is_nullary_operation Z_as_CSetoid 0%Z).
Proof.
 unfold is_nullary_operation.
 intuition.
Qed.


Require Import SMTCoq.SMTCoq.
Require Import Bool.

Require Import ZArith.

Import BVList.BITVECTOR_LIST.
Local Open Scope bv_scope.

Import FArray.
Local Open Scope farray_scope.

(* Examples of the verit tactics (requires verit in your PATH environment
   variable), which handle
   - propositional logic
   - theory of equality
   - linear integer arithmetic
   - universally quantified hypotheses *)

Goal forall a b c, ((a || b || c) && ((negb a) || (negb b) || (negb c)) && ((negb a) || b) && ((negb b) || c) && ((negb c) || a)) = false.
Proof.
  cvc4. (*verit_bool.*)
Qed.

Local Open Scope Z_scope.

Goal forall (a b : Z) (P : Z -> bool) (f : Z -> Z),
  (negb (Z.eqb (f a) b)) || (negb (P (f a))) || (P b).
Proof.
  cvc4. (*verit_bool.*)
Qed.

Goal forall b1 b2 x1 x2,
    implb
      (ifb b1
           (ifb b2 (Z.eqb (2*x1+1) (2*x2+1)) (Z.eqb (2*x1+1) (2*x2)))
           (ifb b2 (Z.eqb (2*x1) (2*x2+1)) (Z.eqb (2*x1) (2*x2))))
      ((implb b1 b2) && (implb b2 b1) && (Z.eqb x1 x2)).
Proof.
  cvc4.
  + verit.
  + easy. (*verit_bool.*)
Qed.

Goal forall
    (x y: Z)
    (f: Z -> Z),
    x = y + 1 -> f y = f (x - 1).
Proof.
  cvc4. verit.
Qed.

(*Some examples of using verit with lemmas. Use <verit H1 .. Hn>
  to temporarily add the lemmas H1 .. Hn to the verit environment. *)

Lemma const_fun_is_eq_val_0 :
  forall f : Z -> Z,
    (forall a b, f a =? f b) ->
    forall x, f x =? f 0.
Proof.
  intros f Hf.
  verit Hf.
Qed.

Section With_lemmas.
  Variable f : Z -> Z.
  Variable k : Z.
  Hypothesis f_k_linear : forall x, f (x + 1) =? f x + k.

  Lemma fSS2:
    forall x, f (x + 2) =? f x + 2 * k.
  Proof. verit_no_check f_k_linear. Qed.
End With_lemmas.

(* Instantiating a lemma with multiple quantifiers *)
Section NonLinear.
  Lemma distr_right_inst a b (mult : Z -> Z -> Z) :
    (forall x y z, mult (x + y)  z =? mult x z + mult y z) ->
    (mult (3 + a) b =? mult 3 b + mult a b).
  Proof.
    intro H.
    verit H.
  Qed.
End NonLinear.

(* You can use <Add_lemmas H1 .. Hn> to permanently add the lemmas H1 .. Hn to
   the environment. If you did so in a section then, at the end of the section,
   you should use <Clear_lemmas> to empty the globally added lemmas because
   those lemmas won't be available outside of the section. *)

Section mult3.
  Variable mult3 : Z -> Z.
  Hypothesis mult3_0 : mult3 0 =? 0.
  Hypothesis mult3_Sn : forall n, mult3 (n+1) =? mult3 n + 3.
  Add_lemmas mult3_0 mult3_Sn.

  Lemma mult_3_4_12 : mult3 4 =? 12.
  Proof. verit. Qed.

  Clear_lemmas.
End mult3.

(* Examples of the smt tactic (requires verit and cvc4 in your PATH environment
   variable):
   - propositional logic
   - theory of equality
   - linear integer arithmetic
   - theory of fixed-sized bit-vectors
   - theory of arrays *)

Goal forall a b c, ((a || b || c) && ((negb a) || (negb b) || (negb c)) && ((negb a) || b) && ((negb b) || c) && ((negb c) || a)) = false.
Proof.
  smt.
Qed.

Goal forall (a b : Z) (P : Z -> bool) (f : Z -> Z),
  (negb (Z.eqb (f a) b)) || (negb (P (f a))) || (P b).
Proof.
  smt.
Qed.
Goal forall b1 b2 x1 x2,
    implb
      (ifb b1
           (ifb b2 (Z.eqb (2*x1+1) (2*x2+1)) (Z.eqb (2*x1+1) (2*x2)))
           (ifb b2 (Z.eqb (2*x1) (2*x2+1)) (Z.eqb (2*x1) (2*x2))))
      ((implb b1 b2) && (implb b2 b1) && (Z.eqb x1 x2)).
Proof.
  smt.
Qed.

Goal forall
    (x y: Z)
    (f: Z -> Z),
    x = y + 1 -> f y = f (x - 1).
Proof.
  smt.
Qed.

Goal forall (bv1 bv2 bv3: bitvector 4),
    bv1 = #b|0|0|0|0|  /\
    bv2 = #b|1|0|0|0|  /\
    bv3 = #b|1|1|0|0|  ->
    bv_ultP bv1 bv2 /\ bv_ultP bv2 bv3.
Proof.
  smt.
Qed.

(* All tactics have a "no_check" variant that is faster but, in case of
  failure, it will only fail at Qed *)

Goal forall (bv1 bv2 bv3: bitvector 4),
    bv1 = #b|0|0|0|0|  /\
    bv2 = #b|1|0|0|0|  /\
    bv3 = #b|1|1|0|0|  ->
    bv_ultP bv1 bv2 /\ bv_ultP bv2 bv3.
Proof.
  smt_no_check.
Qed.

(* From cvc4_bool : Uncaught exception Not_found *)
(* Goal forall (a b c d: farray Z Z), *)
(*     b[0 <- 4] = c  -> *)
(*     d = b[0 <- 4][1 <- 4]  -> *)
(*     a = d[1 <- b[1]]  -> *)
(*     a = c. *)
(* Proof. *)
(*   smt. *)
(* Qed. *)

Goal forall (a b: farray Z Z) (v w x y z t: Z)
            (r s: bitvector 4)
            (f: Z -> Z)
            (g: farray Z Z -> Z)
            (h: bitvector 4 -> Z),
    a[x <- v] = b /\ a[y <- w] = b ->
    a[z <- w] = b /\ a[t <- v] = b ->
    r = s -> v < x + 10 /\ v > x - 5 ->
    ~ (g a = g b) \/ f (h r) = f (h s).
Proof.
  smt.
Qed.

(** SMTCoq also provides conversion tactics, to inject various integer
    types into the type Z supported by SMTCoq. They can be called before
    the standard SMTCoq tactics. **)

Local Open Scope positive_scope.

Goal forall (f : positive -> positive) (x y : positive),
  implb ((x + 3) =? y)
        ((f (x + 3)) <=? (f y))
  = true.
Proof.
  pos_convert.
  verit.
Qed.

Goal forall (f : positive -> positive) (x y : positive),
  implb ((x + 3) =? y)
        ((3 <? y) && ((f (x + 3)) <=? (f y)))
  = true.
Proof.
  pos_convert.
  verit.
Qed.

Local Close Scope positive_scope.

Local Open Scope N_scope.

Goal forall (f : N -> N) (x y : N),
    implb ((x + 3) =? y)
          ((f (x + 3)) <=? (f y))
    = true.
Proof.
  N_convert.
  verit.
Qed.

Goal forall (f : N -> N) (x y : N),
    implb ((x + 3) =? y)
          ((2 <? y) && ((f (x + 3)) <=? (f y)))
    = true.
Proof.
  N_convert.
  verit.
Qed.

Local Close Scope N_scope.

Require Import NPeano.
Local Open Scope nat_scope.

Goal forall (f : nat -> nat) (x y : nat),
    implb (Nat.eqb (x + 3) y)
          ((f (x + 3)) <=? (f y))
    = true.
Proof.
  nat_convert.
  verit.
Qed.

Goal forall (f : nat -> nat) (x y : nat),
    implb (Nat.eqb (x + 3) y)
          ((2 <? y) && ((f (x + 3)) <=? (f y)))
    = true.
Proof.
  nat_convert.
  verit.
Qed.

Local Close Scope nat_scope.

(* An example with all 3 types and a binary function *)
Goal forall f : positive -> nat -> N, forall (x : positive) (y : nat),
  implb (x =? 3)%positive
    (implb (Nat.eqb y 7)
      (implb (f 3%positive 7%nat =? 12)%N
        (f x y =? 12)%N)) = true.
  pos_convert.
  nat_convert.
  N_convert.
  verit.
Qed.

Open Scope Z_scope.

(** Now more insightful examples. The first one automatically proves
    properties in group theory. **)

Section group.
  Variable op : Z -> Z -> Z.
  Variable inv : Z -> Z.
  Variable e : Z.

  (* We can prove automatically that we have a group if we only have the "left" versions
     of the axioms of a group *)
  Hypothesis associative :
    forall a b c : Z, op a (op b c) =? op (op a b) c.
  Hypothesis inverse :
    forall a : Z, (op (inv a) a =? e).
  Hypothesis identity :
    forall a : Z, (op e a =? a).
  Add_lemmas associative identity inverse.

  (* The "right" version of inverse *)
  Lemma inverse' :
    forall a : Z, (op a (inv a) =? e).
  Proof. verit_no_check. Qed.
  Add_lemmas inverse'.
  (* The "right" version of identity *)
  Lemma identity' :
    forall a : Z, (op a e =? a).
  Proof. verit_no_check. Qed.
  Add_lemmas identity'.

  (* Some other interesting facts about groups *)
  Lemma unique_identity e':
    (forall z, op e' z =? z) -> e' =? e.
  Proof. intros pe'. verit pe'. Qed.
  Lemma simplification_right x1 x2 y:
      op x1 y =? op x2 y -> x1 =? x2.
  Proof. intro H. verit_no_check H. Qed.

  Lemma simplification_left x1 x2 y:
      op y x1 =? op y x2 -> x1 =? x2.
  Proof. intro H. verit_no_check H. Qed.

  Clear_lemmas.
End group.

(* A full example coming from CompCert, slightly revisited.
   See: https://hal.inria.fr/inria-00289542
        https://xavierleroy.org/memory-model/doc/Memory.html (Section 3)
 *)
Section CompCert.

  Definition block := Z.
  Variable mem: Set.
  Variable dec_mem : CompDec mem.
  Variable alloc_block: mem -> Z -> Z -> block.
  Variable alloc_mem: mem -> Z -> Z -> mem.
  Variable valid_block: mem -> block -> bool.

  Hypothesis alloc_valid_block_1:
    forall m lo hi b,
      valid_block (alloc_mem m lo hi) b ---> ((b =? (alloc_block m lo hi)) || valid_block m b).

  Hypothesis alloc_valid_block_2:
    forall m lo hi b,
      ((b =? (alloc_block m lo hi)) || valid_block m b) ---> valid_block (alloc_mem m lo hi) b.

  Hypothesis alloc_not_valid_block:
    forall m lo hi,
       negb (valid_block m (alloc_block m lo hi)).

  Lemma alloc_valid_block_inv m lo hi b :
    valid_block m b -> valid_block (alloc_mem m lo hi) b.
  Proof.
    intro H. unfold block in *. verit alloc_valid_block_2 H.
  Qed.

  Lemma alloc_not_valid_block_2 m lo hi b' :
    valid_block m b' -> b' =? (alloc_block m lo hi) = false.
  Proof.
    intro H. unfold block in *. verit alloc_not_valid_block H.
  Qed.

End CompCert.