(** printing |-#    %\vdash_{\#}%    #⊢##     *)
(** printing |-##   %\vdash_{\#\#}%  #⊢&#35&#35#  *)
(** printing |-##v  %\vdash_{\#\#v}% #⊢&#35&#35v# *)
(** printing |-!    %\vdash_!%       #⊢!#         *)
(** remove printing ~ *)

(** * Precise Typing (Elimination Typing II and III) *)

(** This module reasons about
    - properties of precise typing ⊢!! and ⊢!!! (only defined for paths)
    - about well-formedness of environments which is defined through precise typing
    - about equivalent types (path replacement with well-typed paths)
 *)

Set Implicit Arguments.

Require Import Sequences.
Require Import Coq.Program.Equality List.
Require Import Definitions Binding RecordAndInertTypes Replacement.
Require Export PreciseFlow.

Reserved Notation "G '⊢!!' p ':' T" (at level 40, p at level 59).
Reserved Notation "G '⊢!!!' p ':' T" (at level 40, p at level 59).

(** ** II-level Precise Typing *)
Inductive precise_typing2: ctx -> path -> typ -> Prop :=
| pt2: forall G p T U,
    G ⊢! p : T ⪼ U ->
    G ⊢!! p: U
| pt2_sngl_trans : forall G p q a U,
    G ⊢!! p : {{ q }} ->
    G ⊢!! q•a : U ->
    G ⊢!! p•a : {{ q•a }}
where "G '⊢!!' p ':' T" := (precise_typing2 G p T).

(** ** III-level Precise Typing *)
Inductive precise_typing3: ctx -> path -> typ -> Prop :=
| pt3: forall G p T,
    G ⊢!! p : T ->
    G ⊢!!! p: T
| pt3_sngl_trans : forall G p q T,
    G ⊢!! p : {{ q }} ->
    G ⊢!!! q : T ->
    G ⊢!!! p : T
where "G '⊢!!!' p ':' T" := (precise_typing3 G p T).

Hint Constructors precise_typing2 precise_typing3.

(** *** Properties of ⊢!! and ⊢!!!. Relationships between ⊢!, ⊢!!, and ⊢!!! *)

Lemma precise_to_general2: forall G p T,
    G ⊢!! p: T ->
    G ⊢ trm_path p : T.
Proof.
  introv Hp. induction Hp; eauto using precise_to_general.
Qed.

Lemma precise_to_general3: forall G p T,
    G ⊢!!! p: T ->
    G ⊢ trm_path p : T.
Proof.
  introv Hp. induction Hp; eauto using precise_to_general2.
Qed.

Lemma pt2_and_destruct1: forall G p T U,
    G ⊢!! p: T ∧ U ->
    G ⊢!! p: T.
Proof.
  introv Hp. dependent induction Hp; eauto.
Qed.

Lemma pt2_and_destruct2: forall G p T U,
    G ⊢!! p: T ∧ U ->
    G ⊢!! p: U.
Proof.
  introv Hp. dependent induction Hp; eauto.
Qed.

Lemma pt3_and_destruct1: forall G p T U,
    G ⊢!!! p: T ∧ U ->
    G ⊢!!! p: T.
Proof.
  introv Hp. dependent induction Hp; eauto. constructor.
  apply* pt2_and_destruct1.
Qed.

Lemma pt3_and_destruct2: forall G p T U,
    G ⊢!!! p: T ∧ U ->
    G ⊢!!! p: U.
Proof.
  introv Hp. dependent induction Hp; eauto. constructor.
  apply* pt2_and_destruct2.
Qed.

Lemma pt2_inertsngl : forall G p T,
    inert G ->
    G ⊢!! p: T ->
    inert_sngl T \/ record_type T.
Proof.
  introv Hi Pf. induction Pf.
  - apply* pf_inertsngl.
  - left. right. eexists. eauto.
Qed.

Lemma pt3_inertsngl : forall G p T,
    inert G ->
    G ⊢!!! p: T ->
    inert_sngl T \/ record_type T.
Proof.
  introv Hi Pf. induction Pf; eauto;
  apply* pt2_inertsngl.
Qed.

Lemma pt2_psel: forall G p q A,
    inert G ->
    G ⊢!! p : q ↓ A -> False.
Proof.
  introv Hi Hp. dependent induction Hp; eauto. apply* pf_psel.
Qed.

Lemma pt3_psel: forall G p q A,
    inert G ->
    G ⊢!!! p : q ↓ A -> False.
Proof.
  introv Hi Hp. dependent induction Hp; eauto. apply* pt2_psel.
Qed.

Lemma pt3_trans: forall G p q a U,
    G ⊢!! p : {{ q }}->
    G ⊢!!! q•a : U ->
    G ⊢!!! p•a : U.
Proof.
  introv Hp Hq. gen p. dependent induction Hq; introv Hp; eauto.
Qed.

Lemma pt3_trans2: forall G p q a U,
    G ⊢!!! p : {{ q }}->
    G ⊢!!! q•a : U ->
    G ⊢!!! p•a : U.
Proof.
  introv Hp Hq. gen a U. dependent induction Hp; introv Hq.
  - apply* pt3_trans.
  - specialize (IHHp _ eq_refl _ _ Hq). apply* pt3_trans.
Qed.

Lemma pt3_field_elim: forall G p a T,
    G ⊢!!! p : typ_rcd { a ⦂ T } ->
    G ⊢!!! p•a : T.
Proof.
  introv Hp. dependent induction Hp.
  - dependent induction H; eauto.
  - specialize (IHHp _ _ eq_refl).
    gen p. dependent induction IHHp; introv Hpq; eauto.
Qed.

Lemma path_elim_prec: forall G p q a T,
    inert G ->
    G ⊢!!! p: {{ q }}->
    G ⊢!!! q•a : T ->
    G ⊢!!! p•a : {{ q•a }}.
Proof.
  introv Hi Hp Hq.
  gen a T. dependent induction Hp; introv Hq.
  - inversion* Hq.
  - specialize (IHHp _ Hi eq_refl _ _ Hq). apply* pt3_trans.
Qed.

Lemma pf_pt2: forall G p T U V,
    inert G ->
    G ⊢! p: T ⪼ U ->
    G ⊢!! p: V ->
    inert_sngl V ->
    T = V.
Proof.
  introv Hi Hp1 Hp2 His. gen T U. induction Hp2; introv Hp1.
  - lets Heq: (pf_T_unique Hi Hp1 H). subst. destruct His.
    * destruct H0. apply* pf_forall_T. apply* pf_bnd_T.
    * inversions H0. destruct_all. apply* pf_sngl_T.
  - destruct (pf_path_sel _ _ Hi Hp1) as [V Hp].
    assert (inert_sngl {{ q }}) as His'. { right. eexists. auto. }
    specialize (IHHp2_1 Hi His' _ _ Hp). inversion IHHp2_1.
Qed.

Lemma pf_pt2_sngl: forall G p T U q,
    inert G ->
    G ⊢! p: T ⪼ U ->
    G ⊢!! p: {{ q }}->
    T = {{ q }}.
Proof.
  introv Hi Hp1 Hp2. apply* pf_pt2. right. eexists. auto.
Qed.

Lemma field_elim_q0: forall G p q a T,
    inert G ->
    G ⊢! p: {{ q }}⪼ {{ q }}->
    G ⊢!! p•a : T ->
    exists U, G ⊢!! q•a: U.
Proof.
  introv Hi Hp Hpa. gen q.
  dependent induction Hpa; introv Hp; eauto.
  - dependent induction H; try simpl_dot; eauto.
    lets Heq: (pf_T_unique Hi Hp H). subst.
    apply pf_sngl_U in H. inversion H.
  - clear IHHpa1 IHHpa2. simpl_dot.
    lets Heq: (pf_pt2_sngl Hi Hp Hpa1). inversion* Heq.
Qed.

Lemma field_elim_q0': forall G p q a T T',
    inert G ->
    G ⊢!! p: {{ q }}->
    G ⊢! p•a : T ⪼ T' ->
    exists U, G ⊢!! q•a: U.
Proof.
  introv Hi Hp Hpa. gen q.
  dependent induction Hpa; introv Hp; try simpl_dot; eauto.
  lets Hp2: (pf_pt2_sngl Hi Hpa Hp). subst.
  apply pf_sngl_U in Hpa. inversion Hpa.
Qed.

Lemma pf_pt2_sngl_invert G p q a T U :
    inert G ->
    G ⊢!! p: {{ q }}->
    G ⊢! p•a : T ⪼ U ->
    False.
Proof.
  intros Hi Hp Hpf.
  assert (exists V S, G ⊢! p: V ⪼ S) as [V [S Hpvs]]. {
      dependent induction Hpf; try simpl_dot; eauto.
    }
  lets ->: (pf_pt2_sngl Hi Hpvs Hp). clear Hp.
  dependent induction Hpf; try simpl_dot; eauto.
  lets Heq: (pf_T_unique Hi Hpvs Hpf). subst. apply pf_sngl_U in Hpf as[=].
Qed.

Lemma pt2_sngl_exists: forall G p q T,
    inert G ->
    G ⊢!! p: {{ q }}->
    G ⊢!! p: T ->
    exists q', T = {{ q' }}.
Proof.
  introv Hi Hp Ht. gen T. dependent induction Hp; introv Ht; eauto.
  - lets ->: (pf_sngl_T Hi H). dependent induction Ht; eauto.
    lets Heq: (pf_T_unique Hi H H0). subst. eauto using pf_sngl_U.
  - dependent induction Ht; eauto.
    lets Contra: (pf_pt2_sngl_invert _ Hi Hp1 H). inversion Contra.
Qed.

Lemma pt2_sngl_unique: forall G p q1 q2,
    inert G ->
    G ⊢!! p: {{ q1 }} ->
    G ⊢!! p: {{ q2 }} ->
    q1 = q2.
Proof.
  introv Hi Hp. gen q2. dependent induction Hp; introv Ht; eauto.
  - lets ->: (pf_sngl_T Hi H). dependent induction Ht; eauto.
    * lets Heq: (pf_T_unique Hi H H0). subst.
      apply pf_sngl_U in H0 as [=]. auto.
    * lets Contra: (pf_pt2_sngl_invert _ Hi Ht1 H). inversion Contra.
  - specialize (IHHp1 _ Hi eq_refl). gen q U.
    dependent induction Ht; introv Hpq IH1; introv Hqa IH2.
    * lets Contra: (pf_pt2_sngl_invert _ Hi Hpq H). inversion Contra.
    * simpl_dot. f_equal. eauto.
Qed.

Lemma pt2_sngl_unique' G p q T :
    inert G ->
    G ⊢!! p: {{ q }}->
    G ⊢!! p: T ->
    T = {{ q }}.
Proof.
  introv Hi Hp Hpt. destruct (pt2_sngl_exists Hi Hp Hpt) as [q' ->]. f_equal.
  eauto using pt2_sngl_unique.
Qed.

Lemma field_elim_q: forall G p q a T,
    inert G ->
    G ⊢!! p: {{ q }}->
    G ⊢!! p•a : T ->
    exists U, G ⊢!! q•a: U.
Proof.
  introv Hi Hp Hpa. gen a T. dependent induction Hp; introv Hpa.
  - lets Heq: (pf_sngl_T Hi H). subst. apply* field_elim_q0.
  - clear IHHp1 IHHp2.
    gen q0 U. dependent induction Hpa; introv Hp; introv Hq0.
    * apply* field_elim_q0'.
    * unfold sel_fields in x. destruct p0, p. inversions x.
      lets Hxbs: (pt2_sngl_trans _ Hp Hq0).
      assert (inert_sngl {{ q }}) as His. {
        right. eexists. eauto.
      }
      simpl in *.
      lets Hu: (pt2_sngl_unique Hi Hpa1 Hxbs).
      inversions Hu. eauto.
Qed.

Lemma field_elim_q2: forall G p q a T,
    inert G ->
    G ⊢!!! p: {{ q }}->
    G ⊢!! p•a : T ->
    exists U, G ⊢!!! q•a: U.
Proof.
  introv Hi Hp Hpa. gen a T. dependent induction Hp; introv Hpa.
  - destruct* (field_elim_q _ Hi H Hpa).
  - specialize (IHHp _ Hi eq_refl).
    destruct (field_elim_q _ Hi H Hpa) as [V Hqa]. apply* IHHp.
Qed.

Lemma field_elim_q3: forall G p q a T,
    inert G ->
    G ⊢!!! p: {{ q }}->
    G ⊢!!! p•a : T ->
    exists U, G ⊢!!! q•a: U.
Proof.
  introv Hi Hp Hpa.
  gen q. dependent induction Hpa; introv Hp.
  - gen a T. dependent induction Hp; introv Hpa;
               destruct* (field_elim_q _ Hi H Hpa).
  - clear IHHpa Hpa T. gen a q. dependent induction Hp; introv Hpa.
    * destruct* (field_elim_q _ Hi H Hpa).
    * lets Hp': (pt3_sngl_trans H Hp). apply* field_elim_q2.
Qed.

Lemma pt2_field_elim_p: forall G p q a U,
    inert G ->
    G ⊢!! p: {{ q }}->
    G ⊢!! p • a : U ->
    G ⊢!! p • a : {{ q•a }}.
Proof.
  introv Hi Hpq Hpa. destruct (field_elim_q _ Hi Hpq Hpa) as [T Hqa].
  apply* pt2_sngl_trans.
Qed.

Lemma pt3_field_elim_p: forall G p q a U,
    inert G ->
    G ⊢!!! p: {{ q }}->
    G ⊢!!! p • a : U ->
    G ⊢!!! p • a : {{ q•a }}.
Proof.
  introv Hi Hpq Hpa. destruct (field_elim_q3 _ Hi Hpq Hpa) as [T Hqa].
  apply* path_elim_prec.
Qed.

Lemma pt2_backtrack : forall G p a T,
    G ⊢!! p • a : T ->
    exists U, G ⊢!! p : U.
Proof.
  introv Hp. dependent induction Hp; eauto.
  - dependent induction H; try simpl_dot; eauto.
  - simpl_dot. eauto.
Qed.

Lemma pt3_backtrack : forall G p a T,
    G ⊢!!! p • a : T ->
    exists U, G ⊢!!! p : U.
Proof.
  introv Hp. dependent induction Hp;
               apply pt2_backtrack in H; destruct_all; eauto.
Qed.

Lemma pt3_sngl_trans3: forall G p q T,
    G ⊢!!! p: {{ q }}->
    G ⊢!!! q: T ->
    G ⊢!!! p : T.
Proof.
  introv Hp Hq. gen T. dependent induction Hp; introv Hq; eauto.
Qed.

Lemma pt2_field_trans: forall G p q bs T,
    inert G ->
    G ⊢!! p : {{ q }}->
    G ⊢!! q••bs : T ->
    G ⊢!! p••bs : {{ q••bs }}.
Proof.
  Proof.
  introv Hi Hp Hq. gen T q. induction bs; introv Hp Hq;
                              unfolds sel_fields; destruct q, p; simpls; auto.
  rewrite proj_rewrite in *.
  destruct (pt2_backtrack _ _ Hq) as [U Hb].
  specialize (IHbs _ _ Hp Hb). rewrite proj_rewrite.
  apply* pt2_sngl_trans.
Qed.

Lemma pt3_field_trans: forall G p q bs T,
    inert G ->
    G ⊢!!! p : {{ q }}->
    G ⊢!!! q••bs : T ->
    G ⊢!!! p••bs : {{ q••bs }}.
Proof.
  introv Hi Hp Hq. gen T q. induction bs; introv Hp Hq;
                              unfolds sel_fields; destruct q, p; simpls; auto.
  rewrite proj_rewrite in *.
  destruct (pt3_backtrack _ _ Hq) as [U Hb].
  specialize (IHbs _ _ Hp Hb). rewrite proj_rewrite. apply* path_elim_prec.
Qed.

Lemma pt3_field_trans': forall G p q bs T,
    inert G ->
    G ⊢!!! p : {{ q }}->
    G ⊢!!! q••bs : T ->
    G ⊢!!! p••bs : T.
Proof.
  introv Hi Hp1 Hp2. gen p q T.
  induction bs; introv Hp1; introv Hp2; unfolds sel_fields; destruct q, p; simpls.
  - apply* pt3_sngl_trans3.
  - rewrite proj_rewrite in *.
    destruct (pt3_backtrack _ _ Hp2) as [S Hb].
    lets Hh: (pt3_field_trans _ Hi Hp1 Hb).
    apply* pt3_sngl_trans3. apply* path_elim_prec.
Qed.

Lemma pt2_weaken_one G p T x U :
  ok (G & x ~ U) ->
  G ⊢!! p : T ->
  G & x ~ U ⊢!! p : T.
Proof.
  intros Hx Hp. induction Hp.
  - econstructor. rewrite <- concat_empty_r in Hx. apply* pf_weaken_one. do 2 eapply ok_concat_inv_l; eauto.
  - eapply pt2_sngl_trans; eauto.
Qed.

Lemma pt2_weaken G p T G' :
  ok (G & G') ->
  G ⊢!! p : T ->
  G & G' ⊢!! p : T.
Proof.
  intros Hok Hp. induction G' using env_ind.
  - rewrite* concat_empty_r.
  - rewrite concat_assoc in *. apply* pt2_weaken_one.
Qed.

Lemma pt3_weaken_one G p T x U :
  ok (G & x ~ U) ->
  G ⊢!!! p : T ->
  G & x ~ U ⊢!!! p : T.
Proof.
  intros Hx Hp. induction Hp.
  - econstructor. rewrite <- concat_empty_r in Hx. apply* pt2_weaken_one.
  - eapply pt3_sngl_trans; eauto. apply* pt2_weaken_one.
Qed.

Lemma pt3_weaken G G' p T :
  ok (G & G') ->
  G ⊢!!! p: T ->
  G & G' ⊢!!! p: T.
Proof.
  intros Hok Hp. induction G' using env_ind.
  - rewrite* concat_empty_r.
  - rewrite concat_assoc in *. apply* pt3_weaken_one.
Qed.

Lemma pf_strengthen_full G p T U :
  inert G ->
  G ⊢! p : T ⪼ U ->
  exists G1 G2 x bs V, G = G1 & x ~ V & G2 /\
                p = p_sel (avar_f x) bs /\
                G1 & x ~ V ⊢! p : T ⪼ U.
Proof.
  intros Hi Hp.
  pose proof (typed_paths_named (precise_to_general Hp)) as [x [bs ->]].
  induction G as [|G1 y V] using env_ind.
  - apply precise_to_general in Hp. false* typing_empty_false.
  - destruct (classicT (y = x)) as [-> | Hn].
    + repeat eexists; eauto. rewrite* concat_empty_r.
    + apply pf_strengthen in Hp; auto.
      specialize (IHG (inert_prefix Hi) Hp) as [G1' [G2' [z [cs [W [-> [[= -> ->] Hp']]]]]]].
      repeat eexists; eauto. rewrite concat_assoc. eauto.
Qed.

Lemma pt2_destruct_env G p T :
  inert G ->
  G ⊢!! p : T ->
  exists G1 G2 x bs V, G = G1 & x ~ V & G2 /\
                  p = p_sel (avar_f x) bs.
Proof.
  intros Hi Hp. induction Hp.
  - apply pf_strengthen_full in H; auto. destruct_all; repeat eexists; eauto.
  - specialize (IHHp1 Hi). specialize (IHHp2 Hi). destruct_all. simpl_dot. repeat eexists.
Qed.

Lemma pt2_var_sngl G x p :
  inert G ->
  G ⊢!! pvar x : {{ p }}->
  False.
Proof.
  intros Hi Hp. dependent induction Hp; try simpl_dot.
  pose proof (pf_sngl_T Hi H) as ->. apply (pf_binds Hi) in H.
  apply (binds_inert H) in Hi. inversion Hi.
Qed.

Lemma pt2_to_pf G p T :
  G ⊢!! p : T ->
  (inert_typ T \/ record_type T) ->
  exists U, G ⊢! p : U ⪼ T.
Proof.
  intros Hp [Hin | Hr].
  - inversions Hin; inversions Hp; eauto.
  - inversions Hr. inversions H; inversions Hp; eauto.
Qed.

Lemma pt3_trans_trans: forall G p q bs T,
    inert G ->
    G ⊢!!! p : {{ q }}->
    G ⊢!!! p••bs : T ->
    G ⊢!!! p••bs : {{ q••bs }}.
Proof.
  introv Hi Hp Hpbs. gen p q T.
  induction bs; introv Hp; introv Hpbs; unfolds sel_fields; destruct p, q; simpls; auto.
  repeat rewrite proj_rewrite in *. apply* pt3_field_elim_p.
  specialize (IHbs _ _ Hp). apply pt3_backtrack in Hpbs. destruct_all. eauto.
Qed.

Lemma pt2_bnd : forall G p T,
    inert G ->
    G ⊢!! p: μ T ->
    G ⊢!! p: open_typ_p p T.
Proof.
  introv Hi Hp. dependent induction Hp; eauto.
Qed.

Lemma pt2_exists: forall G p T,
    G ⊢!!! p: T ->
    exists U, G ⊢!! p: U.
Proof.
  induction 1; eauto.
Qed.

Lemma pt3_bnd : forall G p T,
    inert G ->
    G ⊢!!! p: μ T ->
    G ⊢!!! p: open_typ_p p T \/
              (exists q U, G ⊢!!! p: {{ q }}/\ G ⊢!! q : U /\ G ⊢!!! p: open_typ_p q T).
Proof.
  introv Hi Hp. dependent induction Hp.
  - left. constructor. apply* pt2_bnd.
  - specialize (IHHp _ Hi eq_refl). destruct IHHp as [Hq | [r [U [Hr1 [Hq Hr2]]]]]; right.
    + apply pt2_exists in Hp as [? ?]. repeat eexists; eauto.
    + exists r. repeat eexists; eauto.
Qed.

Lemma pf_pt2_trans_inv_mult : forall G p q bs T,
    inert G ->
    G ⊢! p: {{ q }}⪼ {{ q }}->
    G ⊢!! p •• bs : T ->
    T = {{ q••bs }}.
Proof.
  introv Hi Hp Hpbs. gen T. induction bs; introv Hpbs.
  - repeat rewrite field_sel_nil in *. apply pt2 in Hp. apply eq_sym. apply eq_sym.
    eauto using pt2_sngl_unique'.
  - rewrite proj_rewrite' in *. destruct (pt2_backtrack _ _ Hpbs) as [U Hb].
    apply pt2 in Hp. specialize (IHbs _ Hb). subst.
    destruct (field_elim_q _ Hi Hb Hpbs) as [U Hf].
    lets Hp2: (pt2_sngl_trans _ Hb Hf).
    eauto using pt2_sngl_unique'.
Qed.

Lemma pf_pt3_trans_inv_mult : forall G p q T,
    inert G ->
    G ⊢!! p: {{ q }}->
    G ⊢!!! p : T ->
    inert_typ T \/ record_type T ->
    G ⊢!!! q : T.
Proof.
  introv Hi Hpq Hp Hr. gen q. induction Hp; introv Hpq.
  - constructor.
    assert (inert_sngl {{ q }}) as His. {
      right. eexists. eauto.
    }
    lets ->: (pt2_sngl_unique' Hi Hpq H). destruct Hr.
    inversion His. inversion H1. inversion H0. inversion H0. inversion H1.
  - specialize (IHHp Hi Hr).
    assert (inert_sngl {{ q }}) as His1. {
      right. eexists. eauto.
    }
    assert (inert_sngl {{ q0 }}) as His2. {
      right. eexists. eauto.
    }
    lets Heq: (pt2_sngl_unique' Hi Hpq H). inversions Heq. eauto.
Qed.

Lemma pf_pt3_trans_inv_mult' : forall G p q T bs,
    inert G ->
    G ⊢! p: {{ q }}⪼ {{ q }}->
    G ⊢!!! p •• bs : T ->
    inert_typ T \/ record_type T ->
    G ⊢!!! q •• bs : T.
Proof.
  introv Hi Hp Hpbs Hr.
  assert (exists U, G ⊢!! p •• bs : U) as [U Hu] by apply* pt2_exists.
  apply* pf_pt3_trans_inv_mult. lets Hpf: (pf_pt2_trans_inv_mult _ Hi Hp Hu). subst*.
Qed.

Lemma pf_pt3_unique : forall G p S A T U,
    inert G ->
    G ⊢! p: S ⪼ typ_rcd {A >: T <: T} ->
    G ⊢!!! p: typ_rcd {A >: U <: U} ->
    T = U.
Proof.
  introv Hi Hp1 Hp3. dependent induction Hp3.
  - apply pt2 in Hp1. dependent induction H. dependent induction Hp1.
    lets Hu: (pf_T_unique Hi H0 H). subst.
    destruct (pf_bnd_T2 Hi H0) as [V Heq]. subst.
    apply* pf_dec_typ_unique.
  - clear IHHp3. apply pt2 in Hp1. assert (inert_sngl {{ q }}) as His. {
      right. eexists. eauto.
    }
    lets Hu: (pt2_sngl_unique' Hi H Hp1). inversion Hu.
Qed.

Lemma pt23_invert : forall G p q T,
    inert G ->
    G ⊢!! p : T ->
    G ⊢!!! p : {{ q }}->
    exists q', {{ q' }} = T /\ (q = q' \/ G ⊢!!! q' : {{ q }}).
Proof.
  introv Hi Hp Hpq. gen T. dependent induction Hpq; introv Hp.
  - exists q. split*.
    apply eq_sym. apply* pt2_sngl_unique'.
  - lets Hu: (pt2_sngl_unique' Hi H Hp). subst*.
Qed.

Lemma pt3_invert : forall G p q T,
    inert G ->
    G ⊢!!! p : T ->
    G ⊢!!! p : {{ q }}->
    G ⊢!!! q: T \/ exists q', {{ q' }} = T /\ (q = q' \/ G ⊢!!! q' : {{ q }}).
Proof.
  introv Hi Hp Hpq. gen q. dependent induction Hp; introv Hpq.
  - right. apply* pt23_invert.
  - destruct (pt23_invert Hi H Hpq) as [q' [Heq [Heq' | Hq']]]; inversions Heq; eauto.
Qed.

Lemma pt3_var_sngl G x p :
  inert G ->
  G ⊢!!! pvar x : {{ p }}->
  False.
Proof.
  intros Hi Hp. dependent induction Hp; false* pt2_var_sngl.
Qed.

Lemma pf_inert_pt2_sngl_false G p q T U :
  inert G ->
  G ⊢! p : T ⪼ U ->
  G ⊢!! p : {{ q }}->
  inert_typ T ->
  False.
Proof.
  intros Hi Hp Hq Hin. gen q. dependent induction Hp; eauto; introv Hpq.
  - false* pt3_var_sngl.
  - lets Hp': (pf_fld Hp). pose proof (pf_pt2_sngl Hi Hp' Hpq) as ->. inversion Hin.
Qed.

Lemma pf_inert_pt3_sngl_false G p q T U :
  inert G ->
  G ⊢! p : T ⪼ U ->
  G ⊢!!! p : {{ q }}->
  inert_typ T ->
  False.
Proof.
  intros Hi Hp Hq Hin. gen T U. dependent induction Hq; introv Hin; introv Hp;
  apply* pf_inert_pt2_sngl_false.
Qed.

Lemma pt3_inert_pt2_sngl_invert G p q T :
  inert G ->
  G ⊢!!! p : T ->
  G ⊢!! p : {{ q }}->
  inert_typ T ->
  G ⊢!!! q : T.
Proof.
  intros Hi Hp Hpq Hin. gen q. induction Hp; introv Hpq.
  - pose proof (pt2_sngl_unique' Hi Hpq H) as ->. inversion Hin.
  - pose proof (pt2_sngl_unique Hi H Hpq) as ->. eauto.
Qed.

Lemma pt3_inert_sngl_invert G p q T :
  inert G ->
  G ⊢!!! p : T ->
  G ⊢!!! p : {{ q }}->
  inert_typ T ->
  G ⊢!!! q : T.
Proof.
  introv Hi Hp Hpq. gen T. dependent induction Hpq; introv Hp Hin;
                             [.. | apply* IHHpq];
                             eapply (pt3_inert_pt2_sngl_invert Hi Hp); eauto.
Qed.

Lemma pt2_dec_typ_tight: forall G p A S U,
    inert G ->
    G ⊢!! p: typ_rcd {A >: S <: U} ->
    S = U.
Proof.
  introv Hi Hp. dependent induction Hp; eauto. apply* pf_dec_typ_tight.
Qed.

Lemma pt3_dec_typ_tight: forall G p A S U,
    inert G ->
    G ⊢!!! p: typ_rcd {A >: S <: U} ->
    S = U.
Proof.
  introv Hi Hp. dependent induction Hp; eauto. apply* pt2_dec_typ_tight.
Qed.

Lemma last_path G p T U :
  inert G ->
  G ⊢!!! p : ∀(T) U ->
  G ⊢!! p : ∀(T) U \/ exists q, G ⊢!!! p: {{ q }} /\ G ⊢!! q : ∀(T) U.
Proof.
  intros Hi Hp. dependent induction Hp; eauto.
  specialize (IHHp _ _ Hi eq_refl) as [Hq | [r [Hq Hr]]]; eauto.
Qed.

Lemma pt2_qbs_typed G p q T bs V:
  inert G ->
  G ⊢! p : {{ q }} ⪼ {{ q }} ->
  G ⊢!! q : T ->
  G ⊢!! p••bs : V ->
  exists U, G ⊢!! q •• bs : U.
Proof.
  intros Hi Hp Hq Hpbs.
  pose proof (pf_pt2_trans_inv_mult _ Hi Hp Hpbs) as ->.
  gen T. dependent induction Hpbs.
  - pose proof (pf_sngl_flds_elim _ Hi Hp H) as ->. rewrite* field_sel_nil.
  - destruct p0 as [p0x p0bs].
    destruct p as [px pbs].
    destruct q as [qx qbs].
    destruct q0 as [q0x q0bs]. inversions x0. inversions x. simpl in IHHpbs2, IHHpbs1.
    destruct bs as [|b bs].
    + rewrite app_nil_l in *. subst. eauto.
    + rewrite <- app_comm_cons in *. inversions H1. inversions H2. eauto.
Qed.

(** ** Wellformed paths and environments *)

Inductive wf : ctx -> Prop :=
| wfe_empty :
    wf empty
| wfe_push G x T :
    wf G ->
    x # G ->
    (forall bs q, G & x ~ T ⊢! p_sel (avar_f x) bs : {{ q }}⪼ {{ q }}->
             exists U, G & x ~ T ⊢!! q : U) ->
    wf (G & x ~ T).

Hint Constructors wf.

Lemma wf_prefix_one G x T :
  wf (G & x ~ T) -> wf G.
Proof.
  intros Hwf. dependent induction Hwf.
  - false* empty_push_inv.
  - apply eq_push_inv in x as [-> [-> ->]]. destruct G as [|G x U] using env_ind; auto.
Qed.

Lemma wf_prefix G G' :
  wf (G & G') -> wf G.
Proof.
  intros Hwf. gen G. induction G' using env_ind; introv Hwf.
  - rewrite concat_empty_r in Hwf; auto.
  - rewrite concat_assoc in *. apply IHG'. apply* wf_prefix_one.
Qed.

Hint Resolve wf_prefix wf_prefix_one.

(** ** Strengthening and Typing of Singleton Types *)
(** Strengthening is the opposite of weakening: removing elements
    of the typing environment. The strengthening lemmas state that
    in a well-formed environment [Γ, x: T], precise typing of a path [y.bs] is
 preserved in the strengthened environment [Γ] if [x ≠ y]. *)

Lemma pf_strengthen_one_helper G y bs T x q :
  inert (G & x ~ T) ->
  wf G ->
  G & x ~ T ⊢! p_sel (avar_f y) bs : {{ q }}⪼ {{ q }}->
  x <> y ->
  exists U, G ⊢!! q : U.
Proof.
  intros Hi Hwf. gen y bs q x T. dependent induction Hwf; introv Hi Hy Hn.
  - rewrite concat_empty_l in *. apply precise_to_general in Hy.
    apply typing_implies_bound in Hy as [S Hb]. apply binds_single_inv in Hb as [-> _]. false*.
  - apply pf_strengthen in Hy; auto.
    destruct (classicT (x = y)) as [-> | Hn']; eauto.
    specialize (IHHwf _ _ _ _ _ (inert_prefix Hi) Hy Hn') as [S Hq]. eexists. apply* pt2_weaken. apply inert_ok.
    apply inert_prefix in Hi; auto.
Qed.

Lemma pt2_strengthen_one_helper G y bs T x q :
  inert (G & x ~ T) ->
  wf G ->
  G & x ~ T ⊢!! p_sel (avar_f y) bs : {{ q }}->
  x <> y ->
  G ⊢!! p_sel (avar_f y) bs : {{ q }}/\ exists S, G ⊢!! q : S.
Proof.
  intros Hi Hwf Ht Hn. dependent induction Ht.
  - split. econstructor. apply* pf_strengthen.
    apply* pf_strengthen_one_helper. pose proof (pf_sngl_T Hi H) as ->. apply H.
  - simpl_dot.
    specialize (IHHt1 _ _ _ _ _ _ Hi Hwf JMeq_refl eq_refl eq_refl Hn) as [IHy [S IHq]].
    pose proof (typed_paths_named (precise_to_general2 Ht2)) as [qx [qbs Heq]]. simpl_dot. simpl in IHHt2.
    assert (x0 <> qx) as Hn'. {
      pose proof (typing_implies_bound (precise_to_general2 IHq)) as [W Hb].
      apply inert_ok in Hi. intros ->. apply ok_push_inv in Hi as [_ Hq]. eapply binds_fresh_inv; eauto.
    }
    rewrite proj_rewrite in *.
    pose proof (pt2_inertsngl Hi Ht2) as [[Hin | [q ->]] | Hr].
    + pose proof (pt2_to_pf Ht2 (or_introl Hin)) as [? Hpr]. apply pf_strengthen in Hpr; auto; split*.
    + specialize (IHHt2 _ _ _ _ _ _ Hi Hwf JMeq_refl eq_refl eq_refl Hn') as [IHqx [W IHq']].
      split.
      * rewrite proj_rewrite in *. eauto.
      * simpl. eexists; eauto.
    + pose proof (pt2_to_pf Ht2 (or_intror Hr)) as [? Hpr]. apply pf_strengthen in Hpr; auto; split*.
Qed.

Lemma pt2_strengthen_one G y bs T x U :
  inert (G & x ~ T) ->
  wf G ->
  G & x ~ T ⊢!! p_sel (avar_f y) bs : U ->
  x <> y ->
  G ⊢!! p_sel (avar_f y) bs : U.
Proof.
  intros Hi Hwf Ht Hn.
  pose proof (pt2_inertsngl Hi Ht) as [[Hin | [q ->]] | Hr].
  - pose proof (pt2_to_pf Ht (or_introl Hin)) as [? Hpr]. apply pf_strengthen in Hpr; eauto.
  - apply* pt2_strengthen_one_helper.
  - pose proof (pt2_to_pf Ht (or_intror Hr)) as [? Hpr]. apply pf_strengthen in Hpr; eauto.
Qed.

(** *** Typing of paths that form singleton types *)

(** The following lemmas state that if a path has a precise type [q.type]
    in a well-formed environment, then [q] is typeable. *)

Lemma sngl_typed G p q :
    inert G ->
    wf G ->
    G ⊢! p: {{ q }}⪼ {{ q }}->
    exists T, G ⊢!! q: T.
Proof.
  intros Hi Hwf Hp. gen p q.
  induction Hwf; introv Hpq.
  - apply precise_to_general in Hpq. false* typing_empty_false.
  - pose proof (typed_paths_named (precise_to_general Hpq)) as [px [pbs ->]].
    destruct (classicT (x = px)) as [-> | Hn]; eauto.
    pose proof (pf_strengthen_one_helper Hi Hwf Hpq Hn) as [U Hq]. eexists. apply* pt2_weaken.
Qed.

Lemma sngl_typed2 : forall G p q,
    inert G ->
    wf G ->
    G ⊢!! p: {{ q }}->
    exists T, G ⊢!! q: T.
Proof.
  introv Hi Hwf Hpq. dependent induction Hpq; eauto.
  pose proof (pf_sngl_T Hi H) as ->. apply* sngl_typed.
Qed.

Lemma sngl_typed3 : forall G p q,
    inert G ->
    wf G ->
    G ⊢!!! p: {{ q }}->
    exists T, G ⊢!!! q: T.
Proof.
  introv Hi Hwf Hp. dependent induction Hp; eauto.
  destruct* (sngl_typed2 Hi Hwf H).
Qed.

Lemma pt2_fld_strengthen G p a T U G' :
  inert (G & G') ->
  wf G ->
  G ⊢!! p : T ->
  G & G' ⊢!! p • a : U ->
  G ⊢!! p • a : U.
Proof.
  intros Hi Hwf Hp Hpa. gen T. dependent induction Hpa; introv Hp.
  - pose proof (pf_strengthen_full Hi H) as [G1 [G2 [px [pbs [V [HeqG [Heqp Hp1]]]]]]]. simpl_dot.
    pose proof (pt2_destruct_env (inert_prefix Hi) Hp) as [G1' [G2' [px' [pbs' [V' [-> [= -> ->]]]]]]].
    rewrite <- concat_assoc in *. apply env_ok_inv' in HeqG as [-> [-> <-]].
    + rewrite concat_assoc in *. apply* pt2_weaken. apply* inert_ok. apply* inert_prefix.
    + apply* inert_ok.
  - simpl_dot.
    destruct f0.
    + pose proof (typed_paths_named (precise_to_general2 Hpa1)) as [px [pbs [= -> <-]]]. false* pt2_var_sngl.
    + rewrite proj_rewrite in *.
      pose proof (pt2_backtrack _ _ Hp) as [W Hpb]. specialize (IHHpa1 _ _ _ _ Hi Hwf JMeq_refl eq_refl _ Hpb).
      specialize (IHHpa2 _ _ _ _ Hi Hwf JMeq_refl eq_refl).
      pose proof (sngl_typed2 (inert_prefix Hi) Hwf IHHpa1) as [X Hq]. eauto.
Qed.

Lemma pt2_strengthen G G1 G2 bs T x U :
  G = G1 & x ~ T & G2 ->
  inert G ->
  wf G ->
  G ⊢!! p_sel (avar_f x) bs : U ->
  G1 & x ~ T ⊢!! p_sel (avar_f x) bs : U.
Proof.
  intros -> Hi Hwf Hp. induction G2 using env_ind.
  - rewrite concat_empty_r in *. auto.
  - destruct (classicT (x0 = x)) as [-> | Hn].
    + apply inert_ok in Hi. apply ok_middle_inv_r in Hi. simpl_dom. apply notin_union in Hi as [Contra _].
      false* notin_same.
    + rewrite concat_assoc in *. eapply pt2_strengthen_one in Hp; auto.
      specialize (IHG2 (inert_prefix Hi) (wf_prefix Hwf) Hp). eauto. apply* wf_prefix.
Qed.

Lemma pt3_strengthen_one G bs T x y U :
  inert (G & x ~ T) ->
  wf (G & x ~ T) ->
  G & x ~ T ⊢!!! p_sel (avar_f y) bs : U ->
  y <> x ->
  G ⊢!!! p_sel (avar_f y) bs : U.
Proof.
  intros Hi Hwf Hp Hn. dependent induction Hp.
  - constructor. apply* pt2_strengthen_one.
  - pose proof (sngl_typed2 Hi Hwf H) as [U Ht%precise_to_general2]. apply typed_paths_named in Ht as [qx [qbs ->]].
    destruct (classicT (qx = x)) as [-> | Hn'].
    + clear IHHp. apply pt2_strengthen_one in H; eauto.
      apply (sngl_typed2 (inert_prefix Hi)) in H as [S Ht]; eauto.
      apply (pt2_destruct_env (inert_prefix Hi)) in Ht as [G1 [G2 [px [pbs [V [-> [= -> ->]]]]]]].
      apply inert_ok in Hi. rewrite <- concat_assoc in Hi. apply ok_middle_inv_r in Hi.
      simpl_dom. apply notin_union in Hi as [Contra _]. false* notin_same.
    + apply pt2_strengthen_one in H; eauto.
Qed.

Lemma pt3_strengthen G G1 G2 bs T x U :
  G = G1 & x ~ T & G2 ->
  inert G ->
  wf G ->
  G ⊢!!! p_sel (avar_f x) bs : U ->
  G1 & x ~ T ⊢!!! p_sel (avar_f x) bs : U.
Proof.
  intros -> Hi Hwf Hp. induction G2 using env_ind.
  - rewrite concat_empty_r in *. auto.
  - destruct (classicT (x0 = x)) as [-> | Hn].
    + apply inert_ok in Hi. apply ok_middle_inv_r in Hi. simpl_dom. apply notin_union in Hi as [Contra _].
      false* notin_same.
    + rewrite concat_assoc in *. apply pt3_strengthen_one in Hp; auto.
      specialize (IHG2 (inert_prefix Hi) (wf_prefix Hwf) Hp). eauto.
Qed.

Lemma pt2_strengthen_full G p T :
  inert G ->
  wf G ->
  G ⊢!! p : T ->
  exists G1 G2 x bs V, G = G1 & x ~ V & G2 /\
                  p = p_sel (avar_f x) bs /\
                  G1 & x ~ V ⊢!! p : T.
Proof.
  intros Hi Hwf Hp. pose proof (pt2_destruct_env Hi Hp) as [G1 [G2 [x [bs [V [-> ->]]]]]].
  repeat eexists. apply* pt2_strengthen.
Qed.

Lemma pt2_strengthen_from_pf G G' p bs T T' U :
  inert (G & G') ->
  wf (G & G') ->
  G ⊢! p: T ⪼ T' ->
  G & G' ⊢!! p••bs : U ->
  G  ⊢!! p••bs : U.
Proof.
  intros Hi Hwf Hp1 Hp2. gen U. induction bs; introv Hp2.
  - rewrite field_sel_nil in *.
    apply pt2_strengthen_full in Hp2 as [G1 [G2 [px [pbs [V [Heq [-> Ht]]]]]]]; auto.
    pose proof (pt2_destruct_env (inert_prefix Hi) (pt2 Hp1)) as [G1' [G2' [px' [pbs' [V' [-> [= -> ->]]]]]]].
    rewrite <- concat_assoc in *. pose proof (inert_ok Hi) as Hok.
    apply env_ok_inv' in Heq as [-> [-> <-]]; rewrite concat_assoc in *; auto.
    apply* pt2_weaken.
  - rewrite proj_rewrite' in *. pose proof (pt2_backtrack _ _ Hp2) as [V Hb].
    specialize (IHbs _ Hb).
    pose proof (pt2_fld_strengthen _ Hi (wf_prefix Hwf) IHbs Hp2). eauto.
Qed.

Lemma pt3_strengthen_full G p T :
  inert G ->
  wf G ->
  G ⊢!!! p : T ->
  exists G1 G2 x bs V, G = G1 & x ~ V & G2 /\
                  p = p_sel (avar_f x) bs /\
                  G1 & x ~ V ⊢!!! p : T.
Proof.
  intros Hi Hwf Hp. induction Hp.
  - pose proof (pt2_destruct_env Hi H) as [G1 [G2 [x [bs [V [-> ->]]]]]].
    repeat eexists. constructor. apply* pt2_strengthen.
  - specialize (IHHp Hi Hwf) as [G1 [G2 [x [bs [V [-> [-> Hp3]]]]]]].
    pose proof (pt2_strengthen_full Hi Hwf H) as [G1' [G2' [y [cs [W3 [Heq [-> Hp2]]]]]]].
    do 5 eexists. split. apply Heq. split*.
    assert (inert (G1' & y ~ W3)) as Hi' by (rewrite Heq in Hi; apply* inert_prefix).
    assert (wf (G1' & y ~ W3)) as Hwf'.
    { rewrite Heq in Hwf. eapply wf_prefix. eauto. }
    pose proof (sngl_typed2 Hi' Hwf' Hp2) as [U Hx].
    apply (pt2_strengthen_full Hi') in Hx as [G1'' [G2'' [z [ds [X [HeqG [[= <- <-] Hx]]]]]]].
    rewrite HeqG in Heq. do 2 rewrite <- concat_assoc in Heq. rewrite concat_assoc in Heq.
    apply env_ok_inv in Heq as [-> [-> ->]].
    apply pt2_weaken with (G':=G2'') in Hx. rewrite <- HeqG in Hx. eapply pt3_sngl_trans.
    apply Hp2. rewrite HeqG. apply* pt3_weaken. rewrite concat_assoc in Hi. apply inert_ok. apply* inert_prefix.
    rewrite concat_assoc in Hi. apply inert_ok. apply* inert_prefix.
    rewrite Heq in Hi. apply* inert_ok. auto.
Qed.

Lemma pt3_fld_strengthen G p a T U G' :
  inert (G & G') ->
  wf (G & G') ->
  G ⊢!!! p : T ->
  G & G' ⊢!!! p • a : U ->
  G ⊢!!! p • a : U.
Proof.
  intros Hi Hwf Hp Hpa.
  pose proof (pt3_strengthen_full Hi Hwf Hpa) as [G1 [G2 [px [pbs [V [HeqG [Heqp Hp1]]]]]]]. simpl_dot.
  pose proof (pt3_strengthen_full (inert_prefix Hi) (wf_prefix Hwf) Hp)
    as [G1' [G2' [px' [pbs' [V' [-> [[= <- <-] HHH]]]]]]].
  rewrite <- concat_assoc in *. apply env_ok_inv' in HeqG as [-> [-> <-]]; auto.
  rewrite concat_assoc in *. apply* pt3_weaken. apply inert_ok. apply* inert_prefix.
Qed.

Lemma pf_strengthen_from_pt3 G G' p T U V :
  inert (G & G') ->
  wf (G & G') ->
  G ⊢!!! p: T ->
  G & G' ⊢! p : U ⪼ V ->
  G  ⊢! p : U ⪼ V.
Proof.
  intros Hi Hwf Hp3 Hpf.
  apply (pf_strengthen_full Hi) in Hpf as [G1 [G2 [px [pbs [W [Heq [-> Hpf]]]]]]].
  apply (pt3_strengthen_full (inert_prefix Hi)) in Hp3 as [G1' [G2' [? [? [? [-> [[= <- <-] Hp3]]]]]]].
  rewrite <- concat_assoc in Heq. apply env_ok_inv in Heq as [-> [-> <-]].
  apply* pf_weaken. apply inert_ok. apply* inert_prefix. rewrite concat_assoc in Heq.
  rewrite Heq in Hi. auto. apply* wf_prefix.
Qed.

(** ** Replacement Composition *)

(** The [typed_repl_comp_qp] relation for equivalent types under a given environment
    states that for two types [T] and [U], [T[q/p]=U], where [p] and [q] are typed
    the environment. *)
Definition typed_repl_comp_qp G T1 T2 :=
  exists p q U,
    G ⊢! p: {{ q }} ⪼ {{ q }} /\
    G ⊢!! q : U /\
    repl_typ q p T1 T2.

(** Reflexivte, transitive closure of [typed_repl_comp_qp]. [repl_composition_qp] allows
    us to express that types are equivalent as a result of multiple replacements *)
Definition repl_composition_qp G := star (typed_repl_comp_qp G).

Notation "G '⊢' T '⟿' U" := (repl_composition_qp G U T) (at level 40, T at level 59).
Inductive typed_path_repl_comp_qp: ctx -> path -> path -> Prop :=
| tpr_path: forall G p q U bs,
    G ⊢! p: {{ q }} ⪼ {{ q }} ->
    G ⊢!! q : U ->
    typed_path_repl_comp_qp G (q •• bs) (p •• bs).

Definition repl_composition_qp_p G := star (typed_path_repl_comp_qp G).

Notation "G '⊢' p '⟿'' q" := (repl_composition_qp_p G q p) (at level 40, p at level 59).

(** In a well-formed environment, there is a precise-typing relation between equivalent
    singleton paths *)
Lemma repl_comp_to_prec': forall G G' p q T,
    inert (G & G') ->
    wf (G & G') ->
    G ⊢ {{ p }} ⟿ {{ q }} ->
    G & G' ⊢!!! p: T ->
    p = q \/ G ⊢!!! p: {{ q }}.
Proof.
  introv Hi Hwf Hr Hp. gen T. dependent induction Hr; introv Hp; eauto.
  assert (exists r, b = {{ r }}) as [r Heq].
  { inversion H as [? [? [? [? [? Hr']]]]]. inversion* Hr'. }
  subst.
  specialize (IHHr _ _ Hi Hwf eq_refl eq_refl). destruct (IHHr _ Hp). subst.
  - destruct H as [p1 [p2 [S [H1 [Hq H2]]]]]. right. inversions H2.
    destruct (pt2_exists Hp) as [U Hu].
    apply (pt2_strengthen_from_pf _ Hi Hwf H1) in Hu.
    lets Hpf: (pf_pt2_trans_inv_mult _ (inert_prefix Hi) H1 Hu). subst*.
  - specialize (IHHr _ Hp). destruct H as [p1 [p2 [S [H1 [Hq H2]]]]].
    destruct (repl_prefixes_sngl H2) as [bs [He1 He2]]. subst.
    destruct IHHr as [Heq | IH].
    * subst. right.
     lets Hs: (sngl_typed3 (inert_prefix Hi) (wf_prefix Hwf) (pt3 (pt2 H1))). destruct Hs.
      apply* pt3_trans_trans. apply* inert_prefix.
    * right*. apply* pt3_sngl_trans3.
      lets Hs: (sngl_typed3 (inert_prefix Hi) (wf_prefix Hwf) IH). destruct Hs.
      apply* pt3_trans_trans. apply* inert_prefix.
Qed.

(** The following lemmas reasoning about further properties of equivalent types. *)

Lemma repl_comp_sngl_inv1 : forall G T p,
    G ⊢ {{ p }} ⟿ T ->
    exists q, T = {{ q }}.
Proof.
  introv Hr. dependent induction Hr; eauto.
  specialize (IHHr _ eq_refl). destruct_all. subst.
  inversions H. destruct_all. invert_repl. eexists. auto.
Qed.

Lemma repl_comp_sngl_inv2 : forall G T p,
    G ⊢ T ⟿ {{ p }}->
    exists q, T = {{ q }}.
Proof.
  introv Hr. dependent induction Hr; eauto.
  inversions H. destruct_all. invert_repl.
  specialize (IHHr _ eq_refl). destruct_all. eexists. eauto.
Qed.

Lemma repl_comp_bnd_inv1 G T U :
  G ⊢ μ U ⟿ T ->
  exists S, T = μ S.
Proof.
  introv Hr. dependent induction Hr; eauto.
  specialize (IHHr _ eq_refl). destruct_all. subst.
  inversions H. destruct_all. invert_repl. eexists; eauto.
Qed.

Lemma repl_comp_bnd_inv2 G T U :
  G ⊢ T ⟿ μ U ->
  exists S, T = μ S.
Proof.
  introv Hr. dependent induction Hr; eauto.
  inversions H. destruct_all. invert_repl.
  specialize (IHHr _ eq_refl). destruct_all. eexists. eauto.
Qed.

Lemma repl_comp_bnd': forall G T T',
    G ⊢ μ T ⟿ μ T' ->
    G ⊢ T ⟿ T'.
Proof.
  introv Hr. dependent induction Hr.
  - apply star_refl.
  - destruct H as [?[?[?[?[? Hr']]]]].
    assert (exists V, b = μ V) as [V ->]. {
      invert_repl. eauto.
    }
    apply star_trans with (b:=V). apply star_one. econstructor. repeat eexists. apply H. inversion* H0.
    invert_repl. eauto. apply* IHHr.
Qed.

Lemma repl_comp_trm_rcd G a T S :
  G ⊢ typ_rcd { a ⦂ T } ⟿ S ->
  exists T', S = typ_rcd { a ⦂ T' } /\ G ⊢ T ⟿ T'.
Proof.
  intros Hr. dependent induction Hr.
  - repeat eexists; apply star_refl.
  - destruct H as [p[q[U[Hp[Hq Hr']]]]].
    specialize (IHHr _ _ eq_refl) as [T' [-> Hrr]]. invert_repl.
    eexists; split; eauto. apply star_trans with (b:=T'); auto. apply star_one. econstructor; repeat eexists; eauto.
Qed.

Lemma repl_comp_trm_rcd' G a T S :
  G ⊢ S ⟿ typ_rcd { a ⦂ T } ->
  exists T', S = typ_rcd { a ⦂ T' } /\ G ⊢ T' ⟿ T .
Proof.
  intros Hr. dependent induction Hr.
  - repeat eexists; apply star_refl.
  - destruct H as [p[q[U[Hp[Hq Hr']]]]]. invert_repl.
    specialize (IHHr _ _ eq_refl) as [T' [-> Hrr]].
    eexists; split; eauto. apply star_trans with (b:=T2); auto. apply star_one. econstructor; repeat eexists; eauto.
Qed.

Lemma repl_comp_typ_and1 G T U S :
  G ⊢ S ⟿ T ∧ U ->
  exists T' U', S = T' ∧ U' /\ G ⊢ T' ⟿ T /\ G ⊢ U' ⟿ U.
Proof.
  intros Hr. dependent induction Hr.
  - repeat eexists; apply star_refl.
  - destruct H as [p[q[V[Hp[Hq Hr']]]]]. invert_repl;
    specialize (IHHr _ _ eq_refl) as [T' [U' [-> [Hr1 Hr2]]]];
    repeat eexists; eauto; apply star_trans with (b:=T2); auto; apply star_one; econstructor; repeat eexists; eauto.
Qed.

Lemma repl_comp_typ_and2 G T U S :
  G ⊢ T ∧ U ⟿ S ->
  exists T' U', S = T' ∧ U' /\ G ⊢ T ⟿ T' /\ G ⊢ U ⟿ U'.
Proof.
  intros Hr. dependent induction Hr.
  - repeat eexists; apply star_refl.
  - destruct H as [p[q[V[Hp[Hq Hr']]]]].
    specialize (IHHr _ _ eq_refl) as [T' [U' [-> [Hr1 Hr2]]]]; invert_repl; repeat eexists; eauto;
      [ apply star_trans with (b:=T') | apply star_trans with (b:=U') ];
      auto; apply star_one; econstructor; repeat eexists; eauto.
Qed.

Lemma repl_comp_record_has2 G T U U' a :
  G ⊢ T ⟿ U ->
  record_has U { a ⦂ U' } ->
  exists T', record_has T { a ⦂ T' } /\ G ⊢ T' ⟿ U'.
Proof.
  intros Hrc Hr. gen T. dependent induction Hr; introv Hrc.
  - apply repl_comp_trm_rcd' in Hrc as [T' [-> Hr]]. eauto.
  - apply repl_comp_typ_and1 in Hrc as [T' [U'' [-> [Hrc1 Hrc2]]]].
    specialize (IHHr _ _ eq_refl _ Hrc1) as [V [Hr' Hrc]].
    eexists. split. apply rh_andl. eauto. auto.
  - apply repl_comp_typ_and1 in Hrc as [T' [U'' [-> [Hrc1 Hrc2]]]].
    specialize (IHHr _ _ eq_refl _ Hrc2) as [V [Hr' Hrc]].
    eexists. split. apply rh_andr. eauto. auto.
Qed.

Lemma repl_comp_record_has1 G T U T' a :
  G ⊢ T ⟿ U ->
  record_has T { a ⦂ T' } ->
  exists U', record_has U { a ⦂ U' } /\ G ⊢ T' ⟿ U'.
Proof.
  intros Hrc Hr. gen U. dependent induction Hr; introv Hrc.
  - apply repl_comp_trm_rcd in Hrc as [T'' [-> Hr]]. eauto.
  - apply repl_comp_typ_and2 in Hrc as [T'' [U'' [-> [Hrc1 Hrc2]]]].
    specialize (IHHr _ _ eq_refl _ Hrc1) as [V [Hr' Hrc]].
    eexists. split. apply rh_andl. eauto. auto.
  - apply repl_comp_typ_and2 in Hrc as [T'' [U'' [-> [Hrc1 Hrc2]]]].
    specialize (IHHr _ _ eq_refl _ Hrc2) as [V [Hr' Hrc]].
    eexists. split. apply rh_andr. eauto. auto.
Qed.

Lemma repl_composition_open G T U p :
  inert G ->
  G ⊢ T ⟿ U ->
  G ⊢ open_typ_p p T ⟿ open_typ_p p U.
Proof.
  intros Hi Hrc. dependent induction Hrc.
  - apply star_refl.
  - eapply star_trans with (b:=open_typ_p p b); auto.
    destruct H as [q [r [V [Hp [Hq Hr]]]]]. apply star_one. econstructor. repeat eexists.
    apply Hp. eauto. apply* repl_open.
    apply precise_to_general2 in Hq. apply* typed_paths_named.
    apply precise_to_general in Hp. apply* typed_paths_named.
Qed.

Lemma repl_composition_weaken_one G x T U V :
  ok G ->
  x # G ->
  G ⊢ T ⟿ U ->
  G & x ~ V ⊢ T ⟿ U.
Proof.
  intros Hok Hn Hr. gen x V. dependent induction Hr; intros.
  - constructor.
  - destruct H as [r [? [? [Hrq [? Hr']]]]].
    eapply star_trans. apply star_one. econstructor. repeat eexists. apply* pf_weaken. apply* pt2_weaken.
    apply Hr'. apply* IHHr.
Qed.

Lemma repl_composition_weaken G G' T U :
  ok (G & G') ->
  G ⊢ T ⟿ U ->
  G & G' ⊢ T ⟿ U.
Proof.
  intros Hok Hr. induction G' using env_ind.
  - rewrite* concat_empty_r.
  - rewrite concat_assoc in *. apply ok_push_inv in Hok as [? ?].
    eapply repl_composition_weaken_one; eauto.
Qed.

Notation "G '⊩' T '⟿' U '⬳' V" := (G ⊢ T ⟿ U /\ G ⊢ V ⟿ U) (at level 40, T at level 59).
Notation "G '⊩' p '⟿'' q '⬳' r" := (G ⊢ p ⟿' q /\ G ⊢ r ⟿' q) (at level 40, p at level 59).

Lemma repl_comp_trans_open G S W T p :
  inert G ->
  G ⊩ S ⟿ W ⬳ T ->
  G ⊩ open_typ_p p S ⟿ open_typ_p p W ⬳ open_typ_p p T.
Proof.
  split; apply* repl_composition_open.
Qed.

Lemma repl_comp_trans_record_has G T S U V a :
  G ⊩ T ⟿ S ⬳ U ->
  record_has U {a ⦂ V} ->
  exists V' S', record_has T {a ⦂ V'} /\ G ⊩ V' ⟿ S' ⬳ V.
Proof.
  intros [Hc1 Hc2] Hr. pose proof (repl_comp_record_has1 Hc2 Hr) as [V1 [Hr1 Hc1']].
  pose proof (repl_comp_record_has2 Hc1 Hr1) as [V2 [Hr2 Hc2']]. repeat eexists; eauto.
Qed.

Lemma field_typing_comp1: forall G r q a U,
  inert G ->
  G ⊢ q ⟿' r ->
  G ⊢!!! q•a : U ->
  exists T, G ⊢!!! r•a : T.
Proof.
  introv Hi Hr Hq. gen a U. dependent induction Hr; introv Hq; eauto.
  destruct (IHHr _ _ Hq) as [T Hba].
  destruct (pt3_backtrack _ _ Hba) as [U' Hb].
  inversions H. apply* field_elim_q3. eapply pt3_trans_trans; eauto.
Qed.

Lemma field_typing_comp2: forall G r q a U,
  inert G ->
  G ⊢ r ⟿' q ->
  G ⊢!!! q•a : U ->
  exists T, G ⊢!!! r•a : T.
Proof.
  introv Hi Hr Hq. gen a U. dependent induction Hr; introv Ha; eauto.
  apply IHHr with (U:=U).
  destruct (pt3_backtrack _ _ Ha) as [U' Hqbs].
  inversions H. eapply pt3_trans2; eauto. eapply pt3_field_trans; eauto.
Qed.

Lemma repl_composition_fld_elim: forall G p q a T,
    inert G ->
    G ⊢ p ⟿' q ->
    G ⊢!!! p • a : T ->
    G ⊢ p•a ⟿' q•a.
Proof.
  introv Hi Hr. gen T. dependent induction Hr; introv Ha.
  - apply star_refl.
  - destruct (field_typing_comp1 _ Hi Hr Ha) as [T1 Tb].
    apply pt2_exists in Tb. destruct Tb as [U Tb].
    inversions H.
    apply star_trans with (b:=(p •• bs)•a).
    * apply star_one. repeat rewrite <- proj_rewrite'. econstructor; eauto.
    * eapply IHHr. eauto.
Qed.


Require Extraction.
Require Import String Fin.
Require Import Kami.All.
Require Import Kami.Simulator.CoqSim.Misc.

Extraction Language Haskell.

(* We postulate Haskell's more efficient datatypes and extract them *)

(* Maps with string keys *)

Parameter Map : Type -> Type.

Parameter empty : forall {V}, Map V.
Parameter map_lookup : forall {V}, string -> Map V -> option V.
Parameter insert : forall {V}, string -> V -> Map V -> Map V.
Parameter map_of_list : forall {V}, list (string * V) -> Map V.

Axiom empty_lookup : forall V x, map_lookup x (empty : Map V) = None.
Axiom map_of_list_lookup : forall V x (ps : list (string * V)),
  map_lookup x (map_of_list ps) = lookup String.eqb x ps.
Axiom insert_lookup_hit : forall V x (v : V) m, map_lookup x (insert x v m) = Some v.
Axiom insert_lookup_miss : forall V x x' (v : V) m, x <> x' -> map_lookup x' (insert x v m) = map_lookup x' m.

Extract Constant Map "v" => "Data.Map.Strict.Map Prelude.String v".
Extract Constant empty => "Data.Map.Strict.empty".
Extract Constant map_lookup => "Data.Map.Strict.lookup".
Extract Constant insert => "Data.Map.Strict.insert".
Extract Constant map_of_list => "Data.Map.Strict.fromList".

(* Vectors *)

Parameter Vector : nat -> Type -> Type.

Parameter vector_index : forall {X n}, Fin.t n -> Vector n X -> X.
Parameter vector_map : forall {X Y n}, (X -> Y) -> Vector n X -> Vector n Y.
Parameter vector_eq : forall {X n}, (X -> X -> bool) -> Vector n X -> Vector n X -> bool.
Parameter vector_to_list : forall {X n}, Vector n X -> list X.
Parameter make_vector : forall {X n}, (Fin.t n -> X) -> Vector n X.
Parameter vector_slice : forall {X n} (i m : nat),  Vector n X -> Vector m X.
Parameter vector_updates : forall {X n}, Vector n X -> list (nat * X) -> Vector n X.

Fixpoint Fin_to_list{X n} : (Fin.t n -> X) -> list X :=
  match n with
  | 0 => fun _ => nil
  | S m => fun f => cons (f Fin.F1) (Fin_to_list (fun i => f (Fin.FS i)))
  end.

Extract Constant Vector "a" => "Data.Vector.Vector a".
Extract Constant vector_index => "(\_ (n,i) v -> v Data.Vector.! i)".
Extract Constant vector_map => "(\_ -> Data.Vector.map)".
Extract Constant vector_eq => "(\_ eqb v1 v2 -> Data.Vector.foldr (Prelude.&&) Prelude.True (Data.Vector.zipWith eqb v1 v2))".
Extract Constant vector_to_list => "(\ _ -> Data.Vector.toList)".
Extract Constant make_vector => "(\n f -> Data.Vector.fromList (coq_Fin_to_list n f))".
Extract Constant vector_slice => "(\_ i m v -> Data.Vector.slice i m v)".
Extract Constant vector_updates => "(\_ -> (Data.Vector.//))".

(* BVs *)

Parameter BV : nat -> Type.
Parameter bv_inv : forall {m}, BV m -> BV m.
Parameter bv_trunc_lsb : forall {m n}, BV (m + n) -> BV m.
Parameter bv_trunc_msb : forall {m n}, BV (m + n) -> BV n.
Parameter bv_uand : forall {m}, BV m -> BV 1.
Parameter bv_uor : forall {m}, BV m -> BV 1.
Parameter bv_uxor : forall {m}, BV m -> BV 1.
Parameter bv_sub : forall {m}, BV m -> BV m -> BV m.
Parameter bv_div : forall {m}, BV m -> BV m -> BV m.
Parameter bv_rem : forall {m}, BV m -> BV m -> BV m.
Parameter bv_sll : forall {m n}, BV m -> BV n -> BV m.
Parameter bv_srl : forall {m n}, BV m -> BV n -> BV m.
Parameter bv_sra : forall {m n}, BV m -> BV n -> BV m.
Parameter bv_concat : forall {m n}, BV m -> BV n -> BV (n + m).
Parameter bv_add : forall {m}, list (BV m) -> BV m.
Parameter bv_mul : forall {m}, list (BV m) -> BV m.
Parameter bv_band : forall {m}, list (BV m) -> BV m.
Parameter bv_bor : forall {m}, list (BV m) -> BV m.
Parameter bv_bxor : forall {m}, list (BV m) -> BV m.
Parameter bv_lt : forall {m}, BV m -> BV m -> bool.
Parameter bv_eq : forall {m}, BV m -> BV m -> bool.
Parameter bv_to_nat : forall {m}, BV m -> nat.
Parameter nat_to_bv : forall {m}, nat -> BV m.
Parameter print_bv_bin : forall {m}, BV m -> string.
Parameter print_bv_dec : forall {m}, BV m -> string.
Parameter print_bv_hex : forall {m}, BV m -> string.

Extract Constant BV => "Data.BitVector.BV".
Extract Constant bv_inv => "(\_ -> Data.BitVector.not)".
Extract Constant bv_trunc_lsb => "(\m _ -> if m Prelude.== 0 then Prelude.const Data.BitVector.nil else Data.BitVector.least m)".
Extract Constant bv_trunc_msb => "(\_ n -> if n Prelude.== 0 then Prelude.const Data.BitVector.nil else Data.BitVector.most n)".
Extract Constant bv_uand => "(\_ v -> Data.BitVector.fromBool (Data.BitVector.foldr (Prelude.&&) Prelude.True v))".
Extract Constant bv_uor => "(\_ v -> Data.BitVector.fromBool (Data.BitVector.foldr (Prelude.||) Prelude.False v))".
Extract Constant bv_uxor => "(\_ v -> Data.BitVector.fromBool (Data.BitVector.foldr (Prelude./=) Prelude.False v))".
Extract Constant bv_sub => "(\_ -> (Prelude.-))".
Extract Constant bv_div => "(\_ -> Prelude.div)".
Extract Constant bv_rem => "(\_ -> Prelude.rem)".
Extract Constant bv_sll => "(\_ _ -> Data.BitVector.shl)".
Extract Constant bv_srl => "(\_ _ -> Data.BitVector.shr)".
Extract Constant bv_sra => "(\_ _ -> Data.BitVector.ashr)".
Extract Constant bv_concat => "(\_ _ -> (Data.BitVector.#))".
Extract Constant bv_add => "(\_ -> Prelude.foldr (Prelude.+) 0)".
Extract Constant bv_mul => "(\_ -> Prelude.foldr (Prelude.*) 1)".
Extract Constant bv_band => "(\n -> Prelude.foldr (Data.Bits..&.) (Data.BitVector.ones n))".
Extract Constant bv_bor => "(\n -> Prelude.foldr (Data.Bits..|.) (Data.BitVector.zeros n))".
Extract Constant bv_bxor => "(\n -> Prelude.foldr Data.Bits.xor (Data.BitVector.zeros n))".
Extract Constant bv_lt => "(\_ -> (Data.BitVector.<.))".
Extract Constant bv_eq => "(\_ -> (Data.BitVector.==.))".
Extract Constant bv_to_nat => "(\_ x -> Prelude.fromIntegral (Data.BitVector.nat x))".
Extract Inlined Constant nat_to_bv => "Data.BitVector.bitVec".
Extract Constant print_bv_bin => "(\_ -> CustomExtract.bv_bin)".
Extract Constant print_bv_dec => "(\_ -> CustomExtract.bv_dec)".
Extract Constant print_bv_hex => "(\_ -> CustomExtract.bv_hex)".

(* IO *)

Require Import String.

Parameter IO : Type -> Type.
Parameter ret : forall {X}, X -> IO X.
Parameter bind : forall {X Y}, IO X -> (X -> IO Y) -> IO Y.
Parameter error : forall {X}, string -> IO X.
Parameter print : string -> IO unit.
Parameter rand_bool : IO bool.
Parameter rand_bv : forall n, IO (BV n).
Parameter rand_vector : forall {X n}, IO X -> IO (Vector n X).
Parameter exit : forall {X}, IO X.

Extract Constant IO "a" => "Prelude.IO a".
Extract Inlined Constant ret => "Prelude.return".
Extract Inlined Constant bind => "(GHC.Base.>>=)".
Extract Inlined Constant error => "Prelude.error".
(*Extract Constant Hprint => "(\str -> (GHC.Base.>>) (Prelude.putStrLn str) (System.IO.hFlush System.IO.stdout))". *)
Extract Inlined Constant print => "Prelude.putStr".
Extract Constant rand_bool => "Prelude.return Prelude.False". (*FIXME*)
Extract Constant rand_bv => "Prelude.undefined". (*FIXME*)
Extract Constant rand_vector => "Prelude.undefined". (*FIXME*)
Extract Constant exit => "System.Exit.exitSuccess".

Module Notations.

Notation "'do' x <- y ; cont" := (bind y (fun x => cont)) (at level 20).

End Notations.

(* Arrays *)

Parameter Arr : Type -> Type.
Parameter arr_repl : forall {X}, nat -> X -> IO (Arr X).
Parameter arr_slice : forall {X} (i m : nat), Arr X -> IO (Vector m X).
Parameter arr_updates : forall {X}, Arr X -> list (nat * X) -> IO unit.
(* Parameter arr_new : forall {X}, nat -> IO (Array X).
 *)
(** does not work at the moment **)
(*Extract Constant HArray "a" => "Data.Array.IO.IOArray Prelude.Int a".
Extract Constant Harr_repl => "(\n x -> Data.Array.MArray.newArray (0, n Prelude.- 1) x)".
Extract Constant Harr_slice => "(\i m a -> Control.Monad.liftM Data.Vector.fromList (Prelude.sequence (Prelude.map (\j -> Data.Array.MArray.readArray a (j Prelude.+ i)) [0..(m Prelude.- 1)])))".
Extract Constant Harr_updates => "(\a ps -> Control.Monad.foldM (\_ (i,e) -> Data.Array.MArray.writeArray a i e) () ps)".*)

Extract Constant Arr "a" => "Data.Vector.Mutable.MVector (Control.Monad.Primitive.PrimState Prelude.IO) a".
Extract Constant arr_repl => "Data.Vector.Mutable.replicate".
Extract Constant arr_slice => "(\i m a -> Data.Vector.Generic.freeze (Data.Vector.Mutable.slice i m a))".
Extract Constant arr_updates => "(\a ps -> Control.Monad.foldM (\_ (i,x) -> Data.Vector.Mutable.write a i x) () ps)".


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2011 Sylvie Boldo
#<br />#
Copyright (C) 2011 Guillaume Melquiond

This library 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 3 of the License, or (at your option) any later version.

This library 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
COPYING file for more details.
*)

Require Import ZArith.
Require Import ZOdiv.

Section Zmissing.

(** About Z *)
Theorem Zopp_le_cancel :
  forall x y : Z,
  (-y <= -x)%Z -> Zle x y.
Proof.
intros x y Hxy.
apply Zplus_le_reg_r with (-x - y)%Z.
now ring_simplify.
Qed.

Theorem Zgt_not_eq :
  forall x y : Z,
  (y < x)%Z -> (x <> y)%Z.
Proof.
intros x y H Hn.
apply Zlt_irrefl with x.
now rewrite Hn at 1.
Qed.

End Zmissing.

Section Proof_Irrelevance.

Scheme eq_dep_elim := Induction for eq Sort Type.

Definition eqbool_dep P (h1 : P true) b :=
  match b return P b -> Prop with
  | true => fun (h2 : P true) => h1 = h2
  | false => fun (h2 : P false) => False
  end.

Lemma eqbool_irrelevance : forall (b : bool) (h1 h2 : b = true), h1 = h2.
Proof.
assert (forall (h : true = true), refl_equal true = h).
apply (eq_dep_elim bool true (eqbool_dep _ _) (refl_equal _)).
intros b.
case b.
intros h1 h2.
now rewrite <- (H h1).
intros h.
discriminate h.
Qed.

End Proof_Irrelevance.

Section Even_Odd.

(** Zeven, used for rounding to nearest, ties to even *)
Definition Zeven (n : Z) :=
  match n with
  | Zpos (xO _) => true
  | Zneg (xO _) => true
  | Z0 => true
  | _ => false
  end.

Theorem Zeven_mult :
  forall x y, Zeven (x * y) = orb (Zeven x) (Zeven y).
Proof.
now intros [|[xp|xp|]|[xp|xp|]] [|[yp|yp|]|[yp|yp|]].
Qed.

Theorem Zeven_opp :
  forall x, Zeven (- x) = Zeven x.
Proof.
now intros [|[n|n|]|[n|n|]].
Qed.

Theorem Zeven_ex :
  forall x, exists p, x = (2 * p + if Zeven x then 0 else 1)%Z.
Proof.
intros [|[n|n|]|[n|n|]].
now exists Z0.
now exists (Zpos n).
now exists (Zpos n).
now exists Z0.
exists (Zneg n - 1)%Z.
change (2 * Zneg n - 1 = 2 * (Zneg n - 1) + 1)%Z.
ring.
now exists (Zneg n).
now exists (-1)%Z.
Qed.

Theorem Zeven_2xp1 :
  forall n, Zeven (2 * n + 1) = false.
Proof.
intros n.
destruct (Zeven_ex (2 * n + 1)) as (p, Hp).
revert Hp.
case (Zeven (2 * n + 1)) ; try easy.
intros H.
apply False_ind.
omega.
Qed.

Theorem Zeven_plus :
  forall x y, Zeven (x + y) = Bool.eqb (Zeven x) (Zeven y).
Proof.
intros x y.
destruct (Zeven_ex x) as (px, Hx).
rewrite Hx at 1.
destruct (Zeven_ex y) as (py, Hy).
rewrite Hy at 1.
replace (2 * px + (if Zeven x then 0 else 1) + (2 * py + (if Zeven y then 0 else 1)))%Z
  with (2 * (px + py) + ((if Zeven x then 0 else 1) + (if Zeven y then 0 else 1)))%Z by ring.
case (Zeven x) ; case (Zeven y).
rewrite Zplus_0_r.
now rewrite Zeven_mult.
apply Zeven_2xp1.
apply Zeven_2xp1.
replace (2 * (px + py) + (1 + 1))%Z with (2 * (px + py + 1))%Z by ring.
now rewrite Zeven_mult.
Qed.

End Even_Odd.

Section Zpower.

Theorem Zpower_plus :
  forall n k1 k2, (0 <= k1)%Z -> (0 <= k2)%Z ->
  Zpower n (k1 + k2) = (Zpower n k1 * Zpower n k2)%Z.
Proof.
intros n k1 k2 H1 H2.
now apply Zpower_exp ; apply Zle_ge.
Qed.

Theorem Zpower_Zpower_nat :
  forall b e, (0 <= e)%Z ->
  Zpower b e = Zpower_nat b (Zabs_nat e).
Proof.
intros b [|e|e] He.
apply refl_equal.
apply Zpower_pos_nat.
elim He.
apply refl_equal.
Qed.

Theorem Zpower_nat_S :
  forall b e,
  Zpower_nat b (S e) = (b * Zpower_nat b e)%Z.
Proof.
intros b e.
rewrite (Zpower_nat_is_exp 1 e).
apply (f_equal (fun x => x * _)%Z).
apply Zmult_1_r.
Qed.

Theorem Zpower_pos_gt_0 :
  forall b p, (0 < b)%Z ->
  (0 < Zpower_pos b p)%Z.
Proof.
intros b p Hb.
rewrite Zpower_pos_nat.
induction (nat_of_P p).
easy.
rewrite Zpower_nat_S.
now apply Zmult_lt_0_compat.
Qed.

Theorem Zeven_Zpower :
  forall b e, (0 < e)%Z ->
  Zeven (Zpower b e) = Zeven b.
Proof.
intros b e He.
case_eq (Zeven b) ; intros Hb.
(* b even *)
replace e with (e - 1 + 1)%Z by ring.
rewrite Zpower_exp.
rewrite Zeven_mult.
replace (Zeven (b ^ 1)) with true.
apply Bool.orb_true_r.
unfold Zpower, Zpower_pos. simpl.
now rewrite Zmult_1_r.
omega.
discriminate.
(* b odd *)
rewrite Zpower_Zpower_nat.
induction (Zabs_nat e).
easy.
unfold Zpower_nat. simpl.
rewrite Zeven_mult.
now rewrite Hb.
now apply Zlt_le_weak.
Qed.

Theorem Zeven_Zpower_odd :
  forall b e, (0 <= e)%Z -> Zeven b = false ->
  Zeven (Zpower b e) = false.
Proof.
intros b e He Hb.
destruct (Z_le_lt_eq_dec _ _ He) as [He'|He'].
rewrite <- Hb.
now apply Zeven_Zpower.
now rewrite <- He'.
Qed.

(** The radix must be greater than 1 *)
Record radix := { radix_val :> Z ; radix_prop : Zle_bool 2 radix_val = true }.

Theorem radix_val_inj :
  forall r1 r2, radix_val r1 = radix_val r2 -> r1 = r2.
Proof.
intros (r1, H1) (r2, H2) H.
simpl in H.
revert H1.
rewrite H.
intros H1.
apply f_equal.
apply eqbool_irrelevance.
Qed.

Variable r : radix.

Theorem radix_gt_0 : (0 < r)%Z.
Proof.
apply Zlt_le_trans with 2%Z.
easy.
apply Zle_bool_imp_le.
apply r.
Qed.

Theorem radix_gt_1 : (1 < r)%Z.
Proof.
destruct r as (v, Hr). simpl.
apply Zlt_le_trans with 2%Z.
easy.
now apply Zle_bool_imp_le.
Qed.

Theorem Zpower_gt_1 :
  forall p,
  (0 < p)%Z ->
  (1 < Zpower r p)%Z.
Proof.
intros [|p|p] Hp ; try easy.
simpl.
rewrite Zpower_pos_nat.
generalize (lt_O_nat_of_P p).
induction (nat_of_P p).
easy.
intros _.
rewrite Zpower_nat_S.
assert (0 < Zpower_nat r n)%Z.
clear.
induction n.
easy.
rewrite Zpower_nat_S.
apply Zmult_lt_0_compat with (2 := IHn).
apply radix_gt_0.
apply Zle_lt_trans with (1 * Zpower_nat r n)%Z.
rewrite Zmult_1_l.
now apply (Zlt_le_succ 0).
apply Zmult_lt_compat_r with (1 := H).
apply radix_gt_1.
Qed.

Theorem Zpower_gt_0 :
  forall p,
  (0 <= p)%Z ->
  (0 < Zpower r p)%Z.
Proof.
intros p Hp.
rewrite Zpower_Zpower_nat with (1 := Hp).
induction (Zabs_nat p).
easy.
rewrite Zpower_nat_S.
apply Zmult_lt_0_compat with (2 := IHn).
apply radix_gt_0.
Qed.

Theorem Zpower_ge_0 :
  forall e,
  (0 <= Zpower r e)%Z.
Proof.
intros [|e|e] ; try easy.
apply Zlt_le_weak.
now apply Zpower_gt_0.
Qed.

Theorem Zpower_le :
  forall e1 e2, (e1 <= e2)%Z ->
  (Zpower r e1 <= Zpower r e2)%Z.
Proof.
intros e1 e2 He.
destruct (Zle_or_lt 0 e1)%Z as [H1|H1].
replace e2 with (e2 - e1 + e1)%Z by ring.
rewrite Zpower_plus with (2 := H1).
rewrite <- (Zmult_1_l (r ^ e1)) at 1.
apply Zmult_le_compat_r.
apply (Zlt_le_succ 0).
apply Zpower_gt_0.
now apply Zle_minus_le_0.
apply Zpower_ge_0.
now apply Zle_minus_le_0.
clear He.
destruct e1 as [|e1|e1] ; try easy.
apply Zpower_ge_0.
Qed.

Theorem Zpower_lt :
  forall e1 e2, (0 <= e2)%Z -> (e1 < e2)%Z ->
  (Zpower r e1 < Zpower r e2)%Z.
Proof.
intros e1 e2 He2 He.
destruct (Zle_or_lt 0 e1)%Z as [H1|H1].
replace e2 with (e2 - e1 + e1)%Z by ring.
rewrite Zpower_plus with (2 := H1).
rewrite Zmult_comm.
rewrite <- (Zmult_1_r (r ^ e1)) at 1.
apply Zmult_lt_compat2.
split.
now apply Zpower_gt_0.
apply Zle_refl.
split.
easy.
apply Zpower_gt_1.
clear -He ; omega.
apply Zle_minus_le_0.
now apply Zlt_le_weak.
revert H1.
clear -He2.
destruct e1 ; try easy.
intros _.
now apply Zpower_gt_0.
Qed.

Theorem Zpower_lt_Zpower :
  forall e1 e2,
  (Zpower r (e1 - 1) < Zpower r e2)%Z ->
  (e1 <= e2)%Z.
Proof.
intros e1 e2 He.
apply Znot_gt_le.
intros H.
apply Zlt_not_le with (1 := He).
apply Zpower_le.
clear -H ; omega.
Qed.

End Zpower.

Section Div_Mod.

Theorem Zmod_mod_mult :
  forall n a b, (0 < a)%Z -> (0 <= b)%Z ->
  Zmod (Zmod n (a * b)) b = Zmod n b.
Proof.
intros n a [|b|b] Ha Hb.
now rewrite 2!Zmod_0_r.
rewrite (Zmod_eq n (a * Zpos b)).
rewrite Zmult_assoc.
unfold Zminus.
rewrite Zopp_mult_distr_l.
apply Z_mod_plus.
easy.
apply Zmult_gt_0_compat.
now apply Zlt_gt.
easy.
now elim Hb.
Qed.

Theorem ZOmod_eq :
  forall a b,
  ZOmod a b = (a - ZOdiv a b * b)%Z.
Proof.
intros a b.
rewrite (ZO_div_mod_eq a b) at 2.
ring.
Qed.

Theorem ZOmod_mod_mult :
  forall n a b,
  ZOmod (ZOmod n (a * b)) b = ZOmod n b.
Proof.
intros n a b.
assert (ZOmod n (a * b) = n + - (ZOdiv n (a * b) * a) * b)%Z.
rewrite <- Zopp_mult_distr_l.
rewrite <- Zmult_assoc.
apply ZOmod_eq.
rewrite H.
apply ZO_mod_plus.
rewrite <- H.
apply ZOmod_sgn2.
Qed.

Theorem Zdiv_mod_mult :
  forall n a b, (0 <= a)%Z -> (0 <= b)%Z ->
  (Zdiv (Zmod n (a * b)) a) = Zmod (Zdiv n a) b.
Proof.
intros n a b Ha Hb.
destruct (Zle_lt_or_eq _ _ Ha) as [Ha'|Ha'].
destruct (Zle_lt_or_eq _ _ Hb) as [Hb'|Hb'].
rewrite (Zmod_eq n (a * b)).
rewrite (Zmult_comm a b) at 2.
rewrite Zmult_assoc.
unfold Zminus.
rewrite Zopp_mult_distr_l.
rewrite Z_div_plus by now apply Zlt_gt.
rewrite <- Zdiv_Zdiv by easy.
apply sym_eq.
apply Zmod_eq.
now apply Zlt_gt.
now apply Zmult_gt_0_compat ; apply Zlt_gt.
rewrite <- Hb'.
rewrite Zmult_0_r, 2!Zmod_0_r.
apply Zdiv_0_l.
rewrite <- Ha'.
now rewrite 2!Zdiv_0_r, Zmod_0_l.
Qed.

Theorem ZOdiv_mod_mult :
  forall n a b,
  (ZOdiv (ZOmod n (a * b)) a) = ZOmod (ZOdiv n a) b.
Proof.
intros n a b.
destruct (Z_eq_dec a 0) as [Za|Za].
rewrite Za.
now rewrite 2!ZOdiv_0_r, ZOmod_0_l.
assert (ZOmod n (a * b) = n + - (ZOdiv (ZOdiv n a) b * b) * a)%Z.
rewrite (ZOmod_eq n (a * b)) at 1.
rewrite ZOdiv_ZOdiv.
ring.
rewrite H.
rewrite ZO_div_plus with (2 := Za).
apply sym_eq.
apply ZOmod_eq.
rewrite <- H.
apply ZOmod_sgn2.
Qed.

Theorem ZOdiv_small_abs :
  forall a b,
  (Zabs a < b)%Z -> ZOdiv a b = Z0.
Proof.
intros a b Ha.
destruct (Zle_or_lt 0 a) as [H|H].
apply ZOdiv_small.
split.
exact H.
now rewrite Zabs_eq in Ha.
apply Zopp_inj.
rewrite <- ZOdiv_opp_l, Zopp_0.
apply ZOdiv_small.
generalize (Zabs_non_eq a).
omega.
Qed.

Theorem ZOmod_small_abs :
  forall a b,
  (Zabs a < b)%Z -> ZOmod a b = a.
Proof.
intros a b Ha.
destruct (Zle_or_lt 0 a) as [H|H].
apply ZOmod_small.
split.
exact H.
now rewrite Zabs_eq in Ha.
apply Zopp_inj.
rewrite <- ZOmod_opp_l.
apply ZOmod_small.
generalize (Zabs_non_eq a).
omega.
Qed.

Theorem ZOdiv_plus :
  forall a b c, (0 <= a * b)%Z ->
  (ZOdiv (a + b) c = ZOdiv a c + ZOdiv b c + ZOdiv (ZOmod a c + ZOmod b c) c)%Z.
Proof.
intros a b c Hab.
destruct (Z_eq_dec c 0) as [Zc|Zc].
now rewrite Zc, 4!ZOdiv_0_r.
apply Zmult_reg_r with (1 := Zc).
rewrite 2!Zmult_plus_distr_l.
assert (forall d, ZOdiv d c * c = d - ZOmod d c)%Z.
intros d.
rewrite ZOmod_eq.
ring.
rewrite 4!H.
rewrite <- ZOplus_mod with (1 := Hab).
ring.
Qed.

End Div_Mod.

Section Same_sign.

Theorem Zsame_sign_trans :
  forall v u w, v <> Z0 ->
  (0 <= u * v)%Z -> (0 <= v * w)%Z -> (0 <= u * w)%Z.
Proof.
intros [|v|v] [|u|u] [|w|w] Zv Huv Hvw ; try easy ; now elim Zv.
Qed.

Theorem Zsame_sign_trans_weak :
  forall v u w, (v = Z0 -> w = Z0) ->
  (0 <= u * v)%Z -> (0 <= v * w)%Z -> (0 <= u * w)%Z.
Proof.
intros [|v|v] [|u|u] [|w|w] Zv Huv Hvw ; try easy ; now discriminate Zv.
Qed.

Theorem Zsame_sign_imp :
  forall u v,
  (0 < u -> 0 <= v)%Z ->
  (0 < -u -> 0 <= -v)%Z ->
  (0 <= u * v)%Z.
Proof.
intros [|u|u] v Hp Hn.
easy.
apply Zmult_le_0_compat.
easy.
now apply Hp.
replace (Zneg u * v)%Z with (Zpos u * (-v))%Z.
apply Zmult_le_0_compat.
easy.
now apply Hn.
rewrite <- Zopp_mult_distr_r.
apply Zopp_mult_distr_l.
Qed.

Theorem Zsame_sign_odiv :
  forall u v, (0 <= v)%Z ->
  (0 <= u * ZOdiv u v)%Z.
Proof.
intros u v Hv.
apply Zsame_sign_imp ; intros Hu.
apply ZO_div_pos with (2 := Hv).
now apply Zlt_le_weak.
rewrite <- ZOdiv_opp_l.
apply ZO_div_pos with (2 := Hv).
now apply Zlt_le_weak.
Qed.

End Same_sign.

(** Boolean comparisons *)

Section Zeq_bool.

Inductive Zeq_bool_prop (x y : Z) : bool -> Prop :=
  | Zeq_bool_true_ : x = y -> Zeq_bool_prop x y true
  | Zeq_bool_false_ : x <> y -> Zeq_bool_prop x y false.

Theorem Zeq_bool_spec :
  forall x y, Zeq_bool_prop x y (Zeq_bool x y).
Proof.
intros x y.
generalize (Zeq_is_eq_bool x y).
case (Zeq_bool x y) ; intros (H1, H2) ; constructor.
now apply H2.
intros H.
specialize (H1 H).
discriminate H1.
Qed.

Theorem Zeq_bool_true :
  forall x y, x = y -> Zeq_bool x y = true.
Proof.
intros x y.
apply -> Zeq_is_eq_bool.
Qed.

Theorem Zeq_bool_false :
  forall x y, x <> y -> Zeq_bool x y = false.
Proof.
intros x y.
generalize (proj2 (Zeq_is_eq_bool x y)).
case Zeq_bool.
intros He Hn.
elim Hn.
now apply He.
now intros _ _.
Qed.

End Zeq_bool.

Section Zle_bool.

Inductive Zle_bool_prop (x y : Z) : bool -> Prop :=
  | Zle_bool_true_ : (x <= y)%Z -> Zle_bool_prop x y true
  | Zle_bool_false_ : (y < x)%Z -> Zle_bool_prop x y false.

Theorem Zle_bool_spec :
  forall x y, Zle_bool_prop x y (Zle_bool x y).
Proof.
intros x y.
generalize (Zle_is_le_bool x y).
case Zle_bool ; intros (H1, H2) ; constructor.
now apply H2.
destruct (Zle_or_lt x y) as [H|H].
now specialize (H1 H).
exact H.
Qed.

Theorem Zle_bool_true :
  forall x y : Z,
  (x <= y)%Z -> Zle_bool x y = true.
Proof.
intros x y.
apply (proj1 (Zle_is_le_bool x y)).
Qed.

Theorem Zle_bool_false :
  forall x y : Z,
  (y < x)%Z -> Zle_bool x y = false.
Proof.
intros x y Hxy.
generalize (Zle_cases x y).
case Zle_bool ; intros H.
elim (Zlt_irrefl x).
now apply Zle_lt_trans with y.
apply refl_equal.
Qed.

End Zle_bool.

Section Zlt_bool.

Inductive Zlt_bool_prop (x y : Z) : bool -> Prop :=
  | Zlt_bool_true_ : (x < y)%Z -> Zlt_bool_prop x y true
  | Zlt_bool_false_ : (y <= x)%Z -> Zlt_bool_prop x y false.

Theorem Zlt_bool_spec :
  forall x y, Zlt_bool_prop x y (Zlt_bool x y).
Proof.
intros x y.
generalize (Zlt_is_lt_bool x y).
case Zlt_bool ; intros (H1, H2) ; constructor.
now apply H2.
destruct (Zle_or_lt y x) as [H|H].
exact H.
now specialize (H1 H).
Qed.

Theorem Zlt_bool_true :
  forall x y : Z,
  (x < y)%Z -> Zlt_bool x y = true.
Proof.
intros x y.
apply (proj1 (Zlt_is_lt_bool x y)).
Qed.

Theorem Zlt_bool_false :
  forall x y : Z,
  (y <= x)%Z -> Zlt_bool x y = false.
Proof.
intros x y Hxy.
generalize (Zlt_cases x y).
case Zlt_bool ; intros H.
elim (Zlt_irrefl x).
now apply Zlt_le_trans with y.
apply refl_equal.
Qed.

Theorem negb_Zle_bool :
  forall x y : Z,
  negb (Zle_bool x y) = Zlt_bool y x.
Proof.
intros x y.
case Zle_bool_spec ; intros H.
now rewrite Zlt_bool_false.
now rewrite Zlt_bool_true.
Qed.

Theorem negb_Zlt_bool :
  forall x y : Z,
  negb (Zlt_bool x y) = Zle_bool y x.
Proof.
intros x y.
case Zlt_bool_spec ; intros H.
now rewrite Zle_bool_false.
now rewrite Zle_bool_true.
Qed.

End Zlt_bool.

Section Zcompare.

Inductive Zcompare_prop (x y : Z) : comparison -> Prop :=
  | Zcompare_Lt_ : (x < y)%Z -> Zcompare_prop x y Lt
  | Zcompare_Eq_ : x = y -> Zcompare_prop x y Eq
  | Zcompare_Gt_ : (y < x)%Z -> Zcompare_prop x y Gt.

Theorem Zcompare_spec :
  forall x y, Zcompare_prop x y (Zcompare x y).
Proof.
intros x y.
destruct (Z_dec x y) as [[H|H]|H].
generalize (Zlt_compare _ _ H).
case (Zcompare x y) ; try easy.
now constructor.
generalize (Zgt_compare _ _ H).
case (Zcompare x y) ; try easy.
constructor.
now apply Zgt_lt.
generalize (proj2 (Zcompare_Eq_iff_eq _ _) H).
case (Zcompare x y) ; try easy.
now constructor.
Qed.

Theorem Zcompare_Lt :
  forall x y,
  (x < y)%Z -> Zcompare x y = Lt.
Proof.
easy.
Qed.

Theorem Zcompare_Eq :
  forall x y,
  (x = y)%Z -> Zcompare x y = Eq.
Proof.
intros x y.
apply <- Zcompare_Eq_iff_eq.
Qed.

Theorem Zcompare_Gt :
  forall x y,
  (y < x)%Z -> Zcompare x y = Gt.
Proof.
intros x y.
apply Zlt_gt.
Qed.

End Zcompare.