(** * Archimedean property *)

(** ** Preamble *)

(** Settings *)

Unset Kernel Term Sharing.

(** Imports *)

Require Import UniMath.Foundations.NaturalNumbers.
Require Import UniMath.Algebra.RigsAndRings.
Require Import UniMath.Algebra.Groups.
Require Import UniMath.Algebra.DivisionRig.
Require Import UniMath.Algebra.Domains_and_Fields.
Require Import UniMath.Algebra.ConstructiveStructures.

Require Import UniMath.MoreFoundations.Tactics.
Import UniMath.Algebra.Monoids.AddNotation.

(** ** The standard function from the natural numbers to a monoid *)

Fixpoint natmult {X : monoid} (n : nat) (x : X) : X :=
  match n with
    | O => 0%addmonoid
    | S O => x
    | S m => (x + natmult m x)%addmonoid
  end.
Definition nattorig {X : rig} (n : nat) : X :=
  natmult (X := rigaddabmonoid X) n 1%rig.
Definition nattoring {X : ring} (n : nat) : X :=
  nattorig (X := ringtorig X) n.

Lemma natmultS :
  ∏ {X : monoid} (n : nat) (x : X),
    natmult (S n) x = (x + natmult n x)%addmonoid.
Proof.
  intros X n x.
  induction n as [|n].
  - now rewrite runax.
  - reflexivity.
Qed.
Lemma nattorigS {X : rig} :
  ∏ (n : nat), nattorig (X := X) (S n) = (1 + nattorig n)%rig.
Proof.
  intros.
  now apply (natmultS (X := rigaddabmonoid X)).
Qed.

Lemma nattorig_natmult :
  ∏ {X : rig} (n : nat) (x : X),
    (nattorig n * x)%rig = natmult (X := rigaddabmonoid X) n x.
Proof.
  intros.
  induction n as [|n IHn].
  - now apply rigmult0x.
  - rewrite nattorigS, natmultS.
    now rewrite rigrdistr, IHn, riglunax2.
Qed.
Lemma natmult_plus :
  ∏ {X : monoid} (n m : nat) (x : X),
    natmult (n + m) x = (natmult n x + natmult m x)%addmonoid.
Proof.
  induction n as [|n IHn] ; intros m x.
  - rewrite lunax.
    reflexivity.
  - change (S n + m)%nat with (S (n + m))%nat.
    rewrite !natmultS, IHn, assocax.
    reflexivity.
Qed.
Lemma nattorig_plus :
  ∏ {X : rig} (n m : nat),
    (nattorig (n + m) : X) = (nattorig n + nattorig m)%rig.
Proof.
  intros X n m.
  apply (natmult_plus (X := rigaddabmonoid X)).
Qed.

Lemma natmult_mult :
  ∏ {X : monoid} (n m : nat) (x : X),
    natmult (n * m) x = (natmult n (natmult m x))%addmonoid.
Proof.
  induction n as [|n IHn] ; intros m x.
  - reflexivity.
  - simpl (_ * _)%nat.
    assert (H : S n = (n + 1)%nat).
    { rewrite <- plus_n_Sm, natplusr0.
      reflexivity. }
    rewrite H ; clear H.
    rewrite !natmult_plus, IHn.
    reflexivity.
Qed.
Lemma nattorig_mult :
  ∏ {X : rig} (n m : nat),
    (nattorig (n * m) : X) = (nattorig n * nattorig m)%rig.
Proof.
  intros X n m.
  unfold nattorig.
  rewrite (natmult_mult (X := rigaddabmonoid X)), <- nattorig_natmult.
  reflexivity.
Qed.

Lemma natmult_op {X : monoid} :
  ∏ (n : nat) (x y : X),
    (x + y = y + x)%addmonoid
    -> natmult n (x + y)%addmonoid = (natmult n x + natmult n y)%addmonoid.
Proof.
  intros.
  induction n as [|n IHn].
  - rewrite lunax.
    reflexivity.
  - rewrite natmultS, assocax, IHn, <- (assocax _ y).
    assert (X1 : (y + natmult n x = natmult n x + y)%addmonoid).
    { clear IHn.
      induction n as [|n IHn].
      - rewrite lunax, runax.
        reflexivity.
      - rewrite !natmultS, <- assocax, <- X0, !assocax, IHn.
        reflexivity. }
    rewrite X1, assocax, <- natmultS, <- assocax, <- natmultS.
    reflexivity.
Qed.

Lemma natmult_binophrel {X : monoid} (R : hrel X) :
  istrans R -> isbinophrel R ->
  ∏ (n : nat) (x y : X), R x y -> R (natmult (S n) x) (natmult (S n) y).
Proof.
  intros Hr Hop n x y H.
  induction n as [|n IHn].
  exact H.
  rewrite !(natmultS (S _)).
  eapply Hr.
  apply (pr1 Hop).
  exact IHn.
  apply (pr2 Hop).
  exact H.
Qed.

(** ** relation  *)

Definition setquot_aux {X : monoid} (R : hrel X) : hrel X :=
  λ x y : X, ∃ c : X, R (x + c)%addmonoid (y + c)%addmonoid.

Lemma istrans_setquot_aux {X : abmonoid} (R : hrel X) :
  istrans R -> isbinophrel R -> istrans (setquot_aux R).
Proof.
  intros Hr Hop.
  intros x y z.
  apply hinhfun2.
  intros (c1,Hc1) (c2,Hc2).
  exists (c1 + c2)%addmonoid.
  eapply Hr.
  rewrite <- assocax.
  apply (pr2 Hop).
  exact Hc1.
  rewrite assocax, (commax _ c1), <- !assocax.
  apply (pr2 Hop).
  exact Hc2.
Qed.

Lemma isbinophrel_setquot_aux {X : abmonoid} (R : hrel X) :
  isbinophrel R -> isbinophrel (setquot_aux R).
Proof.
  intros Hop.
  split.
  - intros x y z.
    apply hinhfun.
    intros (c,Hc).
    exists c.
    rewrite !assocax.
    apply (pr1 Hop).
    exact Hc.
  - intros x y z.
    apply hinhfun.
    intros (c,Hc).
    exists c.
    rewrite !assocax, (commax _ z), <- !assocax.
    apply (pr2 Hop).
    exact Hc.
Qed.

Lemma isequiv_setquot_aux {X : abmonoid} (R : hrel X) :
  isinvbinophrel R ->
  ∏ x y : X, (setquot_aux R) x y <-> R x y.
