Require Import String Showable Connection DepEquivAnti Decidable  HoTT.
Require Import Vector List.
Local Open Scope string_scope.

Notation "{ x : A & P }" := (sigT (A:=A) (fun x => P)) : type_scope.
Notation "x .1" := (projT1 x) (at level 3).
Notation "x .2" := (projT2 x) (at level 3).
Notation " ( x ; p ) " := (existT _ x p).

Arguments length {_} l.

Set Universe Polymorphism.

Definition Hbool := hset bool.

(* =listz= *)
Inductive listZ : bool -> Type :=
| nilZ : listZ false
| cons_zero : forall (n:nat) b, n = 0 -> listZ b -> listZ true
| cons_pos : forall (n:nat) b, not (n = 0) -> listZ b -> listZ b.
(* =end= *)

Definition listZ_inv_zero n b e n' l b' e' l' :
  cons_zero n b e l = cons_zero n' b' e' l' ->
  {eb : b = b' & transport listZ eb l = l'}.
  intro H. inversion H. exists eq_refl. reflexivity.
Defined.

Definition path_sigma_inv {A : Type} (P : A -> Type) (u v : Specif.sigT P):
  u = v -> {p : Specif.projT1 u = Specif.projT1 v & p # (Specif.projT2 u) = Specif.projT2 v}.
Proof.
  destruct 1. exists eq_refl. exact eq_refl.
Defined.

Definition listZ_inv_pos n b e n' l e' l' :
  cons_pos n b e l = cons_pos n' b e' l' ->
  l = l'.
  intro H. inversion H.
  apply path_sigma_inv in H3. destruct H3. cbn in *.
  assert (x = eq_refl); try apply is_hprop. subst. reflexivity.
Defined.

Instance list_with_HSet (b: Hbool) : IsHSet (listZ b).
apply Hedberg. revert b.
assert (forall (b b' : Hbool) (e:b=b') (l: listZ b) (l' : listZ b'),
           (transport listZ e l = l') + not (transport listZ e l = l')).
intros b b' e l. revert b' e.
induction l ; intros b' e' l'; destruct l'; try solve [inversion e'];
  try assert (He : e' = eq_refl); try apply is_hprop; subst; cbn;
    try solve [right; intro H; inversion H];
    try exact (inl eq_refl).
destruct b, b0. specialize (IHl _ eq_refl l'); cbn in IHl.
destruct IHl. subst. exact (inl eq_refl).
right. intro H. apply n. apply listZ_inv_zero in H.
destruct H. assert (He : x = eq_refl); try apply is_hprop; subst; cbn.
reflexivity.
right. intro H; inversion H.
right. intro H; inversion H.
specialize (IHl _ eq_refl l'); cbn in IHl.
destruct IHl. subst. exact (inl eq_refl).
right. intro H. apply n. apply listZ_inv_zero in H.
destruct H. assert (He : x = eq_refl); try apply is_hprop; subst; cbn.
reflexivity.
specialize (IHl _ eq_refl l'); cbn in IHl. destruct IHl.
subst.
destruct (Decidable_eq_nat n n1). subst.
assert (n0 = n2). apply funext. intro x. destruct (n0 x). subst.
exact (inl eq_refl).
right. intro H. apply n3. inversion H. reflexivity.
right. intro H. apply n3. apply listZ_inv_pos in H. assumption.
intros; apply (X _ _ eq_refl).
Defined.

Definition HlistZ (b: Hbool) := hset (listZ b).

Fixpoint contains (A:HSet) `{DecidablePaths A} (a:A) (l:list A) : Hbool :=
  match l with
    nil => false
  | a'::l => match @dec (hprop (a = a')) _ with
               inl _ => true
             | inr _ => contains A a l
             end
  end.

Fixpoint contains_bound (bound a: Hnat) (l:list nat) : Hbool :=
  match bound with
    0 => false
  | S bound =>
    match l with
      nil => false
    | a'::l =>
      match @dec (hprop (a = a')) _ with
                 inl _ => true
               | inr _ => contains_bound bound a l
               end
    end
  end.

(* =listz_p= *)
Definition listZ_P (b:Hbool) (l:list Hnat) : HProp := hprop (contains Hnat 0 l = b).
(* =end= *)

(* =listz_p_bound= *)
Definition listZ_P_bound (b:Hbool) (k :Hnat) (l:list Hnat) : HProp :=
  if b then hprop (contains_bound k 0 l = true) else hprop False.
(* =end= *)

Instance listZ_P_bound_decidable b bound l : Decidable (listZ_P_bound b bound l).
Proof.
  destruct b; typeclasses eauto.
Defined.

(* =listz_checkable= *)
Instance listZ_P_checkable bound b l : Checkable (listZ_P b l) :=
  {| check := listZ_P_bound b bound l |}.
(* =end= *)
Proof.
  destruct b.
  - revert l. induction bound; cbn.
    + intros l H; inversion H.
    + destruct l.
      * intro H; inversion H.
      * destruct n; cbn. apply id. apply IHbound.
  - inversion 1.
Defined.

Definition list A  `{DecidablePaths A} := {| _typeS := list A |} : HSet.

Definition contains_true A  `{DecidablePaths A} a a' l:
  a = a' -> contains A a (a' :: l) = true.
Proof.
  cbn. destruct (@dec (hprop (a = a')) _). reflexivity.
  intro e. destruct (n e).
Defined.

Definition contains_false (n : nat) (b : bool)
  (n0 : not (n = 0))
  (l : listZ b)
  (X : {l : list Hnat & listZ_P b l}):
  listZ_P b (n :: X .1).
Proof.
    destruct n.
    destruct (n0 eq_refl).
    cbn. exact X.2.
Defined.

Definition listZ_to_list (b:Hbool) (l:listZ b) :
  {l : list Hnat & listZ_P b l}.
  revert l. revert b.
  unshelve refine (listZ_rect _ _ _ _); intros.
  - exists nil. reflexivity.
  - exists (n :: X.1).
    exact (contains_true Hnat 0 n X.1 e^).
  - exists (n :: X.1).
    exact (contains_false n b n0 l X).
Defined.

Definition list_to_listZ  (b:Hbool): {l : list Hnat & listZ_P b l} -> listZ b.
  intros [l H]. generalize dependent b. induction l; simpl; intros.
  - destruct b. inversion H.
    exact nilZ.
  - destruct (@dec (hprop (0 = a))) as [Heq | neg]; simpl in *.
    + exact (H # cons_zero a (contains Hnat 0 l) Heq^ (IHl _ eq_refl)).
    + exact (H # cons_pos a (contains Hnat 0 l) (fun H => neg (H^)) (IHl _ eq_refl)).
Defined.

Notation "{ x : A & P }" := (sigT_HSet A (fun x => P)) : type_scope.

Definition DepEquiv_C_list_with_list b bound :
  {l : list Hnat & listZ_P b l} ≈K (list Hnat) :=
  @Checkable_AntiConnectionK (list Hnat) _ (listZ_P_checkable bound b).

Notation "{ x : A & P }" := (sigT (fun x => P)) : type_scope.

Definition decompose_true b (l : listZ b) n e :
  listZ_to_list true (cons_zero n b e l)
  = (cons n (listZ_to_list b l).1 ; contains_true Hnat 0 n (listZ_to_list b l).1 e^).
Proof.
  reflexivity.
Defined.

Definition decompose_false b (l : listZ b) n e :
  listZ_to_list b (cons_pos n b e l)
  = (cons n (listZ_to_list b l).1 ; contains_false n b e l (listZ_to_list b l)).
Proof.
  reflexivity.
Defined.

(* =DepEquiv_listz= *)
Instance DepEquiv_listZ_list (bound : Hnat) : HlistZ ≈K□ list Hnat.
(* =end= *)
Proof.
  unshelve refine (IsDepAntiConnection _ HlistZ _ _ _ listZ_to_list list_to_listZ _ _ _ _).
  - induction 1.
    + exact (Some false).
    + destruct (dec (hprop (a = 0))) as [Heq | neg]; simpl in *.
      * exact (Some true).
      * exact IHlist.
  - clear bound. unfold compose.
    unshelve refine (listZ_rect _ _ _ _).
    + reflexivity.
    + intros. rewrite decompose_true, e. clear e.  cbn.
      destruct ((listZ_to_list b l)) as [l' Hl].
      destruct Hl. apply ap. exact H.
    + intros.
      assert (exists m, n = S m).
      destruct n. destruct (n0 eq_refl).
      exists n. reflexivity.
      destruct H0.
      assert (not (S x = 0)). intro X; inversion X.
      assert (cons_pos n b n0 l = cons_pos (S x) b X l).
      destruct H0. apply (ap (fun Y => cons_pos n b Y l)).
      apply is_hprop.
      rewrite H1. clear n0 H0 H1 n.
      rewrite decompose_false.
      cbn.
      destruct ((listZ_to_list b l)) as [l' Hl]. cbn in *.
      destruct Hl. cbn.
      assert (Heq : (λ H0 : S x = 0,
                            match H0^ in (_ = y) return (y = S x → empty) with
                            | eq_refl =>
       λ H1 : 0 = S x,
              False_rect empty
           (eq_ind 0 (λ e : nat, match e with
                                 | 0 => True
                                 | S _ => False
                                 end) I (S x) H1)
     end eq_refl) = X). apply is_hprop. rewrite Heq. apply ap.
      exact H.
  - intros b [l Hl]. revert b Hl. induction l; unfold compose; intros.
    + destruct b; simpl. cbn in Hl.
      inversion Hl.
      apply path_sigma_uncurried. cbn. exists eq_refl. apply is_hprop.
    + cbn.
      specialize (IHl _ eq_refl). cbn in IHl.
      cbn in Hl. destruct Hl.
      unshelve eapply path_sigma.
      destruct a; cbn; apply ap; exact IHl..1.
      apply is_hprop.
  -  unshelve refine (listZ_rect _ _ _ _); unfold compose; simpl.
     + reflexivity.
     + intros.  destruct (dec (hprop (n = 0))) as [Heq | neg]; simpl in *.
       reflexivity. destruct (neg e).
    + simpl; intros. destruct (dec (hprop (n = 0))) as [Heq | neg]; simpl in *.
      destruct b.
      * reflexivity.
      * destruct (n0 Heq).
      * assert (n0 = neg) by apply is_hprop. destruct H0. exact H.
Defined.


Require Import ListAux.
Require Import TreeAux.
Lemma trie1consistent_triet0 (it_0:tree nat) (i_0:nat) (it_1:tree nat) (it_2:tree nat) (u_0:nat) : (t_spec  it_0 i_0 it_1 it_2) -> (((not (u_0 = i_0))/\(not (tree_member  it_0 u_0))/\(tree_member  it_2 u_0)) -> (tree_member  it_1 u_0)).
Proof. solve_t. Qed.

Lemma trie1consistent_triet1 (it_0:tree nat) (i_0:nat) (it_1:tree nat) (it_2:tree nat) (u_0:nat) : (t_spec  it_0 i_0 it_1 it_2) -> (((not (tree_member  it_2 u_0))) -> (not (tree_member  it_0 u_0))).
Proof. solve_t. Qed.

Lemma trie1consistent_triet2 (it_0:tree nat) (i_0:nat) (it_1:tree nat) (it_2:tree nat) (u_0:nat) : (t_spec  it_0 i_0 it_1 it_2) -> (((not (tree_member  it_2 u_0))) -> (not (u_0 = i_0))).
Proof. solve_t. Qed.

Lemma trie1consistent_triet3 (it_0:tree nat) (i_0:nat) (it_1:tree nat) (it_2:tree nat) (u_0:nat) : (t_spec  it_0 i_0 it_1 it_2) -> (((not (tree_member  it_2 u_0))) -> (not (tree_member  it_1 u_0))).
Proof. solve_t. Qed.


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

Require Export complexes.
Set Implicit Arguments.
Unset Strict Implicit.
Parameter partie_reelle : C -> R.
Parameter partie_imaginaire : C -> R.

Axiom
  partie_reelle_def :
    forall (z : C) (a b : R), z = cons_cart a b -> a = partie_reelle z.

Axiom
  partie_imaginaire_def :
    forall (z : C) (a b : R), z = cons_cart a b -> b = partie_imaginaire z.

Axiom
  forme_algebrique_def :
    forall (z : C) (a b : R),
    a = partie_reelle z -> b = partie_imaginaire z -> z = cons_cart a b.

Lemma car_image_forme_algebrique :
 forall (z : C) (M : PO),
 M = image z ->
 partie_reelle z = abscisse M /\ partie_imaginaire z = ordonnee M.
intros.
elim existence_coordonnees with (O := O) (I := I) (J := J) (M := M);
 [ intros x H2; elim H2; intros y H3 | auto with geo ].
cut (z = cons_cart x y); intros.
rewrite <- (partie_reelle_def H0).
rewrite <- (partie_imaginaire_def H0).
split; eauto with geo.
eauto with geo.
Qed.

Lemma coordonnees_affixe :
 forall M : PO, cons_cart (abscisse M) (ordonnee M) = affixe M :>C.
intros.
elim existence_affixe_point with (M := M); intros z H;
 try clear existence_affixe_point; try exact H.
elim car_image_forme_algebrique with (z := z) (M := M);
 [ intros; try exact H1 | eauto with geo ].
rewrite <- H1; rewrite <- H0; rewrite <- H.
symmetry  in |- *; eauto with geo.
Qed.
#[export] Hint Resolve coordonnees_affixe: geo.

Lemma absvec_ordvec_affixe :
 forall (a b : R) (A B : PO),
 a = absvec (vec A B) ->
 b = ordvec (vec A B) -> cons_cart a b = affixe_vec (vec A B).
intros a b A B.
elim existence_representant_vecteur with (A := O) (B := A) (C := B);
 intros D H1; try exact H1.
rewrite <- H1; intros.
apply affixe_point_vecteur.
rewrite H0; rewrite H; rewrite (ordvec_ordonnee (O:=O) (I:=I) (J:=J) D);
 auto with geo.
rewrite (absvec_abscisse (O:=O) (I:=I) (J:=J) D); auto with geo.
Qed.
Parameter module : C -> R.
Parameter argument : C -> AV.

Axiom
  module_def :
    forall (z : C) (M : PO), M = image z -> module z = distance O M.

Axiom
  argument_def :
    forall (M : PO) (z : C),
    O <> M -> M = image z -> argument z = cons_AV (vec O I) (vec O M).
#[export] Hint Resolve module_def argument_def: geo.

Lemma module_def2 :
 forall (z : C) (M : PO), z = affixe M -> module z = distance O M.
intros; eauto with geo.
Qed.

Lemma argument_def2 :
 forall (M : PO) (z : C),
 O <> M -> z = affixe M -> argument z = cons_AV (vec O I) (vec O M).
intros; eauto with geo.
Qed.

Lemma existence_module : forall z : C, exists r : R, module z = r.
intros.
elim existence_image_complexe with (z := z); intros M H1;
 try clear existence_image_complexe; try exact H1.
exists (distance O M); eauto with geo.
Qed.

Definition zeroC := cons_cart 0 0.

Lemma image_zeroC : image zeroC = O.
elim existence_image_complexe with (z := zeroC); unfold zeroC in |- *;
 intros M H1; try exact H1.
cut (vec O M = add_PP (mult_PP 0 (vec O I)) (mult_PP 0 (vec O J))); intros;
 eauto with geo.
rewrite <- H1.
symmetry  in |- *.
apply vecteur_nul_conf.
rewrite H.
Ringvec.
Qed.
#[export] Hint Resolve image_zeroC: geo.

Lemma affixe_origine : zeroC = affixe O.
eauto with geo.
Qed.
#[export] Hint Resolve affixe_origine: geo.

Lemma module_zeroC : module zeroC = 0.
rewrite (module_def (z:=zeroC) (M:=O)); auto with geo.
Qed.

Lemma module_nul_zeroC : forall z : C, module z = 0 -> z = zeroC.
intros.
elim existence_image_complexe with (z := z); intros M H1;
 try clear existence_image_complexe; try exact H1.
cut (O = M); intros.
rewrite (affixe_image H1).
rewrite <- H0; auto with geo.
apply distance_refl1.
rewrite <- H; symmetry  in |- *; auto with geo.
Qed.
#[export] Hint Resolve module_zeroC module_nul_zeroC: geo.

Lemma module_non_zero : forall z : C, z <> zeroC -> module z <> 0.
red in |- *; intros.
apply H; auto with geo.
Qed.

Lemma nonzero_module : forall z : C, module z <> 0 -> z <> zeroC.
red in |- *; intros.
apply H; rewrite H0; auto with geo.
Qed.
#[export] Hint Resolve module_non_zero nonzero_module: geo.

Lemma image_nonzero_nonorigine :
 forall (M : PO) (z : C), z <> zeroC :>C -> M = image z -> O <> M.
intros.
red in |- *; intros; apply H.
replace z with (affixe M).
rewrite <- H1; auto with geo.
symmetry  in |- *; auto with geo.
Qed.
#[export] Hint Resolve image_nonzero_nonorigine: geo.

Lemma nonorigine_image_nonzero :
 forall (M : PO) (z : C), O <> M -> M = image z -> z <> zeroC :>C.
intros.
red in |- *; intros; apply H.
rewrite H0; rewrite H1.
symmetry  in |- *; auto with geo.
Qed.
#[export] Hint Resolve nonorigine_image_nonzero: geo.

Lemma existence_argument :
 forall z : C, z <> zeroC -> exists a : R, argument z = image_angle a.
intros.
elim existence_image_complexe with (z := z); intros M H1;
 try clear existence_image_complexe; try exact H1.
cut (O <> M); intros; eauto with geo.
mesure O I O M.
exists x.
rewrite H2; eauto with geo.
Qed.

Lemma existence_forme_polaire :
 forall z : C,
 z <> zeroC ->
 exists r : R, (exists a : R, module z = r /\ argument z = image_angle a).
intros.
elim existence_module with (z := z); intros r H0; try clear existence_module;
 try exact H0.
elim existence_argument with (z := z);
 [ intros a H1; try clear existence_argument; try exact H1 | auto ].
exists r; exists a; auto.
Qed.
Parameter cons_pol : R -> R -> C.

Axiom
  forme_polaire_def :
    forall (z : C) (r a : R),
    z <> zeroC ->
    module z = r -> argument z = image_angle a -> z = cons_pol r a.

Axiom complexe_polaire_module : forall r a : R, module (cons_pol r a) = r.

Axiom
  complexe_polaire_argument :
    forall r a : R, r <> 0 -> argument (cons_pol r a) = image_angle a.

Lemma polaire_non_nul : forall r a : R, r <> 0 -> cons_pol r a <> zeroC.
intros.
apply nonzero_module.
rewrite complexe_polaire_module; auto.
Qed.

Lemma complexe_pol_module :
 forall (z : C) (r a : R), z <> zeroC -> z = cons_pol r a -> module z = r.
intros.
rewrite H0; rewrite complexe_polaire_module; auto.
Qed.

Lemma complexe_pol_argument :
 forall (z : C) (r a : R),
 z <> zeroC -> z = cons_pol r a -> argument z = image_angle a.
intros.
rewrite H0; rewrite complexe_polaire_argument; auto.
rewrite <- (complexe_pol_module (z:=z) (r:=r) (a:=a)); auto with geo.
Qed.
#[export] Hint Resolve forme_polaire_def complexe_pol_module complexe_pol_argument
  polaire_non_nul complexe_polaire_module complexe_polaire_module: geo.

Lemma pol_complexe_module :
 forall (z : C) (r a : R) (M : PO),
 z <> zeroC -> z = cons_pol r a -> M = image z -> distance O M = r.
intros.
rewrite <- (module_def H1); eauto with geo.
Qed.

Lemma pol_complexe_argument :
 forall (z : C) (r a : R) (M : PO),
 z <> zeroC ->
 z = cons_pol r a ->
 M = image z -> cons_AV (vec O I) (vec O M) = image_angle a.
intros.
rewrite <- (argument_def (M:=M) (z:=z)); eauto with geo.
Qed.
#[export] Hint Resolve pol_complexe_argument pol_complexe_module: geo.

Lemma image_forme_polaire :
 forall (z : C) (M : PO),
 O <> M ->
 M = image z ->
 module z = distance O M /\ argument z = cons_AV (vec O I) (vec O M).
intros.
split; eauto with geo.
Qed.

Lemma unicite_forme_polaire_nonzero :
 forall (z : C) (r a r' a' : R),
 z <> zeroC ->
 z = cons_pol r a ->
 z = cons_pol r' a' -> r = r' /\ image_angle a = image_angle a'.
intros.
split.
rewrite <- (complexe_pol_module (z:=z) (r:=r) (a:=a)); eauto with geo.
rewrite <- (complexe_pol_argument (z:=z) (r:=r) (a:=a)); eauto with geo.
Qed.
#[export] Hint Resolve unicite_forme_polaire_nonzero image_forme_polaire: geo.

Lemma passage_polaire_algebrique :
 forall (z : C) (r a x y : R),
 z <> zeroC ->
 z = cons_cart x y -> z = cons_pol r a -> x = r * cos a /\ y = r * sin a.
intros.
elim existence_image_complexe with (z := z); intros M H2;
 try clear existence_image_complexe; try exact H2.
elim
 coordonnees_polaires_cartesiennes
  with
    (x := x)
    (y := y)
    (a := a)
    (r := r)
    (O := O)
    (I := I)
    (J := J)
    (M := M);
 [ intros; eauto with geo
 | eauto with geo
 | eauto with geo
 | eauto with geo
 | eauto with geo
 | eauto with geo ].
symmetry  in |- *; eauto with geo.
symmetry  in |- *; eauto with geo.
Qed.

Lemma passage_algebrique_module :
 forall (z : C) (x y : R),
 z = cons_cart x y -> module z = sqrt (Rsqr x + Rsqr y).
intros.
elim existence_image_complexe with (z := z); intros M H2;
 try clear existence_image_complexe; try exact H2.
replace (module z) with (distance O M); auto.
rewrite (distance_coordonnees (O:=O) (I:=I) (J:=J) (M:=M) (x:=x) (y:=y));
 eauto with geo.
symmetry  in |- *; eauto with geo.
Qed.

Lemma passage_algebrique_argument :
 forall (z : C) (r x y a : R),
 z <> zeroC ->
 z = cons_cart x y -> z = cons_pol r a -> cos a = / r * x /\ sin a = / r * y.
intros.
elim
 passage_polaire_algebrique with (z := z) (r := r) (a := a) (x := x) (y := y);
 [ intros | eauto with geo | eauto with geo | eauto with geo ].
cut (r <> 0); intros.
split; [ try assumption | idtac ].
rewrite H2.
field; auto.
rewrite H3.
field; auto.
replace r with (module z); eauto with geo.
Qed.

Lemma egalite_forme_polaire :
 forall z z' : C,
 z <> zeroC ->
 z' <> zeroC -> module z = module z' -> argument z = argument z' -> z = z'.
intros.
elim existence_forme_polaire with (z := z);
 [ intros r H3; elim H3; intros a H4; elim H4; intros H5 H6;
    try clear H4 H3 existence_forme_polaire; try exact H6
 | auto ].
elim existence_forme_polaire with (z := z');
 [ intros r0 H7; elim H7; intros a0 H8; elim H8; intros H9 H10;
    try clear H8 H7 existence_forme_polaire; try exact H10
 | auto ].
rewrite (forme_polaire_def (z:=z) (r:=r) (a:=a)); auto.
rewrite (forme_polaire_def (z:=z') (r:=r) (a:=a)); auto.
rewrite <- H5; auto.
rewrite <- H6; auto.
Qed.
#[export] Hint Resolve passage_algebrique_module passage_algebrique_argument
  egalite_forme_polaire: geo.

Lemma algebrique_zeroC :
 forall a b : R, cons_cart a b = zeroC :>C -> a = 0 /\ b = 0.
intros.
apply unicite_parties_relles_imaginaires with zeroC; auto.
Qed.

Lemma polaire_calcul_algebrique :
 forall (z : C) (r a : R),
 z <> zeroC :>C ->
 z = cons_pol r a :>C -> z = cons_cart (r * cos a) (r * sin a) :>C.
intros.
elim existence_parties_relles_imaginaires with (z := z); intros a0 H1;
 elim H1; intros b H2; try clear H1 existence_parties_relles_imaginaires;
 try exact H2.
elim
 passage_polaire_algebrique
  with (z := z) (r := r) (a := a) (x := a0) (y := b);
 [ intros; try exact H4 | auto | auto | auto ].
rewrite H2; rewrite H3; rewrite H4; auto.
Qed.
#[export] Hint Resolve polaire_calcul_algebrique: geo.

Definition Rinj (x : R) := cons_cart x 0.

Definition oneC := cons_cart 1 0.
#[export] Hint Unfold oneC zeroC Rinj: geo.

Lemma Rinj_zero : Rinj 0 = zeroC.
unfold Rinj, zeroC in |- *; auto.
Qed.

Lemma Rinj_un : Rinj 1 = oneC.
unfold Rinj, oneC in |- *; auto.
Qed.

Lemma module_oneC : module oneC = 1.
intros.
rewrite (passage_algebrique_module (z:=oneC) (x:=1) (y:=0)).
replace (Rsqr 1 + Rsqr 0) with 1 by (unfold Rsqr; ring).
exact sqrt_1.
unfold oneC in |- *; auto.
Qed.

Lemma oneC_nonzero : oneC <> zeroC.
apply nonzero_module.
rewrite module_oneC; auto with real.
Qed.
#[export] Hint Resolve module_oneC oneC_nonzero: geo.

Lemma argument_oneC : argument oneC = image_angle 0.
elim existence_forme_polaire with (z := oneC);
 [ intros r H; elim H; intros a H0; elim H0; intros H1 H2;
    try clear H0 H existence_forme_polaire; try exact H2
 | auto with geo ].
rewrite module_oneC in H1.
rewrite H2.
elim
 passage_algebrique_argument
  with (z := oneC) (r := 1) (x := 1) (y := 0) (a := a);
 [ intros | auto with geo | auto with geo | auto with geo ].
apply egalite_angle_trigo.
rewrite sin_zero; rewrite H4; ring.
rewrite H3; rewrite cos_zero; field.
Qed.
#[export] Hint Resolve argument_oneC: geo.

Definition i := cons_cart 0 1.
#[export] Hint Unfold i: geo.

Lemma module_i : module i = 1.
intros.
rewrite (passage_algebrique_module (z:=i) (x:=0) (y:=1)).
replace (Rsqr 0 + Rsqr 1) with 1 by (unfold Rsqr; ring).
exact sqrt_1.
unfold i in |- *; auto.
Qed.

Lemma i_nonzero : i <> zeroC.
apply nonzero_module.
rewrite module_i; auto with real.
Qed.
#[export] Hint Resolve module_i i_nonzero: geo.

Lemma argument_i : argument i = image_angle pisurdeux.
elim existence_forme_polaire with (z := i);
 [ intros r H; elim H; intros a H0; elim H0; intros H1 H2;
    try clear H0 H existence_forme_polaire; try exact H2
 | auto with geo ].
elim
 passage_algebrique_argument
  with (z := i) (r := 1) (x := 0) (y := 1) (a := a);
 [ intros | auto with geo | auto with geo | auto with geo ].
rewrite module_i in H1.
rewrite H2.
elim
 passage_algebrique_argument
  with (z := i) (r := 1) (x := 0) (y := 1) (a := a);
 [ intros | auto with geo | auto with geo | auto with geo ].
apply egalite_angle_trigo.
rewrite sin_pisurdeux; rewrite H4; field.
rewrite H3; rewrite cos_pisurdeux; ring.
Qed.
#[export] Hint Resolve argument_i: geo.

Lemma forme_polaire_oneC : oneC = cons_pol 1 0.
apply forme_polaire_def; auto with geo.
Qed.

Lemma forme_polaire_i : i = cons_pol 1 pisurdeux.
apply forme_polaire_def; auto with geo.
Qed.
#[export] Hint Resolve forme_polaire_oneC forme_polaire_i: geo.

Lemma egalite_cart_pol :
 forall x y r a : R,
 r <> 0 ->
 module (cons_cart x y) = r ->
 argument (cons_cart x y) = image_angle a :>AV ->
 cons_cart x y = cons_pol r a :>C.
intros.
rewrite <- (forme_polaire_def (z:=cons_cart x y) (r:=r) (a:=a));
 auto with geo.
apply nonzero_module.
rewrite H0; auto.
Qed.

Lemma module_opp_un : module (Rinj (-1)) = 1.
unfold Rinj in |- *.
rewrite (passage_algebrique_module (z:=cons_cart (-1) 0) (x:=-1) (y:=0));
 auto with geo.
replace (Rsqr (-1) + Rsqr 0) with 1 by (unfold Rsqr; ring).
exact sqrt_1.
Qed.

Lemma opp_un_nonzero : Rinj (-1) <> zeroC :>C.
apply nonzero_module.
rewrite module_opp_un; auto with real.
Qed.
#[export] Hint Resolve opp_un_nonzero module_opp_un: geo.

Lemma argument_opp_un : argument (Rinj (-1)) = image_angle pi.
elim existence_forme_polaire with (z := Rinj (-1));
 [ intros r H1; elim H1; intros a H2; elim H2; intros H3 H4; try clear H2 H1;
    try exact H4
 | auto with geo ].
rewrite module_opp_un in H3.
elim
 passage_algebrique_argument
  with (z := Rinj (-1)) (r := 1) (x := -1) (y := 0) (a := a);
 [ intros | auto with geo | auto with geo | auto with geo ].
rewrite H4.
apply egalite_angle_trigo.
rewrite sin_pi; rewrite H0; ring.
rewrite H; rewrite cos_pi; field.
Qed.
#[export] Hint Resolve argument_opp_un: geo.

Lemma forme_polaire_opp_un : Rinj (-1) = cons_pol 1 pi.
apply forme_polaire_def; auto with geo.
Qed.

Lemma module_reel : forall x : R, module (Rinj x) = Rabs x.
unfold Rinj in |- *; intros.
rewrite (passage_algebrique_module (z:=cons_cart x 0) (x:=x) (y:=0));
 auto with geo.
replace (Rsqr x + Rsqr 0) with (Rsqr x) by (unfold Rsqr; ring).
rewrite sqrt_Rsqr_abs; auto.
Qed.

Lemma module_reel_pos : forall x : R, 0 <= x -> module (Rinj x) = x.
unfold Rinj in |- *; intros.
rewrite (passage_algebrique_module (z:=cons_cart x 0) (x:=x) (y:=0));
 auto with geo.
replace (Rsqr x + Rsqr 0) with (Rsqr x) by (unfold Rsqr in |- *; ring).
rewrite sqrt_Rsqr; auto.
Qed.

Lemma reel_non_nul : forall x : R, x <> 0 -> Rinj x <> zeroC.
intros.
apply nonzero_module.
rewrite module_reel.
apply Rabs_no_R0; auto.
Qed.
#[export] Hint Resolve reel_non_nul module_reel_pos module_reel: geo.

Lemma argument_reel_pos :
 forall x : R, 0 < x -> argument (Rinj x) = image_angle 0.
intros.
cut (x <> 0); intros.
elim existence_forme_polaire with (z := Rinj x);
 [ intros r H1; elim H1; intros a H2; elim H2; intros H3 H4; try clear H2 H1;
    try exact H4
 | auto with geo ].
cut (x = r); intros.
elim
 passage_algebrique_argument
  with (z := Rinj x) (r := r) (x := x) (y := 0) (a := a);
 [ intros | auto with geo | auto with geo | auto with geo ].
rewrite H4.
apply egalite_angle_trigo.
rewrite sin_zero; rewrite H5; ring.
rewrite H2; rewrite <- H1; rewrite cos_zero; field; trivial.
rewrite module_reel_pos in H3; auto.
lra.
auto with real.
Qed.
#[export] Hint Resolve argument_reel_pos: geo.

Lemma forme_pol_reel_pos : forall x : R, 0 < x -> Rinj x = cons_pol x 0 :>C.
intros.
apply forme_polaire_def; auto with geo.
apply reel_non_nul; auto with real.
apply module_reel_pos; auto with real.
Qed.

Lemma module_reel_neg : forall x : R, 0 > x -> module (Rinj x) = - x.
intros.
rewrite module_reel; auto.
apply Rabs_left1; auto with real.
Qed.
#[export] Hint Resolve module_reel_neg: geo.

Lemma argument_reel_neg :
 forall x : R, 0 > x -> argument (Rinj x) = image_angle pi.
intros.
cut (x <> 0); intros.
elim existence_forme_polaire with (z := Rinj x);
 [ intros r H1; elim H1; intros a H2; elim H2; intros H3 H4; try clear H2 H1;
    try exact H4
 | auto with geo ].
elim
 passage_algebrique_argument
  with (z := Rinj x) (r := r) (x := x) (y := 0) (a := a);
 [ intros | auto with geo | auto with geo | auto with geo ].
rewrite H4.
apply egalite_angle_trigo.
rewrite sin_pi; rewrite H2; ring.
cut (r = - x); intros.
rewrite H1; rewrite H5; rewrite cos_pi;  field; trivial.
rewrite <- H3.
rewrite module_reel_neg in |- *; [  ring | auto with geo ].
auto with real.
Qed.
#[export] Hint Resolve argument_reel_neg: geo.

Lemma forme_pol_reel_neg :
 forall x : R, 0 > x -> Rinj x = cons_pol (- x) pi :>C.
intros.
apply forme_polaire_def; auto with geo.
apply reel_non_nul; auto with real.
Qed.

Lemma module_pos : forall z : C, module z >= 0.
intros.
elim existence_image_complexe with (z := z); intros M H;
 try clear existence_image_complexe; try exact H.
rewrite (module_def H); auto with geo.
Qed.
#[export] Hint Resolve module_pos: geo.

Lemma module_stric_pos : forall z : C, z <> zeroC :>C -> module z > 0.
intros.
cut (module z >= 0); intros; auto with geo.
elim H0; intros; auto.
absurd (module z = 0); auto with geo.
Qed.
#[export] Hint Resolve module_stric_pos: geo.

Lemma abs_module : forall z : C, module z = Rabs (module z).
intros.
cut (module z >= 0); intros; auto with geo.
rewrite Rabs_right; auto.
Qed.
#[export] Hint Resolve abs_module: geo.


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

Require Import Termes.
Require Import Conv.
Require Import Types.
Require Export ListType.

  (* Kind skeletons *)

  Inductive skel : Type :=
    | PROP : skel
    | PROD : skel -> skel -> skel.

  Lemma EQ_skel : forall a b : skel, {a = b} + {a <> b}.
induction a as [| s H s0 H0]; simple destruct b; intros.
left; auto with core.

right; red in |- *; intros neq; discriminate neq.

right; red in |- *; intros neq; discriminate neq.

elim H with s1; [ intro Heq1 | intro Hneq1 ].
elim Heq1.
elim H0 with s2; [ intro Heq2 | intro Hneq2 ].
elim Heq2.
left; auto with core.

right; red in |- *; intros; apply Hneq2.
injection H1; trivial.

right; red in |- *; intros; apply Hneq1.
injection H1; trivial.
Qed.

  (* Classes *)

  Inductive class : Type :=
    | Trm : class
    | Typ : skel -> class
    | Knd : skel -> class.

  Definition cls := TList class.

  Definition cv_skel (c : class) : skel :=
    match c with
    | Knd s => s
    | _ => PROP
    end.

  Definition typ_skel (c : class) : skel :=
    match c with
    | Typ s => s
    | _ => PROP
    end.

  Lemma commut_case :
   forall (A B : Type) (f : A -> B) (c : class) (bt : A) (bT bK : skel -> A),
   f match c with
     | Trm => bt
     | Typ s => bT s
     | Knd s => bK s
     end =
   match c with
   | Trm => f bt
   | Typ _ => f (bT (typ_skel c))
   | Knd _ => f (bK (cv_skel c))
   end.
simple destruct c; auto with coc core arith datatypes.
Qed.

  Fixpoint cl_term (t : term) : cls -> class :=
    fun i : cls =>
    match t with
    | Srt _ => Knd PROP
    | Ref n => match Tnth_def _ Trm i n with
               | Knd s => Typ s
               | _ => Trm
               end
    | Abs A B =>
        let j := TCs _ (cl_term A i) i in
        match cl_term B j, cl_term A i with
        | Typ s2, Knd s1 => Typ (PROD s1 s2)
        | Typ s, _ => Typ s
        | Knd _, _ => Knd PROP
        | Trm, _ => Trm
        end
    | App u v =>
        match cl_term u i, cl_term v i with
        | Typ (PROD s1 s2), Typ s => Typ s2
        | Typ s, _ => Typ s
        | Knd _, _ => Knd PROP
        | Trm, _ => Trm
        end
    | Prod T U =>
        let j := TCs _ (cl_term T i) i in
        match cl_term U j, cl_term T i with
        | Knd s2, Knd s1 => Knd (PROD s1 s2)
        | Knd s, _ => Knd s
        | Typ s, _ => Typ s
        | c1, _ => c1
        end
    end.

  Fixpoint class_env (e : env) : cls :=
    match e with
    | nil => TNl _
    | t :: f => TCs _ (cl_term t (class_env f)) (class_env f)
    end.

  Lemma nth_class_env :
   forall (t : term) (e f : env) (n : nat),
   item _ t e n ->
   trunc _ (S n) e f ->
   cl_term t (class_env f) = Tnth_def _ Trm (class_env e) n.
simple induction 1; simpl in |- *; intros.
inversion_clear H0.
inversion_clear H1; auto with coc core arith datatypes.

apply H1.
inversion_clear H2; auto with coc core arith datatypes.
Qed.

  Lemma cl_term_lift :
   forall (x : class) (t : term) (k : nat) (f g : cls),
   TIns _ x k f g -> cl_term t f = cl_term (lift_rec 1 t k) g.
simple induction t; intros.
simpl in |- *; auto with coc core arith datatypes.

simpl in |- *.
elim (le_gt_dec k n); simpl in |- *; intros.
elim Tins_le with class k f g Trm x n; auto with coc core arith datatypes.

elim Tins_gt with class k f g Trm x n; auto with coc core arith datatypes.

simpl in |- *.
elim H with k f g; auto with coc core arith datatypes.
elim H0 with (S k) (TCs class (cl_term t0 f) f) (TCs class (cl_term t0 f) g);
 auto with coc core arith datatypes.

simpl in |- *; auto with coc core arith datatypes.
elim H with k f g; auto with coc core arith datatypes.
elim H0 with k f g; auto with coc core arith datatypes.

simpl in |- *.
elim H with k f g; auto with coc core arith datatypes.
elim H0 with (S k) (TCs class (cl_term t0 f) f) (TCs class (cl_term t0 f) g);
 auto with coc core arith datatypes.
Qed.

  Lemma class_env_trunc :
   forall (k : nat) (e f : env),
   trunc _ k e f -> TTrunc _ k (class_env e) (class_env f).
simple induction 1; simpl in |- *; auto with coc core arith datatypes.
Qed.

  Hint Resolve class_env_trunc: coc.

  Lemma cl_trunc :
   forall (n : nat) (e f : cls),
   TTrunc _ n e f -> forall t : term, cl_term (lift n t) e = cl_term t f.
simple induction 1; intros.
rewrite lift0; auto with coc core arith datatypes.

elim H1.
rewrite simpl_lift.
unfold lift at 1 in |- *.
simpl in |- *.
elim cl_term_lift with x (lift k t) 0 e0 (TCs _ x e0);
 auto with coc core arith datatypes.
Qed.

  (* Loose stability results *)

  Inductive loose_eqc : class -> class -> Prop :=
    | leqc_trm : loose_eqc Trm Trm
    | leqc_typ : forall s1 s2 : skel, loose_eqc (Typ s1) (Typ s2)
    | leqc_ord : forall s : skel, loose_eqc (Knd s) (Knd s).

  Hint Resolve leqc_trm leqc_typ leqc_ord: coc.

  Lemma refl_loose_eqc : forall c : class, loose_eqc c c.
simple induction c; auto with coc core arith datatypes.
Qed.

  Hint Resolve refl_loose_eqc: coc.

  Lemma refl_loose_eqc_cls : forall c : cls, Tfor_all2 _ _ loose_eqc c c.
simple induction c; auto with coc core arith datatypes.
Qed.

  Hint Resolve refl_loose_eqc_cls: coc.

  Lemma loose_eqc_trans :
   forall c1 c2 : class,
   loose_eqc c1 c2 -> forall c3 : class, loose_eqc c2 c3 -> loose_eqc c1 c3.
simple induction 1; intros; inversion_clear H0;
 auto with coc core arith datatypes.
Qed.

  Inductive adj_cls : class -> class -> Prop :=
    | adj_t : forall s : skel, adj_cls Trm (Typ s)
    | adj_T : forall s1 s2 : skel, adj_cls (Typ s1) (Knd s2).

  Hint Resolve adj_t adj_T: coc.

  Lemma loose_eqc_stable :
   forall (t : term) (cl1 cl2 : cls),
   Tfor_all2 _ _ loose_eqc cl1 cl2 ->
   loose_eqc (cl_term t cl1) (cl_term t cl2).
simple induction t; simpl in |- *; intros; auto with coc core arith datatypes.
generalize n.
elim H; simpl in |- *; intros; auto with coc core arith datatypes.
case n0; auto with coc core arith datatypes.
inversion_clear H0; auto with coc core arith datatypes.

elim
 H0 with (TCs class (cl_term t0 cl1) cl1) (TCs class (cl_term t0 cl2) cl2);
 auto with coc core arith datatypes.
elim H with cl1 cl2; auto with coc core arith datatypes.

elim H with cl1 cl2; auto with coc core arith datatypes; intros.
elim s1; elim s2; elim H0 with cl1 cl2; auto with coc core arith datatypes.

elim
 H0 with (TCs class (cl_term t0 cl1) cl1) (TCs class (cl_term t0 cl2) cl2);
 auto with coc core arith datatypes.
elim H with cl1 cl2; auto with coc core arith datatypes.
Qed.

  Hint Resolve loose_eqc_stable: coc.

  Lemma cl_term_subst :
   forall (a : class) (G : cls) (x : term),
   adj_cls (cl_term x G) a ->
   forall (t : term) (k : nat) (E F : cls),
   TIns _ a k E F ->
   TTrunc _ k E G -> loose_eqc (cl_term t F) (cl_term (subst_rec x t k) E).
simple induction t; simpl in |- *; intros; auto with coc core arith datatypes.
elim (lt_eq_lt_dec k n); simpl in |- *; [ intro Hlt_eq | intro lt ].
elim Hlt_eq; clear Hlt_eq.
case n; simpl in |- *; [ intro Hlt | intros n0 Heq ].
inversion_clear Hlt.

elim Tins_le with class k E F Trm a n0; auto with coc core arith datatypes.

simple induction 1.
rewrite (Tins_eq class k E F Trm a); auto with coc core arith datatypes.
apply loose_eqc_trans with (cl_term x G).
inversion_clear H; auto with coc core arith datatypes.

elim cl_trunc with k E G x; auto with coc core arith datatypes.

elim Tins_gt with class k E F Trm a n; auto with coc core arith datatypes.

cut (loose_eqc (cl_term t0 F) (cl_term (subst_rec x t0 k) E)); intros;
 auto with coc core arith datatypes.
cut
 (loose_eqc (cl_term t1 (TCs class (cl_term t0 F) F))
    (cl_term (subst_rec x t1 (S k))
       (TCs class (cl_term (subst_rec x t0 k) E) E)));
 intros.
elim H5; auto with coc core arith datatypes; intros.
elim H4; auto with coc core arith datatypes.

apply
 loose_eqc_trans with (cl_term t1 (TCs _ (cl_term (subst_rec x t0 k) E) F));
 auto with coc core arith datatypes.

elim H0 with k E F; auto with coc core arith datatypes; intros.
elim s1; elim s2; elim H1 with k E F; auto with coc core arith datatypes.

cut (loose_eqc (cl_term t0 F) (cl_term (subst_rec x t0 k) E)); intros;
 auto with coc core arith datatypes.
cut
 (loose_eqc (cl_term t1 (TCs class (cl_term t0 F) F))
    (cl_term (subst_rec x t1 (S k))
       (TCs class (cl_term (subst_rec x t0 k) E) E)));
 intros.
elim H5; auto with coc core arith datatypes; intros.
elim H4; auto with coc core arith datatypes.

apply
 loose_eqc_trans with (cl_term t1 (TCs _ (cl_term (subst_rec x t0 k) E) F));
 auto with coc core arith datatypes.
Qed.

  Lemma class_knd :
   forall (e : env) (t T : term),
   typ e t T ->
   T = Srt kind ->
   cl_term t (class_env e) = Knd (cv_skel (cl_term t (class_env e))).
simple induction 1; intros.
simpl in |- *; auto with coc core arith datatypes.

simpl in |- *; auto with coc core arith datatypes.

elim H1; intros.
elim item_trunc with term v e0 x; auto with coc core arith datatypes; intros.
elim wf_sort with v e0 x0 x; auto with coc core arith datatypes; intros.
elim inv_typ_kind with e0 (Srt x1).
elim H2.
rewrite H3.
replace (Srt x1) with (lift (S v) (Srt x1));
 auto with coc core arith datatypes.
apply thinning_n with x0; auto with coc core arith datatypes.

discriminate H6.

elim type_case with e0 u (Prod V Ur); auto with coc core arith datatypes;
 intros.
inversion_clear H5.
apply inv_typ_prod with e0 V Ur (Srt x); auto with coc core arith datatypes.
intros.
elim inv_typ_kind with e0 (Srt s2); auto with coc core arith datatypes.
elim H4.
replace (Srt s2) with (subst v (Srt s2)); auto with coc core arith datatypes.
apply substitution with V; auto with coc core arith datatypes.

discriminate H5.

simpl in H3.
simpl in |- *.
rewrite H3; auto with coc core arith datatypes.
elim (cl_term T0 (class_env e0)); auto with coc core arith datatypes.

elim inv_typ_kind with e0 (Srt s); auto with coc core arith datatypes.
elim H5; auto with coc core arith datatypes.
Qed.

  Lemma class_typ :
   forall (e : env) (t T : term),
   typ e t T ->
   typ e T (Srt kind) ->
   cl_term t (class_env e) = Typ (typ_skel (cl_term t (class_env e))).
simple induction 1; intros.
elim inv_typ_kind with e0 (Srt kind); auto with coc core arith datatypes.

elim inv_typ_kind with e0 (Srt kind); auto with coc core arith datatypes.

elim H1; intros.
simpl in |- *.
elim item_trunc with term v e0 x; auto with coc core arith datatypes; intros.
elim nth_class_env with x e0 x0 v; auto with coc core arith datatypes.
elim cl_trunc with (S v) (class_env e0) (class_env x0) x;
 auto with coc core arith datatypes.
elim H3.
rewrite (class_knd e0 t0 (Srt kind)); auto with coc core arith datatypes.

simpl in |- *.
simpl in H5.
rewrite H5.
elim (cl_term T0 (class_env e0)); intros; auto with coc core arith datatypes.

apply inv_typ_prod with e0 T0 U (Srt kind); intros;
 auto with coc core arith datatypes.
elim conv_sort with s3 kind; auto with coc core arith datatypes.

simpl in |- *.
elim type_case with e0 u (Prod V Ur); auto with coc core arith datatypes;
 intros.
inversion_clear H5.
rewrite H3.
case (typ_skel (cl_term u (class_env e0)));
 auto with coc core arith datatypes.

elim (cl_term v (class_env e0)); auto with coc core arith datatypes.

apply inv_typ_prod with e0 V Ur (Srt x); intros;
 auto with coc core arith datatypes.
apply type_prod with s1; auto with coc core arith datatypes.
elim conv_sort with s2 kind; auto with coc core arith datatypes.
apply typ_unique with e0 (subst v Ur); auto with coc core arith datatypes.
replace (Srt s2) with (subst v (Srt s2)); auto with coc core arith datatypes.
apply substitution with V; auto with coc core arith datatypes.

discriminate H5.

simpl in |- *.
simpl in H3.
rewrite H3; auto with coc core arith datatypes.
replace (Srt s2) with (lift 1 (Srt s2)); auto with coc core arith datatypes.
replace (Srt kind) with (lift 1 (Srt kind));
 auto with coc core arith datatypes.
apply thinning; auto with coc core arith datatypes.
apply wf_var with s1; auto with coc core arith datatypes.

apply H1.
elim type_case with e0 t0 U; auto with coc core arith datatypes; intros.
inversion_clear H6.
elim conv_sort with x kind; auto with coc core arith datatypes.
apply typ_conv_conv with e0 U V; auto with coc core arith datatypes.

elim inv_typ_conv_kind with e0 V (Srt kind);
 auto with coc core arith datatypes.
elim H6; auto with coc core arith datatypes.
Qed.

  Lemma class_typ_ord :
   forall (e : env) (T : term) (s : sort),
   typ e T (Srt s) ->
   forall P : class -> Prop,
   P (Typ (typ_skel (cl_term T (class_env e)))) ->
   P (Knd (cv_skel (cl_term T (class_env e)))) -> P (cl_term T (class_env e)).
simple destruct s; intros.
rewrite (class_knd e T (Srt kind)); auto with coc core arith datatypes.

rewrite (class_typ e T (Srt prop)); auto with coc core arith datatypes.
apply type_prop.
apply typ_wf with T (Srt prop); auto with coc core arith datatypes.

rewrite (class_typ e T (Srt set)); auto with coc core arith datatypes.
apply type_set.
apply typ_wf with T (Srt set); auto with coc core arith datatypes.
Qed.

  Lemma class_trm :
   forall (e : env) (t T : term) (s : sort),
   is_prop s -> typ e t T -> typ e T (Srt s) -> cl_term t (class_env e) = Trm.
intros e t T s is_p.
simple induction 1; intros.
elim inv_typ_kind with e0 (Srt s); auto with coc core arith datatypes.

elim inv_typ_kind with e0 (Srt s); auto with coc core arith datatypes.

elim H1; intros.
simpl in |- *.
elim item_trunc with term v e0 x; auto with coc core arith datatypes; intros.
elim nth_class_env with x e0 x0 v; auto with coc core arith datatypes.
elim cl_trunc with (S v) (class_env e0) (class_env x0) x;
 auto with coc core arith datatypes.
elim H3.
rewrite (class_typ e0 t0 (Srt s)); auto with coc core arith datatypes.
apply type_prop_set; auto with coc core arith datatypes.

simpl in |- *.
simpl in H5.
rewrite H5; auto with coc core arith datatypes.
apply inv_typ_prod with e0 T0 U (Srt s); intros;
 auto with coc core arith datatypes.
elim conv_sort with s3 s; auto with coc core arith datatypes.

simpl in |- *.
elim type_case with e0 u (Prod V Ur); auto with coc core arith datatypes;
 intros.
inversion_clear H5.
rewrite H3; auto with coc core arith datatypes.
apply inv_typ_prod with e0 V Ur (Srt x); intros;
 auto with coc core arith datatypes.
apply type_prod with s1; auto with coc core arith datatypes.
elim conv_sort with s2 s; auto with coc core arith datatypes.
apply typ_unique with e0 (subst v Ur); auto with coc core arith datatypes.
replace (Srt s2) with (subst v (Srt s2)); auto with coc core arith datatypes.
apply substitution with V; auto with coc core arith datatypes.

discriminate H5.

simpl in |- *.
simpl in H3.
rewrite H3; auto with coc core arith datatypes.
replace (Srt s2) with (lift 1 (Srt s2)); auto with coc core arith datatypes.
replace (Srt s) with (lift 1 (Srt s)); auto with coc core arith datatypes.
apply thinning; auto with coc core arith datatypes.
apply wf_var with s1; auto with coc core arith datatypes.

apply H1.
elim type_case with e0 t0 U; auto with coc core arith datatypes; intros.
inversion_clear H6.
elim conv_sort with x s; auto with coc core arith datatypes.
apply typ_conv_conv with e0 U V; auto with coc core arith datatypes.

elim inv_typ_conv_kind with e0 V (Srt s); auto with coc core arith datatypes.
elim H6; auto with coc core arith datatypes.
Qed.

  Lemma cl_term_sound :
   forall (e : env) (t T : term),
   typ e t T ->
   forall K : term,
   typ e T K -> adj_cls (cl_term t (class_env e)) (cl_term T (class_env e)).
intros.
elim type_case with e t T; intros; auto with coc core arith datatypes.
elim H1.
intro x; elim x using sort_level_ind; intros.
rewrite (class_knd e T (Srt kind)); auto with coc core arith datatypes.
rewrite (class_typ e t T); auto with coc core arith datatypes.

rewrite (class_typ e T (Srt s)); auto with coc core arith datatypes.
rewrite (class_trm e t T s); auto with coc core arith datatypes.

apply type_prop_set; trivial.
apply typ_wf with t T; auto with coc core arith datatypes.

elim inv_typ_kind with e K; auto with coc core arith datatypes.
elim H1; auto with coc core arith datatypes.
Qed.

  Lemma cl_term_red1 :
   forall (e : env) (A T : term),
   typ e A T ->
   forall B : term,
   red1 A B -> loose_eqc (cl_term A (class_env e)) (cl_term B (class_env e)).
simple induction 1; intros; auto with coc core arith datatypes.
inversion_clear H1.

inversion_clear H1.

inversion_clear H2.

inversion_clear H6.
simpl in |- *.
elim
 loose_eqc_stable
  with
    M
    (TCs class (cl_term T0 (class_env e0)) (class_env e0))
    (TCs class (cl_term M' (class_env e0)) (class_env e0));
 auto with coc core arith datatypes.
elim H1 with M'; auto with coc core arith datatypes.

simpl in |- *.
replace (TCs class (cl_term T0 (class_env e0)) (class_env e0)) with
 (class_env (T0 :: e0)); trivial.
elim H5 with M'; auto with coc core arith datatypes.
elim (cl_term T0 (class_env e0)); auto with coc core arith datatypes.

generalize H2 H3; clear H2 H3.
inversion_clear H4; intros.
elim type_case with e0 (Abs T0 M) (Prod V Ur); intros;
 auto with coc core arith datatypes.
inversion_clear H4.
apply inv_typ_prod with e0 V Ur (Srt x); intros;
 auto with coc core arith datatypes.
apply inv_typ_abs with e0 T0 M (Prod V Ur); intros;
 auto with coc core arith datatypes.
simpl in |- *.
apply loose_eqc_trans with (cl_term M (class_env (T0 :: e0))).
replace (TCs class (cl_term T0 (class_env e0)) (class_env e0)) with
 (class_env (T0 :: e0)); auto with coc core arith datatypes.
elim cl_term_sound with (T0 :: e0) M T1 (Srt s3); intros;
 auto with coc core arith datatypes.
elim (cl_term T0 (class_env e0)); intros.
elim s4; elim (cl_term v (class_env e0)); auto with coc core arith datatypes.

elim s4; elim (cl_term v (class_env e0)); auto with coc core arith datatypes.

elim (cl_term v (class_env e0)); auto with coc core arith datatypes.

unfold subst in |- *.
apply cl_term_subst with (cl_term T0 (class_env e0)) (class_env e0);
 auto with coc core arith datatypes.
apply cl_term_sound with (Srt s0); auto with coc core arith datatypes.
apply type_conv with V s0; auto with coc core arith datatypes.
apply inv_conv_prod_l with Ur T1; auto with coc core arith datatypes.

simpl in |- *; auto with coc core arith datatypes.

discriminate H4.

simpl in |- *.
elim H4 with N1; intros; auto with coc core arith datatypes.
case s1; case s2; elim (cl_term v (class_env e0));
 auto with coc core arith datatypes.

simpl in |- *.
elim (cl_term u (class_env e0)); intros; auto with coc core arith datatypes.
case s; elim H1 with N2; auto with coc core arith datatypes.

inversion_clear H4.
simpl in |- *.
elim
 loose_eqc_stable
  with
    U
    (TCs class (cl_term T0 (class_env e0)) (class_env e0))
    (TCs class (cl_term N1 (class_env e0)) (class_env e0));
 auto with coc core arith datatypes.
elim H1 with N1; auto with coc core arith datatypes.

simpl in |- *.
replace (TCs class (cl_term T0 (class_env e0)) (class_env e0)) with
 (class_env (T0 :: e0)); auto with coc core arith datatypes.
elim H3 with N2; auto with coc core arith datatypes.
Qed.

  Lemma cl_term_red :
   forall T U : term,
   red T U ->
   forall (e : env) (K : term),
   typ e T K -> loose_eqc (cl_term T (class_env e)) (cl_term U (class_env e)).
simple induction 1; intros; auto with coc core arith datatypes.
apply loose_eqc_trans with (cl_term P (class_env e));
 auto with coc core arith datatypes.
apply H1 with K; auto with coc core arith datatypes.

apply cl_term_red1 with K; auto with coc core arith datatypes.
apply subject_reduction with T; auto with coc core arith datatypes.
Qed.

  Lemma cl_term_conv :
   forall (e : env) (T U K1 K2 : term),
   typ e T K1 ->
   typ e U K2 ->
   conv T U -> loose_eqc (cl_term T (class_env e)) (cl_term U (class_env e)).
intros.
elim church_rosser with T U; intros; auto with coc core arith datatypes.
apply loose_eqc_trans with (cl_term x (class_env e)).
apply cl_term_red with K1; auto with coc core arith datatypes.

elim cl_term_red with U x e K2; auto with coc core arith datatypes.
Qed.

  Lemma skel_sound :
   forall (e : env) (t T : term),
   typ e t T ->
   cv_skel (cl_term T (class_env e)) = typ_skel (cl_term t (class_env e)).
simple induction 1; intros; auto with coc core arith datatypes.
inversion_clear H1.
rewrite H2.
simpl in |- *.
clear H2 t0.
elim H3; simpl in |- *; intros.
unfold lift in |- *.
elim
 cl_term_lift
  with
    (cl_term x (class_env l))
    x
    0
    (class_env l)
    (TCs class (cl_term x (class_env l)) (class_env l));
 auto with coc core arith datatypes.
elim (cl_term x (class_env l)); auto with coc core arith datatypes.

rewrite simpl_lift.
unfold lift at 1 in |- *.
elim
 cl_term_lift
  with
    (cl_term y (class_env l))
    (lift (S n) x)
    0
    (class_env l)
    (TCs class (cl_term y (class_env l)) (class_env l));
 auto with coc core arith datatypes.

simpl in |- *.
replace (TCs class (cl_term T0 (class_env e0)) (class_env e0)) with
 (class_env (T0 :: e0)); auto with coc core arith datatypes.
rewrite
 (commut_case _ _ cv_skel)
                           with
                           (bK :=
                             fun s =>
                             match cl_term T0 (class_env e0) with
                             | Trm => Knd s
                             | Typ _ => Knd s
                             | Knd s0 => Knd (PROD s0 s)
                             end).
rewrite
 (commut_case _ _ typ_skel)
                            with
                            (bT :=
                              fun s =>
                              match cl_term T0 (class_env e0) with
                              | Trm => Typ s
                              | Typ _ => Typ s
                              | Knd s0 => Typ (PROD s0 s)
                              end)
                           (bK := fun s : skel => Knd PROP).
simpl in |- *.
replace (TCs class (cl_term T0 (class_env e0)) (class_env e0)) with
 (class_env (T0 :: e0)); auto with coc core arith datatypes.
pattern (cl_term M (class_env (T0 :: e0))) at 1,
 (cl_term U (class_env (T0 :: e0))) at 1 in |- *.
elim cl_term_sound with (T0 :: e0) M U (Srt s2); intros;
 auto with coc core arith datatypes.
rewrite
 (commut_case _ _ cv_skel)
                           with
                           (bT :=
                             fun s : skel =>
                             Knd (cv_skel (cl_term U (class_env (T0 :: e0)))))
                          (bK :=
                            fun s =>
                            Knd
                              (PROD s
                                 (cv_skel (cl_term U (class_env (T0 :: e0)))))).
rewrite
 (commut_case _ _ typ_skel)
                            with
                            (bT :=
                              fun s : skel =>
                              Typ
                                (typ_skel (cl_term M (class_env (T0 :: e0)))))
                           (bK :=
                             fun s =>
                             Typ
                               (PROD s
                                  (typ_skel
                                     (cl_term M (class_env (T0 :: e0)))))).
elim (cl_term T0 (class_env e0)); auto with coc core arith datatypes.
elim H5; auto with coc core arith datatypes.

elim type_case with e0 u (Prod V Ur); intros;
 auto with coc core arith datatypes.
inversion_clear H4.
apply inv_typ_prod with e0 V Ur (Srt x); intros;
 auto with coc core arith datatypes.
unfold subst in |- *.
generalize H3.
cut (adj_cls (cl_term u (class_env e0)) (cl_term (Prod V Ur) (class_env e0))).
simpl in |- *.
elim
 cl_term_subst
  with
    (cl_term V (class_env e0))
    (class_env e0)
    v
    Ur
    0
    (class_env e0)
    (TCs class (cl_term V (class_env e0)) (class_env e0));
 simpl in |- *; auto with coc core arith datatypes.
intros.
inversion_clear H8.

intros.
inversion_clear H8.
auto with coc core arith datatypes.

elim cl_term_sound with e0 v V (Srt s1); simpl in |- *; intros;
 auto with coc core arith datatypes.
rewrite H9.
inversion_clear H8; auto with coc core arith datatypes.
elim s3; auto with coc core arith datatypes.

generalize H9.
inversion_clear H8; intros; auto with coc core arith datatypes.
simpl in H8.
elim H8; auto with coc core arith datatypes.

apply cl_term_sound with (Srt s1); auto with coc core arith datatypes.

apply cl_term_sound with (Srt x); auto with coc core arith datatypes.

discriminate H4.

simpl in |- *.
simpl in H3.
simpl in H1.
rewrite
 (commut_case _ _ typ_skel)
                            with
                            (bK :=
                              fun s =>
                              match cl_term T0 (class_env e0) with
                              | Trm => Knd s
                              | Typ _ => Knd s
                              | Knd s0 => Knd (PROD s0 s)
                              end).
simpl in |- *.
elim H3.
elim (cl_term U (TCs class (cl_term T0 (class_env e0)) (class_env e0)));
 auto with coc core arith datatypes.
elim (cl_term T0 (class_env e0)); auto with coc core arith datatypes.

elim H1.
elim cl_term_conv with e0 U V (Srt s) (Srt s);
 auto with coc core arith datatypes.
elim type_case with e0 t0 U; auto with coc core arith datatypes; intros.
inversion_clear H5.
elim conv_sort with x s; auto with coc core arith datatypes.
apply typ_conv_conv with e0 U V; auto with coc core arith datatypes.

elim inv_typ_conv_kind with e0 V (Srt s); auto with coc core arith datatypes.
elim H5; auto with coc core arith datatypes.
Qed.

  (* Strict stability results *)

  Inductive typ_cls : class -> class -> Prop :=
    | tc_t : typ_cls Trm (Typ PROP)
    | tc_T : forall s : skel, typ_cls (Typ s) (Knd s).

  Hint Resolve tc_t tc_T: coc.

  Lemma class_subst :
   forall (a : class) (G : cls) (x : term),
   typ_cls (cl_term x G) a ->
   forall (t : term) (k : nat) (E F : cls),
   TIns _ a k E F ->
   TTrunc _ k E G -> cl_term t F = cl_term (subst_rec x t k) E.
simple induction t; simpl in |- *; intros; auto with coc core arith datatypes.
elim (lt_eq_lt_dec k n); simpl in |- *; [ intro Hlt_eq | intro Hlt ].
elim Hlt_eq; clear Hlt_eq.
case n; simpl in |- *; [ intro Hlt | intro; intro Heq ].
inversion_clear Hlt.

elim Tins_le with class k E F Trm a n0; auto with coc core arith datatypes.

simple induction 1.
rewrite (Tins_eq class k E F Trm a); auto with coc core arith datatypes.
replace (cl_term (lift k x) E) with (cl_term x G).
inversion_clear H; auto with coc core arith datatypes.

symmetry  in |- *.
apply cl_trunc; auto with coc core arith datatypes.

elim Tins_gt with class k E F Trm a n; auto with coc core arith datatypes.

elim H0 with k E F; auto with coc core arith datatypes.
elim H1 with (S k) (TCs class (cl_term t0 F) E) (TCs class (cl_term t0 F) F);
 auto with coc core arith datatypes.

elim H0 with k E F; auto with coc core arith datatypes.
elim H1 with k E F; auto with coc core arith datatypes.

elim H0 with k E F; auto with coc core arith datatypes.
elim H1 with (S k) (TCs class (cl_term t0 F) E) (TCs class (cl_term t0 F) F);
 auto with coc core arith datatypes.
Qed.

  Lemma class_sound :
   forall (e : env) (t T : term),
   typ e t T ->
   forall K : term,
   typ e T K -> typ_cls (cl_term t (class_env e)) (cl_term T (class_env e)).
intros.
elim type_case with (1 := H); intros.
elim H1.
intro x; elim x using sort_level_ind; intros.
rewrite (class_knd e T (Srt kind)); trivial.
rewrite (class_typ e t T); trivial.
elim skel_sound with (1 := H); auto with coc.

rewrite (class_typ e T (Srt s)); trivial.
rewrite (class_trm e t T s); trivial.
elim skel_sound with (1 := H3); simpl in |- *; auto with coc.

apply type_prop_set; trivial.
apply typ_wf with t T; auto with coc.

elim inv_typ_kind with e K.
elim H1; auto with coc core arith datatypes.
Qed.

  Lemma class_red :
   forall (e : env) (T U K : term),
   typ e T K -> red T U -> cl_term T (class_env e) = cl_term U (class_env e).
intros.
cut (typ_skel (cl_term T (class_env e)) = typ_skel (cl_term U (class_env e))).
elim cl_term_red with (1 := H0) (2 := H); simpl in |- *; intros; trivial.
elim H1; trivial.

elim skel_sound with (1 := H); trivial.
apply skel_sound.
apply subject_reduction with (1 := H0) (2 := H).
Qed.


(* Elaboration from D<:> with full terms as paths into a simpler CC-style
   dependently typed system without type bounds.

   The current version does not have an explicit subtyping judgement but
   includes intro and elim forms for e.T types as part of the type
   assignment for terms (has_type).
*)

(*
  Source language (currently missing: T ::=  T1 /\ T2 | { z => T^z }):

  DSubSup (D<:>)
  T ::= Top | Bot | t.Type | { Type: S..U } | (z: T) -> T^z
  t ::= x | { Type = T } | lambda x:T.t | t t

  Target language (inspired by https://docs.racket-lang.org/pie/index.html):

  t ::= x | Unit | Type
      | (z: T) -> T^z  | lambda x:T.t | t t
      | Sigma z:T. T^z | (t, t)  | fst t | snd t

  Translation (with syntactic sugar ->/* for non-dependent fun/pair):

  [[ t.Type ]]         = fst [[ t ]]
  [[ { Type: S..U } ]] = Sigma T:Type. ([[ S ]] -> T) * (T -> [[ U ]])

  [[ { Type = T } ]]   = (T, ((lambda x:T. x), (lambda x:T. x)))

*)

(*
  Roadmap:

  Frontend:
    - finish proof of type-preserving translation (esp. binding/subst for dep elim)
    - add intersection and recursive types to source (term-based elim/intro)
    - add subtyping relation
    - introduce rec capabilities and translate to term/nonterm based on context

  Backend (mainly follow Zombie paper POPL14):
    - prove termination of target
    - distinguish terminating/non-terminating fragment

*)

(* TODOs
  * TMem: Universe polymorphic translation
  * Type annotation in Sigma type eliminator
  * rm context wellformedness in src language
*)

Require Export Arith.EqNat.
Require Export Arith.Le.
Require Import Coq.Program.Equality.
Require Import Omega.
Require Import Coq.Lists.List.
Import ListNotations.

Require Import languages.
(* make ⋆ and ◻ available *)
Import CC.Notations.
Open Scope cc_scope.

Import D. (* Dsubsup language *)

(* type-directed translation of D into CC

   TODO: we should have marker syntax in CC for translation artifacts.
   these should not consume fuel in evaluation. we could then show that
   source exps and translation require the exact same amount of fuel.
 *)
(* Why define this recursively over the derivations? At some point, we'll
   integrate subtyping again, and subsumption/subtyping induces coercion terms in
   the translation. We'll need to extract these from the (sub)typing derivations. *)
Fixpoint ttp Gamma T (wf: ty_wf Gamma T): CC.tm :=
  match wf with
  | wf_top _ =>
    CC.TTop
  | wf_bot _ =>
    CC.TBot
  | wf_all _ _ _ ty_wf_T1 ty_wf_T2 =>
    CC.TAll (ttp _ _ ty_wf_T1) (ttp _ _ ty_wf_T2)
  | wf_mem _ _ _ ty_wf_T1 ty_wf_T2 =>
    (* Type L..U ~>  (Σα:⋆.(L → α ,α → U)) : ◻ *)
    (* TODO: this is not type-preserving *)
    let f1 := CC.TAll (ttp _ _ ty_wf_T1) (CC.tvar (varB 1)) in
    let f2 := CC.TAll (CC.tvar (varB 2)) (ttp _ _ ty_wf_T2) in
    CC.TSig ⋆ (CC.TSig f1 f2)
  | wf_sel _ _ _ _ _ _ has_type_e =>
    CC.tfst (ttm _ _ _ has_type_e)
  end
with ttm Gamma t T (typing: has_type Gamma t T): CC.tm :=
  match typing with
  | t_var v _ _ _ _ =>
    CC.tvar (varF v)
  | t_typ _ _ ty_wf_T1 =>
    let T1' := (ttp _ _ ty_wf_T1) in
    let idfun := (CC.tabs T1' (CC.tvar (varB 0))) in
    (* TODO: it seems we need type annotations in tsig, since the result may
       also be typed as Σα:⋆.(α→α×α→α), while we would like the type
       Σα:⋆.(T1'→α×α→T1'). *)
    CC.tsig T1' (CC.tsig idfun idfun)
  | t_seli _ _ _ _ has_type_a_T1 has_type_e_TM_T1_Top =>
    let a' := (ttm _ _ _ has_type_a_T1) in
    let e' := (ttm _ _ _ has_type_e_TM_T1_Top) in
    CC.tapp (CC.tfst (CC.tsnd e')) a'
  | t_sele _ _ _ _ has_type_a_TSel_e has_type_e_TM_Bot_T1 =>
    let a' := (ttm _ _ _ has_type_a_TSel_e) in
    let e' := (ttm _ _ _ has_type_e_TM_Bot_T1) in
    CC.tapp (CC.tsnd (CC.tsnd e')) a'
  | t_app _ _ _ _ _ has_type_f_TAll_T1_T2 has_type_x_T1 =>
    (* TODO this'll need a lemma stating that subst/open and translation commute  *)
    CC.tapp (ttm _ _ _ has_type_f_TAll_T1_T2) (ttm _ _ _ has_type_x_T1)
  | t_abs _ _ _ _ ty_wf_T1 has_type_y_T2 =>
    CC.tabs (ttp _ _ ty_wf_T1) (ttm _ _ _ has_type_y_T2)
  end.

Fixpoint tctx Gamma (wf: ctx_wf Gamma): CC.tenv :=
  match wf with
  | wf_empty => []
  | wf_cons Gamma T wf_Gamma_T wf_Gamma =>
    (ttp _ _ wf_Gamma_T) :: (tctx _ wf_Gamma)
  end.

Lemma extract1: forall Gamma T1 T2, ty_wf Gamma (TMem T1 T2) -> ty_wf Gamma T2.
Proof.
  intros. inversion H. eauto.
Qed.

Lemma extract2: forall Gamma T1 T2, ty_wf Gamma (TMem T1 T2) -> ty_wf Gamma T1.
Proof.
  intros. inversion H. eauto.
Qed.

Lemma ty_wf_open: forall Gamma e T1 T2,
    ty_wf (T1 :: Gamma) (open (varF (length Gamma)) T2) ->
    has_type Gamma e T1 ->
    ty_wf Gamma (open' e T2)
  with
    has_type_open: forall Gamma e1 e2 T1 T2,
      has_type (T1 :: Gamma) e2 T2 ->
      has_type Gamma e1 T1 ->
      has_type Gamma (open_tm' e1 e2) (open' e1 T2).
Proof.
  -  (* ty_wf_open *)
    intros.  unfold open in *. unfold open' in *. unfold open_tm' in *.
    generalize dependent Gamma. generalize dependent e. generalize dependent T1.
    induction T2; intros.
    (* TTop *)
    -- simpl. constructor.
    (* TBot *)
    -- simpl. constructor.
    (* TAll *)
    -- simpl in H. inversion H. subst. simpl. constructor.
       --- eapply IHT2_1; eauto.
       --- unfold open in *.
         admit. (* TODO messy *)
    (* TSel *)
    -- admit.
    (* TMem *)
    -- inversion H. subst. simpl. constructor.
       eapply IHT2_1. eauto. auto.
       eapply IHT2_2. eauto. auto.
    (* TBind *)
    -- inversion H.
    (* TAnd *)
    -- inversion H.

  (* has_type_open *)
  - admit.
Admitted.

Lemma wf_lookup: forall Gamma x T, ctx_wf Gamma -> indexr x Gamma = Some T -> ty_wf Gamma T.
Proof.
Admitted.

Lemma regularity_ctx: forall Gamma e T, has_type Gamma e T -> ctx_wf Gamma.
Proof.
Admitted.

(* if term has a type, the type is well-formed*)
(* TODO have it as fixpoint as below *)
Lemma htwf: forall Gamma e T, has_type Gamma e T -> ty_wf Gamma T.
Proof.
  intros. induction H; auto.
  - eapply wf_lookup; eauto.
  - apply wf_sel with (T1 := T1) (T2 := TTop); auto. constructor.
  - apply (extract1 _ _ _ IHhas_type2).
  - constructor; auto.
  - inversion IHhas_type1. subst. eapply ty_wf_open; eauto.
  - constructor; auto.
Qed.

 (* TODO try defining in this style*)
(* Fixpoint htwf G e T (tm: has_type G e T): ty_wf G T := *)
(*   match tm with *)
(*   | t_var _ _ _ _ ty_wf_T1 => *)
(*     ty_wf_T1 *)
(*   | t_seli _ _ _ _ has_type_a_T1 has_type_e_TM_T1_Top => *)
(*     wf_sel _ _ _ _ (htwf _ _ _ has_type_a_T1) (wf_top _) has_type_e_TM_T1_Top *)
(*   | t_sele _ _ _ _ _ has_type_e_TM_Bot_T1 => *)
(*     extract1 _ _ _ (htwf _ _ _ has_type_e_TM_Bot_T1) *)
(*   | t_typ _ _ ty_wf_T1 => *)
(*     wf_mem _ _ _ ty_wf_T1 ty_wf_T1 *)
(*   | t_app Gamma f x T1 T2 has_type_f_TAll_T1_T2 has_type_x_T1 => *)
(*     match (htwf Gamma f (TAll T1 T2) has_type_f_TAll_T1_T2) as p in (ty_wf _ (TAll _ _)) return (ty_wf Gamma (open' x T2)) with *)
(*     | wf_all _ _ _ _ ty_wf_T2x => *)
(*       (ty_wf_open _ _ _ _ ty_wf_T2x has_type_x_T1) *)
(*     end *)
(*   | t_abs _ _ _ _ i h => *)
(*     wf_all _ _ _ i (htwf _ _ _ h) *)
(*   end. *)

Lemma indexr_lookup_max: forall T (G1:list T) a,
    indexr (length G1) (a :: G1) = Some a.
Proof.
Admitted.

(* todo: ty_wf has a canonical form *)
(* Lemma foobar: forall G T1 T2 i1 i2 e h, htwf G e (TMem T1 T2) h = t_mem G _ _ i1 i2. *)
(* Proof. *)
(* Admitted. *)

Lemma ty_wf_unopen: forall Gamma e T U,
    has_type Gamma e U ->
    ty_wf Gamma (open' e T) ->
    ty_wf (U :: Gamma) (open (varF (length Gamma)) T).
Proof.
  Admitted.

(*
   This essentially says ⟦T{D.open' e}⟧ = ⟦T⟧{CC.open' ⟦e⟧}, which we'll need in the
   main proof for the dependent application case.
   Due to the locally nameless repr and the derivation-indexed translation
   functions, we have to express this in a more roundabout way, using substitution:
   (Γ ⫦ ⟦ T ^ e ⟧) = ((U :: Γ) ⫦ ⟦ T ^ x ⟧){x ↦ (Γ ⫦ ⟦e⟧)}),
   where Γ ⊢ e : U. We write Γ ⫦ ⟦ ⋅ ⟧ for the type resp. term translation
   (not explicitly spelling out the derivation under context Γ).

   We will also need to establish that T^e = (T^x){e/x} in the target language (cf. languages.v).
*)
Lemma open_ttp_commute: forall Gamma e T U x (wf_t: ty_wf Gamma (open' e T)) (e_of_U: has_type Gamma e U),
    x = (length Gamma) ->
    (ttp _ _ wf_t) = (CC.subst x (ttm _ _ _ e_of_U) (ttp _ _ (ty_wf_unopen _ _ _ _ e_of_U wf_t))).
Proof.
  Admitted.

(* Optional: Reduce noise in notation, by making the has_type/ty_wf indices implicit. *)
Module Sugar.
  Class ctx_wf' (Gamma: tenv) := { ctx_wf_holds: ctx_wf Gamma }.
  Class ty_wf' (Gamma: tenv) (T: ty) := { ty_wf_holds: ty_wf Gamma T }.
  Class has_type' (Gamma: tenv) (e: tm) (T: ty) := { has_type_holds: has_type Gamma e T }.

  (* versions of translations leaving the index implicit *)
  Definition tctx' (Gamma: tenv) `{ctx_wf' Gamma} := tctx Gamma ctx_wf_holds.
  Definition ttp' (Gamma: tenv) (T: ty) `{ty_wf' Gamma T}  := ttp Gamma T ty_wf_holds.
  Definition ttm' (Gamma: tenv) (e: tm) (T: ty) `{has_type' Gamma e T} := ttm Gamma e T has_type_holds.

  (* Lemmas about index/derivation transformations become type class instances *)
  Instance ty_wf_unopen' {Gamma e U T} {He: has_type' Gamma e U} {HT: ty_wf' Gamma (open' e T)} : ty_wf' (U :: Gamma) (open (varF (length Gamma)) T).
  Proof.
    constructor. inversion He. inversion HT. eapply ty_wf_unopen; eauto.
  Defined.

  Instance htwf' {Gamma e T} {He: has_type' Gamma e T} : ty_wf' Gamma T.
  Proof.
    constructor. inversion He.
    eapply htwf; eauto.
  Defined.

  Instance regularity_ctx' {Gamma e T} {He: has_type' Gamma e T}: ctx_wf' Gamma.
  Proof.
    constructor. inversion He.
    eapply regularity_ctx; eauto.
  Qed.

End Sugar.

Import Sugar.

(* Example usage, adieu underscores: *)
Lemma open_ttp_commute': forall Gamma e T U `{has_type' Gamma e U} `{ty_wf' Gamma (open' e T)},
    ttp' Gamma (open' e T) = (CC.subst (length Gamma) (ttm' Gamma e U) (ttp' (U :: Gamma) (open (varF (length Gamma)) T))).
Proof.
  (* Set Printing Implicit. *)
  intros. destruct H.
  destruct H0. unfold ttp'. unfold ttm'. simpl. (* remove the typeclass stuff *)
  eapply open_ttp_commute. reflexivity.
Qed.

(* Discussion points:

  - ttpok: can only say that exists a sort s, so that the translated type from the src language
    has that sort in the target, because of the Σ-type encoding of TMem.

  - Problem for the TMem translation: It fixes the existentially quantified variable to be a ⋆,
    but a translated TMem lives at level ◻. DOT is impredicative, so the abstract type could
    be a TMem (and its bounds might also involve TMems). Need to reconcile DOT's impredicativity
    w. the predicativity of the target. E.g.
    1. Have additional restrictions in the source lang?
    2. Propagate more information during translation?

  - critical lemmas: ty_wf_open, has_type_open, open_ttp_commute (nasty binding stuff)

*)

(* Theorem: translation is well-typed *)
Theorem tctxok: forall Gamma (wfG: ctx_wf Gamma), CC.ctx_wf (tctx _ wfG)
  with
    ttpok:
      forall Gamma T (wfG: ctx_wf Gamma) (wfT: ty_wf Gamma T), exists s, CC.has_type (tctx _ wfG) (ttp _ _ wfT) (CC.Sort s) (* TODO fix universe inconsistency *)
  with
    ttmok:
      forall Gamma t T (typing: has_type Gamma t T), CC.has_type (tctx _ (regularity_ctx _ _ _ typing)) (ttm _ _ _ typing) (ttp _ _ (htwf _ _ _ typing)).
Proof.
  apply (ty_wf_ind_mut (* TODO this is not defined yet *)
           (fun G T IT => forall G1, CC.has_type G1 (ttp _ _ IT) CC.Star)
           (fun G e T HT => forall G1, CC.has_type G1 (ttm _ _ _ HT) (ttp _ _ (htwf _ _ _ HT)))).

  - (* TTop *) econstructor.

  - (* TBot *) econstructor.

  - (* TMem T1 T2  ->  \Sigma TX: Type. (T1' -> TX) * (TX -> T2') *)
    intros. simpl. eapply CC.t_sigt. econstructor.
    unfold CC.open. simpl. eapply CC.t_sigt. econstructor. eapply shotgun2. eauto.
    eapply shotgun2. eapply CC.t_var. eapply indexr_lookup_max. econstructor.
    unfold CC.open. simpl. eapply CC.t_all.
    admit. admit. (* boring but tedious, need to get all open/subst right *)

  - (* TAll *) intros. simpl. econstructor. eauto. unfold CC.open. simpl. admit. (* open mismatch *)

  - (* TSel e  ->  fst e' *)
    (* we know e: *)
    (* e: TMem T1 T2  ->  e': \Sigma ... *)
    intros. simpl.

    rewrite (foobar _ _ _ i i0) in H1. simpl in H1.
    eapply CC.t_fst. eapply H1.

  - (* t_var *) intros. econstructor.
    admit. (* indexr *)
    eapply H.

  - (* t_sel2 *)
    (* apply first conversion function *)
    intros. simpl.

    rewrite (foobar _ _ _ (htwf _ _ _ h) (t_top _)) in H0. simpl in H0.

    eapply CC.t_app. eapply CC.t_fst. eapply CC.t_snd. eapply H0. eapply H.

  - (* t_sel1 *)
    (* apply second conversion function *)
    intros. simpl.

    assert (ty_wf env T1) as i0. admit. (* from htwf *)

    rewrite (foobar _ _ _ (t_bot _) i0) in H0. simpl in H0.

    eapply CC.t_app. eapply CC.t_snd. eapply CC.t_snd. eapply H0.

    (* FIXME: function arg -- need correct type: fst of triple *)
    admit.

  - (* t_typ *)
    admit.

  - (* t_app *)
    admit.

  - (* t_abs *)
    admit.

Admitted.

(* sugared version *)
Theorem tctxok': forall Gamma `{ctx_wf Gamma}, CC.ctx_wf (tctx' Gamma)
  with
    ttpok':
      forall Gamma T `{ctx_wf Gamma} `{ty_wf Gamma T}, exists s, CC.has_type (tctx' Gamma) (ttp' Gamma T) (CC.Sort s) (* TODO fix universe inconsistency *)
  with
    ttmok':
      forall Gamma t T `{has_type Gamma t T}, CC.has_type (tctx' Gamma) (ttm' Gamma t T) (ttp' Gamma T).
Proof.
Admitted.


(* Prove that all real number instances are equivalent *)

Require Import Real.
Require Import testsearch.
Require Import Psatz.

Section rounding.

  Generalizable Variables K M Real.

  Context `{klb : LazyBool K} `{M_Monad : Monad M}
          {MultivalueMonad_description : Monoid_hom M_Monad NPset_Monad}
          {M_MultivalueMonad : MultivalueMonad}
          {Real : Type}
          {SemiDecOrderedField_Real : SemiDecOrderedField Real}
          {ComplArchiSemiDecOrderedField_Real : ComplArchiSemiDecOrderedField}.

  (* ring structure on Real *)
  Ltac IZReal_tac t :=
    match t with
    | real_0 => constr:(0%Z)
    | real_1 => constr:(1%Z)
    | IZreal ?u =>
      match isZcst u with
      | true => u
      | _ => constr:(InitialRing.NotConstant)
      end
    | _ => constr:(InitialRing.NotConstant)
    end.

  Add Ring realRing : (realTheory ) (constants [IZReal_tac]).

  Lemma naive_rounding_pos : forall x : Real, x > real_0 -> M {k  | Nreal k < x < Nreal (k + 4) }.
    intros.
    pose proof (epsilon_smallest_PQ_M (fun n => x < Nreal (n) + prec 1) (fun n => Nreal (n) - prec 1 < x)).
    simpl in X.
    assert ((forall n : nat,
       M ({x < Nreal (n ) + real_1 / real_2_neq_0} + {Nreal (n ) - real_1 / real_2_neq_0 < x}))).
    intro.
    apply choose; auto with real.
    pose proof (W_split x (Nreal n) (real_1 / real_2_neq_0)).
    assert (real_1 / real_2_neq_0 > real_0).
    pose proof (prec_pos (S O)).
    simpl in H1.
    exact H1.
    apply H0 in H1; clear H0.
    destruct H1; auto.
    left.
    apply (real_lt_plus_lt (real_1 / real_2_neq_0)) in H0.
    replace (real_1 / real_2_neq_0 + (x - real_1 / real_2_neq_0)) with x in H0 by ring.
    rewrite real_plus_comm; auto.

    apply X in X0; clear X.
    apply (fun a => M_lift _  _ a X0).
    intro.
    destruct H0.
    destruct a.
    destruct x0.
    simpl in H0.
    exists O.
    split;  auto.
    apply (real_lt_lt_lt _ _ _ H0).
    rewrite real_plus_unit.
    assert (jj :  real_1 / real_2_neq_0 < real_1) by ( apply real_gt_half, real_1_gt_0).
    apply (real_lt_lt_lt _ _ _ jj).
    rewrite <- (real_plus_unit real_1).
    rewrite real_plus_comm.
    fold (Nreal 1).
    apply Nreal_strict_monotone.
    lia.

    destruct x0.
    exists O.
    split; auto.
    apply (real_lt_lt_lt _ _ _ H0).
    assert (jj :  real_1 / real_2_neq_0 < real_1) by ( apply real_gt_half, real_1_gt_0).
    apply (real_lt_plus_lt (Nreal 1)) in jj.

    apply (real_lt_lt_lt _ _ _ jj).
    replace (Nreal 1 + real_1) with (Nreal 2) by (simpl; ring).
    apply Nreal_strict_monotone.
    lia.

    exists (x0)%nat.
    split.
    pose proof (H1 (S x0)).
    assert (j : (S x0 < S (S x0))%nat) by lia.
    apply H2 in j; clear H2.
    apply (fun a => real_lt_lt_lt _ _ _ a j).
    rewrite Nreal_S.
    (* replace (Nreal (x0 + 1)) with (real_1 + Nreal x0). *)
    apply (real_lt_add_r (- Nreal x0 + real_1 / real_2_neq_0)).

    replace (Nreal x0 + (- Nreal x0 + real_1 / real_2_neq_0)) with (real_1 / real_2_neq_0) by ring.
    replace ( real_1 + Nreal x0 - real_1 / real_2_neq_0 + (- Nreal x0 + real_1 / real_2_neq_0)) with real_1 by ring.
    apply real_gt_half, real_1_gt_0.
    apply (real_lt_lt_lt _ _ _  H0).

    replace (Nreal (x0 + 4)) with (Nreal (S (S x0)) + real_1 + real_1).
    apply (real_lt_add_r (- Nreal (S (S x0)))).
    replace ( Nreal (S (S x0)) + real_1 / real_2_neq_0 + - Nreal (S (S x0))) with (real_1 / real_2_neq_0) by ring.
    replace ( Nreal (S (S x0)) + real_1 + real_1 + - Nreal (S (S x0))) with (real_1 + real_1) by ring.
    assert (jj :  real_1 / real_2_neq_0 < real_1) by ( apply real_gt_half, real_1_gt_0).
    pose proof (real_lt_lt_plus_lt _ _ _ _ jj (real_1_gt_0)).

    rewrite real_plus_comm, real_plus_unit in H2.
    exact H2.
    replace (x0 + 4)%nat with (S (S (S (S x0)))) by lia.
    replace (Nreal (S (S x0)) + real_1 + real_1) with (real_1 + (real_1 + Nreal (S (S x0)))) by ring.
    rewrite <-  Nreal_S.
    rewrite <-  Nreal_S.
    apply eq_refl.

    assert (x + real_1 > real_0).
    pose proof (real_lt_lt_plus_lt _ _ _ _ H real_1_gt_0).
    rewrite real_plus_unit in H0.
    exact H0.
    pose proof (nat_bound_above (x + real_1) H0).
    destruct H1.
    exists x0.
    apply real_lt_nlt.
    apply (real_lt_plus_lt (- real_1)) in H1.
    replace ( - real_1 + (x + real_1)) with x in H1 by ring.
    apply (real_lt_lt_lt _ _ _ H1).
    apply (real_lt_add_r (real_1 + real_1/real_2_neq_0 - Nreal x0)).
    replace (- real_1 + Nreal x0 + (real_1 + real_1 / real_2_neq_0 - Nreal x0)) with (real_1 / real_2_neq_0) by ring.
    replace (Nreal x0 - real_1 / real_2_neq_0 + (real_1 + real_1 / real_2_neq_0 - Nreal x0)) with real_1 by ring.
    apply real_gt_half, real_1_gt_0.
  Defined.

  Lemma naive_rounding : forall x : Real,  M {k  | IZreal k < x < IZreal (k + 4) }.
  Proof.
    intro.
    pose proof (choose (- prec 1 < x < prec 1) (real_0 < x \/ x < real_0)).
    apply (M_lift_dom ({- prec 1 < x < prec 1} + {real_0 < x \/ x < real_0})).
    intro.
    clear X.
    destruct H.
    apply M_unit.
    exists (-1)%Z.
    simpl.
    unfold IZreal.
    unfold IPreal.
    unfold IPreal_2.
    split.
    destruct a.

    apply (fun a =>  real_lt_lt_lt _ _ _ a H).
    apply (real_lt_add_r (real_1 + prec 1)).
    replace (- real_1 + (real_1 + prec 1)) with (prec 1) by ring.
    replace ( - prec 1 + (real_1 + prec 1)) with real_1 by ring.
    apply real_gt_half, real_1_gt_0.

    destruct a.
    apply (real_lt_lt_lt _ _ _ H0).
    assert (prec 1 < real_1) by (apply real_gt_half, real_1_gt_0).
    apply (real_lt_lt_lt _ _ _ H1).
    replace (real_1 + (real_1 + real_1)) with (Nreal 3) by (simpl; ring).
    replace (real_1 ) with (Nreal 1) by (simpl; ring).
    apply Nreal_strict_monotone; lia.
    pose proof (choose (real_0 < x) (x < real_0)) as X.
    assert (H : semidec (real_0 < x)) by auto with real.
    assert (H0 : semidec (x < real_0)) by auto with real.
    pose proof (X H H0 o).
    clear o X H H0.
    apply M_hprop_elim_f in X0.
    destruct X0.
    pose proof (naive_rounding_pos _ r).
    apply (fun f => M_lift _ _ f X).
    intro.
    clear X; destruct H.
    exists (Z.of_nat x0).
    replace (Z.of_nat x0 + 4)%Z with (Z.of_nat (x0 + 4)).
    rewrite (IZreal_Nreal) in a.
    rewrite (IZreal_Nreal) in a.
    exact a.
    lia.
    assert (real_0 < - x).
    apply (real_lt_add_r x).
    replace (real_0 + x) with x by ring.
    replace (-x + x) with real_0 by ring.
    exact r.
    pose proof (naive_rounding_pos _ H).
    apply (fun f => M_lift _ _ f X).
    intro.
    clear X; destruct H0.
    exists (- Z.of_nat x0 - 4)%Z.
    replace (- Z.of_nat x0 - 4)%Z with (- (Z.of_nat (x0 +4)))%Z by lia.
    replace ((- (Z.of_nat (x0 + 4)) + 4))%Z with (- Z.of_nat x0)%Z by lia.
    rewrite IZ_asym.
    rewrite IZ_asym.
    destruct a.
    apply (real_lt_plus_lt (x - Nreal (x0 + 4))) in H1.
    replace (x - Nreal (x0 + 4) + - x) with (- Nreal (x0 + 4)) in H1 by ring.
    replace (x - Nreal (x0 + 4) + Nreal (x0 + 4)) with x in H1 by ring.
    apply (real_lt_plus_lt (x - Nreal (x0 ))) in H0.
    replace (x - Nreal (x0 ) + - x) with (- Nreal (x0 )) in H0 by ring.
    replace (x - Nreal (x0 ) + Nreal (x0 )) with x in H0 by ring.
    rewrite (IZreal_Nreal) in H0.
    rewrite (IZreal_Nreal) in H1.
    split; auto.
    intros i j.
    destruct i, j.
    assert (r = r0) by apply irrl.
    rewrite H; auto.
    contradict (real_lt_nlt _ _ r r0).
    contradict (real_lt_nlt _ _ r r0).
    assert (r = r0) by apply irrl.
    rewrite H; auto.

    apply X.
    apply semidec_and; auto with real.
    apply semidec_or; auto with real.

    destruct (real_total_order x real_0).
    auto.
    destruct H.
    left.
    rewrite H.
    split.
    apply (real_lt_add_r (prec 1)).
    replace (- prec 1 + prec 1) with real_0 by ring.
    replace (real_0 + prec 1) with (prec 1) by ring.
    apply prec_pos.
    apply prec_pos.
    auto.

  Defined.

  Lemma rounding : forall x : Real,  M {k  | IZreal (k - 1) < x < IZreal (k + 1) }.
  Proof.
    intros.
    pose proof (naive_rounding x).
    apply (fun f => M_lift_dom _ _ f X).
    intro.
    destruct H.
    pose proof (choose (IZreal x0 < x < IZreal (x0 + 3)) (IZreal (x0 + 2) < x < IZreal (x0 + 4))).
    assert (semidec (IZreal x0 < x < IZreal (x0 + 3))) by (apply semidec_and; auto with real).
    assert (semidec (IZreal (x0 + 2) < x < IZreal (x0 + 4))) by (apply semidec_and; auto with real).
    assert (IZreal x0 < x < IZreal (x0 + 3) \/ IZreal (x0 + 2) < x < IZreal (x0 + 4)).
    apply overlapping; auto.
    apply IZreal_strict_monotone.
    lia.
    rename H into H1.
    rename X1 into H.
    rename X2 into H0.
    pose proof (X0 H H0 H1); clear X0 H H0 H1.
    apply (fun f => M_lift_dom _ _ f X1).
    intro; clear X1.
    destruct H.
    pose proof (choose (IZreal x0 < x < IZreal (x0 + 2)) (IZreal (x0 + 1) < x < IZreal (x0 + 3))).
    assert (semidec (IZreal x0 < x < IZreal (x0 + 2))) by (apply semidec_and; auto with real).
    assert (semidec (IZreal (x0 + 1) < x < IZreal (x0 + 3))) by (apply semidec_and; auto with real).
    assert (IZreal x0 < x < IZreal (x0 + 2) \/ IZreal (x0 + 1) < x < IZreal (x0 + 3)).
    apply overlapping; auto.
    apply IZreal_strict_monotone.
    lia.
    rename H into H1.
    rename X1 into H.
    rename X2 into H0.
    pose proof (X0 H H0 H1); clear H H0 H1.
    apply (fun f => M_lift_dom _ _ f X1).
    intro; clear X1.
    destruct H.
    apply M_unit.
    exists (x0 + 1)%Z.
    replace (x0 + 1 - 1)%Z with x0 by lia.
    replace (x0 + 1 + 1)%Z with (x0 + 2)%Z by lia.
    exact a1.
    apply M_unit.
    exists (x0 + 2)%Z.
    replace (x0 + 2 - 1)%Z with (x0 + 1)%Z by lia.
    replace (x0 + 2 + 1)%Z with (x0 + 3)%Z by lia.
    exact a1.
    apply M_unit.
    exists (x0 + 3)%Z.
    replace (x0 + 3 - 1)%Z with (x0 + 2)%Z by lia.
    replace (x0 + 3 + 1)%Z with (x0 + 4)%Z by lia.
    exact a0.
  Defined.

  Lemma M_approx_seq : forall x : Real, forall n,  M {z  | dist (prec n * IZreal z) x <= prec n}.
  Proof.
    intros.
    pose proof (rounding (x * Nreal (Npow2 n))).
    apply (fun f => M_lift _ _ f X).
    intro.
    destruct H.
    exists x0.
    apply (proj2   (dist_le_prop (prec n * IZreal x0) x (prec n) )).
    destruct a.
    apply (real_lt_mult_pos_lt _ _ _ (prec_pos n)) in H.
    replace (prec n * (x * Nreal (Npow2 n)))
      with ((prec n * Nreal (Npow2 n)) * x) in H by ring.
    rewrite prec_Npow2_unit in H.
    rewrite real_mult_unit in H.
    replace (IZreal (x0 - 1)) with (IZreal x0 - real_1) in H.
    replace (prec n * (IZreal x0 - real_1)) with (prec n * IZreal x0 - prec n) in H by ring.
    apply (real_lt_plus_lt (-x + prec n)) in H.
    replace (- x + prec n + (prec n * IZreal x0 - prec n)) with (prec n * IZreal x0 - x) in H by ring.
    replace (- x + prec n + x) with (prec n) in H by ring.

    apply (real_lt_mult_pos_lt _ _ _ (prec_pos n)) in H0.
    replace (prec n * (x * Nreal (Npow2 n)))
      with ((prec n * Nreal (Npow2 n)) * x) in H0 by ring.
    rewrite prec_Npow2_unit in H0.
    rewrite real_mult_unit in H0.
    replace (IZreal (x0 + 1)) with (IZreal x0 + real_1) in H0.
    replace (prec n * (IZreal x0 + real_1)) with (prec n * IZreal x0 + prec n) in H0 by ring.
    apply (real_lt_plus_lt (-x - prec n)) in H0.
    replace (- x - prec n + (prec n * IZreal x0 + prec n)) with (prec n * IZreal x0 - x) in H0 by ring.
    replace (- x - prec n + x) with (- prec n) in H0 by ring.
    split; left; auto.
    rewrite IZreal_hom.
    ring.
    replace (x0 - 1)%Z with (x0 + (-1))%Z by lia.
    rewrite IZreal_hom.

    ring.
  Defined.

  Definition dyadic_sequence : (nat -> Z) -> (nat -> Real) := fun f n => prec n * IZreal (f n).

  Definition dyadic_M_sequence : (nat -> M Z) -> (nat -> M Real).
  Proof.
    intros f n.
    apply (fun g => M_lift _ _ g (f n)).
    intro z.
    exact (prec n * IZreal z).
  Defined.

  Lemma approx_dyadic_sequence : forall x : Real, M {f : nat -> Z | is_fast_limit x (dyadic_sequence f)}.
  Proof.
    intros.
    pose proof (M_countable_lift _ (M_approx_seq x)).
    apply (fun f => M_lift _ _ f X).
    intro; clear X.
    exists (fun n => projP1 _ _ (H n)).
    intro n.
    unfold dyadic_sequence.
    destruct (H n).
    simpl.
    rewrite dist_symm.
    exact r.
  Defined.

  Definition converging_dyadic_M_sequence : forall x : Real, {f : nat -> M Z | M_is_fast_cauchy (dyadic_M_sequence f) /\ M_is_fast_limit_all x (dyadic_M_sequence f)}.
  Proof.
    intros.
    exists (fun n => projP1 _ _ (M_existence_to_all _ _  (M_approx_seq x n))).
    split.
    simpl.

    unfold M_is_fast_cauchy.
    intros.

    rewrite M_all_picture_1.
    intro.
    rewrite M_all_picture_1.
    intros.
    unfold dyadic_M_sequence in H, H0.
    pose proof (@M_fun_cont _ _ _ Z Real (fun z : Z => prec n * IZreal z) (M_projP1 Z (fun z : Z => dist (prec n * IZreal z) x <= prec n) (M_approx_seq x n)) a).
    unfold M_lift in H.
    simpl in H.
    rewrite H1 in H; clear H1.

    pose proof (@M_fun_cont _ _ _ Z Real (fun z : Z => prec m * IZreal z) (M_projP1 Z (fun z : Z => dist (prec m * IZreal z) x <= prec m) (M_approx_seq x m)) a0).
    unfold M_lift in H0.
    simpl in H0.
    rewrite H1 in H0; clear H1.
    destruct H, H0.
    destruct H.
    destruct H0.
    rewrite H1, H2.
    unfold M_projP1 in H.
    pose proof (M_fun_cont  (fun X0 : {x0 : Z | dist (prec n * IZreal x0) x <= prec n} => let (x0, _) := X0 in x0) (M_approx_seq x n) x0).
    rewrite H3 in H; clear H3.
    destruct H.
    destruct x2.

    destruct H.

    pose proof (M_fun_cont  (fun X0 : {x0 : Z | dist (prec m * IZreal x0) x <= prec m} => let (x0, _) := X0 in x0) (M_approx_seq x m) x1).
    unfold M_projP1 in H0.
    rewrite H4 in H0; clear H4.
    destruct H0.
    destruct x3.
    destruct H0.
    induction H3.
    induction H4.
    clear H0 H.
    rewrite <- H2; rewrite<- H2 in r0.
    rewrite <- H1; rewrite<- H1 in r.
    rewrite dist_symm in r0.
    pose proof (real_le_le_plus_le _ _ _ _  r r0).
    exact (real_le_le_le _ _ _ (real_ge_le _ _ (dist_tri a x a0)) H).

    intro.
    rewrite M_all_picture_1.
    intro.
    intros.
    unfold dyadic_M_sequence in H.
    rewrite (M_fun_cont (fun z : Z => prec n * IZreal z)) in H.
    destruct H.
    destruct H.
    unfold projP1 in H.
    unfold M_existence_to_all in H.
    unfold M_projP1 in H.
    rewrite M_fun_cont in H.
    destruct H.
    destruct H.
    destruct x1.
    induction H1.
    clear H.
    rewrite <- H0 in r.
    rewrite dist_symm.
    exact r.

  Defined.

End rounding.