(** In this file, we show the equivalence between the Skolemized
   and existentially quantified presentations of ZF.
 *)

Require Import basic.
Require Export ZFdef.
Require Import EnsEm Sublogic.

Module Skolem (L:SublogicTheory). (*<: IZF_R_sig L *)

(** We assume we have a model of set theory with existential axioms in
    sublogic L. We could do the same with the abstract signature... *)
Module Z := Ensembles L.
Import L.

Instance Zsetoid: Equivalence Z.eq_set.
Proof.
split; red; intros; rewrite Z.eq_set_ax in *; intros.
 reflexivity.
 symmetry; trivial.
 transitivity (Z.in_set z0 y); trivial.
Qed.

Instance Zin_morph : Proper (Z.eq_set ==> Z.eq_set ==> iff) Z.in_set.
Proof.
do 3 red; intros.
rewrite Z.eq_set_ax in H0.
split; intros.
 rewrite <- H0.
 apply Z.in_reg with x; trivial.

 rewrite H0.
 symmetry in H.
 apply Z.in_reg with y; trivial.
Qed.

(** * Existential sets and their relation with regular sets *)

(** The type of existential sets *)
Definition set :=
  { f : Z.set -> Prop |
    (#exists u, f u) /\
    (forall a a', f a -> f a' -> Z.eq_set a a') }.

Lemma set_intro : forall (f:Z.set->Prop) (P:set->Prop),
  (#exists u, f u) ->
  (forall a a', f a -> f a' -> Z.eq_set a a') ->
  (forall Hex Huniq, P (exist _ f (conj Hex Huniq))) ->
  sig P.
intros.
exists (exist _ f (conj H H0)); trivial.
Qed.

(** Membership. (Uses an inductive to avoid unwanted unfolding...) *)
Inductive in_set_ (x y:set) : Prop :=
 InSet
  (_:#exists2 x', proj1_sig x x' &
      exists2 y', proj1_sig y y' & Z.in_set x' y').

Definition in_set := in_set_.

Lemma inset_isL x y : isL (in_set x y).
red.
constructor.
Telim H; intro.
destruct H; trivial.
Qed.
Global Hint Resolve inset_isL.

Lemma in_set_elim : forall x y, in_set x y <->
  #exists2 x', proj1_sig x x' &
   exists2 y', proj1_sig y y' & Z.in_set x' y'.
split; intros.
 destruct H; trivial.
 constructor; trivial.
Qed.

Notation "x ∈ y" := (in_set x y).

(** Equality *)
Definition eq_set a b := forall x, x ∈ a <-> x ∈ b.

Notation "x == y" := (eq_set x y).

Lemma eqset_isL x y : isL (x == y).
red; red; intros.
Telim H; auto.
Qed.
Global Hint Resolve eqset_isL.

Lemma eq_set_ax : forall a b, a == b <-> (forall x, x ∈ a <-> x ∈ b).
reflexivity.
Qed.

Instance eq_setoid: Equivalence eq_set.
Proof.
split; do 2 red; intros.
 reflexivity.
 symmetry; trivial.
 transitivity (x0 ∈ y); trivial.
Qed.

Lemma In_intro: forall x y: set,
  (forall x' y', proj1_sig x x' -> proj1_sig y y' -> Z.in_set x' y') ->
  x ∈ y.
intros.
destruct (proj2_sig x).
Tdestruct H0.
destruct (proj2_sig y).
Tdestruct H2.
constructor.
Texists x0; trivial.
exists x1; auto.
Qed.

Lemma In_elim (P:Prop) (x y:set):
  isL P ->
  (forall x' y', proj1_sig x x' -> proj1_sig y y' -> Z.in_set x' y' -> P) ->
  x ∈ y -> P.
intros.
rewrite in_set_elim in H1.
Tdestruct H1.
destruct H2.
eauto.
Qed.

(** Lifting sets to existential sets *)
Definition Z2set (x:Z.set) : set.
exists (fun a => Z.eq_set a x).
split.
 Texists x; reflexivity.

 intros; transitivity x; trivial.
 symmetry; trivial.
Defined.

Lemma Eq_proj : forall (x:set) x', proj1_sig x x' -> x == Z2set x'.
intros.
destruct (proj2_sig x).
clear H0.
split; intros.
 rewrite in_set_elim in H0.
 Tdestruct H0.
 destruct H2.
 constructor.
 Texists x1; simpl; trivial.
 exists x2; auto.

 rewrite in_set_elim in H0.
 Tdestruct H0; simpl in *.
 destruct H2.
 constructor.
 Texists x1; simpl; trivial.
 exists x'; trivial.
 rewrite <- H2; trivial.
Qed.

(** Perservation of equality and membership by lifting *)
Lemma inZ_in : forall a b, Z.in_set a b -> Z2set a ∈ Z2set b.
unfold Z2set, in_set; simpl.
intros.
constructor; simpl.
Texists a; try reflexivity.
exists b; try reflexivity; trivial.
Qed.

Lemma in_inZ : forall a b, Z2set a ∈ Z2set b -> Z.in_set a b.
intros.
rewrite in_set_elim in H.
Tdestruct H.
destruct H0.
unfold Z2set in *; simpl in *.
apply Z.in_reg with x; trivial.
rewrite <- H0; auto.
Qed.

Lemma in_equiv a b : in_set (Z2set a) (Z2set b) <-> Z.in_set a b.
split; intros.
 apply in_inZ; trivial.
 apply inZ_in; trivial.
Qed.

Lemma eq_Zeq : forall x y, Z2set x == Z2set y -> Z.eq_set x y.
intros.
rewrite Z.eq_set_ax; split; intros.
 apply in_inZ.
 apply (proj1 (H (Z2set z))).
 apply inZ_in; trivial.

 apply in_inZ.
 apply (proj2 (H (Z2set z))).
 apply inZ_in; trivial.
Qed.

Lemma Zeq_eq : forall x y, Z.eq_set x y -> Z2set x == Z2set y.
intros.
split; intros.
 rewrite in_set_elim in H0.
 Tdestruct H0.
 destruct H1.
 simpl in H1.
 constructor.
 Texists x1; trivial.
 exists x2; trivial.
 simpl.
 transitivity x; trivial.

 rewrite in_set_elim in H0.
 Tdestruct H0.
 destruct H1.
 simpl in H1.
 constructor.
 Texists x1; trivial.
 exists x2; trivial.
 simpl.
 transitivity y; trivial.
 symmetry; trivial.
Qed.

Lemma eq_equiv x y : Z2set x == Z2set y <-> Z.eq_set x y.
split; intros.
 apply eq_Zeq; trivial.
 apply Zeq_eq; trivial.
Qed.

Instance Z2set_morph : Proper (Z.eq_set ==> eq_set) Z2set.
exact Zeq_eq.
Qed.

(** Compatibility axiom *)
Lemma in_reg : forall a a' b, a == a' -> a ∈ b -> a' ∈ b.
intros.
rewrite in_set_elim in H0.
Tdestruct H0 as (a0,eq_a,(b0,eq_b,in_ab)).
destruct (proj2_sig a') as (h,_).
Tdestruct h as (a'0, eq_a').
constructor.
Texists a'0; trivial.
exists b0; trivial.
apply Z.in_reg with a0; trivial.
apply eq_Zeq.
rewrite <- (Eq_proj _ _ eq_a).
rewrite <- (Eq_proj _ _ eq_a').
trivial.
Qed.

Instance in_morph : Proper (eq_set ==> eq_set ==> iff) in_set.
Proof.
unfold eq_set in |- *; split; intros.
 apply in_reg with x; auto.
 elim (H0 x); auto.

 apply in_reg with y; auto.
  symmetry  in |- *; auto.
  elim (H0 y); auto.
Qed.

(** Surjectivity of lifting *)
Lemma Z2set_surj : forall x, #exists y, x == Z2set y.
intros.
destruct (proj2_sig x).
Tdestruct H.
Texists x0.
split; intros.
 rewrite in_set_elim in H1.
 Tdestruct H1.
 destruct H2.
 constructor.
 Texists x2; trivial.
 exists x3; trivial.
 simpl; auto.

 rewrite in_set_elim in H1.
 Tdestruct H1.
 destruct H2.
 constructor.
 Texists x2; trivial.
 simpl in H2.
 exists x0; trivial.
 rewrite <- H2; trivial.
Qed.

(**)

Lemma ex2_equiv (P Q:_->Prop) (P' Q':_->Prop) :
  (forall x x', x == Z2set x' -> (P x <-> P' x')) ->
  (forall x x', x == Z2set x' -> (Q x <-> Q' x')) ->
  ((#ex2 P Q) <-> (#ex2 P' Q')).
split; intros.
 Tdestruct H1.
 Tdestruct (Z2set_surj x) as (x',?).
 Texists x'.
  revert H1; apply -> H; trivial.
  revert H2; apply -> H0; trivial.

 Tdestruct H1.
 Texists (Z2set x).
  revert H1; apply <- H; reflexivity.
  revert H2; apply <- H0; reflexivity.
Qed.

Lemma set_intro' (P:set->Prop) (P':set->Prop) :
  (forall x, isL (P x)) ->
  Proper (eq_set ==> iff) P ->
  (forall z, (forall x, x ∈ z <-> P x) -> P' z) ->
  (#exists z, forall x, Z.in_set x z <-> P (Z2set x)) ->
  sig P'.
intros.
apply set_intro with (fun z => forall x, Z.in_set x z <-> P (Z2set x)); trivial.
 intros.
 apply Z.eq_set_ax; intros.
 rewrite H3; rewrite H4; reflexivity.

 intros.
 apply H1.
 split; intros.
  apply In_elim with (3:=H3); simpl; intros; auto.
  apply Eq_proj in H4.
  rewrite H4; rewrite <- H5; trivial.

  apply In_intro; simpl; intros.
  apply Eq_proj in H4.
  rewrite H5.
  rewrite <- H4; trivial.
Qed.

(** * Skolemizing Zermelo axioms *)

(** empty set *)

Lemma empty_sig : { empty | forall x, x ∈ empty -> #False }.
apply set_intro' with (P:=fun _ => #False); intros; auto.
 do 2 red; reflexivity.

 rewrite H in H0; trivial.

 Tdestruct Z.empty_ex; intros.
 Texists x; split; intros; eauto.
 Tabsurd; trivial.
Qed.

Definition empty := proj1_sig empty_sig.
Lemma empty_ax: forall x, x ∈ empty -> #False.
Proof proj2_sig empty_sig.

(** pair *)

Let pair_spec a b x := #(x == a \/ x == b).

Let pair_spec_morph a b :
  Proper (eq_set ==> iff) (pair_spec a b).
unfold pair_spec; intros.
do 2 red; intros.
rewrite H; reflexivity.
Qed.

Lemma pair_sig : forall a b,
  { pair | forall x, x ∈ pair <-> pair_spec a b x }.
intros a b.
apply set_intro' with (P:=pair_spec a b); unfold pair_spec; intros; auto.
 apply pair_spec_morph; trivial.

 Tdestruct (Z2set_surj a) as (a',?).
 Tdestruct (Z2set_surj b) as (b',?).
 Tdestruct (Z.pair_ex a' b') as (w,?).
 Texists w; intros.
 rewrite H1.
 rewrite H; rewrite H0.
 apply Tr_morph.
 apply or_iff_morphism.
  symmetry; apply eq_equiv.

  symmetry; apply eq_equiv.
Qed.

Definition pair a b := proj1_sig (pair_sig a b).
Lemma pair_ax: forall a b x, x ∈ pair a b <-> #(x == a \/ x == b).
Proof fun a b => proj2_sig (pair_sig a b).

(** union *)

Let union_spec a x := #exists2 y, x ∈ y & y ∈ a.

Let union_spec_morph a :
  Proper (eq_set==>iff) (union_spec a).
do 2 red; intros.
apply Tr_morph; apply ex2_morph; red; intros; auto with *.
rewrite H; reflexivity.
Qed.

Lemma union_sig: forall a,
  { union | forall x, x ∈ union <-> union_spec a x }.
intro a.
apply set_intro' with (P:=union_spec a); unfold union_spec; intros; auto.
 apply union_spec_morph; trivial.

 Tdestruct (Z2set_surj a) as (a',?).
 Tdestruct (Z.union_ex a') as (z,spec).
 Texists z; intros.
 rewrite spec.
 symmetry; apply ex2_equiv; intros.
  rewrite H0; apply in_equiv.

  rewrite H0; rewrite H; apply in_equiv.
Qed.

Definition union a := proj1_sig (union_sig a).
Lemma union_ax: forall a x,
  x ∈ union a <-> #exists2 y, x ∈ y & y ∈ a.
Proof fun a => proj2_sig (union_sig a).

(** subset *)

Let subset_spec a P x := x ∈ a /\ #exists2 x', x == x' & P x'.

Let subset_spec_morph a P :
  Proper (eq_set ==> iff) (subset_spec a P).
do 2 red; intros.
apply and_iff_morphism.
 rewrite H; reflexivity.

 apply Tr_morph; apply ex2_morph; red; intros; auto with *.
 rewrite H; reflexivity.
Qed.

Lemma subset_sig: forall a P,
  { subset | forall x, x ∈ subset <->
             (x ∈ a /\ #exists2 x', x==x' & P x') }.
intros a P.
apply set_intro' with (P:=subset_spec a P); unfold subset_spec; intros; auto.
 apply subset_spec_morph; trivial.

 Tdestruct (Z2set_surj a) as (a',?).
 Tdestruct (Z.subset_ex a' (fun z => #exists2 z', z' == Z2set z & P z')) as (w,?).
 Texists w; intros.
 rewrite H0.
 apply and_iff_morphism.
  rewrite H; symmetry; apply in_equiv.

  split; intros.
   Tdestruct H1.
   Tdestruct H2.
   Texists x1; trivial.
   rewrite H2; apply eq_equiv; trivial.

   Tdestruct H1.
   Texists x; auto with *.
   Texists x0; auto with *.
Qed.

Definition subset a P := proj1_sig (subset_sig a P).
Lemma subset_ax : forall a P x,
    x ∈ subset a P <-> (x ∈ a /\ #exists2 x', x==x' & P x').
Proof fun a P => proj2_sig (subset_sig a P).

(** power set *)

Let power_spec a x := forall y, y ∈ x -> y ∈ a.

Let power_spec_morph a :
  Proper (eq_set ==> iff) (power_spec a).
do 2 red; intros.
apply fa_morph; intro.
rewrite H; reflexivity.
Qed.

Lemma power_sig: forall a,
  { power | forall x, x ∈ power <-> (forall y, y ∈ x -> y ∈ a) }.
intro a.
apply set_intro' with (P:=power_spec a); unfold power_spec; intros; auto.
 apply power_spec_morph; trivial.

 Tdestruct (Z2set_surj a) as (a',?).
 Tdestruct (Z.power_ex a') as (z,spec).
 Texists z; intros.
 rewrite spec.
 split; intros.
  Tdestruct (Z2set_surj y).
  rewrite H; rewrite H2; apply in_equiv; apply H0; apply in_equiv.
  rewrite <- H2; trivial.

  apply in_equiv; rewrite <- H; apply H0; apply in_equiv; trivial.
Qed.

Definition power a := proj1_sig (power_sig a).
Lemma power_ax:
  forall a x, x ∈ power a <-> (forall y, y ∈ x -> y ∈ a).
Proof fun a => proj2_sig (power_sig a).

(** uchoice holds, but we need to give the proof that P is a specification to
    the Skolem symbol. *)

Definition uchoice_pred (P:set->Prop) :=
  (forall x x', x == x' -> P x -> P x') /\
  (#exists x, P x) /\
  (forall x x', P x -> P x' -> x == x').

Definition uchoice (P : set -> Prop) (Hp : uchoice_pred P) : set.
exists (fun z => P (Z2set z)).
destruct Hp.
destruct H0.
split; intros.
 Tdestruct H0.
 Tdestruct (Z2set_surj x).
 Texists x0; apply H with x; trivial.

 apply eq_Zeq.
 auto.
Defined.

Lemma uchoice_ax : forall P h x,
  (x ∈ uchoice P h <-> #exists2 z, P z & x ∈ z).
split; intros.
 destruct H.
 Tdestruct H.
 destruct H0.
 simpl in H0.
 Texists (Z2set x1); trivial.
 apply In_intro; intros.
 simpl in H3.
 rewrite H3.
 destruct (proj2_sig x).
 rewrite (H5 x' x0); trivial.

 Tdestruct H.
 destruct H0.
 Tdestruct H0.
 destruct H1.
 constructor.
 Texists x1; trivial.
 simpl.
 exists x2; trivial.
 apply (proj1 h x0); trivial.
 apply Eq_proj; trivial.
Qed.

Lemma uchoice_morph_raw : forall (P1 P2:set->Prop) h1 h2,
  (forall x x', x == x' -> (P1 x <-> P2 x')) ->
  uchoice P1 h1 == uchoice P2 h2.
intros.
apply eq_set_ax; intros.
rewrite uchoice_ax.
rewrite uchoice_ax.
apply Tr_morph; apply ex2_morph; red; intros.
 apply H; reflexivity.

 reflexivity.
Qed.

Instance uchoice_pred_morph : Proper ((eq_set ==> iff) ==> iff) uchoice_pred.
apply morph_impl_iff1; auto with *.
do 3 red; intros.
destruct H0 as (?,(?,?)); split;[|split]; intros.
 assert (x x0).
  revert H4; apply H; auto with *.
 revert H5; apply H; trivial.

 Tdestruct H1; Texists x0.
 revert H1; apply H; auto with *.

 apply H2; [revert H3|revert H4]; apply H; auto with *.
Qed.

Lemma uchoice_ext : forall (P:set->Prop) h x, (#P x) -> x == uchoice P h.
intros.
apply eq_set_ax;intros.
rewrite uchoice_ax.
Telim H; intro.
split; intros.
 Texists x; trivial.

 Tdestruct H0.
 destruct h.
 destruct H3.
 rewrite (H4 x x1); auto.
Qed.

Lemma uchoice_def : forall P h, #P (uchoice P h).
intros.
destruct h.
destruct a.
Tdestruct t.
Tin; apply p with x; trivial.
apply uchoice_ext; trivial.
Tin; trivial.
Qed.

(** infinite set (natural numbers) *)

Definition Nat x :=
  forall (P:set),
  empty ∈ P ->
  (forall x, x ∈ P -> union (pair x (pair x x)) ∈ P) ->
  x ∈ P.

Instance Nat_morph : Proper (eq_set ==> iff) Nat.
unfold Nat; split; intros.
 rewrite <- H; apply H0; trivial.
 rewrite H; apply H0; trivial.
Qed.

Lemma Nat_S : forall x,
  Nat x -> Nat (union (pair x (pair x x))).
unfold Nat; intros; auto.
Qed.

Definition infinite_sig :
  { infty | empty ∈ infty /\
      forall x, x ∈ infty -> union (pair x (pair x x)) ∈ infty }.
apply set_intro' with (P:=Nat).
 unfold Nat; auto.

 apply Nat_morph.

 intros.
 split; intros.
  rewrite H; red; auto.

  rewrite H in H0|-*.
  apply Nat_S; trivial.

 Tdestruct Z.infinity_ex as (infty,?,?).
 Tdestruct (Z.subset_ex infty (fun x => Nat(Z2set x))) as (z,spec).
 Texists z.
 split; intros.
  rewrite spec in H1.
  destruct H1.
  red; Tdestruct H2.
  revert H3; apply Nat_morph.
  apply eq_equiv; trivial.

  rewrite spec.
  split.
  2:Texists x; auto with *.
  apply in_equiv; apply H1; intros.
   Tdestruct H.
   assert (empty == Z2set x0).
    apply eq_set_ax; split; intros.
     Tabsurd; apply empty_ax with (1:=H3).

     Tdestruct (Z2set_surj x1).
     Tabsurd; apply H with x2.
     apply in_equiv; rewrite<- H4; trivial.
   rewrite H3; apply in_equiv; trivial.

   Tdestruct (Z2set_surj x0).
   rewrite H3 in H2; apply in_equiv in H2.
apply H0 in H2; clear H0.
Tdestruct H2.
apply in_equiv in H2; revert H2; apply in_reg.
rewrite eq_set_ax.
intros.
rewrite union_ax.
Tdestruct (Z2set_surj x3).
rewrite H2; rewrite in_equiv.
rewrite H0.
split; intros.
 Tdestruct H4.
  Texists (pair x0 x0).
   rewrite pair_ax; Tleft.
   rewrite H2; rewrite H3; apply eq_equiv; trivial.

   rewrite pair_ax; Tright; reflexivity.

  Texists x0.
   rewrite H2; rewrite H3; apply in_equiv; trivial.

   rewrite pair_ax; Tleft; reflexivity.

 Tdestruct H4.
 rewrite <- eq_equiv.
 rewrite <- in_equiv.
 rewrite <- H3.
 rewrite <- H2.
 rewrite pair_ax in H5; Tdestruct H5.
  Tright; rewrite <- H5; trivial.

  rewrite H5 in H4.
  Tleft.
  rewrite pair_ax in H4; Tdestruct H4; trivial.
Qed.
Definition infinite := proj1_sig infinite_sig.
Lemma infinity_ax1: empty ∈ infinite.
Proof proj1 (proj2_sig infinite_sig).

Lemma infinity_ax2: forall x,
  x ∈ infinite -> union (pair x (pair x x)) ∈ infinite.
Proof proj2 (proj2_sig infinite_sig).

(** well-founded induction *)

Lemma wf_ax0 (P:set->Prop):
  (forall x, isL (P x)) ->
  (forall x, (forall y, y ∈ x -> P y) -> P x) ->
  forall x, P x.
intros.
cut (forall xs (x:set), x == Z2set xs -> P x).
 intros.
 Tdestruct (Z2set_surj x).
 eauto.
clear x.
intros xs; elim xs using Z.wf_ax0; intros; auto.
apply H0; intros.
Tdestruct (Z2set_surj y).
rewrite H2,H4 in H3.
apply in_inZ in H3; eauto.
Qed.

Lemma wf_ax :
  forall (P:set->Prop),
  (forall x, (forall y, y ∈ x -> #P y) -> #P x) ->
  forall x, #P x.
intros; apply wf_ax0 with (P:=fun x => #P x); auto.
Qed.

(** * Skolemizing Replacement *)

Definition funDom (R:set -> set -> Prop) x :=
  forall x' y y', R x y -> R x' y' -> x == x' -> y == y'.
Definition downR (R:set -> set -> Prop) x' y' :=
  exists2 x, x == Z2set x' /\ funDom R x & exists2 y, y == Z2set y' & R x y.

Lemma downR_morph : Proper
  ((eq_set ==> eq_set ==> iff) ==> Z.eq_set ==> Z.eq_set ==> iff) downR.
do 4 red; intros.
unfold downR.
apply Zeq_eq in H0.
apply Zeq_eq in H1.
apply ex2_morph; red; intros.
 apply and_iff_morphism.
  rewrite H0; reflexivity.

  unfold funDom.
  split; intros.
   rewrite <- (fun e1 => H a a e1 y2 y2) in H3; auto with *.
   rewrite <- (fun e1 => H x' x' e1 y' y') in H4; eauto with *.

   rewrite (fun e1 => H a a e1 y2 y2) in H3; auto with *.
   rewrite (fun e1 => H x' x' e1 y' y') in H4; eauto with *.

 apply ex2_morph; red; intros.
  rewrite H1; reflexivity.
  apply H; reflexivity.
Qed.

Lemma downRm : forall R x x' y y',
  Z.eq_set x x' ->
  Z.eq_set y y' ->
  downR R x y ->
  downR R x' y'.
intros.
destruct H1 as (xx,(eqx,fdomx), (yy,eqy,rel)).
exists xx.
 split; trivial.
 rewrite eqx.
 rewrite eq_equiv; trivial.
exists yy; trivial.
rewrite eqy.
rewrite eq_equiv; trivial.
Qed.

Lemma downR_fun : forall R x y y',
  downR R x y ->
  downR R x y' ->
  Z.eq_set y y'.
intros.
destruct H as (xx,(eqx,fdomx), (yy,eqy,rel)).
destruct H0 as (xx',(eqx',_), (yy',eqy',rel')).
apply eq_Zeq.
rewrite <- eqy; rewrite <- eqy'.
red in fdomx.
apply fdomx with xx'; trivial.
rewrite eqx; rewrite eqx'.
reflexivity.
Qed.

Module Type ExReplacement.
Parameter repl_ex : forall a (R:Z.set->Z.set->Prop),
  (forall x x' y y', Z.in_set x a -> Z.eq_set x x' -> Z.eq_set y y' -> R x y -> R x' y') ->
  (forall x y y', Z.in_set x a -> R x y -> R x y' -> Z.eq_set y y') ->
  #exists b, forall x, Z.in_set x b <-> #exists2 y, Z.in_set y a & R y x.
End ExReplacement.

Module SkolemReplacement (Repl : ExReplacement).

Lemma repl0 : forall (a:set) (R:set->set->Prop), set.
intros a R.
exists
 (fun a' => forall x,
  Z.in_set x a' <-> #exists2 y, Z2set y ∈ a & downR R y x).
split; intros.
 Tdestruct (Z2set_surj a).
 assert (R'm := fun x0 x' y y' (_:Z.in_set x0 x) => downRm R x0 x' y y').
 assert (R'fun := fun x0 y y' (_:Z.in_set x0 x) => downR_fun R x0 y y').
 Tdestruct (Repl.repl_ex x (downR R) R'm R'fun); intros.
 Texists x0; intros.
 rewrite H0.
 apply Tr_morph; apply ex2_morph; red; intros.
 2:reflexivity.
 split; intros.
  rewrite H.
  apply inZ_in; trivial.

  apply in_inZ.
  rewrite <- H; trivial.

 rewrite Z.eq_set_ax; intros.
 rewrite H.
 rewrite H0.
 reflexivity.
Defined.

Definition incl_set x y := forall z, z ∈ x -> z ∈ y.

Lemma repl0_mono :
  Proper (incl_set ==> (eq_set ==> eq_set ==> iff) ==> incl_set) repl0.
do 4 red; simpl; intros.
rewrite in_set_elim in *.
Tdestruct H1.
destruct H2.
simpl in *; intros.
Tdestruct (Z2set_surj y).
assert (R'm := fun x x' y y' (_:Z.in_set x x3) => downRm y0 x x' y y').
assert (R'fun := fun x y y' (_:Z.in_set x x3) => downR_fun y0 x y y').
Tdestruct (Repl.repl_ex x3 (downR y0) R'm R'fun).
Texists x1; trivial.
exists x4; trivial.
 intro; rewrite H5.
 apply Tr_morph; apply ex2_morph; red; intros; auto with *.
 rewrite H4.
 symmetry; apply in_equiv.

 rewrite H5.
 rewrite H2 in H3.
 clear x2 H1 H2 x4 H5.
 Tdestruct H3.
 Texists x2.
  apply H in H1.
  rewrite H4 in H1; rewrite in_equiv in H1; trivial.

  revert H2; apply iff_impl; apply downR_morph; auto with *.
Qed.

Lemma repl_sig :
  { repl |
    Proper (incl_set ==> (eq_set ==> eq_set ==> iff) ==> incl_set) repl /\
    forall a (R:set->set->Prop),
    (forall x x' y y', x ∈ a -> x == x' -> y == y' -> R x y -> R x' y') ->
    (forall x y y', x ∈ a -> R x y -> R x y' -> y == y') ->
    forall x, x ∈ repl a R <-> #exists2 y, y ∈ a & R y x }.
exists repl0; split.
 exact repl0_mono.
split; intros.
 rewrite in_set_elim in H1.
 Tdestruct H1.
 destruct H2; simpl in *.
 rewrite H2 in H3.
 Tdestruct H3.
 destruct H4.
 destruct H5.
 destruct H4.
 Texists x3.
  rewrite H4; trivial.
 revert H6; apply H; auto with *.
  rewrite H4; trivial.

  apply Eq_proj in H1.
  rewrite H1; trivial.

 Tdestruct H1.
 apply In_intro; simpl; intros.
 rewrite H4; clear H4.
 Tdestruct (Z2set_surj x0).
 Texists x1.
  rewrite <- H4; trivial.
 exists x0.
  split; intros; eauto.
  red; intros.
  apply H0 with x0; trivial.
  revert H6; apply H; auto with *.
  rewrite <- H7; trivial.

  exists x; trivial.
  apply Eq_proj; trivial.
Defined.

Definition repl := proj1_sig repl_sig.
Lemma repl_mono :
  Proper (incl_set ==> (eq_set ==> eq_set ==> iff) ==> incl_set) repl.
Proof (proj1 (proj2_sig repl_sig)).
Lemma repl_ax:
    forall a (R:set->set->Prop),
    (forall x x' y y', x ∈ a -> x == x' -> y == y' -> R x y -> R x' y') ->
    (forall x y y', x ∈ a -> R x y -> R x y' -> y == y') ->
    forall x, x ∈ repl a R <-> #exists2 y, y ∈ a & R y x.
Proof proj2 (proj2_sig repl_sig).

End SkolemReplacement.

(*
(** Replacement can be skolemized in the general case only using TTColl *)
Module TTCollRepl : ExReplacement.
Definition repl_ex := Z.repl_ex.
End TTCollRepl.
Include SkolemReplacement TTCollRepl.
*)

(** * Collection *)

(** ** Keeping existential version of collection in intutionistic logic. *)

Definition downR' (R:set -> set -> Prop) x' y' :=
  exists2 x, x == Z2set x' & exists2 y, y == Z2set y' & R x y.

Lemma downR'_morph : Proper
  ((eq_set ==> eq_set ==> iff) ==> Z.eq_set ==> Z.eq_set ==> iff) downR'.
do 4 red; intros.
unfold downR'.
apply Zeq_eq in H0.
apply Zeq_eq in H1.
apply ex2_morph; red; intros.
 rewrite H0; reflexivity.

 apply ex2_morph; red; intros.
  rewrite H1; reflexivity.
  apply H; reflexivity.
Qed.

Lemma coll_ex : forall A (R:set->set->Prop),
    Proper (eq_set ==> eq_set ==> iff) R ->
    #exists B, forall x, x ∈ A ->
         (#exists y, R x y) -> #exists2 y, y ∈ B & R x y.
intros.
Tdestruct (Z2set_surj A) as (A',?).
Tdestruct (Z.coll_ex A' _ (downR'_morph R R H)) as (B,HB).
Texists (Z2set B).
intros.
rewrite H0 in H1.
Tdestruct (Z2set_surj x) as (x',?).
rewrite H3 in H1; rewrite in_equiv in H1.
assert (#exists y, downR' R x' y).
 Tdestruct H2 as (y,?).
 Tdestruct (Z2set_surj y) as (y',?).
 Texists y'; red; eauto.
Tdestruct (HB _ H1 H4) as (y,?,(x'',?,(y',?,?))).
Texists y'.
 rewrite H7; rewrite in_equiv; trivial.

 rewrite H3; rewrite <- H6; trivial.
Qed.

(** ** Skolemizing Collection in classical logic *)

Module ClassicCollection.

(** Proving that collection can be skolemized in classical ZF:
    we need excluded-middle to prove coll_ax_uniq (see EnsEm)
 *)

Section Classic.

Hypothesis EM : forall P, #(P \/ (P -> #False)).

(** We need to provide a spec that is more specific than what appears here
    (it is not uniquely satifiable). Instead, we specify coll as the
    smallest Veblen universe that satisfies collection. This is why we need
    excluded-middle. *)
Lemma coll_sig : forall A (R:set->set->Prop),
  {coll| Proper (eq_set==>eq_set==>iff) R ->
     forall x, x ∈ A ->
     (#exists y, R x y) ->
     (#exists2 y, y ∈ coll & R x y) }.
intros A R.
pose (R' x y := exists2 x', Z2set x == x' & exists2 y', Z2set y == y' & R x' y').
assert (R'm : Proper (Z.eq_set==>Z.eq_set==>iff) R').
 apply morph_impl_iff2; auto with *.
 do 4 red; intros.
 destruct H1 as (x'',?,(y'',?,?)).
 exists x'';[|exists y'';trivial].
  transitivity (Z2set x); trivial.
  apply Zeq_eq.
  symmetry; trivial.

  transitivity (Z2set x0); trivial.
  apply Zeq_eq.
  symmetry; trivial.
apply set_intro with
  (Z.lst_rk(fun B => exists2 A', Z2set A' == A & forall x, Z.in_set x A' ->
      (#exists y, R' x y) ->
      (#exists2 y, Z.in_set y B & R' x y))); intros.
 Tdestruct (Z2set_surj A) as (A',e).
 Tdestruct (Z.coll_ax_uniq EM A' R' R'm) as (B,HB); eauto.
 Texists B.
 revert HB; apply Z.lst_rk_morph; auto with *.
 intros.
 split; intros.
  exists A'; intros; auto with *.
  Tdestruct (H0 x0 H1 H2) as (y,?,?); trivial.
  Texists y; trivial.
  revert H3; apply Zin_morph; auto with *.

  destruct H0 as (A'',e',?).
  rewrite e in e'.
  apply eq_Zeq in e'.
  rewrite <- e' in H1.
  Tdestruct (H0 x0 H1 H2) as (y,?,?); trivial.
  Texists y; trivial.
  revert H3; apply Zin_morph; auto with *.

 apply Z.lst_fun with (1:=H) (2:=H0).

 Tdestruct Hex as (B,HB).
 assert (Bok := Z.lst_incl _ _ HB).
 destruct Bok as (A',eA,Bok).
 Tdestruct (Z2set_surj x) as (x',ex).
 rewrite ex in H0; rewrite <- eA in H0; apply in_inZ in H0.
 assert (#exists y, R' x' y).
  Tdestruct H1 as (y,Rxy).
  Tdestruct (Z2set_surj y) as (y',ey).
  Texists y'; exists x; [|exists y]; auto with *.
 Tdestruct (Bok x' H0 H2)  as (y,?,?).
 destruct H4 as (x'',?,(y',?,?)).
 Texists (Z2set y).
  apply In_intro; simpl; intros.
  specialize Huniq with (1:=HB) (2:=H8).
  rewrite <- Huniq.
  rewrite H7; trivial.

  revert H6; apply H; trivial.
  rewrite ex; trivial.
Qed.

Definition coll A R := proj1_sig (coll_sig A R).
Lemma coll_ax : forall A (R:set->set->Prop),
  Proper (eq_set==>eq_set==>iff) R ->
  forall x, x ∈ A -> (#exists y, R x y) ->
  #exists2 y, y ∈ coll A R & R x y.
Proof (fun A R => proj2_sig (coll_sig A R)).

End Classic.
End ClassicCollection.

End Skolem.

(** * Instance *)

(** Several useful instances *)

(** Model of IZF_R *)

Module IZF_R <: IZF_R_sig CoqSublogicThms.
  Import CoqSublogic.
  Include Skolem CoqSublogicThms.
  Definition intuit : forall P:Prop, Tr P -> P := fun P h => h.
  Module Re <: ExReplacement.
    Definition repl_ex := Z.intuit_repl_ax intuit.
  End Re.
  Include SkolemReplacement Re.
End IZF_R.

Let IZFRpack := (IZF_R.repl_mono,IZF_R.repl_ax,IZF_R.wf_ax).
Print Assumptions IZFRpack. (* TTrepl *)

(** Model of IZF_C *)

Module IZF_C <: IZF_C_sig CoqSublogicThms := Skolem CoqSublogicThms.
Let IZFCpack := (IZF_C.coll_ex,IZF_C.wf_ax).
Print Assumptions IZFCpack. (* TTcoll (with intuitionistic equality on sets) *)

(** A model of ZF, based only on TTColl (no ecluded-middle in the
    metatheory).
 *)
Module ZF <: ZF_sig ClassicSublogicThms.
 Include Skolem ClassicSublogicThms.
 Import ClassicSublogicThms.
 Lemma EM : forall P, #(P \/ (P -> #False)).
cbv beta; intros P nem.
apply nem.
right; intros p _.
apply nem.
left; exact p.
Qed.
 Definition coll := (ClassicCollection.coll EM).
 Lemma coll_ax : forall A R,
    Proper (eq_set==>eq_set==>iff) R ->
    forall x, x ∈ A ->
      (#exists y, R x y) -> (#exists2 y, y ∈ coll A R & R x y).
 Proof ClassicCollection.coll_ax EM.
End ZF.

Let ZFpack := ZF.coll_ax.
Print Assumptions ZFpack. (* TTColl (with classical equality on sets) *)
(* Eval cbv beta delta - [ ZF.Z.eq_set Proper respectful iff ] iota in ZF.Z.ttcoll.
 *)


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Meta_theory.Parallel_postulates.rah_thales_postulate.
Require Import GeoCoq.Meta_theory.Parallel_postulates.thales_converse_postulate_weak_triangle_circumscription_principle.
Require Import GeoCoq.Meta_theory.Parallel_postulates.thales_postulate_thales_converse_postulate.
Require Import GeoCoq.Meta_theory.Parallel_postulates.weak_triangle_circumscription_principle_bachmann_s_lotschnittaxiom.
Require Import GeoCoq.Tarski_dev.Annexes.saccheri.
Require Import GeoCoq.Tarski_dev.Ch12_parallel.

Section universal_posidonius_postulate_perpendicular_transversal_postulate.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma universal_posidonius_postulate__perpendicular_transversal_postulate :
  universal_posidonius_postulate -> perpendicular_transversal_postulate.
Proof.
intros HP A B C D P Q HPar HPerp1 HCop.
elim HPar; intro HParS; [|destruct HParS as [_ [_ [HC1 HC2]]]; assert_diffs;
                          apply perp_sym; apply perp_col0 with A B; Col; ColR].
assert (H := HPerp1); destruct H as [R HR];
apply perp_in_col in HR; destruct HR as [HC1 HC2].
assert (HEF : exists E F, Col A B E /\ Col C D F /\ Perp A B E F /\ E <> R).
  {
  destruct (l8_18_existence A B C) as [E1 [HC3 HPerp2]];
  [apply par_strict_not_col_1 with D; Par|].
  destruct (l8_18_existence A B D) as [E2 [HC4 HPerp3]];
  [apply par_strict_not_col_1 with C; Par|].
  elim (eq_dec_points E1 R); intro; treat_equalities;
  [|exists E1, C; repeat (split; Col; Perp)].
  elim (eq_dec_points E1 E2); intro; treat_equalities;
  [|exists E2, D; repeat (split; Col; Perp)].
  assert (HC4 : Col E1 C D)
    by (apply cop_perp2__col with A B; Perp; apply par__coplanar in HPar; Cop).
  destruct HParS as [_ [_ [_ HF]]]; exfalso; apply HF; exists E1; Col.
  }
destruct HEF as [E [F [HC3 [HC4 [HPerp2 HD1]]]]].
assert (HGH : exists G H,
                Col A B G /\ Col C D H /\ Perp A B G H /\ E <> G /\ F <> H).
  {
  destruct (l8_18_existence A B C) as [E1 [HC5 HPerp3]];
  [apply par_strict_not_col_1 with D; Par|].
  destruct (l8_18_existence A B D) as [E2 [HC6 HPerp4]];
  [apply par_strict_not_col_1 with C; Par|].
  elim (eq_dec_points E1 E); intro HD; treat_equalities;
  [|exists E1, C; repeat (split; Col; Perp); intro; treat_equalities; apply HD;
    apply l6_21 with A B F E; assert_diffs; Col;
    [elim (perp_not_col2 _ _ _ _ HPerp2); Col|
     apply cop_perp2__col with A B; Perp]]; Cop.
  elim (eq_dec_points E1 E2); intro HD'; treat_equalities;
  [assert (HC7 : Col E1 C D)
     by (apply cop_perp2__col with A B; Perp; apply par__coplanar in HPar; Cop);
   destruct HParS as [_ [_ [_ HF]]]; exfalso; apply HF; exists E1; Col|].
  exists E2, D; repeat (split; Col; Perp); intro; treat_equalities; apply HD'.
  apply l6_21 with A B F E1; assert_diffs; Col;
  [elim (perp_not_col2 _ _ _ _ HPerp2); Col|apply cop_perp2__col with A B; Perp;
                                            apply par__coplanar in HPar; Cop].
  }
destruct HGH as [G [H [HC5 [HC6 [HPerp3 [HD2 HD3]]]]]].
assert (HSacc1 : Saccheri E F H G).
  {
  split; [apply perp_per_1; apply perp_col0 with A B; Perp|].
  split; [apply perp_per_1; apply perp_sym; apply perp_col0 with A B; Perp|].
  split; [assert (Cong E F G H); Cong; apply HP with A B C D; Col|].
  apply l12_6; apply par_strict_col2_par_strict with C D; Col.
  apply par_strict_symmetry;
  apply par_strict_col2_par_strict with A B; Col; Par.
  }
destruct (midpoint_existence E G) as [M1 HMid1].
destruct (midpoint_existence F H) as [M2 HMid2].
assert (HLamb := mid2_sac__lam6521 _ _ _ _ _ _ HSacc1 HMid2 HMid1).
assert (HSacc2 : Saccheri E F M2 M1).
  {
  split; [unfold Lambert in *; spliter; Perp|].
  split; [unfold Lambert in *; spliter; Perp|].
  assert (HCong : Cong E F M1 M2); [|split; Cong].
    {
    apply HP with A B C D; Col; try solve [assert_diffs; assert_cols; ColR].
    apply perp_sym; apply perp_col0 with E M1;
    try solve [assert_diffs; assert_cols; Col; ColR].
    apply per_perp; unfold Lambert in *; spliter; Perp.
    }
  apply l12_6; apply par_strict_col2_par_strict with C D; Col;
  try solve [assert_diffs; assert_cols; Col; ColR].
  apply par_strict_symmetry;
  apply par_strict_col2_par_strict with A B; Col; Par;
  assert_diffs; assert_cols; Col; ColR.
  }
assert (HRAH : postulate_of_right_saccheri_quadrilaterals)
  by (apply per_sac__rah with M1 M2 F E; try apply sac_perm;
      unfold Lambert in *; spliter; auto).
assert (HP' : forall A1 A2 B1 B2 C1 C2 D1 D2 IAB IAC IBD,
        Perp A1 A2 B1 B2 -> Perp A1 A2 C1 C2 -> Perp B1 B2 D1 D2 ->
        Col A1 A2 IAB -> Col B1 B2 IAB ->
        Col A1 A2 IAC -> Col C1 C2 IAC ->
        Col B1 B2 IBD -> Col D1 D2 IBD ->
        Coplanar IAB IAC IBD C1 -> Coplanar IAB IAC IBD C2 ->
        Coplanar IAB IAC IBD D1 -> Coplanar IAB IAC IBD D2 ->
       ~ Col IAB IAC IBD ->
        exists I, Col C1 C2 I /\ Col D1 D2 I).
  {
  cut bachmann_s_lotschnittaxiom.

    {
    clear HP; clear dependent P; clear dependent Q; clear dependent R.
    intros bla A1 A2 B1 B2 C1 C2 D1 D2 IAB IAC IBD HPerpAB HPerpAC HPerpBD.
    intros HCol1 HCol2 HCol3 HCol4 HCol5 HCol6 HCop1 HCop2 HCop3 HCop4 HNC1.
    assert (Col IAB IAC A1) by (assert_diffs; ColR).
    assert (Col IAB IAC A2) by (assert_diffs; ColR).
    assert (Col IAB IBD B1) by (assert_diffs; ColR).
    assert (Col IAB IBD B2) by (assert_diffs; ColR).
    assert (Coplanar IAB IAC IBD A1) by Cop.
    assert (Coplanar IAB IAC IBD A2) by Cop.
    assert (Coplanar IAB IAC IBD B1) by Cop.
    assert (Coplanar IAB IAC IBD B2) by Cop.
    assert (HNC2 : ~ Col A1 A2 D1).
      {
      apply par_strict_not_col_1 with D2; apply par_not_col_strict with IBD;
      Col; try (intro; apply HNC1; assert_diffs; ColR).
      apply l12_9 with B1 B2; Perp; CopR.
      }
    assert (HNC3 : ~ Col B1 B2 C1).
      {
      apply par_strict_not_col_1 with C2; apply par_not_col_strict with IAC;
      Col; try (intro; apply HNC1; assert_diffs; ColR).
      apply l12_9 with A1 A2; Perp; CopR.
      }
    assert (HParA : Par_strict A1 A2 D1 D2).
      apply par_not_col_strict with D1; Col; apply l12_9 with B1 B2; Perp; CopR.
    assert (HParB : Par_strict B1 B2 C1 C2).
      apply par_not_col_strict with C1; Col; apply l12_9 with A1 A2; Perp; CopR.
    assert (HNCol3 : ~ Col IAC B1 B2) by (apply par_not_col with C1 C2; Par; ColR).
    assert (HNCol4 : ~ Col IBD A1 A2) by (apply par_not_col with D1 D2; Par; ColR).
    assert (HPQ : IAC <> IAB) by (assert_diffs; auto).
    assert (HQR : IAB <> IBD) by (assert_diffs; auto).
    destruct (diff_col_ex3 C1 C2 IAC) as [P1 [HC1P1 [HC2P1 [HPP1 HCP1]]]]; Col.
    destruct (diff_col_ex3 D1 D2 IBD) as [R1 [HD1R1 [HD2R1 [HRR1 HDR1]]]]; Col.
    destruct (bla IAC IAB IBD P1 R1) as [I [HI1 HI2]]; auto.
      apply perp_per_2; apply perp_col2 with A1 A2; Col;
      apply perp_sym; apply perp_col2 with B1 B2; Col; Perp.
      apply perp_per_2; apply perp_col2 with A1 A2; Col;
      apply perp_sym; apply perp_col2 with C1 C2; Col; Perp.
      apply perp_per_2; apply perp_col2 with B1 B2; Col;
      apply perp_sym; apply perp_col2 with D1 D2; Col; Perp.
      assert_diffs; apply col_cop2__cop with C1 C2; Col; CopR.
      assert_diffs; apply col_cop2__cop with D1 D2; Col; CopR.
    exists I.
    split; assert_diffs; ColR.
    }

    {
    apply weak_triangle_circumscription_principle__bachmann_s_lotschnittaxiom.
    apply thales_converse_postulate__weak_triangle_circumscription_principle.
    apply thales_postulate__thales_converse_postulate.
    apply rah__thales_postulate; assumption.
    }
  }
assert (HNC : ~ Col E R F).
  {
  assert_diffs; intro; destruct HParS as [_ [_ [_ HF]]];
  apply HF; exists F; split; Col; ColR.
  }
assert (~ Col C D R).
  {
  assert_diffs; intro; destruct HParS as [_ [_ [_ HF]]];
  apply HF; exists R; split; Col; ColR.
  }
assert (Col E R A) by (assert_diffs; ColR).
assert (Coplanar E R F A) by Cop.
assert (Col E R B) by (assert_diffs; ColR).
assert (Coplanar E R F B) by Cop.
assert (~ Col A B F) by (assert_diffs; intro; apply HNC; ColR).
assert (Coplanar A B F C)
  by (assert_diffs; apply col2_cop__cop with C D;
      try (apply pars__coplanar); Col).
assert (Coplanar A B F D)
  by (assert_diffs; apply col2_cop__cop with C D;
      try (apply pars__coplanar); Col).
assert (Coplanar C D R P)
  by (assert_diffs; apply col2_cop__cop with P Q; Col; Cop).
assert (Coplanar C D R Q)
  by (assert_diffs; apply col2_cop__cop with P Q; Col; Cop).
assert (Coplanar A B Q F) by CopR.
assert (Coplanar E R F P) by CopR.
assert (Coplanar E R F Q) by CopR.
assert (Coplanar E R F C) by CopR.
assert (Coplanar E R F D) by CopR.
assert (Coplanar A B Q E) by Cop.
destruct (HP' A B E F P Q C D E R F) as [S [HC7 HC8]]; Col;
[apply perp_col0 with F M2; try (apply perp_sym; apply per_perp);
 try solve [assert_diffs; assert_cols; Col; ColR];
 rewrite (lam_per__rah M1 _ _ _); try apply lam_perm; assumption|].
assert (HSacc3 : Saccheri E F S R).
  {
  split; [apply perp_per_1; apply perp_col0 with A B; Perp|].
  split; [apply perp_per_1; apply perp_col0 with P Q; try apply perp_col0 with A B; Perp;
          intro; treat_equalities; destruct HParS as [_ [_ [_ HF]]];
          exfalso; apply HF; exists S; Col|].
  split; [assert (Cong E F R S); Cong; apply HP with A B C D; Col;
          apply perp_col0 with P Q; Perp; intro; treat_equalities;
          destruct HParS as [_ [_ [_ HF]]]; exfalso; apply HF; exists R; Col|].
  apply l12_6; apply par_strict_col2_par_strict with C D; Col;
  try solve [assert_diffs; assert_cols; Col; ColR];
  try apply par_strict_symmetry;
  try apply par_strict_col2_par_strict with A B; Col; Par.
  intro; treat_equalities; assert (HC8 : Col E P Q)
    by (apply col_cop2_perp2__col with F A B; Col; Perp; Cop).
  apply HD1; elim (perp_not_col2 _ _ _ _ HPerp2); intro;
  [apply l6_21 with A B E F|apply l6_21 with A B F E];
  assert_diffs; Col; try ColR.
  }
apply perp_col0 with S R; try solve [assert_diffs; assert_cols; Col; ColR].
apply perp_col0 with F S; try solve [assert_diffs; assert_cols; Col; ColR].
apply per_perp; try solve[apply sac_distincts in HSacc3; spliter; auto].
apply l8_2; apply HRAH with E; apply sac_perm; assumption.
Qed.

End universal_posidonius_postulate_perpendicular_transversal_postulate.


From Equations Require Import Equations.
Require Import List.

(* The rest is a nonsensical, just to give a minimalistic reproducible example *)
Inductive Foo :=
| Prod : list Foo -> Foo.
Fixpoint compact_prod (T: list Type): Type :=
  match T with
  | nil => unit
  | t :: nil => t
  | t :: T0 => (t * compact_prod T0)%type
  end.

Equations foo_type (t : Foo) : Type :=
  foo_type (Prod fs) := compact_prod (List.map foo_type fs).

(* Moving val into the return type, rather than having it as an argument might be unnecessary if
   https://github.com/mattam82/Coq-Equations/issues/73 was fixed *)

Equations lookup (t:Foo) (val: foo_type t) (what: list nat) : option nat by struct t := {
  lookup (Prod ss) val nil := None;
  lookup (Prod ss) val (cons hd tl) := lookup_prod ss val hd tl }

    (* match what with nil=> None | cons hd tail => lookup_prod ss val hd tail end} *)

  where lookup_prod (ss: list Foo)
                                  (val : compact_prod (map foo_type ss))
                                  (what_hd: nat) (what_tl: list nat) : option nat by struct ss := {
  lookup_prod nil _ _ _ := None;
  lookup_prod (cons shd stl) _ _ what_tl with (fun val what_hd => lookup_prod stl val what_hd what_tl) => {
    lookup_prod (cons shd nil) val 0 what_tl _ := lookup shd val what_tl;
    lookup_prod (cons shd nil) _ _ _ _ := None;
    lookup_prod (cons shd _) val 0 what_tl _ := lookup shd (fst val) what_tl;
    lookup_prod (cons _ _) val (S what_hd) _ what_stl_fun := what_stl_fun (snd val) what_hd}}.


Ltac hyp_of_type t :=
 match goal with
| H1:t |- _ => H1
  end.

Ltac one_lemma :=
 match goal with
 | H:_ |- _ => solve [apply H;trivial | eapply H;eassumption]
  end.

Ltac mysubst :=
 repeat
( match goal with
 | H1:?a=?b |- _ => (subst a;try revert H1)
 end);intros.

Ltac spliter := repeat
match goal with
   | H:(?X1 /\ ?X2) |- _ => decompose [and] H;revert H
end;intros.

Lemma split_conj_imp : forall A B C : Prop, (A -> (B /\ C)) <-> ((A->B) /\ (A->C)).
Proof.
intros.
tauto.
Qed.

Lemma split_conj_forall : forall T: Type, forall (P Q: T -> Prop),
 (forall X, P X /\ Q X) <-> ((forall X, P X) /\ (forall X, Q X)).
Proof.
intros P Q.
split;intro H.
split;auto;intro;apply H.
spliter;auto.
Qed.

(* Splits conjunctions under forall *)
Ltac strong_spliter := repeat
 match goal with
 | H:_ |- _ => progress (repeat (setoid_rewrite split_conj_imp in H );
               repeat (setoid_rewrite (split_conj_forall) in H))
  end;
 spliter.

Ltac splits :=
 repeat
 match goal with
  | |- ?x /\ ?y => split
end.

Ltac remove_exists :=
repeat
 match goal with
  | |- exists x, _ => eexists
 end.

Ltac destruct_all :=
repeat
match goal with
   | H:_ |- _ => progress (decompose [ex and] H);clear H
end.

Create HintDb Sym.

Ltac finish_conj := splits;(eassumption || trivial || one_lemma || auto with Sym || eauto with Sym).

Ltac one_of_disjunct :=
 solve [repeat (solve [finish_conj] || (left;solve [finish_conj]) || right)].

Ltac rename_H H := let T := fresh in try rename H into T.

Ltac applying t :=
apply t;splits;(assumption || trivial || (strong_spliter;one_lemma) || (strong_spliter;eauto with Sym) ).

Ltac conclude := solve [unshelve (strong_spliter;remove_exists;one_of_disjunct);assumption | remove_exists;eassumption ].

Ltac contradict :=
 match goal with
 | H: False |- _ => elim H
 end.

Lemma negElimGen : forall P:Prop, P -> ~ P -> False.
Proof.
intros.
contradiction.
Qed.

Ltac contradiction_on t := apply (negElimGen t);strong_spliter;eauto with Sym.

Tactic Notation "by" "cases" "on" constr(t) :=
(let H := hyp_of_type t in destruct H;spliter).

#[global] Hint Resolve not_eq_sym : Sym.

Ltac inline_lemma_solver := intros;eauto 3 with Sym || (strong_spliter; eauto 4 with Sym || congruence).

Require Export Classical.

Lemma eq_neg_elim : forall {T:Type} (A B:T), A=B -> A<>B -> False.
Proof.
intros.
apply H0.
apply H.
Qed.

Lemma eq_excluded_middle : forall {T:Type} (A B:T), A = B \/ A <> B.
Proof.
intros.
elim (classic (A=B));auto.
Qed.


From discprob.basic Require Import base order.
From discprob.prob Require Import prob countable finite.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
Require Import Reals Fourier FunctionalExtensionality Psatz.
Require Import Coq.omega.Omega.
From Coquelicot Require Import Rcomplements Rbar Series Lim_seq Hierarchy Markov.
Global Set Bullet Behavior "Strict Subproofs".

Notation "x ≤ y" := (Rle x y) (at level 70, no associativity).
Notation "x ≥ y" := (Rge x y) (at level 70, no associativity).

Lemma Finite_inj x y: Finite x = Finite y → x = y.
Proof.
  inversion 1. done.
Qed.
Lemma big_cons_Rplus:
  ∀ (I : Type)
  (i : I) (r : seq I) (P : pred I) (F : I → R)
  (x:=\big[Rplus/0]_(j <- r | P j) F j),
  \big[Rplus/0]_(j <- (i :: r) | P j) F j = (if P i then (F i) else 0) + x.
Proof.
  intros. rewrite big_cons. case: ifP => //. by rewrite Rplus_0_l.
Qed.

Lemma Rlt_not_eq': ∀ r1 r2, r1 < r2 → r2 ≠ r1.
Proof. intros ??? Hfalse. symmetry in Hfalse. eapply Rlt_not_eq; last exact Hfalse. done. Qed.

Lemma if_sumbool_case_match {A: Type} P Q (b: {P} + {¬ P}) (b': {Q} + {¬ Q}) (x y: A):
  (P ↔ Q) → (if b then x else y) = (if b' then x else y).
Proof.
  intros HPQ; destruct b as [p|np], b' as [q|nq] => //=.
  - contradiction nq. by rewrite -HPQ.
  - contradiction np. by rewrite HPQ.
Qed.

(* TODO: lots of redundancy and duplication here *)

Lemma pr_sum_restrict {A: finType} (Ω: distrib A) (X: rrvar Ω) l P:
  \big[Rplus/0]_(i <- l | P i) pr_eq X i =
  \big[Rplus/0]_(i <- l | P i && (Rgt_dec (pr_eq X i) 0)) pr_eq X i.
Proof.
  symmetry; induction l.
  * rewrite ?big_nil //=.
  * rewrite ?big_cons.
    symmetry. case: ifP.
    **  intros HP. rewrite //=.
        case: ifP.
        *** intros. f_equal; eauto.
        *** rewrite /pr//=. destruct (Rgt_dec) as [|Hnt] => // _. apply Rnot_lt_ge in Hnt.
            rewrite -[a in _ = a]Rplus_0_l; f_equal; eauto.
            move: Hnt.
            rewrite /pr_eq.
            edestruct (ge_pr_0 Ω) as [Hge|]; eauto.
            intros. exfalso. rewrite //= in Hnt. rewrite //= in Hge. fourier.
    ** rewrite //=.
Qed.

Section pr_gt.

Definition pr_gt_indicator {A} {Ω: distrib A} (T: rrvar Ω) r :=
  indicator T (λ n, Rgt_dec n r).

Lemma pr_gt_to_indicator {A} {Ω: distrib A} (T: rrvar Ω) r:
  pr (rvar_dist T) (λ n, Rgt_dec (T n) r) = pr_eq (pr_gt_indicator T r) 1.
Proof.
  rewrite /pr_eq/pr. apply Series_ext => n. rewrite /countable_sum; destruct pickle_inv => //=.
  destruct Rgt_dec; rewrite /rvar_dist//=; eauto; case: ifP => //=; move /eqP; nra.
Qed.

Variable A: finType.
Variable Ω: distrib A.
Variable T: rrvar Ω.

Lemma pr_gt_alt r: pr (rvar_dist T) (λ a, Rgt_dec (T a) r)
                 = \big[Rplus/0]_(v : imgT T) if (Rgt_dec (sval v) r) then pr_eq T (sval v) else 0.
Proof.
  rewrite pr_gt_to_indicator /pr_gt_indicator. apply Finite_inj.
  rewrite -Ex_indicator/indicator//=. rewrite Ex_fin_comp => //=. rewrite /index_enum/id_rvar//=.
  f_equal; eapply eq_bigr => ?? => //=. case: ifP => ?; destruct Rgt_dec => //=; nra.
Qed.

(* There must be a better way to do this kind of splitting on sequences... *)
Lemma pr_gt_alt3 r: pr (rvar_dist T) (λ n, Rgt_dec (T n) r) =
                    \big[Rplus/0]_(i <- filter (λ x, Rgt_dec (sval x) r)
                                     (Finite.enum [finType of imgT T])) (pr_eq T (sval i)).
Proof.
  rewrite pr_gt_alt.
  rewrite big_filter //=.
  symmetry.
  transitivity (\big[Rplus/0]_(i : imgT (A:=A) T | (λ i, true) i && (Rgt_dec (sval i) r))
                 if (Rgt_dec (sval i) r) then pr_eq T (sval i) else 0).
  { apply eq_bigr. rewrite //=.  intros ?; destruct Rgt_dec => //=; done. }
  assert (H0: 0 = (\big[Rplus/0]_(i : imgT (A:=A) T | (λ i, true) i && ~~ (Rgt_dec (sval i) r))
                 if (Rgt_dec (sval i) r) then pr_eq T (sval i) else 0)).
  {
    symmetry; apply big1 => i.  move /negP. destruct (Rgt_dec) => //=.
  }
  rewrite -[a in a = _]Rplus_0_r [a in _ + a = _]H0 -bigID.
  rewrite //=.
Qed.
End pr_gt.

Lemma pr_gt_alt_comp {A: finType} {B: eqType} {Ω: distrib A} (T: rvar Ω B) (f: B → R) r:
 pr (rvar_dist (rvar_comp T f)) (λ n, Rgt_dec ((rvar_comp T f) n) r)
                 = \big[Rplus/0]_(v : imgT T) if (Rgt_dec (f (sval v)) r) then pr_eq T (sval v) else 0.
Proof.
  rewrite pr_gt_to_indicator /pr_gt_indicator. apply Finite_inj.
  rewrite -Ex_indicator/indicator//=. rewrite rvar_comp_assoc.
  rewrite Ex_fin_comp => //=. rewrite /index_enum/id_rvar//=.
  f_equal; eapply eq_bigr => ??; case: ifP; destruct (Rgt_dec) => //=; nra.
Qed.

Section pr_ge.

Definition pr_ge_indicator {A} {Ω: distrib A} (T: rrvar Ω) r :=
  indicator T (λ n, Rge_dec n r).

Lemma pr_ge_to_indicator {A} {Ω: distrib A} (T: rrvar Ω) r:
  pr (rvar_dist T) (λ n, Rge_dec (T n) r) = pr_eq (pr_ge_indicator T r) 1.
Proof.
  rewrite /pr_eq/pr. apply Series_ext => n. rewrite /countable_sum; destruct pickle_inv => //=.
  destruct Rge_dec; rewrite /rvar_dist//=; eauto; case: ifP => //=; move /eqP; nra.
Qed.

Variable A: finType.
Variable Ω: distrib A.
Variable T: rrvar Ω.

Lemma pr_ge_alt r: pr (rvar_dist T) (λ a, Rge_dec (T a) r)
                 = \big[Rplus/0]_(v : imgT T) if (Rge_dec (sval v) r) then pr_eq T (sval v) else 0.
Proof.
  rewrite pr_ge_to_indicator /pr_ge_indicator. apply Finite_inj.
  rewrite -Ex_indicator/indicator//=. rewrite Ex_fin_comp => //=. rewrite /index_enum/id_rvar//=.
  f_equal; eapply eq_bigr => ??; case: ifP; destruct Rge_dec => //=; nra.
Qed.

(* There must be a better way to do this kind of splitting on sequences... *)
Lemma pr_ge_alt3 r: pr (rvar_dist T) (λ n, Rge_dec (T n) r) =
                    \big[Rplus/0]_(i <- filter (λ x, Rge_dec (sval x) r)
                                     (Finite.enum [finType of imgT T])) (pr_eq T (sval i)).
Proof.
  rewrite pr_ge_alt.
  rewrite big_filter //=.
  symmetry.
  transitivity (\big[Rplus/0]_(i : imgT (A:=A) T | (λ i, true) i && (Rge_dec (sval i) r))
                 if (Rge_dec (sval i) r) then pr_eq T (sval i) else 0).
  { apply eq_bigr. rewrite //= => ?; destruct Rge_dec => //=. }
  assert (H0: 0 = (\big[Rplus/0]_(i : imgT (A:=A) T | (λ i, true) i && ~~ (Rge_dec (sval i) r))
                 if (Rge_dec (sval i) r) then pr_eq T (sval i) else 0)).
  {
    symmetry; apply big1 => i.  move /negP. destruct (Rge_dec) => //=.
  }
  rewrite -[a in a = _]Rplus_0_r [a in _ + a = _]H0 -bigID.
  rewrite //=.
Qed.
End pr_ge.

Lemma pr_ge_alt_comp {A: finType} {B: eqType} {Ω: distrib A} (T: rvar Ω B) (f: B → R) r:
 pr (rvar_dist (rvar_comp T f)) (λ n, Rge_dec ((rvar_comp T f) n) r)
                 = \big[Rplus/0]_(v : imgT T) if (Rge_dec (f (sval v)) r) then pr_eq T (sval v) else 0.
Proof.
  rewrite pr_ge_to_indicator /pr_ge_indicator. apply Finite_inj.
  rewrite -Ex_indicator/indicator//=. rewrite rvar_comp_assoc.
  rewrite Ex_fin_comp => //=. rewrite /index_enum/id_rvar//=.
  f_equal; eapply eq_bigr => ??; case: ifP; destruct Rge_dec => //=; nra.
Qed.

Section pr_eq.

Definition pr_eq_indicator {A} {B: eqType} {Ω: distrib A} (T: rvar Ω B) r :=
  indicator T (λ n, n == r).

Lemma pr_eq_to_indicator {A} {B} {Ω: distrib A} (T: rvar Ω B) r:
  pr (rvar_dist T) (λ n, (T n) == r) = pr_eq (pr_eq_indicator T r) 1.
Proof.
  rewrite /pr_eq/pr. apply Series_ext => n. rewrite /countable_sum; destruct pickle_inv => //=.
  case: ifP => ?; rewrite /rvar_dist//=; eauto; case: ifP => //=; move /eqP; nra.
Qed.

Variable A: finType.
Variable B: eqType.
Variable Ω: distrib A.
Variable T: rvar Ω B.

Lemma pr_eq_alt r: pr (rvar_dist T) (λ a, (T a) == r)
                 = \big[Rplus/0]_(v : imgT T) if (sval v == r) then pr_eq T (sval v) else 0.
Proof.
  rewrite pr_eq_to_indicator /pr_gt_indicator. apply Finite_inj.
  rewrite -Ex_indicator/indicator//=. rewrite Ex_fin_comp => //=. rewrite /index_enum/id_rvar//=.
  f_equal; eapply eq_bigr => ??; case: ifP; nra.
Qed.

End pr_eq.

Lemma pr_eq_alt_comp {A: finType} {B C: eqType} {Ω: distrib A} (T: rvar Ω B) (f: B → C) r:
  pr (rvar_dist (rvar_comp T f)) (λ n, (rvar_comp T f) n == r)
  = \big[Rplus/0]_(v : imgT T) if (f (sval v) == r) then pr_eq T (sval v) else 0.
Proof.
  rewrite pr_eq_to_indicator /pr_eq_indicator. apply Finite_inj.
  rewrite -Ex_indicator/indicator//=. rewrite rvar_comp_assoc.
  rewrite Ex_fin_comp => //=. rewrite /index_enum/id_rvar//=.
  f_equal; eapply eq_bigr => ??; case: ifP; nra.
Qed.

Section convert.
Lemma pr_gt_to_geq_eps {A: finType} {Ω: distrib A} (X: rrvar Ω) (x eps: R):
  (eps > 0 ∧ ∀ y, y \in img X → y ≠ x → Rabs (x - y) ≥ eps) →
    pr_gt X x = pr_ge X (x + eps/2).
Proof.
  intros (Hgt0&HX).
  rewrite /pr_ge /pr_gt !pr_ge_alt !pr_gt_alt.
  rewrite big_seq_cond.
  rewrite [a in _ = a]big_seq_cond.
  apply eq_bigr. intros (y&?) Hin => //=. rewrite Bool.andb_true_r in Hin.
  destruct (Rgt_dec) as [Hgt|Hngt] => //=.
  - destruct (Rge_dec) as [Hge|Hnge]; first done.
    exfalso; eapply Rlt_not_ge; last eapply (HX y); eauto.
    * rewrite Rabs_minus_sym Rabs_right; nra.
    * apply Rgt_not_eq. done.
  - destruct (Rge_dec); last done.
    exfalso; eapply Rlt_not_ge; last eapply (HX y); eauto.
    * rewrite Rabs_minus_sym Rabs_right; nra.
    * apply Rlt_not_eq. nra.
Qed.

Lemma pr_ge_to_gt_eps {A: finType} {Ω: distrib A} (X: rrvar Ω) (x eps: R):
  (eps > 0 ∧ ∀ y, y \in img X → y ≠ x → Rabs (x - y) ≥ eps) →
    pr_ge X x = pr_gt X (x - eps/2).
Proof.
  intros (Hgt0&HX).
  rewrite /pr_ge /pr_gt ?pr_ge_alt ?pr_gt_alt.
  rewrite big_seq_cond.
  rewrite [a in _ = a]big_seq_cond.
  apply eq_bigr. intros (y&?) Hin => //=. rewrite Bool.andb_true_r in Hin.
  destruct (Rge_dec).
  - destruct (Rgt_dec); first done.
    exfalso; eapply Rlt_not_ge; last eapply (HX y); eauto.
    * rewrite Rabs_minus_sym Rabs_right; nra.
    * apply Rlt_not_eq. nra.
  - destruct (Rgt_dec); last done.
    exfalso; eapply Rlt_not_ge; last eapply (HX y); eauto.
    * rewrite Rabs_minus_sym Rabs_left; nra.
    * apply Rlt_not_eq. nra.
Qed.

Lemma pr_ge_split_eps {A: finType} {Ω: distrib A} (X: rrvar Ω) (x eps: R):
  (eps > 0 ∧ ∀ y, y \in img X → y ≠ x → Rabs (x - y) ≥ eps) →
    pr_eq X x = pr_ge X (x - eps/2) - pr_ge X (x + eps/2).
Proof.
  intros (Hgt0&HX).
  rewrite /pr_ge ?pr_ge_alt.
  rewrite /Rminus.
  rewrite -[a in _ = _ + - a](Rmult_1_l) Ropp_mult_distr_l.
  rewrite big_distrr //=.
  rewrite -big_split //=.
  rewrite {1}/pr_eq ?pr_eq_alt.
  rewrite big_seq_cond.
  rewrite [a in _ = a]big_seq_cond.
  apply eq_bigr. intros (y&?) Hin => //=. rewrite Bool.andb_true_r in Hin.
  case: ifP.
  - move /eqP => ->.
    destruct (Rge_dec) as [Hle|Hle]; last nra.
    destruct (Rge_dec) as [Hle'|Hle']; first nra.
    rewrite Rmult_0_r Rplus_0_r //.
  - move /eqP => Hneq.
    destruct (Rge_dec) as [Hle|Hle] => //=; try nra;
    destruct (Rge_dec) as [Hle'|Hle'] => //=; try nra.
    exfalso.
    eapply Rlt_not_ge; last eapply (HX y); eauto.
    assert (y - x ≤ eps / 2) by nra.
    assert (x - y ≤ eps / 2) by fourier.
    destruct (Rle_dec 0 (x - y)) as [?|Hgt%Rnot_le_gt].
    ** rewrite Rabs_right; fourier.
    ** rewrite Rabs_minus_sym Rabs_right; fourier.
Qed.

Lemma Rmin_dist_list (l: seq R) (x: R):
  ∃ eps, eps > 0 ∧ ∀ y, y \in l → y ≠ x → Rabs (x - y) >= eps.
Proof.
  exists (foldl (Rmin) 1 (map (λ y, Rabs (x - y)) (filter (predC1 x) l))).
  split.
  * assert (1 > 0) as Hgt0 by fourier.
    revert Hgt0; generalize 1.
    induction l.
    ** rewrite //=; fourier.
    ** rewrite //=. case: ifP.
       *** rewrite map_cons //=.
           move /eqP => Hneq r Hgt.
           eapply IHl.
           apply Rmin_case => //.
           apply Rabs_pos_lt. intros Heq.
           apply Hneq; symmetry; by apply Rminus_diag_uniq.
       *** intros; eauto.
  * intros y Hin Hneq.
    generalize 1. induction l.
    ** rewrite //=.
    ** rewrite in_cons in Hin.
       move /orP in Hin; destruct Hin as [Heqa|Hinl].
       *** move /eqP in Heqa.
           subst. move /eqP /negbTE in Hneq. rewrite //= Hneq /=.
           intros. apply Rle_ge.  eapply Rle_trans; first eapply seq_ext.foldl_Rmin.
           apply Rmin_r.
       *** rewrite //=. case: ifP; intros; eapply IHl; eauto.
Qed.

(* Because we are working with finite probability spaces, the following is true: *)

Lemma pr_ge_split2 {A B: finType} {Ω: distrib A} {Ω': distrib B} (X: rrvar Ω) (Y: rrvar Ω')
      (x: R): ∃ x1 x2,
    pr_eq X x = pr_ge X x1 - pr_ge X x2 ∧
    pr_eq Y x = pr_ge Y x1 - pr_ge Y x2.
Proof.
  edestruct (Rmin_dist_list (map sval (Finite.enum [finType of imgT X])
                            ++ map sval (Finite.enum [finType of imgT Y])) x) as (eps&Hgt0&Hdist).
  exists (x - eps/2). exists (x + eps/2).
  split; eapply pr_ge_split_eps.
  - split; auto. intros. eapply Hdist; auto.
    rewrite mem_cat. apply /orP; left.
    rewrite /index_enum [Finite.enum]unlock //=. rewrite img_fin_enum_sval.
    by apply img_alt', img_alt.
  - split; auto. intros. eapply Hdist; auto.
    rewrite mem_cat. apply /orP; right.
    rewrite /index_enum [Finite.enum]unlock //=. rewrite img_fin_enum_sval.
    by apply img_alt', img_alt.
Qed.

Lemma pr_gt_to_geq2 {A B: finType} {Ω: distrib A} {Ω': distrib B} (X: rrvar Ω) (Y: rrvar Ω')
      (x: R): ∃ x',
    pr_gt X x = pr_ge X x' ∧
    pr_gt Y x = pr_ge Y x'.
Proof.
  edestruct (Rmin_dist_list (map sval (Finite.enum [finType of imgT X])
                            ++ map sval (Finite.enum [finType of imgT Y])) x) as (eps&Hgt0&Hdist).
  exists (x + eps/2).
  split; eapply pr_gt_to_geq_eps.
  - split; auto. intros. eapply Hdist; auto.
    rewrite mem_cat. apply /orP; left.
    rewrite /index_enum [Finite.enum]unlock //=. rewrite img_fin_enum_sval.
    by apply img_alt', img_alt.
  - split; auto. intros. eapply Hdist; auto.
    rewrite mem_cat. apply /orP; right.
    rewrite /index_enum [Finite.enum]unlock //=. rewrite img_fin_enum_sval.
    by apply img_alt', img_alt.
Qed.

Lemma pr_ge_to_gt2 {A B: finType} {Ω: distrib A} {Ω': distrib B} (X: rrvar Ω) (Y: rrvar Ω')
      (x: R): ∃ x',
    pr_ge X x = pr_gt X x' ∧
    pr_ge Y x = pr_gt Y x'.
Proof.
  edestruct (Rmin_dist_list (map sval (Finite.enum [finType of imgT X])
                            ++ map sval (Finite.enum [finType of imgT Y])) x) as (eps&Hgt0&Hdist).
  exists (x - eps/2).
  split; eapply pr_ge_to_gt_eps.
  - split; auto. intros. eapply Hdist; auto.
    rewrite mem_cat. apply /orP; left.
    rewrite /index_enum [Finite.enum]unlock //=. rewrite img_fin_enum_sval.
    by apply img_alt', img_alt.
  - split; auto. intros. eapply Hdist; auto.
    rewrite mem_cat. apply /orP; right.
    rewrite /index_enum [Finite.enum]unlock //=. rewrite img_fin_enum_sval.
    by apply img_alt', img_alt.
Qed.
End convert.

Definition eq_dist {A B: countType} {C: eqType} {Ω1: distrib A} {Ω2: distrib B}
           (X: rvar Ω1 C) (Y: rvar Ω2 C) := ∀ x, pr_eq X x = pr_eq Y x.

Lemma eq_dist_ext {A: countType} {B: eqType} {Ω: distrib A} (X Y: rvar Ω B) :
  (∀ x: A, X x = Y x) →
  eq_dist X Y.
Proof.
  intros Hext v. rewrite /pr_eq. apply pr_eq_pred' => i; by rewrite Hext.
Qed.

Lemma eq_dist_refl {A: countType} {C: eqType} {Ω: distrib A} (X: rvar Ω C) :
  eq_dist X X.
Proof. rewrite /eq_dist => x; done. Qed.

Lemma eq_dist_sym {A B: countType} {C: eqType} {Ω: distrib A} {Ω': distrib B}
      (X: rvar Ω C) (Y: rvar Ω' C) :
  eq_dist X Y → eq_dist Y X.
Proof. rewrite /eq_dist => ??; done. Qed.

Lemma eq_dist_trans {A B C: countType} (D: eqType) {ΩA: distrib A} {ΩB: distrib B} {ΩC: distrib C}
      (X: rvar ΩA D) (Y: rvar ΩB D) (Z: rvar ΩC D) :
  eq_dist X Y → eq_dist Y Z → eq_dist X Z.
Proof. rewrite /eq_dist => Hxy Hyz x. etransitivity; eauto. Qed.

Global Instance eq_dist_Reflexive {A} {B} {Ω}: Reflexive (@eq_dist A A B Ω Ω).
Proof. intros ?. apply eq_dist_refl. Qed.

Lemma eq_dist_comp {A1 A2: finType} {B C: eqType} {Ω1: distrib A1} {Ω2: distrib A2}
      (X1: rvar Ω1 B) (X2: rvar Ω2 B) (f: B → C) :
  eq_dist X1 X2 → eq_dist (rvar_comp X1 f) (rvar_comp X2 f).
Proof.
  intros Heq c. rewrite /pr_eq ?pr_eq_alt_comp.
  rewrite -(big_map sval (λ x, true) (λ v, if f v == c then pr_eq X1 v else 0)).
  rewrite -(big_map sval (λ x, true) (λ v, if f v == c then pr_eq X2 v else 0)).
  rewrite bigop_cond_non0.
  eapply (sum_reidx_map _ _ _ _ (λ x, x)).
  - intros. by rewrite Heq.
  - rewrite //=. intros a ?. case: ifP; last by (intros ?; move /eqP; nra).
    intros _.  move /eqP. rewrite Heq => Hnon0.
    split; auto.
    assert (a \in img X2) as Hin.
    { apply pr_img. move: Hnon0. rewrite /pr_eq. edestruct (ge_pr_0 Ω2); eauto; nra. }
    destruct (proj1 (img_alt X2 a) Hin) as (x&Heq').
    subst. apply /mapP.
    exists (exist _ (X2 x) Hin) => //=.
    rewrite /index_enum [Finite.enum]unlock //=. apply img_fin_mem.
  - intros b Hin _ Hfalse.
    rewrite -Heq. apply /eqP.
    case_eq ((if f b == c then pr_eq X1 b else 0) == 0); auto.
    move /eqP => Hneq.
    exfalso; apply Hfalse.
    exists b; split; auto.
    * move: Hneq. case: ifP; last (intros ?; nra).
      move /eqP => _  Himg.
      assert (b \in img X1) as Hin'.
      { apply pr_img. move: Himg. rewrite /pr_eq.  edestruct (ge_pr_0 Ω1); eauto; nra. }
      destruct (proj1 (img_alt X1 b) Hin') as (x&Heq').
      subst. apply /mapP.
      exists (exist _ (X1 x) Hin') => //=.
      rewrite /index_enum [Finite.enum]unlock //=. apply img_fin_mem.
    * split; auto. rewrite /=. apply /eqP. done.
  - rewrite /index_enum [Finite.enum]unlock //=. rewrite img_fin_enum_sval. apply undup_uniq.
  - rewrite /index_enum [Finite.enum]unlock //=. rewrite img_fin_enum_sval. apply undup_uniq.
  - auto.
Qed.

Lemma big_mkcond_sumbool
     : ∀ (R : Type) (idx : R) (op : Monoid.law idx) (I : Type) (r : seq I) (Q S: I → Prop)
       (P : ∀ i, {Q i} + {S i}) (F : I → R),
       \big[op/idx]_(i <- r | is_left (P i)) F i = \big[op/idx]_(i <- r) (if P i then F i else idx).
Proof.
  intros. rewrite big_mkcond. apply eq_bigr => i ?. destruct (P i) => //=.
Qed.

Lemma eq_dist_pr_ge {A B: finType} {Ω: distrib A} {Ω': distrib B} (X: rrvar Ω)
      (Y: rrvar Ω'):
  eq_dist X Y ↔ (∀ x, pr_ge X x = pr_ge Y x).
Proof.
  rewrite /eq_dist; split.
  - intros Heqd x. rewrite /pr_ge. rewrite ?pr_ge_alt.
    rewrite -?big_mkcond_sumbool.
    rewrite -!(big_map sval (λ y, Rge_dec y x)).
    rewrite //=.
    rewrite (pr_sum_restrict).
    apply sum_reidx_map with (h := λ x, x); auto.
    * intros a Hin. move /andP => [Hge Hgt].
      destruct (Rgt_dec) => //=.
      split; auto.
      rewrite /index_enum [Finite.enum]unlock //=. rewrite img_fin_enum_sval.
      apply img_alt', img_alt.
      apply pr_img. rewrite -Heqd. done.
    * intros ??? Hfalse. edestruct (pr_eq_ge_0 Y); eauto.
      exfalso; apply Hfalse.
      eexists. split; eauto.
      ** rewrite /index_enum [Finite.enum]unlock //=. rewrite img_fin_enum_sval.
         apply img_alt', img_alt, pr_img. rewrite Heqd /pr. eauto.
      ** split; auto. apply /andP; split; auto.
         rewrite Heqd /pr. destruct (Rgt_dec) => //=.
    * rewrite /index_enum [Finite.enum]unlock //=. rewrite img_fin_enum_sval. apply undup_uniq.
    * rewrite /index_enum [Finite.enum]unlock //=. rewrite img_fin_enum_sval. apply undup_uniq.
  - intros Heqd x.
    edestruct (pr_ge_split2 X Y x) as (x1&x2&HeqX&HeqY).
    rewrite HeqX HeqY ?Heqd. done.
Qed.

Lemma eq_dist_pr_gt {A B: finType} {Ω: distrib A} {Ω': distrib B}
      (X: rrvar Ω) (Y: rrvar Ω'):
  eq_dist X Y ↔ (∀ x, pr_gt X x = pr_gt Y x).
Proof.
  rewrite eq_dist_pr_ge; split.
  - intros Heqd x.
    edestruct (pr_gt_to_geq2 X Y x) as (x1&HeqX&HeqY).
    rewrite HeqX HeqY ?Heqd. done.
  - intros Heqd x.
    edestruct (pr_ge_to_gt2 X Y x) as (x1&HeqX&HeqY).
    rewrite HeqX HeqY ?Heqd. done.
Qed.

Module eq_dist_Ex.
Section eq_dist_Ex.

  Variable (A1 A2: countType).
  Variable (B: eqType).
  Variable (Ω1: distrib A1).
  Variable (Ω2: distrib A2).
  Variable (X1: rvar Ω1 B).
  Variable (X2: rvar Ω2 B).
  Variable (f: B → R).

  Variable (EQDIST: eq_dist X1 X2).
  Variable (EX: ex_Ex (rvar_comp X1 f)).

  Definition a := countable_sum (λ r: imgT X1, pr_eq X1 (sval r) * f (sval r)).
  Definition a' :=
         λ n, match n with
              | O => 0
              | S n' => countable_sum (λ r : imgT X1, pr_eq X1 (sval r) * f (sval r)) n'
              end.
  Definition σ := λ n,
            match @pickle_inv [countType of imgT X2] n with
            | None => O
            | Some yb =>
              match Rgt_dec (pr_eq X1 (sval yb)) 0 with
              | left Hpf => S (@pickle [countType of imgT X1] (exist _ (sval yb) (pr_img _ _ Hpf)))
              | _ => O
              end
            end.

  Lemma σinj: ∀ n n', a' (σ n) <> 0 → σ n = σ n' → n = n'.
  Proof.
    intros n n'.
    rewrite /σ.
    case_eq (@pickle_inv [countType of imgT X2] n); rewrite //=.
    intros s Heqs.
    case_eq (@pickle_inv [countType of imgT X2] n'); rewrite //=.
    - intros s' Heqs'. rewrite Heqs'.
      do 2 destruct (Rgt_dec) => //=.
      * intros ? Heq. inversion Heq as [Heq']. apply pickle_inj in Heq'.
        eapply pickle_inv_some_inj; eauto.
        rewrite Heqs Heqs'. f_equal. inversion Heq'.
        by apply sval_inj_pred.
    - intros Hnone.
      destruct (Rgt_dec) => //=.
      rewrite Hnone.
      intros Heqa' Heq0. inversion Heq0.
  Qed.

  Lemma σcov: ∀ n, a' n <> 0 → ∃ m, σ m = n.
  Proof.
    intros n. rewrite /a'. destruct n => //=.
    rewrite /countable_sum.
    case_eq (@pickle_inv (img_countType X1) n).
    - intros s Heq => //= Hneq0.
      rewrite EQDIST in Hneq0.
      assert (Hneq0': pr_eq X2 (sval s) <> 0).
      { intros Heq0. rewrite Heq0 Rmult_0_l //= in Hneq0. }
      exists (@pickle [countType of imgT X2] (exist _ (sval s) (pr_img0 _ _ Hneq0'))).
      rewrite /σ pickleK_inv //=.
      destruct (Rgt_dec) as [|Hngt].
      * f_equal. apply pickle_inv_some_inv. rewrite Heq.
        f_equal. apply sval_inj_pred => //=.
      * exfalso. rewrite EQDIST in Hngt. destruct (pr_eq_ge_0 X2 (sval s)); nra.
    - rewrite //=.
  Qed.

  Lemma ex_Ex_alt:
    ex_series (Rabs \o a').
  Proof.
    apply ex_series_incr_1 => //=.
    eapply (ex_series_ext); last by eapply (Ex_comp_pt.ex_series_Ex_comp_pt_abs _ _ _ X1 f).
    intros n. rewrite /countable_sum.
    destruct (pickle_inv) => //=.
    * rewrite Rabs_mult. symmetry. rewrite Rabs_right; last by apply pr_eq_ge_0.
      done.
    * by rewrite Rabs_R0.
  Qed.

  Lemma rearrange:
    ex_series (λ n, Rabs (a' (σ n))) ∧
    is_series (λ n, a' (σ n)) (Series a').
  Proof.
    destruct (ex_Ex_alt) as (v&Hisv).
    edestruct (rearrange.series_rearrange_covering a' σ).
    - apply σinj.
    - apply σcov.
    - eauto.
    - split.
      ** exists v; eauto.
      ** eauto.
  Qed.

  Lemma a'_equal_ex_X1:
    Ex (rvar_comp X1 f) = Series a'.
  Proof.
    rewrite /a'.
    rewrite Series_incr_1; last first.
    { apply ex_series_Rabs, ex_Ex_alt. }
    rewrite Rplus_0_l //.
    by apply Ex_comp_pt.Ex_comp.
  Qed.

  Lemma ex_Ex_eq_dist:
    ex_Ex (rvar_comp X2 f).
  Proof.
    apply ex_Ex_comp_by_alt.
    destruct rearrange as (Hex&_).
    eapply ex_series_ext; last eapply Hex.
    intros n => //=.
    rewrite /a'/σ/countable_sum.
    destruct (pickle_inv) => //=; last by apply Rabs_R0.
    destruct Rgt_dec => //=.
    * rewrite pickleK_inv //= Rabs_mult.
      rewrite Rabs_right; last by nra.
      rewrite EQDIST //.
    * destruct (pr_eq_ge_0 X1 (sval s)) as [?|Heq0]; first by nra.
      rewrite -EQDIST Heq0 Rabs_R0; nra.
  Qed.

  Lemma Ex_eq_dist:
    Ex (rvar_comp X1 f) = Ex (rvar_comp X2 f).
  Proof.
    rewrite a'_equal_ex_X1.
    transitivity (Series (a' \o σ)).
    { symmetry.  apply is_series_unique. destruct rearrange; eauto. }
    rewrite Ex_comp_pt.Ex_comp; last apply ex_Ex_eq_dist.
    apply Series_ext.
    intros n => //=.
    rewrite /a'/σ/countable_sum.
    destruct (pickle_inv) => //=.
    destruct Rgt_dec => //=.
    - rewrite pickleK_inv //= EQDIST //.
    - destruct (pr_eq_ge_0 X1 (sval s)) as [?|Heq0]; first by nra.
      rewrite -EQDIST Heq0; nra.
  Qed.
End eq_dist_Ex.
End eq_dist_Ex.

Definition ex_Ex_eq_dist := eq_dist_Ex.ex_Ex_eq_dist.
Definition Ex_eq_dist := eq_dist_Ex.Ex_eq_dist.
Arguments ex_Ex_eq_dist {_ _ _ _ _}.
Arguments Ex_eq_dist {_ _ _ _ _}.

Lemma Ex_eq_dist_fin {A: finType} {B: countType}
      {Ω: distrib A} {Ω': distrib B} (X: rrvar Ω) (Y: rrvar Ω'):
  eq_dist X Y → Ex X = Ex Y.
Proof.
  intros. apply: (Ex_eq_dist _ _ id) => //=.
Qed.


(*
  vim: filetype=coq
*)
(*
Copyright (C) 2016-2018 Philip H. Smith

This program 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 3 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.
*)

Require Import Way.Tactics.

Require Import Way.Conversion.
Require Import Way.Open.
Require Import Way.Preterm.
Require Import Way.Relation.
Require Import Way.Term.

(* The subtyping relation.

Subtyping serves two roles in this logic.  First it includes conversion, and so the
conversion typing rule becomes the subtyping rule.  Second it brings transitivity to the
type hierarchy, allowing (type 0) to be considered a term of (type 2), for example.
*)
Inductive subtyping : relation :=

(* Convertible types are subtypes of each other. *)
| conversion : forall (T U : preterm), Conversion.conversion T U -> subtyping T U

(* Each sort is a subtype of the next in the hierarchy. *)
| type : forall (n : nat), subtyping (Preterm.type n) (Preterm.type (S n))

(* Subtyping descends into codomains of products with convertible domains. *)
| product : forall (l : list atom) (T V : preterm), Conversion.conversion T V ->
  forall (U W : preterm), (fresh (a : l), subtyping (open_free a U) (open_free a W)) ->
  subtyping (Preterm.product T U) (Preterm.product V W)

(* Terms are reflexivily subtypes of themselves. *)
(* TODO(phs): If we could move this guard then we could use star. *)
(* TODO(phs): Alternately, we could demand relations deal only in terms *)
| reflexivity : forall (T : preterm), term T -> subtyping T T

(* Subtyping is transitive. *)
| transitivity :
    forall (U T V : preterm), subtyping T U -> subtyping U V -> subtyping T V.

Hint Resolve conversion type reflexivity : way.

Module Examples.

Import Aliases.

Example convertible_terms_are_subtypes :
  subtyping
    (app (abs (type 1) (bvar 0)) (type 0))
    (type 0).
Proof.
  infer.
Defined.

Example sort_is_subtype_of_next : subtyping (type 2) (type 3).
Proof.
  infer.
Defined.

Example subtyping_descends_into_product_codomains :
  subtyping
    (prod (type 0) (app (abs (type 1) (bvar 0)) (type 0)))
    (prod (type 0) (type 0)).
Proof.
  infer.
Defined.

Example subtyping_is_reflexive_for_terms :
  subtyping
    (abs (type 0) (bvar 0))
    (abs (type 0) (bvar 0)).
Proof.
  infer.
Defined.

Example subtyping_is_transitive : subtyping (type 0) (type 2).
Proof.
  apply (Subtyping.transitivity (type 1));
  infer.
Defined.

End Examples.


Require Import Coq.Relations.Relations.

Require Export CatSem.PCF_o_c.RPCF_rep.

Set Implicit Arguments.
Unset Strict Implicit.

Unset Automatic Introduction.

Notation "^ f" := (lift (M:= opt_monad _) f) (at level 5).

Ltac fin := simpl in *; intros;
   autorewrite with fin; auto with fin.

Hint Unfold lift : fin.
Hint Extern 1 (_ = _) => f_equal : fin.

Notation "V *" := (opt (T:=unit) _ V) (at level 5).

Definition TT := ITYPE unit.

Lemma l_eq (V W : TT) (f g : forall t, V t -> W t) r:
   (forall t v, f t v = g t v) ->
       (forall t (v : opt r V t),
       lift (M:=opt_monad r) f t v = ^g t v).
Proof.
  intros.
  destruct v;
  unfold lift;
  simpl;
  auto.
  rewrite H.
  auto.
Qed.

Section ULC_syntax.

Inductive ULC (V : TT) : TT :=
  | Var : forall t, V t -> ULC V t
  | Abs : forall t : unit, ULC (opt t V) t -> ULC V t
  | App : forall t, ULC V t -> ULC V t -> ULC V t.

Fixpoint rename V W (f : V ---> W) t (y : ULC V t) : ULC W t :=
  match y with
  | Var _ v => Var (f _ v)
  | Abs _ v => Abs (rename ^f v)
  | App _  s t => App (rename f s) (rename f t)
  end.

Definition inj u V := rename (V:=V) (W:= opt u V)
                (@some unit u V).

Definition _shift (u : unit) (V W : TT) (f : V ---> ULC W) :
         V*  ---> ULC (W*) :=
   fun t v =>
   match v in (opt _ _ y) return (ULC (W *) y) with
   | some t0 p => inj u (f t0 p)
   | none => Var (none u W)
   end.

Fixpoint _subst V W (f : V ---> ULC W) t (y : ULC V t) : ULC W t :=
  match y with
  | Var _ v => f _ v
  | Abs _ v => Abs (_subst (_shift f) v)
  | App _ s t => App (_subst f s) (_subst f t)
  end.

Definition substar (u : unit) (V : TT) (M : ULC V u) :
           ULC (opt u V) ---> ULC V :=
 _subst (fun t (y : opt u V t) => match y with
         | none => M
         | some _ v => Var v
         end).

Notation "M [*:= N ]" := (substar N M) (at level 50).

(** Notations for functions *)
Notation "y //- f" := (rename f y)(at level 42, left associativity).
Notation "y >- f" := (_shift f y) (at level 40).
Notation "y >>= f" := (_subst f y) (at level 42, left associativity).

Lemma rename_eq : forall (V : TT) (t : unit) (v : ULC V t)
         (W : TT) (f g : V ---> W),
     (forall t y, f t y = g t y) -> v //- f = v //- g.
Proof.
  intros V t v.
  induction v;
  intros;
  simpl.
  rewrite H;
  auto.

  apply f_equal.
  apply IHv.
  simpl in *.
  intros.
  destruct t.
  destruct t0.
  assert (H':= l_eq (r:=tt) H (t:=tt) y).
  simpl in *.
  rewrite <- H'.
  auto.

  rewrite (IHv1 _ _ _ H).
  rewrite (IHv2 _ _ _ H).
  auto.
Qed.

Hint Resolve rename_eq l_eq : fin.
Hint Rewrite rename_eq l_eq : fin.

Lemma rename_comp V t (y : ULC V t) W
         (f : V ---> W) Z (g : W ---> Z):
 y //- (fun s y => g s (f s y)) =  y //- f //- g.
Proof.
  intros V t y.
  induction y;
  simpl;
  intros;
  fin.

  apply f_equal.
  rewrite <- IHy.
  apply rename_eq.
  intros r y0.
  destruct y0;
  fin.
Qed.

Lemma rename_id_eq V t (y : ULC V t) (f : V ---> V)
        (H : forall t v, f t v = v) :
    y //- f = y.
Proof.
  intros V t y.
  induction y;
  simpl;
  intros;
  fin.
  apply f_equal.
  apply IHy.
  intros r v;
  destruct v;
  fin. unfold lift.
  fin.
Qed.

Lemma rename_id V t (y : ULC V t) : y //- id _ = y .
Proof.
  intros V t y.
  apply rename_id_eq.
  fin.
Qed.

Lemma _shift_eq u V W (f g : V ---> ULC W)
     (H : forall t v, f t v = g t v) t (y : opt u V t) :
          y >- f = y >- g.
Proof.
  intros u V W f g H t v.
  destruct v;
  fin.
Qed.

Hint Resolve  rename_id _shift_eq : fin.
Hint Rewrite  rename_id _shift_eq : fin.

Lemma shift_var u (V : TT) t (y : opt u V t) :
       y >- @Var _ = Var y.
Proof.
  intros u V t y;
  induction y;
  fin.
Qed.

Hint Resolve shift_var : fin.
Hint Rewrite shift_var : fin.

Lemma var_lift_shift (u : unit) V W (f : V ---> W) t (y : opt u V t) :
     Var (^f _ y) = y >- (f ;; @Var _ ).
Proof.
  intros u V W f t y;
  induction y; fin.
Qed.

Hint Resolve var_lift_shift : fin.

Lemma shift_lift u V W Z (f : V ---> W)
         (g : W ---> ULC Z) t (y : opt u V t) :
      (^f _ y) >- g = y >- (f ;; g).
Proof.
  intros u V W Z f g t y.
  induction y; fin.
Qed.

Hint Resolve shift_lift : fin.
Hint Rewrite shift_lift : fin.

Lemma subst_eq V t (y : ULC V t)
      W (f g : V ---> ULC W)
       (H : forall t y, f t y = g t y):  y >>= f = y >>= g.
Proof.
  intros V t y.
  induction y;
  fin.
Qed.

Hint Resolve subst_eq : fin.
Hint Rewrite subst_eq : fin.

Obligation Tactic := unfold Proper; red; fin.

Program Instance subst_oid V W :
 Proper (equiv ==> equiv (Setoid:=mor_oid (ULC V) (ULC W)))
                (@_subst V W).

Lemma subst_var (V : TT) :
    forall t (v : ULC V t), v >>= (@Var V) = v .
Proof.
  intros V t y.
  induction y;
  fin.
  apply f_equal.
  rewrite <- IHy at 2.
  apply subst_eq.
  fin.
Qed.

Lemma subst_eq_rename V t (v : ULC V t) W (f : V ---> W)  :
     v //- f  = v >>= (f ;; Var (V:=W)).
Proof.
  intros V t y.
  induction y;
  fin.
  apply f_equal.
  rewrite IHy.
  apply subst_eq.
  intros tr z;
  destruct z;
  fin.
Qed.

Lemma rename_shift a V W Z (f : V ---> ULC W) (g : W ---> Z) t
       (y : opt a V t) :
    (y >- f) //- ^g = y >- (f ;; rename g).
Proof.
  intros a V W Z f g t y.
  induction y;
  fin.
  unfold inj.
  rewrite <- rename_comp.
  rewrite <- rename_comp.
  fin.
Qed.

Hint Rewrite rename_shift : fin.
Hint Resolve rename_shift : fin.

Hint Unfold inj : fin.

Lemma rename_subst V t (v : ULC V t) W Z (f : V ---> ULC W)
      (g : W ---> Z) :
      (v >>= f) //- g  = v >>= (f ;; rename g).
Proof.
  intros V t y.
  induction y;
  fin.
  rewrite IHy.
  apply f_equal.
  apply subst_eq.
  intros tr z;
  destruct z;
  simpl; auto.
  unfold inj.
  rewrite <- rename_comp.
  rewrite <- rename_comp.
  apply rename_eq.
  fin.
Qed.

Lemma subst_rename V t (v : ULC V t) W Z (f : V ---> W)
      (g : W ---> ULC Z) :
      v //- f >>= g = v >>= (f ;; g).
Proof.
  intros V t y.
  induction y;
  fin.
  apply f_equal.
  rewrite IHy.
  apply subst_eq.
  intros tr z;
  destruct z;
  fin.
Qed.

Lemma rename_substar V u t (v : ULC (opt u V) t) W
       (f : V ---> W) N:
     v [*:= N] //- f = (v //- ^f) [*:= N //- f ].
Proof.
  intros.
  unfold substar.
  rewrite rename_subst.
  rewrite subst_rename.
  apply subst_eq.
  intros t0 z ;
  destruct z ;
  fin.
Qed.

Hint Rewrite subst_rename rename_subst : fin.

Hint Rewrite rename_shift : fin.
Hint Resolve rename_shift : fin.

Lemma subst_shift_shift (u:unit) V (t : unit)(v : opt u V t)
         W Z (f: V ---> ULC W) (g: W ---> ULC Z):
    (v >- f) >>= (_shift g)  =
             v >- (f ;; _subst g).
Proof.
  intros u V t v.
  induction v;
  simpl; intros;
  try apply subst_term_inj; auto.
  unfold inj.
  rewrite subst_rename.
  fin.
Qed.

Hint Resolve subst_shift_shift : fin.
Hint Rewrite subst_shift_shift : fin.

Lemma subst_subst V t (v : ULC V t) W Z (f : V ---> ULC W)
             (g : W ---> ULC Z) :
     v >>= f >>= g = v >>= (f;; _subst g).
Proof.
  intros V t y.
  induction y;
  fin.
  apply f_equal.
  rewrite IHy.
  apply subst_eq.
  intros tr z;
  destruct z;
  fin.
  unfold inj.
  fin.
Qed.

Lemma lift_rename V t (s : ULC V t) W (f : V ---> W) :
          s >>= (fun t z => Var (f t z)) = s //- f.
Proof.
  intros V t y.
  induction y;
  fin.
  apply f_equal.
  rewrite <- IHy.
  apply subst_eq.
  intros tr z;
  destruct z;
  fin.
Qed.

Lemma subst_var_eta (V:TT) t (v:ULC V t):
        v >>= (fun t z => @Var V t z) = v.
Proof.
  induction v; intros; simpl; auto.
  rewrite <- IHv at 2.
  apply f_equal. apply subst_eq.
  intros; apply shift_var.
  rewrite IHv1. rewrite IHv2; auto.
Qed.

Lemma subst_substar (V W : TT)
       t (M: ULC (opt t V) t) (N:ULC V t)
      (f:forall t, V t -> ULC W t):
   M [*:=N]  >>= f = (M >>= _shift f) [*:= (N >>= f)].
Proof.
  intros V W t M N f.
  unfold substar. simpl.
  repeat rewrite subst_subst.
  apply subst_eq.
  intros t0 y.
  simpl.
  destruct y. unfold _shift.
  unfold inj.
  simpl.
  rewrite subst_rename. simpl.
  rewrite (subst_var_eta (f t0 v)). auto.
  simpl.
  apply subst_eq; auto.
Qed.

Hint Resolve subst_var subst_subst lift_rename : fin.
Hint Rewrite subst_subst lift_rename: fin.

Section Relations_on_ULC.

Reserved Notation "x :> y" (at level 70).

Variable rel : forall (V:TT) t, relation (ULC V t).

Inductive ULCpropag (V: TT)
       : forall t, relation (ULC V t) :=
| relorig : forall t (v v': ULC V t), rel v v' ->  v :> v'
| relApp1: forall t (M M' : ULC V t) N,
       M :> M' -> App M N :> App M' N
| relApp2: forall t (M:ULC V t) N N',
      N :> N' -> App M N :> App M N'
| relAbs: forall t (M M':ULC (opt t V) t),
      M :> M' -> Abs M :> Abs M'

where "y :> z" := (@ULCpropag _ _ y z).

Notation "y :>> z" :=
  (clos_refl_trans_1n _ (@ULCpropag _ _ ) y z) (at level 50).

Variable V : TT.
Variable t : unit.

(** these are some trivial lemmata  which will be used later *)

Lemma cp_App1 (M M': ULC V t) N :
    M :>> M' -> App M N :>> App M' N.
Proof.
  intros. generalize N.
  induction H. constructor.
  intros. constructor 2 with (App y N0); auto.
  constructor 2. auto.
Qed.

Lemma cp_App2 (M : ULC V t) N N':
    N :>> N' -> App M N :>> App M N'.
Proof.
  intros. generalize M.
  induction H. constructor.
  intros. constructor 2 with (App M0 y); auto.
  constructor 3. auto.
Qed.

Lemma cp_Abs (M M': ULC (opt t V) t ):
      M :>> M' -> Abs M :>> Abs M'.
Proof.
  intros. induction H. constructor.
  constructor 2 with (Abs y); auto.
  constructor 4. auto.
Qed.

End Relations_on_ULC.

(** Beta reduction *)

Reserved Notation "a >> b" (at level 70).

Inductive beta (V : TT): forall t, relation (ULC V t) :=
| app_abs : forall t (M: ULC (opt t V) t) N,
               beta (App (Abs M) N) (M [*:= N]).

Definition beta_star := ULCpropag beta.

Definition beta_rel :=
   fun (V : TT) t => clos_refl_trans_1n _ (@beta_star V t).

Obligation Tactic := idtac.

Program Instance ULCBETA_struct (V : TT) : ipo_obj_struct (ULC V) := {
 IRel t := @beta_rel V t
}.
Next Obligation.
Proof.
  constructor.
  constructor.
  assert (H':= @clos_rt_is_preorder _ (@beta_star V t)).
  unfold beta_rel in *.
  unfold Transitive.
  intros.
  destruct H' as [H1 H2].
  unfold transitive in H2.
  simpl in *.
  apply trans_rt1n.
  apply H2 with y;
    apply rt1n_trans;
    auto.
Qed.

Definition ULCBETA (V: TT) : IPO unit :=
    Build_ipo_obj (ULCBETA_struct V ).

Program Instance Var_s (V : TT) :
    ipo_mor_struct (a:=SM_ipo _ V) (b:=ULCBETA V) (Var (V:=V)).
Next Obligation.
Proof.
  intros V t.
  unfold Proper;
  red.
  simpl.
  intros y z H.
  induction H.
  reflexivity.
Qed.

Definition VAR V := Build_ipo_mor (Var_s V).

Program Instance subst_s (V W : TT) (f : SM_ipo _ V ---> ULCBETA W) :
   ipo_mor_struct (a:=ULCBETA V) (b:=ULCBETA W) (_subst f).
Next Obligation.
Proof.
  intros V W f t.
  unfold Proper;
  red.
  intros y z H.
  generalize dependent W.
  induction H;
  simpl;
  intros.
  constructor.
  transitivity (_subst f y);
  try apply IHclos_refl_trans_1n.
  clear dependent z.

    generalize dependent W.
  induction H;
  simpl;
  intros.

  Focus 2.
  apply cp_App1.
  apply IHULCpropag.
  Focus 2.
  apply cp_App2.
  apply IHULCpropag.
  Focus 2.
  apply cp_Abs.
  simpl in *.
  apply (IHULCpropag _ (SM_ind
            (V:=opt _ V) (W:=ULCBETA (opt t W)) (fun t y => _shift f y))).

  generalize dependent W.
    induction H;
    simpl;
    intros.
    apply clos_refl_trans_1n_contains.
    apply relorig.
    assert (H:=app_abs (_subst (_shift f) M) (_subst f N)).
    rewrite subst_substar.
    auto.
Qed.

Definition SUBST V W f := Build_ipo_mor (subst_s V W f).

Obligation Tactic := fin.

Program Instance ULCBETAM_s : RMonad_struct (SM_ipo unit) ULCBETA := {
   rweta := VAR;
   rkleisli a b f := SUBST f
}.
Next Obligation.
Proof.
  unfold Proper;
  red;
  fin.
Qed.

Definition ULCBETAM : RMonad (SM_ipo unit) := Build_RMonad ULCBETAM_s.

Lemma rename_lift V t (v : ULC V t) W (f : V ---> W) :
       v //- f = rlift ULCBETAM f _ v.
Proof.
  unfold lift;
  fin.
Qed.

Hint Rewrite lift_rename : fin.

Lemma shift_shift r s V W (f : SM_ipo _ V ---> ULCBETAM W)
                (y : (opt r V) s) :
   sshift_ (P:=ULCBETAM) (W:=W) f y = y >- f .
Proof.
  intros r  s V W f y.
  destruct y as [t y | ];
  simpl;
  unfold inj;
  fin.
Qed.

Hint Resolve shift_shift rename_lift : fin.
Hint Rewrite shift_shift rename_lift : fin.

Definition PCF_ULC_type_mor : TY -> unit := fun _ => tt.

Check App.
Program Instance ulc_app_s r s :
 RModule_Hom_struct
   (M:= ULCBETAM [PCF_ULC_type_mor (r ~> s)] x (ULCBETAM [PCF_ULC_type_mor r]))
   (N:=ULCBETAM [PCF_ULC_type_mor s])
   (fun V t => App (fst t) (snd t)).

Definition ulc_app r s := Build_Module_Hom (ulc_app_s r s).

Program Instance ulc_abs_s r s : Module_Hom_struct
  (S:= d ULCM // PCF_ULC_type_mor r [PCF_ULC_type_mor s] )
  (T:= ULCM [PCF_ULC_type_mor (r ~> s)])
  (fun z t => abs t).

Definition ulc_abs r s := Build_Module_Hom (ulc_abs_s r s).

Definition ULC_fix (V : TT) t : ULC V t :=
   abs (
        app (V:=opt t V) (
               abs (V:=opt t V)(
                      app (V:=opt t (opt t V))
                          (var (V:= opt t (opt t V))
                                        (some t (A:= opt t V)
                                                ( none t (V) )))
                          (app (var (none t (V*))) (var (none t V*)))
                   )
            )
            (
               abs (

                      app (V:=opt t (opt t V))
                          (var (V:= opt t (opt t V))
                                        (some t (A:= opt t V)
                                                ( none t (V) )))
                          (app (var (none t (V*))) (var (none t V*)))

                   )
            )
     ).

Program Instance ulc_rec_s t : Module_Hom_struct
 (S := ULCM [PCF_ULC_type_mor (t ~> t)])
 (T:=ULCM [PCF_ULC_type_mor t])
 (fun V Z => app (ULC_fix V tt) Z).

Definition ulc_rec t := Build_Module_Hom (ulc_rec_s t).

Program Instance ulc_ttt_s : Module_Hom_struct
 (S:= Term (C:=MOD ULCM TYPE))
 (T:= ULCM [PCF_ULC_type_mor Bool])
 (fun V _ => abs (V:=V)
               (abs (V:= opt tt V)
                   (var
                      (some tt (A:=opt tt V)
                          (none tt V))))).

Definition ulc_ttt := Build_Module_Hom ulc_ttt_s.

Program Instance ulc_fff_s : Module_Hom_struct
 (S:= Term (C:=MOD ULCM TYPE))
 (T:= ULCM [PCF_ULC_type_mor Bool])
 (fun V _ => abs (V:=V)
               (abs (V:= opt tt V)
                   (var (none tt (V*))))).

Definition ulc_fff := Build_Module_Hom ulc_fff_s.

Fixpoint ULC_Nat (n : nat) (V : TT) := match n with
| 0 => abs (abs (var (none tt (opt tt V))))
| S n' =>
      abs (V:=V) (abs (V:=opt tt V)
       (
        app ( app (ULC_Nat n' _) (var (none tt (opt tt V))))
            (var (some tt (A:=opt tt V) (none tt V)))))
end.

Obligation Tactic := idtac.

Program Instance ulc_nats_s m : Module_Hom_struct
 (S:= Term (C:=MOD ULCM TYPE))
 (T:= ULCM [PCF_ULC_type_mor Nat])
 (fun V _ => ULC_Nat m V).
Next Obligation.
Proof.
  simpl.
  intro m.
  induction m;
  simpl.
  intros. auto.

  intros V W f r.
  apply f_equal.
  apply f_equal.
  fin.
Qed.

Definition ulc_nats m := Build_Module_Hom (ulc_nats_s m).

(** plus = \n.\m.\f.\x. n(f) (m(f)x) *)

Definition ULC_plus (V : TT) :=
  abs (V:=V)
   (
   abs (V:=opt tt V)
       (
       abs (V:= opt tt (opt tt V))
           (
             abs (V:= opt tt (opt tt (opt tt V)))
              (
                app (V:=opt tt (opt tt (opt tt (opt tt V))))
                  (app (V:=opt tt (opt tt (opt tt (opt tt V))))
                       (var (V:=opt tt (opt tt (opt tt (opt tt V))))
                            (some tt (some tt (some tt (none tt V)))))
                       (var (V:=opt tt (opt tt (opt tt (opt tt V))))
                            (some tt (A:=(opt tt (opt tt (opt tt V))))
                                 (none tt (opt tt (opt tt V)) ))) )
                  (app (V:=opt tt (opt tt (opt tt (opt tt V))))
                       (app (V:=opt tt (opt tt (opt tt (opt tt V))))
                            (var (V:=opt tt (opt tt (opt tt (opt tt V))))
                                 (some tt (some tt (none tt (opt tt V) ))))
                            (var (V:=opt tt (opt tt (opt tt (opt tt V))))
                                 (some tt (A:= opt tt (opt tt (opt tt V)))
                                     (none tt (opt tt (opt tt V))))))
                       (var (V:=opt tt (opt tt (opt tt (opt tt V))))
                            (none tt (opt tt (opt tt (opt tt V) )) )))
                 )

             )
       )
 ).

Obligation Tactic := fin.

(** succ = 1 + _ *)

Program Instance ulc_succ_s : Module_Hom_struct
  (S:= Term (C:=MOD ULCM TYPE))
  (T:= ULCM [PCF_ULC_type_mor (Nat ~> Nat)])
  (fun V _ => app (ULC_plus V) (ulc_nats (S 0) _ (tt) )).

Definition ulc_succ := Build_Module_Hom ulc_succ_s.

(** if then else = \a.\b.\c. a(b)(c) *)

Definition ULC_cond (V : TT) :=
     abs (V:=V)
        ( abs (V:=opt tt V)
            ( abs (V:=opt tt (opt tt V))
               (
                   app (V:= opt tt (opt tt (opt tt V)))
                      (app (V:= opt tt (opt tt (opt tt V)))
                         (var (V:= opt tt (opt tt (opt tt V)))
                            (some tt (some tt (none tt V))))
                         (var (some tt (none tt (opt tt V))))
                      )
                      (var (none tt (opt tt (opt tt V)))
                      )
               )
            )
        ).

Program Instance ulc_condn_s : Module_Hom_struct
  (S := Term (C:=MOD ULCM TYPE))
  (T:= ULCM [PCF_ULC_type_mor (Bool ~> Nat ~> Nat ~> Nat)])
  (fun V _ => ULC_cond V).

Definition ulc_condn := Build_Module_Hom ulc_condn_s.

Program Instance ulc_condb_s : Module_Hom_struct
  (S := Term (C:=MOD ULCM TYPE))
  (T:= ULCM [PCF_ULC_type_mor (Bool ~> Bool ~> Bool ~> Bool)])
  (fun V _ => ULC_cond V).

Definition ulc_condb := Build_Module_Hom ulc_condb_s.

Definition ULC_omega (V : TT) :=
    abs (V:= V)
      ( app (var (none tt V)) (var (none tt V))).

Program Instance ulc_bottom_s t : Module_Hom_struct
  (S:= Term (C:= MOD ULCM TYPE))
  (T:= ULCM [PCF_ULC_type_mor t])
  (fun V _ => ULC_omega V).

Definition ulc_bottom t := Build_Module_Hom (ulc_bottom_s t).

(* zero? = Ln.((n)(true)false)true     *)

Definition ULC_zero (V : TT) :=
    abs (V:=V)
       (
       app (
              (app (var (none tt V))
                   (app (ulc_ttt _ tt) (ulc_fff _ tt)))
           )
           (
               ulc_ttt _ tt
           )
       ).

Program Instance ulc_zero_s : Module_Hom_struct
  (S:= Term (C := MOD ULCM TYPE))
  (T:= ULCM [PCF_ULC_type_mor (Nat ~> Bool)])
  (fun V _ => ULC_zero V).

Definition ulc_zero := Build_Module_Hom ulc_zero_s.

Program Instance PCF_ULC_rep_s :
 PCF_rep_s (U:=unit) (PCF_ULC_type_mor) ULCM := {

  app r s := ulc_app r s ;
  abs r s := ulc_abs r s ;
  rec t := ulc_rec t ;
  tttt := ulc_ttt ;
  ffff := ulc_fff ;
  nats m := ulc_nats m ;
  Succ := ulc_succ ;
  CondB := ulc_condb ;
  CondN := ulc_condn ;
  bottom t := ulc_bottom t ;
  Zero := ulc_zero
}.

Definition PCF_ULC_rep := Build_PCF_rep PCF_ULC_rep_s.

Definition PCF_ULC_compilation := InitMor PCF_ULC_rep.

End ULC_syntax.


Require Import Coq.Program.Program Coq.Program.Equality.

Variable A : Set.

Inductive vector : nat -> Type := vnil : vector 0 | vcons : A -> forall {n}, vector n -> vector (S n).

Goal forall n, forall v : vector (S n), vector n.
Proof.
  intros n H.
  dependent destruction H.
  assumption.
Save.

Require Import ProofIrrelevance.

Goal forall n, forall v : vector (S n), exists v' : vector n, exists a : A, v = vcons a v'.
Proof.
  intros n v.
  dependent destruction v.
  exists v ; exists a.
  reflexivity.
Save.

(* Extraction Unnamed_thm. *)

Inductive type : Type :=
| base : type
| arrow : type -> type -> type.

Notation " t --> t' " := (arrow t t') (at level 20, t' at next level).

Inductive ctx : Type :=
| empty : ctx
| snoc : ctx -> type -> ctx.

Bind Scope context_scope with ctx.
Delimit Scope context_scope with ctx.

Arguments Scope snoc [context_scope].

Notation " Γ , τ " := (snoc Γ τ) (at level 25, τ at next level, left associativity) : context_scope.

Fixpoint conc (Δ Γ : ctx) : ctx :=
  match Δ with
    | empty => Γ
    | snoc Δ' x => snoc (conc Δ' Γ) x
  end.

Notation " Γ  ; Δ " := (conc Δ Γ) (at level 25, left associativity) : context_scope.

Reserved Notation " Γ ⊢ τ " (at level 30, no associativity).

Generalizable All Variables.

Inductive term : ctx -> type -> Type :=
| ax : `(Γ, τ ⊢ τ)
| weak : `{Γ ⊢ τ -> Γ, τ' ⊢ τ}
| abs : `{Γ, τ ⊢ τ' -> Γ ⊢ τ --> τ'}
| app : `{Γ ⊢ τ --> τ' -> Γ ⊢ τ -> Γ ⊢ τ'}

where " Γ ⊢ τ " := (term Γ τ) : type_scope.

Hint Constructors term : lambda.

Open Local Scope context_scope.

Ltac eqns := subst ; reverse ; simplify_dep_elim ; simplify_IH_hyps.

Lemma weakening : forall Γ Δ τ, Γ ; Δ ⊢ τ ->
  forall τ', Γ , τ' ; Δ ⊢ τ.
Proof with simpl in * ; eqns ; eauto with lambda.
  intros Γ Δ τ H.

  dependent induction H.

  destruct Δ as [|Δ τ'']...

  destruct Δ as [|Δ τ'']...

  destruct Δ as [|Δ τ'']...
    apply abs.
    specialize (IHterm Γ (Δ, τ'', τ))...

  intro. eapply app...
Defined.

Lemma exchange : forall Γ Δ α β τ, term (Γ, α, β ; Δ) τ -> term (Γ, β, α ; Δ) τ.
Proof with simpl in * ; eqns ; eauto.
  intros until 1.
  dependent induction H.

  destruct Δ ; eqns.
    apply weak ; apply ax.

    apply ax.

  destruct Δ...
    pose (weakening Γ (empty, α))...

    apply weak...

  apply abs...
    specialize (IHterm Γ (Δ, τ))...

  eapply app...
Defined.

(** Example by Andrew Kenedy, uses simplification of the first component of dependent pairs. *)

Set Implicit Arguments.

Inductive Ty :=
 | Nat : Ty
 | Prod : Ty -> Ty -> Ty.

Inductive Exp : Ty -> Type :=
| Const : nat -> Exp Nat
| Pair : forall t1 t2, Exp t1 -> Exp t2 -> Exp (Prod t1 t2)
| Fst : forall t1 t2, Exp (Prod t1 t2) -> Exp t1.

Inductive Ev : forall t, Exp t -> Exp t -> Prop :=
| EvConst   : forall n, Ev (Const n) (Const n)
| EvPair    : forall t1 t2 (e1:Exp t1) (e2:Exp t2) e1' e2',
               Ev e1 e1' -> Ev e2 e2' -> Ev (Pair e1 e2) (Pair e1' e2')
| EvFst     : forall t1 t2 (e:Exp (Prod t1 t2)) e1 e2,
               Ev e (Pair e1 e2) ->
               Ev (Fst e) e1.

Lemma EvFst_inversion : forall t1 t2 (e:Exp (Prod t1 t2)) e1, Ev (Fst e) e1 -> exists e2, Ev e (Pair e1 e2).
intros t1 t2 e e1 ev. dependent destruction ev. exists e2 ; assumption.
Qed.