Proof.
  intros H x y.
  split.
  apply hinhuniv.
  intros (c,H').
  generalize H'; clear H'.
  apply (pr2 H).
  intros H1.
  apply hinhpr.
  exists 0%addmonoid.
  rewrite !runax.
  exact H1.
Qed.

(** ** Archimedean property in a monoid *)

Definition isarchmonoid {X : abmonoid} (R : hrel X) :=
  ∏ x y1 y2 : X,
    R y1 y2 ->
    (∃ n : nat, R (natmult n y1 + x)%addmonoid (natmult n y2))
      × (∃ n : nat, R (natmult n y1) (natmult n y2 + x)%addmonoid).

Definition isarchmonoid_1 {X : abmonoid} (R : hrel X) :
  isarchmonoid R ->
  ∏ x y1 y2 : X,
    R y1 y2 ->
    ∃ n : nat, R (natmult n y1 + x)%addmonoid (natmult n y2) :=
  λ H x y1 y2 Hy, (pr1 (H x y1 y2 Hy)).
Definition isarchmonoid_2 {X : abmonoid} (R : hrel X) :
  isarchmonoid R ->
  ∏ x y1 y2 : X,
    R y1 y2 ->
    ∃ n : nat, R (natmult n y1) (natmult n y2 + x)%addmonoid :=
  λ H x y1 y2 Hy, (pr2 (H x y1 y2 Hy)).

(** ** Archimedean property in a group *)

Definition isarchgr {X : abgr} (R : hrel X) :=
  ∏ x y1 y2 : X,
    R y1 y2 ->
    ∃ n : nat, R (natmult n y1 + x)%addmonoid (natmult n y2).

Local Lemma isarchgr_isarchmonoid_aux {X : abgr} (R : hrel X) :
  isbinophrel R ->
  ∏ (n : nat) (x y1 y2 : X),
    R (natmult n y1 * grinv X x)%multmonoid (natmult n y2) -> R (natmult n y1) (natmult n y2 * x)%multmonoid.
Proof.
  intros Hop.
  intros n x y1 y2 Hy.
  apply (pr2 (isinvbinophrelgr _ Hop) _ _ (grinv X x)).
  rewrite assocax, (grrinvax X), runax.
  exact Hy.
Qed.
Lemma isarchgr_isarchmonoid {X : abgr} (R : hrel X) :
  isbinophrel R ->
  isarchgr R ->
  isarchmonoid (X := abgrtoabmonoid X) R.
Proof.
  intros Hop H x y1 y2 Hy.
  split.
  - now apply H.
  - generalize (H (grinv X x) _ _ Hy).
    apply hinhfun.
    intros (n,Hn).
    exists n.
    apply isarchgr_isarchmonoid_aux.
    exact Hop.
    exact Hn.
Defined.

Lemma isarchmonoid_isarchgr {X : abgr} (R : hrel X) :
  isarchmonoid (X := abgrtoabmonoid X) R ->
  isarchgr R.
Proof.
  intros H x y1 y2 Hy.
  apply (isarchmonoid_1 _ H x y1 y2 Hy).
Defined.

Local Lemma isarchabgrdiff_aux {X : abmonoid} (R : hrel X)
      (Hr : isbinophrel R)
      (Hr' : istrans R)
      (y1 y2 x : abmonoiddirprod X X)
      (n1 : nat)
      (Hn1 : setquot_aux R (natmult n1 (pr1 y1 * pr2 y2) * pr1 x)%multmonoid
                         (natmult n1 (pr1 y2 * pr2 y1)%multmonoid))
      (n2 : nat)
      (Hn2 : setquot_aux R (natmult n2 (pr1 y1 * pr2 y2)%multmonoid)
                         (natmult n2 (pr1 y2 * pr2 y1) * pr2 x)%multmonoid) :
  abgrdiffrel X Hr
              (natmult (X := abgrdiff X) (n1 + n2) (setquotpr (binopeqrelabgrdiff X) y1) *
               setquotpr (binopeqrelabgrdiff X) x)%multmonoid
              (natmult (X := abgrdiff X) (n1 + n2) (setquotpr (binopeqrelabgrdiff X) y2)).
Proof.
  intros.
  assert (H0 : ∏ n y, natmult (X := abgrdiff X) n (setquotpr (binopeqrelabgrdiff X) y) = setquotpr (binopeqrelabgrdiff X) (natmult n (pr1 y) ,, natmult n (pr2 y))).
  { intros n y.
    induction n as [|n IHn].
    reflexivity.
    rewrite !natmultS, IHn.
    reflexivity. }
  rewrite !H0.
  revert Hn1 Hn2.
  apply hinhfun2 ; simpl.
  intros (c1,Hc1) (c2,Hc2).
  exists (c1 * c2)%multmonoid.
  eapply Hr'.
  assert (X0 : (natmult (n1 + n2) (pr1 y1) * pr1 x * natmult (n1 + n2) (pr2 y2) * (c1 * c2) = (natmult n1 (pr1 y1 * pr2 y2) * pr1 x * c1) * (natmult n2 (pr1 y1 * pr2 y2) * c2))%multmonoid).
  { rewrite !natmult_op, !natmult_plus, !assocax.
    apply maponpaths.
    rewrite commax, !assocax.
    rewrite commax, !assocax.
    apply maponpaths.
    rewrite commax, !assocax.
    rewrite commax, !assocax.
    rewrite commax, !assocax.
    rewrite commax, !assocax.
    apply maponpaths.
    rewrite commax, !assocax.
    apply maponpaths.
    rewrite commax, !assocax.
    reflexivity.
    apply commax.
    apply commax. }
  simpl in X0 |- *.
  rewrite X0 ; clear X0.
  apply (pr2 Hr).
  apply Hc1.
  assert (X0 : (natmult (n1 + n2) (pr1 y2) * (natmult (n1 + n2) (pr2 y1) * pr2 x) * (c1 * c2) = (natmult n1 (pr1 y2 * pr2 y1) * c1) * (natmult n2 (pr1 y2 * pr2 y1) * pr2 x * c2))%multmonoid).
  { rewrite !natmult_op, !natmult_plus, !assocax.
    apply maponpaths.
    rewrite commax, !assocax.
    apply maponpaths.
    rewrite commax, !assocax.
    rewrite commax, !assocax.
    apply maponpaths.
    rewrite commax, !assocax.
    reflexivity.
    apply commax.
    apply commax. }
  simpl in X0 |- *.
  rewrite X0 ; clear X0.
  apply (pr1 Hr).
  apply Hc2.
Qed.
Lemma isarchabgrdiff {X : abmonoid} (R : hrel X)  (Hr : isbinophrel R) :
  istrans R ->
  isarchmonoid (setquot_aux R) ->
  isarchgr (X := abgrdiff X) (abgrdiffrel X (L := R) Hr).
Proof.
  intros Hr' H.
  simple refine (setquotuniv3prop _ (λ x y1 y2, (abgrdiffrel X Hr y1 y2 ->
    ∃ n : nat, abgrdiffrel X Hr (natmult (X := abgrdiff X) n y1 * x)%multmonoid (natmult (X := abgrdiff X) n y2)) ,, _) _).
  abstract apply isapropimpl, propproperty.
  intros x y1 y2 Hy.
  eapply hinhfun2.
  2: apply (isarchmonoid_1 _ H (pr1 x) (pr1 y1 * pr2 y2)%multmonoid (pr1 y2 * pr2 y1)%multmonoid), Hy.
  2: apply (isarchmonoid_2 _ H (pr2 x) (pr1 y1 * pr2 y2)%multmonoid (pr1 y2 * pr2 y1)%multmonoid), Hy.
  intros n1 n2.
  exists (pr1 n1 + pr1 n2)%nat.
  apply isarchabgrdiff_aux.
  exact Hr'.
  exact (pr2 n1).
  exact (pr2 n2).
Defined.

(** ** Archimedean property in a rig *)

Definition isarchrig {X : rig} (R : hrel X) :=
  (∏ y1 y2 : X, R y1 y2 -> ∃ n : nat, R (nattorig n * y1)%rig (1 + nattorig n * y2)%rig)
    × (∏ x : X, ∃ n : nat, R (nattorig n) x)
    × (∏ x : X, ∃ n : nat, R (nattorig n + x)%rig 0%rig).

Definition isarchrig_diff {X : rig} (R : hrel X) :
  isarchrig R ->
  ∏ y1 y2 : X, R y1 y2 -> ∃ n : nat, R (nattorig n * y1)%rig (1 + nattorig n * y2)%rig :=
  pr1.
Definition isarchrig_gt {X : rig} (R : hrel X) :
  isarchrig R ->
  ∏ x : X, ∃ n : nat, R (nattorig n) x :=
  λ H, (pr1 (pr2 H)).
Definition isarchrig_pos {X : rig} (R : hrel X) :
  isarchrig R ->
  ∏ x : X, ∃ n : nat, R (nattorig n + x)%rig 0%rig :=

  λ H, (pr2 (pr2 H)).

Lemma isarchrig_setquot_aux {X : rig} (R : hrel X) :
  isinvbinophrel (X := rigaddabmonoid X) R
  → isarchrig R
  → isarchrig (setquot_aux (X := rigaddabmonoid X) R).
Proof.
  intros Hr H.
  split ; [ | split].
  - intros y1 y2.
    apply hinhuniv.
    intros Hy.
    generalize (isarchrig_diff R H y1 y2 (pr2 Hr _ _ _ (pr2 Hy))).
    apply hinhfun.
    intros n.
    exists (pr1 n).
    apply hinhpr.
    exists 0%rig.
    rewrite runax, runax.
    exact (pr2 n).
  - intros x.
    generalize (isarchrig_gt R H x).
    apply hinhfun.
    intros n.
    exists (pr1 n).
    apply hinhpr.
    exists 0%rig.
    rewrite runax, runax.
    exact (pr2 n).
  - intros x.
    generalize (isarchrig_pos R H x).
    apply hinhfun.
    intros n.
    exists (pr1 n).
    apply hinhpr.
    exists 0%rig.
    rewrite runax, runax.
    exact (pr2 n).
Qed.

Local Lemma isarchrig_isarchmonoid_1_aux {X : rig} (R : hrel X)
      (Hr1 : R 1%rig 0%rig)
      (Hr : istrans R)
      (Hop1 : isbinophrel (X := rigaddabmonoid X) R)
      (x y1 y2 : rigaddabmonoid X)
      (m : nat)
      (Hm : R (nattorig m * y1)%ring (1%rig + nattorig m * y2)%ring)
      (n : nat)
      (Hn : R (nattorig n + x)%ring 0%rig) :
   R (natmult (max 1 n * m) y1 * x)%multmonoid
     (natmult (max 1 n * m) y2).
Proof.
  intros.
  rewrite !nattorig_natmult in Hm.
  destruct n.
  + rewrite riglunax1 in Hn.
    eapply Hr.
    apply (pr1 Hop1).
    exact Hn.
    rewrite runax.
    simpl.
    rewrite <- (lunax _ (natmult m y2)).
    eapply Hr.
    exact Hm.
    apply (pr2 Hop1).
    exact Hr1.
  + rewrite natmult_mult.
    simpl max.
    rewrite <- (runax _ (natmult (S n * m) y2)).
    refine (Hr _ _ _ _ _).
    apply (pr2 Hop1).
    apply natmult_binophrel.
    exact Hr.
    exact Hop1.
    exact Hm.
    rewrite rigcomm1.
    change BinaryOperations.op1 with (BinaryOperations.op (X := rigaddabmonoid X)).
    rewrite natmult_op, assocax, <- natmult_mult.
    apply (pr1 Hop1).
    exact Hn.
    apply rigcomm1.
Qed.
Local Lemma isarchrig_isarchmonoid_2_aux {X : rig} (R : hrel X)
      (Hr1 : R 1%rig 0%rig)
      (Hr : istrans R)
      (Hop1 : isbinophrel (X := rigaddabmonoid X) R)
      (x y1 y2 : rigaddabmonoid X)
      (m : nat)
      (Hm : R (nattorig m * y1)%ring (1%rig + nattorig m * y2)%ring)
      (n : nat)
      (Hn : R (nattorig n) x) :
  R (natmult (max 1 n * m) y1)
    (natmult (max 1 n * m) y2 * x)%multmonoid.
Proof.
  intros.
  rewrite !nattorig_natmult in Hm.
  destruct n.
  + eapply Hr.
    exact Hm.
    rewrite rigcomm1.
    apply (pr1 Hop1).
    eapply Hr.
    exact Hr1.
    exact Hn.
  + rewrite natmult_mult.
    eapply Hr.
    simpl max.
    apply natmult_binophrel.
    exact Hr.
    exact Hop1.
    exact Hm.
    rewrite rigcomm1.
    change BinaryOperations.op1 with (BinaryOperations.op (X := rigaddabmonoid X)).
    rewrite natmult_op, <- natmult_mult.
    apply (pr1 Hop1).
    exact Hn.
    apply rigcomm1.
Qed.
Lemma isarchrig_isarchmonoid {X : rig} (R : hrel X) :
  R 1%rig 0%rig ->
  istrans R -> isbinophrel (X := rigaddabmonoid X) R ->
  isarchrig R -> isarchmonoid (X := rigaddabmonoid X) R.
Proof.
  intros Hr1 Hr Hop1 H x y1 y2 Hy.
  split.
  - generalize (isarchrig_diff _ H _ _ Hy) (isarchrig_pos _ H x).
    apply hinhfun2.
    intros m n.
    exists (max 1 (pr1 n) * (pr1 m))%nat.
    apply isarchrig_isarchmonoid_1_aux.
    exact Hr1.
    exact Hr.
    exact Hop1.
    exact (pr2 m).
    exact (pr2 n).
  - generalize (isarchrig_diff _ H _ _ Hy) (isarchrig_gt _ H x).
    apply hinhfun2.
    intros m n.
    exists (max 1 (pr1 n) * (pr1 m))%nat.
    apply isarchrig_isarchmonoid_2_aux.
    exact Hr1.
    exact Hr.
    exact Hop1.
    exact (pr2 m).
    exact (pr2 n).
Defined.

Lemma isarchmonoid_isarchrig {X : rig} (R : hrel X) :
  (R 1%rig 0%rig)
  -> isarchmonoid (X := rigaddabmonoid X) R
  -> isarchrig R.
Proof.
  intros H01 H.
  repeat split.
  - intros y1 y2 Hy.
    generalize (isarchmonoid_2 _ H 1%rig y1 y2 Hy).
    apply hinhfun.
    intros n.
    exists (pr1 n).
    abstract (rewrite !nattorig_natmult, rigcomm1 ;
               exact (pr2 n)).
  - intros x.
    generalize (isarchmonoid_2 _ H x _ _ H01).
    apply hinhfun.
    intros n.
    exists (pr1 n).
    abstract (
        pattern x at 1;
        rewrite <- (riglunax1 X x) ;
        pattern (0%rig : X) at 1;
        rewrite <- (rigmultx0 X (nattorig (pr1 n))) ;
        rewrite nattorig_natmult ;
        exact (pr2 n)).
  - intros x.
    generalize (isarchmonoid_1 _ H x _ _ H01).
    apply hinhfun.
    intros n.
    exists (pr1 n).
    abstract (
        pattern (0%rig : X) at 1;
        rewrite <- (rigmultx0 X (nattorig (pr1 n))), nattorig_natmult ;
        exact (pr2 n)).
Defined.

(** ** Archimedean property in a ring *)

Definition isarchring {X : ring} (R : hrel X) :=
  (∏ x : X, R x 0%ring -> ∃ n : nat, R (nattoring n * x)%ring 1%ring)
    × (∏ x : X, ∃ n : nat, R (nattoring n) x).

Definition isarchring_1 {X : ring} (R : hrel X) :
  isarchring R ->
  ∏ x : X, R x 0%ring -> ∃ n : nat, R (nattoring n * x)%ring 1%ring := pr1.
Definition isarchring_2 {X : ring} (R : hrel X) :
  isarchring R ->
  ∏ x : X, ∃ n : nat, R (nattoring n) x := pr2.

Lemma isarchring_isarchrig {X : ring} (R : hrel X) :
  isbinophrel (X := rigaddabmonoid X) R ->
  isarchring R -> isarchrig (X := ringtorig X) R.
Proof.
  intros Hop1 H.
  repeat split.
  - intros y1 y2 Hy.
    assert (X0 : R (y1 - y2)%ring 0%ring).
    abstract (apply (pr2 (isinvbinophrelgr X Hop1)) with y2 ;
               change BinaryOperations.op with (@BinaryOperations.op1 X) ;
               rewrite ringassoc1, ringlinvax1, ringlunax1, ringrunax1 ;
               exact Hy).
    generalize (isarchring_1 _ H _ X0).
    apply hinhfun.
    intros n.
    exists (pr1 n).
    abstract
      (rewrite <- (ringrunax1 _ (nattorig (pr1 n) * y1)%ring), <- (ringlinvax1 _ (nattorig (pr1 n) * y2)%ring), <- ringassoc1 ;
        apply (pr2 Hop1) ;
        rewrite <- ringrmultminus, <- ringldistr ;
        exact (pr2 n)).
  - apply isarchring_2.
    exact H.
  - intros x.
    generalize (isarchring_2 _ H (- x)%ring).
    apply hinhfun.
    intros n.
    exists (pr1 n).
    abstract (change 0%rig with (0%ring : X) ;
               rewrite <- (ringlinvax1 _ x) ;
               apply (pr2 Hop1) ;
               exact (pr2 n)).
Defined.

Lemma isarchrig_isarchring {X : ring} (R : hrel X) :
  isbinophrel (X := rigaddabmonoid X) R ->
  isarchrig (X := ringtorig X) R -> isarchring R.
Proof.
  intros Hr H.
  split.
  - intros x Hx.
    generalize (isarchrig_diff _ H _ _ Hx).
    apply hinhfun.
    intros (n,Hn).
    exists n.
    rewrite <- (ringrunax1 _ 1%ring), <- (ringmultx0 _ (nattoring n)).
    exact Hn.
  - apply (isarchrig_gt (X := ringtorig X)).
    exact H.
Defined.

Lemma isarchring_isarchgr {X : ring} (R : hrel X) :
  R 1%ring 0%ring ->
  istrans R ->
  isbinophrel (X := X) R ->
  isarchring R -> isarchgr (X := X) R.
Proof.
  intros Hr0 Hr Hop1 H.
  apply isarchmonoid_isarchgr.
  apply (isarchrig_isarchmonoid (X := X)).
  exact Hr0.
  exact Hr.
  exact Hop1.
  now apply isarchring_isarchrig.
Defined.

Lemma isarchgr_isarchring {X : ring} (R : hrel X) :
  R 1%ring 0%ring ->
  istrans R ->
  isbinophrel (X := X) R ->
  isarchgr (X := X) R -> isarchring R.
Proof.
  intros Hr0 Hr Hop1 H.
  apply isarchrig_isarchring.
  exact Hop1.
  apply isarchmonoid_isarchrig.
  exact Hr0.
  now apply (isarchgr_isarchmonoid (X := X)).
Defined.

Theorem isarchrigtoring :
  ∏ (X : rig) (R : hrel X) (Hr : R 1%rig 0%rig)
    (Hadd : isbinophrel (X := rigaddabmonoid X) R)
    (Htra : istrans R)
    (Harch : isarchrig (setquot_aux (X := rigaddabmonoid X) R)), isarchring (X := rigtoring X) (rigtoringrel X Hadd).
Proof.
  intros.
  apply isarchgr_isarchring.
  abstract (apply hinhpr ; simpl ;
  exists 0%rig ; rewrite !rigrunax1 ;
  exact Hr).
  now apply (istransabgrdiffrel (rigaddabmonoid X)).
  now generalize Hadd ; apply isbinopabgrdiffrel.
  apply (isarchabgrdiff (X := rigaddabmonoid X)).
  exact Htra.
  apply isarchrig_isarchmonoid.
  abstract (apply hinhpr ; simpl ;
  exists 0%rig ; rewrite !rigrunax1 ;
  exact Hr).
  (now apply (istrans_setquot_aux (X := rigaddabmonoid X))).
  (now apply (isbinophrel_setquot_aux (X := rigaddabmonoid X))).
  exact Harch.
(* Proof without (Hr : R 1%rig 0%rig)
  split.
  - intros xx Hx0.
    generalize (pr1 (pr2 xx)).
    apply hinhuniv ; intros (x,Hx).
    rewrite <- (setquotl0 _ xx (x,,Hx)) in Hx0 |- * ; simpl pr1 in Hx0 |- * ; clear xx Hx.
    eapply hinhfun.
    2: apply (isarchrig_diff _ Harch (pr1 x) (pr2 x)).
    intros (n,Hn).
    exists n.
    assert ((nattoring (X := rigtoring X) n * setquotpr
    (binopeqrelabgrdiff (rigaddabmonoid X)) x)%ring = (setquotpr
    (binopeqrelabgrdiff (rigaddabmonoid X)) (nattorig n * pr1 x ,,
    nattorig n * pr2 x))%ring).
    { clear.
      induction n as [|n IHn].
      - rewrite !rigmult0x, ringmult0x.
        reflexivity.
      - unfold nattoring.
        rewrite !nattorigS, !rigrdistr, ringrdistr, !riglunax2, ringlunax2.
        simpl.
        eapply pathscomp0.
        apply maponpaths.
        apply IHn.
        reflexivity. }
    rewrite X0 ; clear X0.
    revert Hn.
    apply hinhfun ; simpl.
    intros (c,Hc).
    exists c.
    rewrite rigrunax1.
    exact Hc.
    revert Hx0.
    apply hinhfun ; simpl.
    intros (c,Hc).
    exists c.
    rewrite riglunax1, rigrunax1 in Hc.
    exact Hc.
  - intros xx.
    generalize (pr1 (pr2 xx)).
    apply hinhuniv ; intros (x,Hx).
    rewrite <- (setquotl0 _ xx (x,,Hx)) ; simpl pr1 ; clear xx Hx.
    generalize (isarchrig_gt _ Harch (pr1 x)) (isarchrig_pos _ Harch (pr2 x)).
    apply hinhfun2.
    intros (n1,Hn1) (n2,Hn2).
    exists (n1 + n2)%nat.
    revert Hn1 Hn2.
    assert (nattoring (X := rigtoring X) (n1 + n2) = setquotpr
    (binopeqrelabgrdiff (rigaddabmonoid X)) (nattorig (n1 + n2) ,,
    0%rig)).
    { generalize (n1 + n2) ; clear.
      induction n as [|n IHn].
      - reflexivity.
      - unfold nattoring ; rewrite !nattorigS.
        rewrite <- (riglunax1 _ 0%rig).
        eapply pathscomp0.
        apply maponpaths.
        exact IHn.
        reflexivity. }
    rewrite X0 ; clear X0.
    apply hinhfun2 ; simpl.
    intros (c1,Hc1) (c2,Hc2).
    exists (c1+c2)%rig.
    eapply Htra.
    assert (nattorig (n1 + n2) + pr2 x + (c1 + c2) =
            ((nattorig n1 + c1) + (nattorig n2 + pr2 x + c2)))%rig.
    { rewrite nattorig_plus, !rigassoc1.
      apply maponpaths.
      rewrite rigcomm1, !rigassoc1.
      rewrite rigcomm1, !rigassoc1.
      apply maponpaths.
      rewrite rigcomm1, !rigassoc1.
      reflexivity. }
    simpl in X0 |- * ; rewrite X0 ; clear X0.
    apply (pr2 Hadd).
    exact Hc1.
    rewrite rigrunax1, <- rigassoc1.
    apply (pr1 Hadd).
    rewrite riglunax1 in Hc2.
    exact Hc2.*)
Defined.

Lemma natmult_commringfrac {X : commring} {S : subabmonoid _} :
  ∏ n (x : X × S), natmult (X := commringfrac X S) n (setquotpr (eqrelcommringfrac X S) x) = setquotpr (eqrelcommringfrac X S) (natmult (X := X) n (pr1 x) ,, (pr2 x)).
Proof.
  simpl ; intros n x.
  induction n as [|n IHn].
  - apply (iscompsetquotpr (eqrelcommringfrac X S)).
    apply hinhpr ; simpl.
    exists (pr2 x).
    rewrite !(ringmult0x X).
    reflexivity.
  - rewrite !natmultS, IHn.
    apply (iscompsetquotpr (eqrelcommringfrac X S)).
    apply hinhpr ; simpl.
    exists (pr2 x) ; simpl.
    rewrite <- (ringldistr X).
    rewrite (ringcomm2 X (pr1 (pr2 x))).
    rewrite !(ringassoc2 X).
    reflexivity.
Qed.

Lemma isarchcommringfrac {X : commring} {S : subabmonoid _} (R : hrel X) Hop1 Hop2 Hs:
  R 1%ring 0%ring ->
  istrans R ->
  isarchring R -> isarchring (X := commringfrac X S) (commringfracgt X S (R := R) Hop1 Hop2 Hs).
Proof.
  intros H0 Htra Hr.
  split.
  - simple refine (setquotunivprop _ (λ _, (_,,_)) _).
    apply isapropimpl, propproperty.
    intros x Hx.
    revert Hx ; apply hinhuniv ; intros (c,Hx) ; simpl in Hx.
    rewrite !(ringmult0x X), (ringrunax2 X) in Hx.
    apply (hinhfun (X := ∑ n, commringfracgt X S Hop1 Hop2 Hs (setquotpr (eqrelcommringfrac X S) ((nattoring n * pr1 x)%ring,, pr2 x)) 1%ring)).
    intros H.
    eexists (pr1 H).
    unfold nattoring.
    rewrite (nattorig_natmult (X := commringfrac X S)).
    rewrite (natmult_commringfrac (X := X) (S := S)).
    rewrite <- (nattorig_natmult (X := X)).
    now apply (pr2 H).
    generalize (isarchring_1 _ Hr _ Hx) (isarchring_2 _ Hr (pr1 (pr2 x) * pr1 c)%ring).
    apply hinhfun2.
    intros (m,Hm) (n,Hn).
    exists (max 1 n * m)%nat.
    destruct n ; simpl max.
    + apply hinhpr ; simpl.
      exists c.
      rewrite (ringrunax2 X), (ringlunax2 X), (ringassoc2 X).
      eapply Htra.
      exact Hm.
      eapply Htra.
      exact H0.
      exact Hn.
    + unfold nattoring.
      rewrite (nattorig_natmult (X := X)), natmult_mult.
      apply hinhpr ; simpl.
      exists c.
      change (R
                (natmult (succ n) (natmult (X := X) m (pr1 x)) * 1 * pr1 c)%ring
                (1 * pr1 (pr2 x) * pr1 c)%ring).
      rewrite <- (nattorig_natmult (X := X)), (ringrunax2 X), (ringlunax2 X), (ringassoc2 X), (nattorig_natmult (X := X)).
      eapply Htra.
      apply (natmult_binophrel (X := X) R).
      exact Htra.
      exact Hop1.
      rewrite <- (nattorig_natmult (X := X)), (ringassoc2 X).
      exact Hm.
      exact Hn.
  - simple refine (setquotunivprop _ _ _).
    intros x.
    apply (hinhfun (X := ∑ n : nat, commringfracgt X S Hop1 Hop2 Hs
     (setquotpr (eqrelcommringfrac X S) (nattoring n,, unel S))
     (setquotpr (eqrelcommringfrac X S) x))).
    intros (n,Hn).
    exists n.
    unfold nattoring, nattorig.
    change 1%rig with (setquotpr (eqrelcommringfrac X S)
                                (1%ring,, unel S)).
    rewrite (natmult_commringfrac (X := X) (S := S) n).
    exact Hn.
    generalize (isarchring_1 _ Hr _ (Hs (pr1 (pr2 x)) (pr2 (pr2 x)))) (isarchring_2 _ Hr (pr1 x)%ring).
    apply hinhfun2.
    intros (m,Hm) (n,Hn).
    exists (max 1 n * m)%nat.
    destruct n ; simpl max.
    + apply hinhpr ; simpl.
      exists (pr2 x).
      apply (isringmultgttoisrringmultgt X).
      exact Hop1.
      exact Hop2.
      apply Hs.
      apply (pr2 (pr2 x)).
      eapply Htra.
      exact Hm.
      eapply Htra.
      exact H0.
      rewrite (ringrunax2 X).
      exact Hn.
    + apply hinhpr ; simpl.
      exists (pr2 x).
      change (n * m + m)%nat with (succ n * m)%nat.
      unfold nattoring.
      apply (isringmultgttoisrringmultgt X).
      exact Hop1.
      exact Hop2.
      apply Hs.
      apply (pr2 (pr2 x)).
      rewrite (ringrunax2 X), (nattorig_natmult (X := X)), natmult_mult.
      eapply Htra.
      apply (natmult_binophrel (X := X) R).
      exact Htra.
      exact Hop1.
      rewrite <- (nattorig_natmult (X := X)).
      exact Hm.
      exact Hn.
Qed.

(** ** Archimedean property in a field *)

Definition isarchfld {X : fld} (R : hrel X) :=
  ∏ x : X, ∃ n : nat, R (nattoring n) x.

Lemma isarchfld_isarchring {X : fld} (R : hrel X) :
  ∏ (Hadd : isbinophrel (X := rigaddabmonoid X) R) ( Hmult : isringmultgt X R)
    (Hirr : isirrefl R),
    isarchfld R -> isarchring R.
Proof.
  intros Hadd Hmult Hirr H.
  split.
  - intros x Hx.
    case (fldchoice x) ; intros x'.
    + generalize (H (pr1 x')).
      apply hinhfun.
      intros n.
      exists (pr1 n).
      abstract (pattern (1%ring : X) at 1 ;
                 rewrite <- (pr1 (pr2 x')) ;
                apply (isringmultgttoisrringmultgt _ Hadd Hmult _ _ _ Hx (pr2 n))).
    + apply hinhpr.
      exists O.
      abstract (apply fromempty ;
                 refine (Hirr _ _) ;
                 rewrite x' in Hx ;
                 apply Hx).
  - exact H.
Defined.
Lemma isarchring_isarchfld {X : fld} (R : hrel X) :
    isarchring R -> isarchfld R.
Proof.
  intros H.
  intros x.
  apply (isarchring_2 R H x).
Defined.

Theorem isarchfldfrac ( X : intdom ) ( is : isdeceq X )  { R : hrel X } ( is0 : @isbinophrel X R ) ( is1 : isringmultgt X R ) ( is2 : R 1%ring 0%ring ) ( nc : neqchoice R ) ( irr : isirrefl R ) ( tra : istrans R ) :
  isarchring R -> isarchfld (X := fldfrac X is ) (fldfracgt _  is is0 is1 is2 nc).
Proof.
  intros.
  apply isarchring_isarchfld.
  unfold fldfracgt.
  generalize (isarchcommringfrac (X := X) (S := ringpossubmonoid X is1 is2) R is0 is1 (λ (c : X) (r : (ringpossubmonoid X is1 is2) c), r) is2 tra X0).
  intros.
  assert (H_f : ∏ n x, (weqfldfracgt_f X is is0 is1 is2 nc (nattoring n * x)%ring) = (nattoring n * weqfldfracgt_f X is is0 is1 is2 nc x)%ring).
  { clear -irr.
    intros n x.
    unfold nattoring.
    rewrite (nattorig_natmult (X := fldfrac X is)), (nattorig_natmult (X := commringfrac X (@ringpossubmonoid X R is1 is2))).
    induction n as [|n IHn].
    - refine (pr2 (pr1 (isringfunweqfldfracgt_f _ _ _ _ _ _ _))).
      exact irr.
    - rewrite !natmultS, <- IHn.
      refine (pr1 (pr1 (isringfunweqfldfracgt_f _ _ _ _ _ _ _)) _ _).
      exact irr. }
  assert (H_0 : (weqfldfracgt_f X is is0 is1 is2 nc 0%ring) = 0%ring).
  { refine (pr2 (pr1 (isringfunweqfldfracgt_f _ _ _ _ _ _ _))).
    exact irr. }
  assert (H_1 : (weqfldfracgt_f X is is0 is1 is2 nc 1%ring) = 1%ring).
  { refine (pr2 (pr2 (isringfunweqfldfracgt_f _ _ _ _ _ _ _))).
    exact irr. }
  split.
  - intros x Hx.
    eapply hinhfun.
    2: apply (isarchring_1 _ X1 (weqfldfracgt_f X is is0 is1 is2 nc x)).
    intros (n,Hn).
    exists n.
    rewrite H_f, H_1.
    exact Hn.
    rewrite H_0 in Hx.
    exact Hx.
  - intros x.
    eapply hinhfun.
    2: apply (isarchring_2 _ X1 (weqfldfracgt_f X is is0 is1 is2 nc x)).
    intros (n,Hn).
    exists n.
    rewrite <- (ringrunax2 _ (nattoring n)), H_f, H_1, ringrunax2.
    exact Hn.
Defined.

(** ** Archimedean property in a constructive field *)

Definition isarchCF {X : ConstructiveField} (R : hrel X) :=
  ∏ x : X, ∃ n : nat, R (nattoring n) x.

Lemma isarchCF_isarchring {X : ConstructiveField} (R : hrel X) :
  ∏ (Hadd : isbinophrel (X := rigaddabmonoid X) R) ( Hmult : isringmultgt X R)
    (Hirr : isirrefl R),
    (∏ x : X, R x 0%CF -> (x ≠ 0)%CF) ->
    isarchCF R -> isarchring R.
Proof.
  intros Hadd Hmult Hirr H0 H.
  split.
  - intros x Hx.
    generalize (H (CFinv x (H0 _ Hx))).
    apply hinhfun.
    intros (n,Hn).
    exists n.
    change 1%ring with (1%CF : X).
    rewrite <- (islinv_CFinv x (H0 x Hx)).
    apply isringmultgttoisrringmultgt.
    exact Hadd.
    exact Hmult.
    exact Hx.
    exact Hn.
  - exact H.
Defined.
Lemma isarchring_isarchCF {X : ConstructiveField} (R : hrel X) :
    isarchring R -> isarchCF R.
Proof.
  intros H.
  intros x.
  apply (isarchring_2 R H x).
Defined.


Require Import LibWfenv Core_Infrastructure
               Source_Definitions Target_Definitions
               Source_Properties Target_Properties.
Require Import CpdtTactics.
Require Import Recdef.

(* for applications where the type argument is irrelevant *)
Definition dummy_type := t_typ_bool.
Definition s_dummy_type := s_typ_bool.

Fixpoint cps_type_trans (s:typ) :=
  match s with
    | s_typ_bool => t_typ_bool
    | s_typ_arrow s1 s2 =>
      t_typ_arrow (t_typ_pair (cps_type_trans s1)
                              (t_typ_arrow (cps_type_trans s2) (t_typ_bvar 1)))
                  (t_typ_bvar 0)
    | _ => typ_bad
  end.

Notation "( s +)" := (cps_type_trans s) (at level 0).

Lemma cps_type_trans_preserves_well_formed_types : forall s,
  s_type s -> t_type (s+).
Proof.
  induction 1; auto.
  simpl. apply_fresh t_type_arrow as X; simpl; auto.
  apply t_type_pair; rewrite* open_tt_rec_t_type.
  apply_fresh t_type_arrow as Y; rewrite* open_tt_rec_t_type.
Qed.

Lemma cps_type_trans_preserves_wft : forall s,
  s_type s -> t_wft empty (s+).
Proof.
  induction 1; auto.
  apply_fresh t_wft_arrow as X; simpl; auto.
  apply t_wft_pair. rewrite* open_tt_rec_t_type. apply* t_wft_weaken.
  apply_fresh t_wft_arrow as Y; simpl; auto.
  repeat rewrite* open_tt_rec_t_type. repeat apply* t_wft_weaken.
Qed.

Lemma cps_type_trans_preserves_wfenv : forall G,
  wfenv s_type G -> wfenv (t_wft empty) (map cps_type_trans G).
Proof.
  apply wfenv_ind.
  rewrite map_empty. apply wfenv_empty.
  intros.
  rewrite map_push.
  apply wfenv_push; auto.
  apply* cps_type_trans_preserves_wft.
Qed.

Definition cps_type_trans_computation (s : typ) :=
  t_typ_arrow (t_typ_arrow (s+) (t_typ_bvar 1)) (t_typ_bvar 0).

Notation "( s %)" := (cps_type_trans_computation s) (at level 0).

Function cps_term_trans (G : env_term)  (e : trm) {measure trm_size e}: trm :=
match e with
| s_trm_fvar v =>
  let s := get v G in
  match s with
  | Some s' =>
    (* λ [σ] k:s+ → α . k [_] x *)
    (t_trm_abs (t_typ_arrow (cps_type_trans s') (t_typ_bvar 0))
               (t_trm_app (t_trm_bvar 0) dummy_type (t_trm_fvar v)))
  | None => trm_bad
  end
| s_trm_true =>
  (* λ [σ] k:bool+ → α . k [_] true *)
  (t_trm_abs (t_typ_arrow (cps_type_trans s_typ_bool) (t_typ_bvar 0))
                     (t_trm_app (t_trm_bvar 0) dummy_type t_trm_true))
| s_trm_false =>
  (* λ [σ] k:bool+ → α . k [_] false *)
  (t_trm_abs (t_typ_arrow (cps_type_trans s_typ_bool) (t_typ_bvar 0))
                     (t_trm_app (t_trm_bvar 0) dummy_type t_trm_false))
| s_trm_abs s1 bdy =>
  (* TODO: write a type inferencer to get s2 *)
  let s2 := s_dummy_type in
  let x := var_gen (fv_ee source bdy) in
  let v := cps_term_trans (G & x ~ s1) (s_open_ee_var bdy x) in
  (* λ [α] k:((σ1 → σ2)+ → α) . *)
  (t_trm_abs (t_typ_arrow (cps_type_trans (s_typ_arrow s1 s2)) (t_typ_bvar 0))
    (* k [_] ... *)
    (t_trm_app (t_trm_bvar 0) dummy_type
      (* (λ [β] pr:(σ1+ ⅹ (σ2+ → β)) . *)
      (t_trm_abs (t_typ_pair (cps_type_trans s1) (t_typ_arrow (cps_type_trans s2) (t_typ_bvar 0)))
        (* TODO: check let projection bvar indices *)
        (* let y = fst pr in let k' = snd pr in *)
        (t_trm_let_fst (t_trm_bvar 0)
          (t_trm_let_snd (t_trm_bvar 1)
            (* (v [β] k') *)
            (t_trm_app v (t_typ_bvar 0) (t_trm_bvar 0)))))))
| s_trm_app e1 e2 =>
  (* TODO: s2 -> s from type inference e1 *)
  let s := s_dummy_type in
  let s2 := s_dummy_type in
  let s_arr_plus := (cps_type_trans (s_typ_arrow s2 s)) in
  let v1 := (cps_term_trans G e1) in
  let v2 := (cps_term_trans G e2) in
  (t_trm_abs
    (* k : s+ -> α *)
    (t_typ_arrow (cps_type_trans s) (t_typ_bvar 0))
    (t_trm_app v1 (t_typ_bvar 0)
      (* λ [_] x1:(σ2→σ)+ . *)
      (t_trm_abs s_arr_plus
        (* v1 [σ] ... *)
        (t_trm_app v2 (t_typ_bvar 1)
          (* λ [_] x2:σ2+ . *)
          (t_trm_abs (cps_type_trans s2)
            (* x1 [σ] (x2, k) *)
            (t_trm_app (t_trm_bvar 1) (t_typ_bvar 2)
              (t_trm_pair (t_trm_bvar 0) (t_trm_bvar 2))))))))

| s_trm_if e e1 e2 =>
  (* TODO: s from type inference of e2 *)
  let s_plus := (cps_type_trans s_dummy_type) in
  let v := (cps_term_trans G e) in
  let v1 := (cps_term_trans G e1) in
  let v2 := (cps_term_trans G e2) in
  (* λ [α] k:(σ+ → α) . ...*)
  (t_trm_abs (t_typ_arrow s_plus (t_typ_bvar 0))
    (* v [σ] ... *)
    (t_trm_app v (t_typ_bvar 0)
      (* λ [_] x:bool . if x then (v1 [α] k) else (v2 [α] k) *)
      (t_trm_abs t_typ_bool
        (t_trm_if (t_trm_bvar 0)
          (t_trm_app v1 (t_typ_bvar 0) (t_trm_bvar 1))
          (t_trm_app v2 (t_typ_bvar 0) (t_trm_bvar 1))))))

| _ => trm_bad
end.
(* termination proof *)
  (* abs case *)
  intros. simpl. pick_fresh x. rewrite* s_trm_size_open_var. crush.
  (* if case *)
  crush. crush. crush.
  (* app case *)
  crush. crush.
Defined.

Inductive cps_trans : env_term -> trm -> typ -> trm -> Prop :=
  | cps_trans_var : forall G x s, wfenv s_type G -> binds x s G ->
    cps_trans G (s_trm_fvar x) s
      (t_trm_abs (t_typ_arrow (s+) (t_typ_bvar 1))
        (t_trm_app (t_trm_bvar 0) dummy_type (t_trm_fvar x)))
  | cps_trans_true : forall G, wfenv s_type G ->
    cps_trans G s_trm_true s_typ_bool
      (t_trm_abs (t_typ_arrow t_typ_bool (t_typ_bvar 1))
        (t_trm_app (t_trm_bvar 0) dummy_type t_trm_true))
  | cps_trans_false : forall G, wfenv s_type G ->
    cps_trans G s_trm_false s_typ_bool
      (t_trm_abs (t_typ_arrow t_typ_bool (t_typ_bvar 1))
        (t_trm_app (t_trm_bvar 0) dummy_type t_trm_false))
  | cps_trans_abs : forall L G e s1 s2 u,
      (forall x, x \notin L ->
        cps_trans (G & x ~ s1) (s_open_ee_var e x) s2 (open_ee_rec target 1 (t_trm_fvar x) u)) ->
      s_type s1 ->
      cps_trans G (s_trm_abs s1 e) (s_typ_arrow s1 s2)
        (t_trm_abs (*A*)
                   (*k*)(t_typ_arrow ((s_typ_arrow s1 s2)+) (t_typ_bvar 1))
          (t_trm_app (*k*)(t_trm_bvar 0) dummy_type
            (t_trm_abs (*B*)
                       (*p*) (t_typ_pair (s1+) (t_typ_arrow (s2+) (t_typ_bvar 1)))
              (t_trm_let_fst (t_trm_bvar 0) (* let x = fst p in *)
                (t_trm_let_snd (t_trm_bvar 1) (* let k' = snd p in *)
                  (t_trm_app u (*B*)(t_typ_bvar 0) (*k'*)(t_trm_bvar 0)))))))
  | cps_trans_if : forall G e1 e2 e3 s u1 u2 u3,
      cps_trans G e1 s_typ_bool u1 ->
      cps_trans G e2 s u2 -> cps_trans G e3 s u3 ->
      cps_trans G (s_trm_if e1 e2 e3) s
        (t_trm_abs (*A*) (*k*)(t_typ_arrow (s+) (t_typ_bvar 1))
          (t_trm_app u1 (t_typ_bvar 0)
            (t_trm_abs (*x*)t_typ_bool
              (t_trm_if (t_trm_bvar 0)
                (t_trm_app u2 (t_typ_bvar 1) (t_trm_bvar 1))
                (t_trm_app u3 (t_typ_bvar 1) (t_trm_bvar 1))))))
  | cps_trans_app : forall G e1 e2 s1 s2 u1 u2,
      cps_trans G e1 (s_typ_arrow s1 s2) u1 -> cps_trans G e2 s1 u2 ->
      cps_trans G (s_trm_app e1 e2) s2
        (t_trm_abs (*A*) (*k*)(t_typ_arrow (s2+) (t_typ_bvar 1))
          (t_trm_app u1 (t_typ_bvar 0)
            (t_trm_abs (*x1*)((s_typ_arrow s1 s2)+)
              (t_trm_app u2 (t_typ_bvar 1)
                (t_trm_abs (*x2*)(s1+)
                  (t_trm_app (t_trm_bvar 1) (t_typ_bvar 2)
                    (t_trm_pair (t_trm_bvar 0) (t_trm_bvar 2)))))))).

(* compiler only defined on well-typed source terms *)
Lemma cps_trans_implies_s_typing : forall G e s u,
  cps_trans G e s u -> s_typing G e s.
Proof. induction 1; eauto. Qed.

(* hints for following lemma *)
Hint Local Resolve
     cps_type_trans_preserves_wfenv
     cps_type_trans_preserves_wft
     cps_type_trans_preserves_well_formed_types
     (wfenv_binds s_type)
     cps_trans_implies_s_typing
     t_wft_weaken.

Ltac prove_app :=
  match goal with
    | [ |- t_typing (empty & ?X ~ star) _ (t_trm_app _ _ _) _] =>
      replace (t_typ_fvar X) with (open_tt (t_typ_fvar X) dummy_type); auto;
      apply* t_typing_app end.

Ltac simplify_t_wft_arrow :=
  let Y := fresh "Y" in
    apply_fresh t_wft_arrow as Y; simpl; repeat rewrite* open_tt_rec_t_type; try apply* t_wft_var.

Ltac prove_t_wft :=
  match goal with
    | [ |- t_wft _ (t_typ_arrow _ _)] => simplify_t_wft_arrow; prove_t_wft
    | [ |- t_wft _ (t_typ_pair _ _)] => apply* t_wft_pair; prove_t_wft
    | [ |- (t_wft _ _)] =>
      apply* t_wft_weaken; repeat apply* ok_push; auto using cps_type_trans_preserves_wft; prove_t_wft end.

Ltac prove_t_value_typing :=
  match goal with
    | [ |- t_value_typing _ _ (t_trm_fvar _) _] => apply* t_value_typing_var
    | [ |- t_value_typing _ _ t_trm_true _] => apply* t_value_typing_true
    | [ |- t_value_typing _ _ t_trm_false _] => apply* t_value_typing_false
    | [ |- t_value_typing _ _ (t_trm_abs _ _) _] =>
      let y := fresh "y" in apply_fresh* t_value_typing_abs as y; intros; simpl end;
  repeat rewrite* open_tt_rec_t_type;
  repeat apply wfenv_push; try apply (wfenv_implies (t_wft empty)); auto;
  try apply cps_type_trans_preserves_wfenv; try apply* s_typing_implies_wfenv;
  try prove_t_wft.

(* type-preserving compilation *)
Lemma cps_trans_implies_t_typing : forall G e s u,
  cps_trans G e s u -> t_value_typing empty (map cps_type_trans G) u (s%).
Proof.
  induction 1;
  apply_fresh* t_value_typing_abs as k; (* all cases start with lambda k. _ *)
  try solve [apply* cps_type_trans_preserves_wfenv; apply* s_typing_implies_wfenv];
  intros; simpl;
  rename x into k. (* I dunno why the "as k" above doesn't work but whatever *)

  (* variable case *)
  prove_app; prove_t_value_typing.

  (* true case *)
  prove_app; prove_t_value_typing.

  (* false case *)
  prove_app; prove_t_value_typing.

  (* abs case *)
  assert (s_type s2).
    apply* s_typing_implies_s_type. apply* cps_trans_implies_s_typing. apply* (H k).
  repeat rewrite* open_tt_rec_t_type. unfold inc_if_eq. simpl.
  prove_app; simpl. (* k (lambda ...) *)
    (* k *)
    prove_t_value_typing.

    (* (lambda ...) *)
    simpl. repeat rewrite* open_tt_rec_t_type. prove_t_value_typing.
    apply_fresh t_typing_let_fst as x; simpl. prove_t_value_typing.
    apply_fresh t_typing_let_snd as k'; simpl. prove_t_value_typing.
    replace (t_typ_fvar X0) with (open_tt (t_typ_bvar 0) (t_typ_fvar X0)); auto.
    unfold inc_if_eq. cases_if*.
    apply t_typing_app with (t1 := t_typ_arrow (s2+) (t_typ_bvar 1));
    auto; simpl; repeat rewrite* open_tt_rec_t_type.
    rewrite* open_ee_rec_t_term;
    rewrite* t_open_ee_rec_open_te_rec; rewrite* open_te_rec_t_term;
    rewrite* t_open_ee_rec_open_ee_rec; rewrite* open_ee_rec_t_term;
    rewrite* t_open_ee_rec_open_te_rec; rewrite* open_te_rec_t_term;
    rewrite* t_open_ee_rec_open_ee_rec; rewrite* open_ee_rec_t_term.
    apply t_value_typing_weaken.
    apply t_value_typing_weaken_generalized. apply t_value_typing_weaken_generalized.
    repeat apply* t_value_typing_weaken_delta.
    rewrite <- map_push.
    apply* H0.
    (* clean up after all those weakens *)
    repeat apply wfenv_push; auto. apply* (wfenv_implies (t_wft empty)).
    apply cps_type_trans_preserves_wfenv. apply* s_typing_implies_wfenv.
    prove_t_wft.

    repeat apply wfenv_push; auto. apply* (wfenv_implies (t_wft empty)).
    apply cps_type_trans_preserves_wfenv. apply* s_typing_implies_wfenv.
    prove_t_wft. prove_t_wft.

    repeat apply wfenv_push; auto. apply* (wfenv_implies (t_wft empty)).
    apply cps_type_trans_preserves_wfenv. apply* s_typing_implies_wfenv.
    prove_t_wft. prove_t_wft. prove_t_wft.

    (* ok on to k' finally *)
    prove_t_value_typing.

  (* if case *)
  assert (s_type s). apply* s_typing_implies_s_type.
  replace (t_typ_fvar X) with (open_tt (t_typ_bvar 0) (t_typ_fvar X)); auto.
  apply* t_typing_app; simpl.
    (* u1 *)
    rewrite* open_ee_rec_t_term. rewrite* open_te_rec_t_term. rewrite* open_tt_rec_t_type.
    apply* t_value_typing_weaken. apply* t_value_typing_weaken_delta. apply wfenv_push; auto.
      apply (wfenv_implies (t_wft empty)); auto;
        apply cps_type_trans_preserves_wfenv; apply* s_typing_implies_wfenv.
      prove_t_wft.

    (* if x then u2 else u3 *)
    unfold inc_if_eq. cases_if*.
    prove_t_value_typing. apply* t_typing_if; try prove_t_value_typing;
    replace (t_typ_fvar X) with (open_tt (t_typ_bvar 0) (t_typ_fvar X)); auto;
    apply* t_typing_app; simpl;
    try (rewrite* open_te_rec_t_term; rewrite* open_ee_rec_t_term;
         rewrite* open_te_rec_t_term; rewrite* open_ee_rec_t_term;
         repeat apply* t_value_typing_weaken; try solve [repeat apply* t_value_typing_weaken_delta];
         repeat apply wfenv_push; auto; try prove_t_wft; apply (wfenv_implies (t_wft empty)); auto;
         apply cps_type_trans_preserves_wfenv; apply* s_typing_implies_wfenv);
    simpl; prove_t_value_typing.

  (* app case *)
  assert (s_type s1). apply* s_typing_implies_s_type.
  assert (s_type s2). apply* s_typing_implies_s_type.
  replace (t_typ_fvar X) with (open_tt (t_typ_bvar 0) (t_typ_fvar X)); auto.
  apply* t_typing_app; simpl.
    (* u1 *)
    rewrite* open_ee_rec_t_term. rewrite* open_te_rec_t_term. rewrite* open_tt_rec_t_type.
    apply* t_value_typing_weaken. apply* t_value_typing_weaken_delta. apply wfenv_push; auto.
      apply (wfenv_implies (t_wft empty)); auto;
        apply cps_type_trans_preserves_wfenv; apply* s_typing_implies_wfenv.
      prove_t_wft.

    (* u2 *)
    unfold inc_if_eq. cases_if*.
    prove_t_value_typing.
    replace (t_typ_fvar X) with (open_tt (t_typ_bvar 0) (t_typ_fvar X)); auto.
    apply* t_typing_app; simpl.
    rewrite* open_te_rec_t_term; rewrite* open_ee_rec_t_term;
    rewrite* open_te_rec_t_term; rewrite* open_ee_rec_t_term.
    repeat apply* t_value_typing_weaken; try solve [repeat apply* t_value_typing_weaken_delta];
    repeat apply wfenv_push; auto; try prove_t_wft; apply (wfenv_implies (t_wft empty)); auto;
    apply cps_type_trans_preserves_wfenv; apply* s_typing_implies_wfenv.

    (* x1 x2 *)
    simpl. rewrite* open_tt_rec_t_type. prove_t_value_typing.
    replace (t_typ_fvar X) with (open_tt (t_typ_bvar 0) (t_typ_fvar X)); auto.
    apply* t_typing_app; simpl. prove_t_value_typing. simpl. apply* t_value_typing_pair; prove_t_value_typing.
Qed.


Require Import Notation.
Require Import GeneralTactics.
Require Import Axioms.Classical.
Require Import Axioms.Extensionality.

Require Import Setoid.

(* The inhabited type constructor is sometimes called "propositional truncation"
   because, under the proof-irrelevance interpretation, it truncates types down to
   a single witness.
 *)

Notation "| a |" := (inhabits a)
  (at level 50, format "| a |").
Notation "‖ A ‖" := (inhabited A)
  (at level 50, format "‖ A ‖").

Definition to_trunc (a b: Type): Prop := a -> ‖b‖.

(* If `H: ‖a‖`, and the goal is a Prop, then `uninhabit H` transforms the
   hypothesis into `H: a` by inversion.
 *)
Ltac uninhabit H :=
  let i := fresh in
  inversion H as [i];
  clear H;
  rename i into H.

(* `inhabit`/`in` applies the inhabits-valued theorem in the hypothesis, and then
   `uninhabits` the hypothesis.
 *)
Tactic Notation "inhabit" uconstr(c) "in" hyp(H) :=
  apply c in H;
  uninhabit H.

Tactic Notation "einhabit" uconstr(c) "in" hyp(H) :=
  eapply c in H;
  uninhabit H.

Tactic Notation "inhabitc" hyp(c) "in" hyp(H) :=
  inhabit c in H;
  clear c.

Tactic Notation "einhabitc" hyp(c) "in" hyp(H) :=
  einhabit c in H;
  clear c.

Theorem inhabited_codomain: forall a b,
  (a -> b) ->
  a -> ‖b‖.
Proof using.
  intros * H Ha.
  constructor.
  auto.
Qed.

Theorem extend_truncation_domain: forall a b,
  (a -> ‖b‖) ->
  ‖a‖ -> ‖b‖.
Proof using.
  intros a b H inhA.
  uninhabit inhA.
  auto.
Qed.

Theorem lift_trunc_arrow : forall A B,
  (A -> B) ->
  ‖A‖ -> ‖B‖.
Proof using.
  intros * f [a].
  exists (f a).
Qed.

Theorem domain_truncated_irrelevant : forall A B,
  (A -> ‖B‖) = (‖A‖ -> ‖B‖).
Proof using.
  intros *.
  extensionality; split.
  - intros f [a].
    now apply f.
  - intros f a.
    apply f.
    exists a.
Qed.

(* Transforms goal from `‖a‖` to `a` *)
Tactic Notation "inhabit" :=
  match goal with
  | |- ‖ _ ‖ => constructor
  end.

(* ` *)
Tactic Notation "inhabit" uconstr(c) :=
  solve [inhabit; apply c] +
  match type of c with
  | ‖ _ ‖ -> ‖ _ ‖ => apply c
  | _ -> ‖ _ ‖ => apply (extend_truncation_domain _ _ c)
  end +
  apply c.

Tactic Notation "einhabit" uconstr(c) :=
  solve [inhabit; eapply c] +
  match type of c with
  | ‖ _ ‖ -> ‖ _ ‖ => eapply c
  | _ -> ‖ _ ‖ => eapply (extend_truncation_domain _ _ c)
  end +
  eapply c.

Tactic Notation "inhabitc" hyp(c) :=
  inhabit c; clear c.

Tactic Notation "einhabitc" hyp(c) :=
  einhabit c; clear c.

Theorem truncation_idempotent: forall a,
  ‖a‖ = ‖‖a‖‖.
Proof using.
  intro a.
  extensionality H.
  - inhabit H.
  - now uninhabit H.
Qed.

Theorem to_trunc_refl : reflexive Type to_trunc.
Proof using.
  intros ? x.
  inhabit x.
Qed.

Theorem to_trunc_trans : transitive Type to_trunc.
Proof using.
  unfold transitive, to_trunc.
  intros X Y Z Hxy Hyz x.
  inhabit Hyz.
  inhabit Hxy.
  inhabit x.
Qed.

Add Parametric Relation : Type to_trunc
  reflexivity  proved by to_trunc_refl
  transitivity proved by to_trunc_trans
  as to_trunc_rel.

Theorem to_trunc_weaker: forall a b (P: Prop),
  (a -> ‖b‖) ->
  (b -> P) ->
  a -> P.
Proof using.
  intros * Hab ? a.
  inhabitc Hab in a.
  auto.
Qed.

Theorem truncated_eq_exists_true : forall A,
  ‖A‖ = exists _: A, True.
Proof using.
  intros *.
  extensionality H; now destruct H.
Qed.

Theorem truncated_eq_double_neg : forall A: Type,
  (* ‖A‖ = ((A -> False) -> False). *)
  ‖A‖ = notT (notT A).
Proof using.
  unfold notT.
  intros *.
  extensionality H.
  - intros ?.
    now uninhabit H.
  - contradict goal.
    applyc H.
    auto.
Qed.

(* Various truncation-equivalents *)

Lemma trunc_prod_eq_conj : forall P Q: Prop,
  ‖P × Q‖ = (P /\ Q).
Proof using.
  intros *.
  extensionality H.
  - uninhabit H.
    now destruct H.
  - now inhabit.
Qed.

Lemma trunc_sig_eq_exists : forall A (P: A -> Prop),
  ‖{x | P x}‖ = ∃ x, P x.
Proof using.
  intros *.
  extensionality H.
  - uninhabit H.
    follows destruct H.
  - follows destruct H.
Qed.

Lemma trunc_sigma_eq_exists : forall A (P: A -> Type),
  ‖Σ x, P x‖ = ∃ x, ‖P x‖.
Proof using.
  intros *.
  extensionality H.
  - uninhabit H.
    follows destruct H.
  - follows destruct H as [? [?]].
Qed.

Lemma trunc_sum_eq_disj : forall P Q: Prop,
  ‖{P} + {Q}‖ = (P \/ Q).
Proof using.
  intros *.
  extensionality H.
  - uninhabit H.
    now destruct H; [left|right].
  - now destruct H; inhabit; [left|right].
Qed.

Theorem sig_factor_trunc : forall (A: Type) (B: A -> Type),
  (Σ x, ‖B x‖) -> ‖Σ x, B x‖.
Proof using.
  intros * [x H].
  uninhabit H.
  exists ⟨x, H⟩.
Qed.