Set Implicit Arguments.
Require Import LibLN Main_ott Main_Infra Main_Proofs.
Implicit Types x : var.
Implicit Types G : env.

Require Alg_Aux.
Module S := Alg_Aux.

Inductive _typing : env -> trm -> trm -> trm -> Prop :=
  | _typing_star : forall G,
      _wf G -> _typing G trm_star trm_star trm_star
  | _typing_var : forall e G x A,
      _wf G -> binds x (bind_sub e A) G -> _typing G (trm_var_f x) A (trm_var_f x)
  | _typing_top : forall G A MA,
      _typing G A trm_star MA -> _typing G trm_top A (trm_anno trm_top MA)
  | _typing_lam : forall MB L G e1 e2 A B Me1 Me2 MA,
      _typing G e1 A Me1 ->
      _typing G A trm_star MA ->
      (forall x, x \notin L ->
                 _typing (G & x ~ bind_sub e1 A) (B ^ x) trm_star (MB ^ x)) ->
      (forall x, x \notin L ->
                 _typing (G & x ~ bind_sub e1 A) (e2 ^ x) (B ^ x) (Me2 ^ x)) ->
      _typing G (trm_abs e1 A e2) (trm_prod e1 A B) (trm_abs Me1 MA Me2)
  | _typing_app : forall e3 G e A B C Me MA,
      _typing G A B MA ->
      _sub G A e3 ->
      _typing G e (trm_prod e3 B C) Me ->
      _typing G (trm_app e A) (C ^^ A) (trm_app Me MA)
  | _typing_pi : forall L G e A B Me MA MB,
      _typing G e A Me ->
      _typing G A trm_star MA ->
      (forall x, x \notin L ->
        _typing (G & x ~ bind_sub e A) (B ^ x) trm_star (MB ^ x)) ->
      _typing G (trm_prod e A B) trm_star (trm_prod Me MA MB)
  | _typing_castup : forall G e A B MB Me,
      _typing G B trm_star MB ->
      _typing G e A Me ->
      reduct B A ->
      _typing G (trm_castup B e) B (trm_castup MB Me)
  | _typing_castdn : forall G e A B MB Me,
      _typing G B trm_star MB ->
      _typing G e A Me ->
      reduct A B ->
      _typing G (trm_castdn e) B (trm_anno (trm_castdn Me) MB)
  | _typing_sub : forall A G e B Me MB,
      _typing G e A Me ->
      _sub G A B ->
      _typing G B trm_star MB ->
      _typing G e B (trm_anno Me MB)

with _wf : env -> Prop :=
  | _wf_nil : _wf empty
  | _wf_cons : forall G x e A Me MA,
      x # G ->
      _typing G e A Me ->
      _typing G A trm_star MA ->
      _wf (G & x ~ bind_sub e A)

with _sub : env -> trm -> trm -> Prop :=
  | _sub_star : forall G, _wf G -> _sub G trm_star trm_star
  | _sub_var_refl : forall G x e A,
      _wf G -> binds x (bind_sub e A) G -> _sub G (trm_var_f x) (trm_var_f x)
  | _sub_var_trans : forall e1 A G x e2,
      binds x (bind_sub e1 A) G -> _sub G e1 e2 ->
      _sub G (trm_var_f x) e2
  | _sub_top : forall G e,
      _wf G -> lc_trm e -> _sub G e trm_top
  | _sub_top_refl : forall G,
      _wf G -> _sub G trm_top trm_top
  | _sub_lam : forall Me3 MA L G e1 e2 e3 A,
      _typing G e3 A Me3 ->
      _typing G A trm_star MA ->
      (forall x, x \notin L -> _sub (G & x ~ bind_sub e3 A) (e1 ^ x) (e2 ^ x)) ->
      _sub G (trm_abs e3 A e1) (trm_abs e3 A e2)
  | _sub_app : forall G e1 e2 A,
      lc_trm A ->
      _sub G e1 e2 -> _sub G (trm_app e1 A) (trm_app e2 A)
  | _sub_pi : forall Me MC L G e A B C D,
      _typing G e C Me ->
      _typing G C trm_star MC ->
      _sub G C A ->
      (forall x, x \notin L -> _sub (G & x ~ bind_sub e C) (B ^ x) (D ^ x)) ->
      _sub G (trm_prod e A B) (trm_prod e C D)
  | _sub_castup : forall G A e1 e2,
      lc_trm A -> _sub G e1 e2 -> _sub G (trm_castup A e1) (trm_castup A e2)
  | _sub_castdn : forall G e1 e2,
      _sub G e1 e2 -> _sub G (trm_castdn e1) (trm_castdn e2).

Hint Constructors _typing _sub _wf.

Scheme typing_induct := Induction for _typing Sort Prop
  with twf_induct := Induction for _wf Sort Prop
  with tsub_induct := Induction for _sub Sort Prop.

Lemma regular_typing : forall E t T M, _typing E t T M ->
  (_wf E /\ ok E /\ contains_terms E /\ lc_trm t /\ lc_trm T /\ lc_trm M).
Proof.
  apply typing_induct with
  (P0 := fun E (_ : _wf E) => ok E /\ contains_terms E)
  (P1 := fun E t1 t2 (_: _sub E t1 t2) => _wf E /\ ok E /\ contains_terms E /\ lc_trm t2);
    unfolds contains_terms; intros; splits*.
  destructs H. lets: H0 b. jauto.
  intros. false* (binds_empty_inv).
  intros. destruct (binds_push_inv H1) as [[? P]|[? ?]]; try (inversions P); subst*.
  destructs H. apply* H5.
Qed.

Lemma regular_tsub : forall E t T, _sub E t T ->
  (_wf E /\ ok E /\ contains_terms E /\ lc_trm t /\ lc_trm T).
Proof.
  apply tsub_induct with
  (P0 := fun E (_ : _wf E) => ok E /\ contains_terms E)
  (P := fun E t1 t2 t3 (_: _typing E t1 t2 t3) => _wf E /\ ok E /\ contains_terms E /\ lc_trm t1 /\lc_trm t2 /\ lc_trm t3);
   unfolds contains_terms; intros; splits*.
  destructs H. lets: H0 b. jauto.
  intros. false* (binds_empty_inv).
  intros. destruct (binds_push_inv H1) as [[? P]|[? ?]]; try (inversions P); subst*.
  destructs H. apply* H5.
Qed.

Hint Extern 1 (lc_trm ?t) => match goal with
  | H: _typing _ t _ _ |- _ => apply (proj31 (proj44 (regular_typing H)))
  | H: _typing _ _ t _ |- _ => apply (proj32 (proj44 (regular_typing H)))
  | H: _typing _ _ _ t |- _ => apply (proj33 (proj44 (regular_typing H)))
  | H: _sub _ t _ |- _ => apply (proj32 (proj33 (regular_tsub H)))
  | H: _sub _ _ t |- _ => apply (proj33 (proj33 (regular_tsub H)))
  end.

Lemma ok_from_twf : forall E, _wf E -> ok E.
Proof.
  induction 1. auto. autos* (regular_typing H0).
Qed.

Hint Extern 1 (ok ?E) => match goal with
  | H: _wf E |- _ => apply (ok_from_twf H)
  end.

Hint Extern 1 (_wf ?E) => match goal with
  | H: _typing E _ _ _ |- _ => apply (proj1 (regular_typing H))
  | H: _sub E _ _ |- _ => apply (proj1 (regular_tsub H))
  end.

Lemma twf_push_inv : forall E x T U,
  _wf (E & x ~ bind_sub T U) -> _wf E /\ lc_trm T /\ lc_trm U.
Proof.
  introv W. inversions W.
  false (empty_push_inv H0).
  destruct (eq_push_inv H) as [? [? ?]]. inversions H4. subst~.
Qed.

Lemma term_from_binds_in_twf : forall x E T U,
  _wf E -> binds x (bind_sub T U) E -> lc_trm T /\ lc_trm U.
Proof.
  introv W Has. gen E. induction E using env_ind; intros.
  false* binds_empty_inv.
  induction v.
  destruct (twf_push_inv W).
  destruct (binds_push_inv Has) as [[? ?] | [? ?]].
  inversion H2. subst*.
  apply* IHE.
Qed.

Lemma term_from_binds_in_twf_left : forall x E T U,
  _wf E -> binds x (bind_sub T U) E -> lc_trm T.
Proof.
  intros. destruct~ (term_from_binds_in_twf H H0).
Qed.

Lemma term_from_binds_in_twf_right : forall x E T U,
  _wf E -> binds x (bind_sub T U) E -> lc_trm U.
Proof.
  intros. destruct~ (term_from_binds_in_twf H H0).
Qed.

Hint Extern 1 (lc_trm ?t) => match goal with
  | H: binds ?x (bind_sub t ?t2) ?E |- _ => apply (@term_from_binds_in_twf_left x E)
  | H: binds ?x (bind_sub ?t2 t) ?E |- _ => apply (@term_from_binds_in_twf_right x E)
  end.

Lemma twf_left : forall E F : env,
  _wf (E & F) -> _wf E.
Proof.
  intros. induction F using env_ind.
  rewrite~ concat_empty_r in H.
  rewrite concat_assoc in H.
   inversions H. false (empty_push_inv H1).
   destruct (eq_push_inv H0) as [? [? ?]]. subst~.
Qed.

Implicit Arguments twf_left [E F].

Lemma typing_fresh : forall E T U M x,
  _typing E T U M -> x # E -> x \notin fv T.
Proof.
  introv Typ.
  induction Typ; simpls; intros; try solve [eauto 4].
  rewrite notin_singleton. intro. subst. applys binds_fresh_inv H0 H1.
  pick_fresh y. notin_simpl; auto. apply* (@fv_open_var y).
  pick_fresh y. notin_simpl; auto. apply* (@fv_open_var y).
Qed.

Lemma notin_fv_from_twf : forall E F x U V,
  _wf (E & x ~ bind_sub U V & F) -> x \notin fv U /\ x \notin fv V.
Proof.
  intros.
  lets W: (twf_left H). inversions W.
  false (empty_push_inv H1).
  destruct (eq_push_inv H0) as [? [P ?]]. inversions P.
  split; apply* typing_fresh.
Qed.

Hint Extern 1 (?x \notin fv ?U) =>
  match goal with H: _wf (?E & x ~ (bind_sub U ?V) & ?F) |- _ =>
    apply (proj1 (notin_fv_from_twf H)) end.

Hint Extern 1 (?x \notin fv ?V) =>
  match goal with H: _wf (?E & x ~ (bind_sub ?U V) & ?F) |- _ =>
    apply (proj2 (notin_fv_from_twf H)) end.

Lemma notin_fv_from_tbinds : forall x y T U E,
  _wf E -> binds y (bind_sub T U) E -> x # E -> x \notin fv T /\ x \notin fv U.
Proof.
  induction E using env_ind; intros.
  false* binds_empty_inv.
  induction v.
  destruct (twf_push_inv H).
    destruct (binds_push_inv H0) as [[? ?] | [? ?]].
    inversion H5. subst. inversions H. false* (empty_push_inv H6).
     destruct (eq_push_inv H4) as [? [? ?]].  inversion H9. subst~.
     split; apply* typing_fresh.
    autos*.
Qed.

Lemma notin_fv_from_tbinds_left : forall x y T U E,
  _wf E -> binds y (bind_sub T U) E -> x # E -> x \notin fv T.
Proof.
  introv A B C. destructs~ (notin_fv_from_tbinds A B C).
Qed.

Lemma notin_fv_from_tbinds_right : forall x y T U E,
  _wf E -> binds y (bind_sub T U) E -> x # E -> x \notin fv U.
Proof.
  introv A B C. destructs~ (notin_fv_from_tbinds A B C).
Qed.

Lemma notin_fv_from_tbinds' : forall E F x V y U1 U2,
  _wf (E & x ~ V & F) ->
  binds y (bind_sub U1 U2) E ->
  x \notin fv U1 /\ x \notin fv U2.
Proof.
  intros. lets W: (twf_left H). inversions keep W.
  false (empty_push_inv H2).
  induction V.
  destruct (eq_push_inv H1) as [? [P ?]]. inversion P. subst~.
  lets W': (twf_left W). apply* notin_fv_from_tbinds.
Qed.

Hint Extern 1 (?x \notin fv ?U1) =>
  match goal with H: _wf (?E & x ~ ?V & ?F), B: binds ?y (bind_sub U1 ?U2) ?E |- _ =>
    apply (proj1 (notin_fv_from_tbinds' H B)) end.

Hint Extern 1 (?x \notin fv ?U2) =>
  match goal with H: _wf (?E & x ~ ?V & ?F), B: binds ?y (bind_sub ?U1 U2) ?E |- _ =>
    apply (proj2 (notin_fv_from_tbinds' H B)) end.

Lemma tsub_weaken : forall G E F t T,
  _sub (E & G) t T ->
  _wf (E & F & G) ->
  _sub (E & F & G) t T.
Proof.
  introv Sub Wf.
  gen_eq Env: (E & G). gen E F G.
  apply tsub_induct with
   (P := fun Env t T M (Typt : _typing Env t T M) =>
      forall E F G, _wf (E & F & G) -> Env = E & G ->
      _typing (E & F & G) t T M)
   (P0 := fun (Env:env) (W: _wf Env) =>
      forall E F G, _wf (E & F & G) -> Env = E & G ->
      _wf (E & F & G))
   (P1 := fun (Env:env) t T (Subt : _sub Env t T) =>
      forall E F G, _wf (E & F & G) -> Env = E & G ->
      _sub (E & F & G) t T);
   intros; subst; simpls subst; try solve [autos*].

  (* case: var *)
  apply* _typing_var. apply* binds_weaken.
  (* case: trm_abs *)
  apply_fresh* (@_typing_lam MB) as y.
  apply_ih_bind* H1. apply_ih_bind* H2.
  (* case: trm_prod *)
  apply_fresh* (@_typing_pi) as y. apply_ih_bind* H1.

  (* case: var *)
  apply* _sub_var_refl. apply* binds_weaken.
  (* case: trans *)
  apply* (@_sub_var_trans e1 A). apply* binds_weaken.
  (* case: trm_abs *)
  apply_fresh* (@_sub_lam Me3 MA) as y.
  apply_ih_bind* H1.
  (* case: trm_prod *)
  apply_fresh* (@_sub_pi Me MC) as y.
  apply_ih_bind* H2.
Qed.

Lemma typing_weaken : forall G E F t T M,
  _typing (E & G) t T M ->
  _wf (E & F & G) ->
  _typing (E & F & G) t T M.
Proof.
  introv Sub Wf.
  gen_eq Env: (E & G). gen E F G.
  apply typing_induct with
   (P := fun Env t T M (Typt : _typing Env t T M) =>
      forall E F G, _wf (E & F & G) -> Env = E & G ->
      _typing (E & F & G) t T M)
   (P0 := fun (Env:env) (W: _wf Env) =>
      forall E F G, _wf (E & F & G) -> Env = E & G ->
      _wf (E & F & G))
   (P1 := fun (Env:env) t T (Subt : _sub Env t T) =>
      forall E F G, _wf (E & F & G) -> Env = E & G ->
      _sub (E & F & G) t T);
   intros; subst; simpls subst; try solve [autos* | apply* tsub_weaken].

  (* case: var *)
  apply* _typing_var. apply* binds_weaken.
  (* case: trm_abs *)
  apply_fresh* (@_typing_lam MB) as y.
  apply_ih_bind* H1. apply_ih_bind* H2.
  (* case: trm_prod *)
  apply_fresh* (@_typing_pi) as y. apply_ih_bind* H1.
Qed.

Lemma tsub_refl : forall G t T M,
  _typing G t T M -> _sub G t t.
Proof.
  intros. inductions H; eauto.
Qed.

Lemma typing_wf_from_context : forall x T U (E:env),
  binds x (bind_sub T U) E ->
  _wf E -> exists M1 M2,
  _typing E T U M1 /\
  _typing E U trm_star M2.
Proof.
  introv B W. induction E using env_ind.
  false* binds_empty_inv.
  destruct (binds_push_inv B) as [[? ?]|[? ?]].
    subst. inversions W. false (empty_push_inv H0).
     destruct (eq_push_inv H) as [? [P ?]]. inversions P. subst.
     exists Me MA.
     split; apply_empty* typing_weaken.
    induction v.
    destruct (twf_push_inv W).
    destruct~ IHE as [M1 [M2 [? ?]]].
     exists M1 M2. split; apply_empty* typing_weaken.
Qed.

Lemma typing_wf_from_twf : forall G x e A,
  _wf (G & x ~ bind_sub e A) -> exists M1 M2, _typing G e A M1 /\ _typing G A (trm_star) M2.
Proof.
  intros. inversions H.
  false. apply* empty_push_inv.
  destruct (eq_push_inv H0) as [? [? ?]]. inversion H4. exists Me MA. subst*.
Qed.

Lemma typing_substitution_var : forall V e (F:env) (y:var) (E:env) x t T M,
  binds y (bind_sub e V) E ->
  _typing (E & x ~ bind_sub e V & F) t T M ->
  _typing (E & (map (substenv x (trm_var_f y)) F)) (subst x (trm_var_f y) t) (subst x (trm_var_f y) T) (subst x (trm_var_f y) M).
Proof.
  introv Bnd Typt.
  gen_eq G: (E & x ~ bind_sub e V & F). gen F.
  apply typing_induct with
   (P := fun (G:env) t T M (Typt : _typing G t T M) =>
      forall (F:env), G = E & x ~ bind_sub e V & F ->
      _typing (E & map (substenv x (trm_var_f y)) F) ([x ~> trm_var_f y]t) ([x ~> trm_var_f y]T) ([x~>trm_var_f y] M))
   (P0 := fun (G:env) (W: _wf G) =>
      forall F, G = E & x ~ bind_sub e V & F ->
      _wf (E & (map (substenv x (trm_var_f y)) F)))
   (P1 := fun (G:env) t T (Subt : _sub G t T) =>
      forall (F:env), G = E & x ~ bind_sub e V & F ->
      _sub (E & map (substenv x (trm_var_f y)) F) ([x ~> trm_var_f y]t) ([x ~> trm_var_f y]T));
   intros; subst; simpls subst; try solve [eauto 4].
  (* case: var *)
  case_var.
    binds_mid~. inversions TEMP. rewrite* subst_fresh. apply_empty* typing_weaken.
    apply* (@_typing_var e). apply* twf_left.
    apply~ (@_typing_var ([x~>trm_var_f y]e0)). rewrite substenv_eq.
    destruct~ (binds_not_middle_inv b) as [K|[Fr K]]. rewrite* substenv_fresh.
  (* case: trm_abs *)
  apply_fresh* (@_typing_lam ([x ~> trm_var_f y]MB)) as y; rewrite* substenv_eq.
   cross; auto. apply_ih_map_bind* H1.
   cross; auto. apply_ih_map_bind* H2.
  (* case: trm_app *)
  rewrite* subst_open.
  (* case: trm_prod *)
  apply_fresh* (@_typing_pi) as y; rewrite* substenv_eq.
   cross; auto. apply_ih_map_bind* H1.
  (* case: castup *)
  apply* _typing_castup. apply* reduct_red_out.
  (* case: castdn *)
  apply* _typing_castdn. apply* reduct_red_out.
  (* case: sub *)
  apply* (@_typing_sub ([x ~> trm_var_f y] A)).
  (* case: wf nil *)
  false (empty_middle_inv H).
  (* case: wf cons *)
  change LibEnv.env with LibEnv.env in *.
  induction F using env_ind.
    rewrite concat_empty_r in H1.
     destruct (eq_push_inv H1) as [? [? ?]]. subst.
     rewrite map_empty. rewrite~ concat_empty_r.
    clear IHF. rewrite concat_assoc in H1.
     destruct (eq_push_inv H1) as [? [? ?]]. subst.
     rewrite map_push. rewrite concat_assoc. apply* (@_wf_cons).
  (* case sub_var *)
  case_var.
    binds_mid~. apply_empty* tsub_weaken.
    asserts*: (_typing E (trm_var_f y) V (trm_var_f y)).
    apply* (@_typing_var e). apply* twf_left. apply* tsub_refl.
    apply _sub_var_refl with (A := [x ~> trm_var_f y] A) (e := [x ~> trm_var_f y] e0). auto.
    rewrite substenv_eq.
    destruct~ (binds_not_middle_inv b) as [K|[Fr K]]. rewrite* substenv_fresh.
  (* case sub_var trans *)
  asserts* W: (_wf (E & x ~ bind_sub e V & F)).
  case_var.
    binds_mid~. inversions TEMP.
    lets: (H _ eq_refl).
    apply (@_sub_var_trans e V).
    rewrite <- concat_empty_r.
    apply* binds_weaken. rewrite concat_empty_r. apply* ok_from_twf.
    rewrite* subst_fresh in H0.
    apply* (@_sub_var_trans ([x~>trm_var_f y]e1) ([x~>trm_var_f y]A)).
    rewrite substenv_eq.
    destruct~ (binds_not_middle_inv b) as [K|[Fr K]]. rewrite* substenv_fresh.
  (* case: sub_abs *)
  apply_fresh* (@_sub_lam ([x~>trm_var_f y]Me3) ([x~>trm_var_f y]MA)) as y;
    rewrite* substenv_eq.
   cross; auto. apply_ih_map_bind* H1.
  (* case: sub_app *)
  autos*.
  (* case: sub_prod *)
  apply_fresh* (@_sub_pi ([x~>trm_var_f y]Me) ([x~>trm_var_f y]MC)) as y;
    rewrite* substenv_eq.
  cross; auto. apply_ih_map_bind* H2.
Qed.

Lemma typing_rename : forall x y E e U1 T1 T2 M,
  x \notin (fv e \u fv T2 \u fv M) -> y \notin (dom E \u fv e) ->
  _typing (E & (x ~ bind_sub U1 T1)) (e ^ x) (T2 ^ x) (M ^ x) ->
  _typing (E & (y ~ bind_sub U1 T1)) (e ^ y) (T2 ^ y) (M ^ y).
Proof.
  intros.
  tests: (x = y). auto.
  lets W: (proj1 (regular_typing H1)).
  inductions W. false* (empty_push_inv).
  destruct (eq_push_inv x) as [Eq1 [Eq2 Eq3]].
  inversions Eq2.
  rewrite* (@subst_intro x1 e).
  rewrite* (@subst_intro x1 T2).
  rewrite* (@subst_intro x1 M).
  apply_empty* (@typing_substitution_var T1 U1).
  apply* typing_weaken.
  apply _wf_cons with (MA := MA) (Me := Me).
  auto.
  apply_empty* typing_weaken.
  apply_empty* typing_weaken.
Qed.

Lemma styping_to_typing : forall G t T,
  S._typing G t T -> exists M, _typing G t T M.
Proof.
  apply S.typing_induct with
   (P0 := fun (G:env) (W:S._wf G) => _wf G)
   (P1 := fun (G:env) e1 e2 (W:S._sub G e1 e2) =>
            _sub G e1 e2);
    intros; eauto 3.
  (* top *)
  destruct H as [MA ?]. exists* (trm_anno trm_top MA).
  (* abs *)
  destruct H as [Me1 ?].
  destruct H0 as [MA ?].
  pick_fresh y.
  lets P1: H1 y __. auto. destruct P1 as [MB ?].
  lets P2: H2 y __. auto. destruct P2 as [Me2 ?].
  exists (trm_abs Me1 MA (close_var y Me2)).
  apply_fresh* (@_typing_lam (close_var y MB)) as z.
  asserts* W: (trm_star = trm_star ^ z). rewrite W.
  apply* (@typing_rename y). notin_simpl; simpl; auto.
  apply* close_var_fresh. rewrite* <- (@close_var_open y).
  apply* (@typing_rename y). notin_simpl; simpl; auto.
  apply* close_var_fresh. rewrite* <- (@close_var_open y).
  (* app *)
  destruct H as [MA ?].
  destruct H1 as [Me ?].
  exists* (trm_app Me MA).
  (* prod *)
  destruct H as [Me ?].
  destruct H0 as [MA ?].
  pick_fresh y.
  lets P1: H1 y __. auto. destruct P1 as [MB ?].
  exists (trm_prod Me MA (close_var y MB)).
  apply_fresh* (@_typing_pi) as z.
  asserts* W: (trm_star = trm_star ^ z). rewrite W.
  apply* (@typing_rename y). notin_simpl; simpl; auto.
  apply* close_var_fresh. rewrite* <- (@close_var_open y).
  (* castup *)
  destruct H as [MB ?].
  destruct H0 as [Me ?].
  exists* (trm_castup MB Me).
  (* casedn *)
  destruct H as [MB ?].
  destruct H0 as [Me ?].
  exists* (trm_anno (trm_castdn Me) MB).
  (* sub *)
  destruct H as [Me ?].
  destruct H1 as [MB ?].
  exists* (trm_anno Me MB).
  (* wf cons *)
  destruct H as [Me ?].
  destruct H0 as [MA ?].
  apply* _wf_cons.
  (* sub abs *)
  destruct H as [Me3 ?].
  destruct H0 as [MA ?].
  apply_fresh* (@_sub_lam Me3 MA) as y.
  (* sub prod *)
  destruct H as [Me ?].
  destruct H0 as [MC ?].
  apply_fresh* (@_sub_pi Me MC) as y.
Qed.

Lemma stsub_to_tsub : forall G t T,
  S._sub G t T -> _sub G t T.
Proof.
  apply S.tsub_induct with
   (P := fun G t T (W:S._typing G t T) =>
     exists M, _typing G t T M)
   (P0 := fun (G:env) (W:S._wf G) => _wf G)
   (P1 := fun (G:env) e1 e2 (W:S._sub G e1 e2) =>
            _sub G e1 e2);
    intros; eauto 3.
  (* top *)
  destruct H as [MA ?]. exists* (trm_anno trm_top MA).
  (* abs *)
  destruct H as [Me1 ?].
  destruct H0 as [MA ?].
  pick_fresh y.
  lets P1: H1 y __. auto. destruct P1 as [MB ?].
  lets P2: H2 y __. auto. destruct P2 as [Me2 ?].
  exists (trm_abs Me1 MA (close_var y Me2)).
  apply_fresh* (@_typing_lam (close_var y MB)) as z.
  asserts* W: (trm_star = trm_star ^ z). rewrite W.
  apply* (@typing_rename y). notin_simpl; simpl; auto.
  apply* close_var_fresh. rewrite* <- (@close_var_open y).
  apply* (@typing_rename y). notin_simpl; simpl; auto.
  apply* close_var_fresh. rewrite* <- (@close_var_open y).
  (* app *)
  destruct H as [MA ?].
  destruct H1 as [Me ?].
  exists* (trm_app Me MA).
  (* prod *)
  destruct H as [Me ?].
  destruct H0 as [MA ?].
  pick_fresh y.
  lets P1: H1 y __. auto. destruct P1 as [MB ?].
  exists (trm_prod Me MA (close_var y MB)).
  apply_fresh* (@_typing_pi) as z.
  asserts* W: (trm_star = trm_star ^ z). rewrite W.
  apply* (@typing_rename y). notin_simpl; simpl; auto.
  apply* close_var_fresh. rewrite* <- (@close_var_open y).
  (* castup *)
  destruct H as [MB ?].
  destruct H0 as [Me ?].
  exists* (trm_castup MB Me).
  (* casedn *)
  destruct H as [MB ?].
  destruct H0 as [Me ?].
  exists* (trm_anno (trm_castdn Me) MB).
  (* sub *)
  destruct H as [Me ?].
  destruct H1 as [MB ?].
  exists* (trm_anno Me MB).
  (* wf cons *)
  destruct H as [Me ?].
  destruct H0 as [MA ?].
  apply* _wf_cons.
  (* sub abs *)
  destruct H as [Me3 ?].
  destruct H0 as [MA ?].
  apply_fresh* (@_sub_lam Me3 MA) as y.
  (* sub prod *)
  destruct H as [Me ?].
  destruct H0 as [MC ?].
  apply_fresh* (@_sub_pi Me MC) as y.
Qed.

Lemma stwf_to_twf : forall G,
  S._wf G -> _wf G.
Proof.
  intros. inductions H; auto.
  destruct (styping_to_typing H0) as [Me ?].
  destruct (styping_to_typing H1) as [MA ?].
  apply* _wf_cons.
Qed.

Lemma typing_to_styping : forall G t T M,
  _typing G t T M -> S._typing G t T.
Proof.
  apply typing_induct with
   (P0 := fun (G:env) (W:_wf G) => S._wf G)
   (P1 := fun (G:env) e1 e2 (W:_sub G e1 e2) =>
            S._sub G e1 e2);
    intros; eauto 3.
Qed.

Lemma tsub_to_stsub : forall G t T,
  _sub G t T -> S._sub G t T.
Proof.
  apply tsub_induct with
   (P := fun G t T M (W:_typing G t T M) => S._typing G t T)
   (P0 := fun (G:env) (W:_wf G) => S._wf G)
   (P1 := fun (G:env) e1 e2 (W:_sub G e1 e2) =>
            S._sub G e1 e2);
    intros; eauto 3.
Qed.

Lemma twf_to_stwf : forall G,
  _wf G -> S._wf G.
Proof.
  apply twf_induct with
   (P := fun G t T M (W:_typing G t T M) => S._typing G t T)
   (P0 := fun (G:env) (W:_wf G) => S._wf G)
   (P1 := fun (G:env) e1 e2 (W:_sub G e1 e2) =>
            S._sub G e1 e2);
    intros; eauto 3.
Qed.

Fixpoint remove_anno (e : trm) {struct e} : trm :=
  match e with
  | trm_var_b i        => trm_var_b i
  | trm_var_f x        => trm_var_f x
  | trm_star          => trm_star
  | trm_top           => trm_top
  | trm_app t1 t2     => trm_app (remove_anno t1) (remove_anno t2)
  | trm_abs t0 t1 t2  => trm_abs (remove_anno t0) (remove_anno t1) (remove_anno t2)
  | trm_prod t0 t1 t2 => trm_prod (remove_anno t0) (remove_anno t1) (remove_anno t2)
  | trm_castup t1 t2  => trm_castup (remove_anno t1) (remove_anno t2)
  | trm_castdn t1     => trm_castdn (remove_anno t1)
  | trm_anno t1 t2    => remove_anno t1
  end.

Notation "[# e #]" := (remove_anno e) (at level 2).

Definition rem_anno_env (p:binding) :=
  match p with
  | bind_sub e A => bind_sub (remove_anno e) (remove_anno A)
  end.

Lemma rem_anno_env_eq : forall e1 e2,
  bind_sub [#e1#] [#e2#] = rem_anno_env (bind_sub e1 e2).
Proof.
  intros. simpls*.
Qed.

Notation "{# E #}" := (map rem_anno_env E) (at level 2).

Lemma open_rem_comm : forall A B,
  [# A ^^ B #] = [#A#] ^^ [#B#].
Proof.
  intros. unfolds open_trm_wrt_trm. generalize 0.
  induction A; intros; simpls; autos*.
  case_nat~.
  rewrite* (IHA1 n). rewrite* (IHA2 n).
  rewrite* (IHA1 n). rewrite* (IHA2 n). rewrite* (IHA3 (S n)).
  rewrite* (IHA1 n). rewrite* (IHA2 n). rewrite* (IHA3 (S n)).
  rewrite* (IHA1 n). rewrite* (IHA2 n).
  rewrite* (IHA n).
Qed.

Lemma subst_rem : forall x u e,
  [# [x ~> u]e #] = [x ~> [#u#] ] [#e#].
Proof.
  intros. induction e; simpl; f_equal*.
  case_var*.
Qed.

Lemma rem_not_fv : forall x e,
  x \notin fv e ->
  x \notin fv [#e#].
Proof.
  intros. inductions e; simpls; autos*.
Qed.

Lemma double_rem_eq : forall A,
  [# [#A#] #] = [#A#].
Proof.
  intros. inductions A; simpls; try solve [fequals | auto].
Qed.

Lemma dbinds_rem : forall x e A E,
  binds x (bind_sub e A) E ->
  binds x (bind_sub [#e#] [#A#]) {#E#}.
Proof.
  intros. induction E using env_ind.
  false* (binds_empty_inv).
  induction v.
  destruct (binds_push_inv H) as [[? ?]|[? ?]].
  inversions H1. rewrite* rem_anno_env_eq.
  lets: (IHE H1).
  rewrite* rem_anno_env_eq.
Qed.

Lemma double_rem_env_eq : forall E,
  {# {#E#} #} = {#E#}.
Proof.
  intros. induction E using env_ind.
  rewrite map_empty.
  rewrite* map_empty.
  rewrite map_push.
  rewrite map_push.
  rewrite IHE.
  induction v.
  rewrite <- rem_anno_env_eq.
  rewrite <- rem_anno_env_eq.
  rewrite* double_rem_eq.
  rewrite* double_rem_eq.
Qed.

Lemma typing_era : forall G t T M,
  _typing G t T M -> [#M#] = t /\ {#G#} = G /\ [#t#] = t /\ [#T#] = T.
Proof.
  apply typing_induct with
   (P0 := fun (G:env) (W:_wf G) => {#G#} = G)
   (P1 := fun (G:env) e1 e2 (W:_sub G e1 e2) =>
            {#G#} = G);
    intros; simpls; try (splits*); fequals*.
  (* var *)
  lets: dbinds_rem b.
  rewrite <- H in b.
  lets: binds_func b H0.
  injection H1; intros. auto.
  (* abs *)
  pick_fresh y. destructs~ (H2 y).
  rewrite open_rem_comm in *. simpl in *.
  apply* open_var_inj. apply* rem_not_fv.
  pick_fresh y. destructs~ (H2 y).
  rewrite open_rem_comm in *. simpl in *.
  apply* open_var_inj. apply* rem_not_fv.
  pick_fresh y. destructs~ (H2 y).
  rewrite open_rem_comm in *. simpl in *.
  apply* open_var_inj. apply* rem_not_fv.
  (* app *)
  rewrite* open_rem_comm.
  fequals*.
  destructs H1. injection H4; intros; auto.
  (* prod *)
  pick_fresh y. destructs~ (H1 y).
  rewrite open_rem_comm in *. simpl in *.
  apply* open_var_inj. apply* rem_not_fv.
  pick_fresh y. destructs~ (H1 y).
  rewrite open_rem_comm in *. simpl in *.
  apply* open_var_inj. apply* rem_not_fv.
  (* env nil *)
  rewrite* map_empty.
  (* env push *)
  rewrite* map_push.
  simpls.
  destructs H. rewrite H1. rewrite H2. rewrite~ H3.
Qed.

Inductive dsub : env -> trm -> trm -> Prop :=
  | dsub_star : forall G, ok G -> dsub G trm_star trm_star
  | dsub_var_refl : forall G x e A,
      ok G -> binds x (bind_sub e A) G -> dsub G (trm_var_f x) (trm_var_f x)
  | dsub_var_trans : forall e1 A G x e2,
      binds x (bind_sub e1 A) G -> dsub G e1 e2 ->
      dsub G (trm_var_f x) e2
  | dsub_top : forall G e,
      ok G -> lc_trm e -> dsub G e trm_top
  | dsub_lam : forall L G e1 e2 e3 A,
      ok G ->
      (forall x, x \notin L -> dsub (G & x ~ bind_sub [#e3#] [#A#]) (e1 ^ x) (e2 ^ x)) ->
      dsub G (trm_abs e3 A e1) (trm_abs e3 A e2)
  | dsub_app : forall G e1 e2 A,
      lc_trm A ->
      dsub G e1 e2 -> dsub G (trm_app e1 A) (trm_app e2 A)
  | dsub_pi : forall L G e A B C D,
      dsub G C A ->
      (forall x, x \notin L -> dsub (G & x ~ bind_sub [#e#] [#C#]) (B ^ x) (D ^ x)) ->
      dsub G (trm_prod e A B) (trm_prod e C D)
  | dsub_castup : forall G A e1 e2,
      lc_trm A -> dsub G e1 e2 -> dsub G (trm_castup A e1) (trm_castup A e2)
  | dsub_castdn : forall G e1 e2,
      dsub G e1 e2 -> dsub G (trm_castdn e1) (trm_castdn e2).

Inductive dir := inf | chk.

Inductive dtyping : dir -> env -> trm -> trm -> Prop :=
  | dtyping_star : forall G,
      dwf G -> dtyping inf G trm_star trm_star
  | dtyping_var : forall e G x A,
      dwf G -> binds x (bind_sub e A) G -> dtyping inf G (trm_var_f x) A
  | dtyping_top : forall G A,
      dtyping chk G A trm_star -> dtyping chk G trm_top A
  | dtyping_lam : forall L G e1 e2 A B,
      dtyping chk G e1 [#A#] ->
      dtyping chk G A trm_star ->
      (forall x, x \notin L ->
                 dtyping inf (G & x ~ bind_sub [#e1#] [#A#]) (e2 ^ x) (B ^ x)) ->
      dtyping inf G (trm_abs e1 A e2) (trm_prod [#e1#] [#A#] B)
  | dtyping_app : forall e3 G e A B C,
      dtyping chk G A B ->
      dsub G [#A#] e3 ->
      dtyping inf G e (trm_prod e3 B C) ->
      dtyping inf G (trm_app e A) (C ^^ [#A#])
  | dtyping_pi : forall L G e A B,
      dtyping chk G e [#A#] ->
      dtyping chk G A trm_star ->
      (forall x, x \notin L ->
        dtyping chk (G & x ~ bind_sub [#e#] [#A#]) (B ^ x) trm_star) ->
      dtyping inf G (trm_prod e A B) trm_star
  | dtyping_castup : forall G e A B,
      dtyping chk G B trm_star ->
      dtyping inf G e A ->
      reduct [#B#] [#A#] ->
      dtyping inf G (trm_castup B e) [#B#]
  | dtyping_castdn : forall G e A B,
      dtyping chk G B trm_star ->
      dtyping inf G e A ->
      reduct [#A#] [#B#] ->
      dtyping chk G (trm_castdn e) B
  | dtyping_anno : forall G e A,
      dtyping chk G e A ->
      dtyping chk G A trm_star ->
      dtyping inf G (trm_anno e A) [#A#]
  | dtyping_sub : forall A G e B,
      dtyping inf G e A ->
      dsub G A [#B#] ->
      dtyping chk G B trm_star ->
      dtyping chk G e B
  | dtyping_chk : forall G e A,
      dtyping inf G e A ->
      dtyping chk G e A

with dwf : env -> Prop :=
  | dwf_nil : dwf empty
  | dwf_cons : forall G x e A,
      x # G ->
      dtyping chk G e [#A#] ->
      dtyping chk G A trm_star ->
      dwf (G & x ~ bind_sub [#e#] [#A#]).

Hint Constructors dtyping dsub dwf.

Scheme dtyping_induct := Induction for dtyping Sort Prop
  with dwf_induct := Induction for dwf Sort Prop.

Lemma typing_to_dtyping : forall G t T M,
  _typing G t T M ->
  dtyping inf G M T.
Proof.
  intros.
  apply typing_induct with
   (P := fun G t T M (Ty:_typing G t T M) =>
           dtyping inf G M T)
   (P0 := fun (G:env) (W:_wf G) => dwf G)
   (P1 := fun (G:env) e1 e2 (S:_sub G e1 e2) => dsub G e1 e2)
   (e := G) (t := t) (t0 := T) (t1 := M);
    intros; eauto 4.
  (* top *)
  asserts* P1: (_typing G0 A trm_star MA).
  destructs (typing_era P1).
  rewrite <- H1.
  apply* dtyping_anno.
  (* abs *)
  asserts* P1: (_typing G0 e1 A Me1).
  destructs (typing_era P1). destructs (typing_era _0).
  rewrite <- H4. rewrite <- H8.
  pick_fresh z. lets: _1 z __. auto.
  destructs (typing_era H12).
  rewrite open_rem_comm in *. simpl in *.
  assert ([#B#] = B).
  apply* open_var_inj. apply* rem_not_fv.
  rewrite <- H17.
  apply_fresh* dtyping_lam as y. rewrite~ H8.
  rewrite H4. rewrite H8. rewrite~ H17.
  (* app *)
  asserts* P1: (_typing G0 A B MA).
  destructs (typing_era P1). destructs (typing_era _1).
  simpl in H10. injection H10; intros.
  rewrite <- H3. apply* dtyping_app.
  rewrite~ H3.
  (* prod *)
  asserts* P1: (_typing G0 e A Me).
  destructs (typing_era P1). destructs (typing_era _0).
  apply_fresh* dtyping_pi as y.
  rewrite~ H7.
  rewrite H3. rewrite~ H7.
  (* castup *)
  asserts* P1: (_typing G0 B trm_star MB).
  destructs (typing_era P1).  destructs (typing_era _0).
  rewrite <- H2. apply* dtyping_castup.
  rewrite H2. rewrite~ H9.
  (* castdn *)
  asserts* P1: (_typing G0 B trm_star MB).
  destructs (typing_era P1).  destructs (typing_era _0).
  rewrite <- H2. apply* dtyping_anno.
  apply* dtyping_castdn.
  rewrite H9. rewrite~ H2.
  (* sub *)
  asserts* P1: (_typing G0 e A Me).
  destructs (typing_era P1). destructs (typing_era _1).
  rewrite <- H7. apply* dtyping_anno.
  apply* dtyping_sub. rewrite~ H7.
  (* dwf cons *)
  asserts* P1: (_typing G0 e A Me).
  destructs (typing_era P1). destructs (typing_era _0).
  rewrite <- H2. rewrite <- H6.
  apply* dwf_cons. rewrite~ H6.
  (* sub abs *)
  apply_fresh* dsub_lam as y.
  apply* ok_from_twf.
  asserts* P1: (_typing G0 e3 A Me3).
  destructs (typing_era P1). destructs (typing_era _0).
  rewrite H5. rewrite~ H9.
  (* sub prod *)
  apply_fresh* dsub_pi as y.
  asserts* P1: (_typing G0 e C Me).
  destructs (typing_era P1). destructs (typing_era _0).
  rewrite H6. rewrite~ H7.
Qed.

Lemma tsub_to_dsub : forall G e1 e2,
  _sub G e1 e2 -> dsub G e1 e2.
Proof.
  intros.
  apply tsub_induct with
   (P := fun G t T M (Ty:_typing G t T M) =>
           dtyping inf G M T)
   (P0 := fun (G:env) (W:_wf G) => dwf G)
   (P1 := fun (G:env) e1 e2 (S:_sub G e1 e2) => dsub G e1 e2);
    intros; try solve [apply* typing_to_dtyping | eauto 4].
  (* dwf cons *)
  asserts* P1: (_typing G0 e A Me).
  destructs (typing_era P1). destructs (typing_era _0).
  rewrite <- H2. rewrite <- H6.
  apply* dwf_cons. rewrite~ H6.
  (* sub abs *)
  apply_fresh* dsub_lam as y.
  apply* ok_from_twf.
  asserts* P1: (_typing G0 e4 A Me3).
  destructs (typing_era P1). destructs (typing_era _0).
  rewrite H5. rewrite~ H9.
  (* sub prod *)
  apply_fresh* dsub_pi as y.
  asserts* P1: (_typing G0 e C Me).
  destructs (typing_era P1). destructs (typing_era _0).
  rewrite H6. rewrite~ H7.
Qed.

Lemma twf_to_wt : forall G x e A,
  S._wf (G & x ~ bind_sub e A) -> S._typing G e A /\ S._typing G A (trm_star).
Proof.
  intros. inversions H.
  false. apply* empty_push_inv.
  destruct (eq_push_inv H0) as [? [? ?]]. inversion H4. subst*.
Qed.

Lemma open_var_rem : forall x e,
  [#e ^ x#] = [#e#] ^ x.
Proof.
  intros. rewrite* open_rem_comm.
Qed.

Lemma styping_castup_inv : forall G A e T,
  S._typing G (trm_castup A e) T ->
  exists B, S._typing G e B.
Proof.
  intros. inductions H; eauto.
Qed.

Lemma styping_castdn_inv : forall G e T,
  S._typing G (trm_castdn e) T ->
  exists B, S._typing G e B.
Proof.
  intros. inductions H; eauto.
Qed.

Lemma dsub_to_stsub : forall G e1 e2,
  dsub G e1 e2 ->
  forall A B, S._typing {#G#} [#e1#] A ->
              S._typing {#G#} [#e2#] B ->
              S._sub {#G#} [#e1#] [#e2#].
Proof.
  intros. gen A B.
  inductions H; intros; simpls; eauto 2.
  (* case: sub var *)
  lets: dbinds_rem H0.
  apply* S._sub_var_refl.
  (* case: sub var trans *)
  lets: dbinds_rem H.
  destructs~ (S.typing_wf_from_context H3).
  apply S._sub_var_trans with (e1 := [#e1#])(A:=[#A#]).
    auto. apply* IHdsub.
  (* case: sub lam *)
  destruct (S.typing_abs_inv H2) as [TT [LL ?]].
  destructs H4.
  destruct (S.typing_abs_inv H3) as [TT2 [LL2 ?]].
  destructs H9.
  apply_fresh S._sub_lam as y.
    auto. auto. rewrite <- open_var_rem.
    rewrite <- open_var_rem.
    rewrite <- double_rem_eq.
    asserts W2: ([#A#] = [#[#A#]#]).
    rewrite* double_rem_eq.
    rewrite W2.
    rewrite rem_anno_env_eq.
    rewrite <- map_push.
    lets M1: H1 y __. auto. lets M2: H8 y __. auto.
    lets M3: H13 y __. auto.
    rewrite map_push in *. rewrite <- rem_anno_env_eq in *.
    rewrite double_rem_eq in *.
    rewrite double_rem_eq in *.
    rewrite open_var_rem in *.
    rewrite open_var_rem in *.
    apply* M1.
  (* case: sub app *)
  destruct (S.typing_app_inv H1) as [e3' [B' [C' ?]]].
  destructs H3.
  destruct (S.typing_app_inv H2) as [e3'' [B'' [C'' ?]]].
  destructs H7.
  apply S._sub_app. auto. apply* IHdsub.
  (* case: sub prod *)
  destructs (S.typing_prod_inv H2).
  destruct H7 as [L' ?].
  destructs (S.typing_prod_inv H3).
  destruct H11 as [L'' ?].
  apply_fresh S._sub_pi as y.
    auto. auto. apply* IHdsub.
    rewrite <- open_var_rem.
    rewrite <- open_var_rem.
    rewrite <- double_rem_eq.
    asserts W2: ([#C#] = [#[#C#]#]).
    rewrite* double_rem_eq.
    rewrite W2.
    rewrite rem_anno_env_eq.
    rewrite <- map_push.
    lets M1: H1 y __. auto. lets M2: H7 y __. auto.
    lets M3: H11 y __. auto.
    rewrite map_push in *. rewrite <- rem_anno_env_eq in *.
    rewrite double_rem_eq in *.
    rewrite double_rem_eq in *.
    rewrite open_var_rem in *.
    rewrite open_var_rem in *.
    apply (M1 trm_star) with (B0 := trm_star).
      apply_empty~ (@S.typing_narrowing_typ [#e#] [#A#] [#C#]).
      apply* IHdsub.
      auto.
  (* case: sub castup *)
  destruct (styping_castup_inv H1) as [T1 ?].
  destruct (styping_castup_inv H2) as [T2 ?].
  asserts* TM1: (lc_trm (trm_castup [#A#] [#e2#])).
  inversions TM1.
  apply S._sub_castup. auto. apply* IHdsub.
  (* case: sub castdn *)
  destruct (styping_castdn_inv H0) as [T1 ?].
  destruct (styping_castdn_inv H1) as [T2 ?].
  apply S._sub_castdn. apply* IHdsub.
Qed.

Lemma dtyping_to_styping : forall d G t T,
  dtyping d G t T ->
  S._typing {#G#} [#t#] [#T#].
Proof.
  apply dtyping_induct with
    (P := fun d G t T (Ty: dtyping d G t T) =>
      S._typing {#G#} [#t#] [#T#])
    (P0 := fun G (W: dwf G) => S._wf {#G#});
  intros; simpls; eauto 2.
  (* case: var *)
  lets: dbinds_rem b.
  apply* S._typing_var.
  (* case: abs *)
  rewrite double_rem_eq.
  rewrite double_rem_eq.
  rewrite double_rem_eq in *.
  apply_fresh S._typing_lam as y.
    auto. auto. rewrite <- open_var_rem.
    lets: H1 y __. auto.
    lets: (S.typing_wf_from_typing H2).
    rewrite map_push in *. rewrite <- rem_anno_env_eq in *.
    rewrite double_rem_eq in *. rewrite double_rem_eq in *.
    auto.
    lets: H1 y __. auto.
    rewrite map_push in *. rewrite <- rem_anno_env_eq in *.
    rewrite double_rem_eq in *. rewrite double_rem_eq in *.
    rewrite <- open_var_rem. rewrite~ <- open_var_rem.
  (* case: app *)
  rewrite open_rem_comm.
  rewrite double_rem_eq.
  lets: S.typing_wf_from_typing H0.
  destructs (S.typing_prod_inv H1).
  apply S._typing_app with (e3 := [#e3#])(B := [#B#]).
    auto. assert ([#A#] = [#[#A#]#]). rewrite *double_rem_eq.
    rewrite H6. rewrite H6 in H.
    apply* dsub_to_stsub. auto.
  (* case: prod *)
  rewrite double_rem_eq in *.
  apply_fresh S._typing_pi as y.
    auto. auto. rewrite <- open_var_rem.
    lets: H1 y __. auto.
    rewrite map_push in *. rewrite <- rem_anno_env_eq in *.
    rewrite double_rem_eq in *. rewrite double_rem_eq in *.
    auto.
  (* case: castup *)
  rewrite double_rem_eq.
  apply* S._typing_castup.
  (* case: anno *)
  rewrite* double_rem_eq.
  (* case: sub *)
  lets: S.typing_wf_from_typing H.
  apply (@S._typing_sub [#A#]).
    auto. assert ([#B#] = [#[#B#]#]). rewrite *double_rem_eq.
    rewrite H2. rewrite H2 in H0.
    apply* dsub_to_stsub. auto.
  (* case: empty *)
  rewrite~ map_empty.
  (* case: cons *)
  rewrite map_push.
  rewrite <- rem_anno_env_eq.
  rewrite double_rem_eq in *.
  rewrite double_rem_eq in *.
  apply* S._wf_cons.
Qed.

Lemma sub_to_bidir : forall G e1 e2 A,
  sub G e1 e2 A ->
  dsub G e1 e2 /\
  exists e1' e2',
    dtyping inf G e1' A /\ dtyping inf G e2' A /\
    [#e1'#] = e1 /\ [#e2'#] = e2.
Proof.
  intros. destructs (S.sub_to H).
  split.
  apply tsub_to_dsub.
  apply~ stsub_to_tsub.
  destruct (styping_to_typing H0) as [Me1 P1].
  destruct (styping_to_typing H1) as [Me2 P2].
  destructs (typing_era P1).
  destructs (typing_era P2).
  exists Me1 Me2. splits*; apply* typing_to_dtyping.
Qed.

Lemma bidir_to_sub : forall G d e1 e2 A,
  dtyping d G e1 A ->
  dtyping d G e2 A ->
  dsub G e1 e2 ->
  sub {#G#} [#e1#] [#e2#] [#A#].
Proof.
  intros.
  lets P1: dtyping_to_styping H.
  lets P2: dtyping_to_styping H0.
  lets P3: dsub_to_stsub H1 P1 P2.
  apply* S.sub_from.
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e384m2e128m2e96p2e32m1_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


From Hammer Require Import Hammer.

From Topology Require Export MetricSpaces.
From ZornsLemma Require Import Proj1SigInjective.
Require Import FunctionalExtensionality.
From Topology Require Export Completeness.
Require Import Description.
Require Import Max.
Require Import Psatz.

Section UniformTopology.

Variable X Y:Type.
Variable d:Y->Y->R.
Variable y0:X->Y.
Hypothesis d_metric: metric d.
Hypothesis X_inhabited: inhabited X.

Definition uniform_space := { f:X->Y | bound (Im Full_set
(fun x:X => d (y0 x) (f x))) }.

Definition uniform_metric (f g:uniform_space) : R.
refine (match f, g with exist f0 Hf, exist g0 Hg =>
proj1_sig (sup (Im Full_set (fun x:X => d (f0 x) (g0 x))) _ _) end).
destruct Hf as [mf].
destruct Hg as [mg].
exists (mf + mg).
red; intros.
destruct H1.
rewrite H2.
apply Rle_trans with (d (y0 x) (f0 x) + d (y0 x) (g0 x)).
rewrite (metric_sym _ d d_metric (y0 x) (f0 x)); trivial;
apply triangle_inequality; trivial.
assert (d (y0 x) (f0 x) <= mf) by (apply H; exists x; trivial).
assert (d (y0 x) (g0 x) <= mg) by (apply H0; exists x; trivial).
auto with real.

destruct X_inhabited as [x0].
exists (d (f0 x0) (g0 x0)); exists x0; trivial; constructor.
Defined.

Lemma uniform_metric_is_metric: metric uniform_metric.
Proof. hammer_hook "UniformTopology" "UniformTopology.uniform_metric_is_metric".
constructor; intros.
unfold uniform_metric.
destruct x as [f0 Hf]; destruct y as [g0 Hg]; destruct sup.
simpl.
destruct X_inhabited as [x0].
apply Rge_trans with (d (f0 x0) (g0 x0)).
cut (d (f0 x0) (g0 x0) <= x); auto with real.
apply i.
exists x0; trivial.
constructor.
apply d_metric.
unfold uniform_metric.
destruct x as [f0 Hf]; destruct y as [g0 Hg].
destruct sup.
destruct sup.
simpl.
assert (Im Full_set (fun x:X => d (f0 x) (g0 x)) =
Im Full_set (fun x:X => d (g0 x) (f0 x))).
apply Extensionality_Ensembles; split; red; intros.
destruct H.
exists x1.
constructor.
rewrite metric_sym; trivial.
destruct H.
exists x1.
constructor.
rewrite metric_sym; trivial.
apply Rle_antisym.
apply i.
rewrite H.
apply i0.
apply i0.
rewrite <- H.
apply i.

destruct x as [f0 Hf]; destruct y as [g0 Hg]; destruct z as [h0 Hh].
simpl.
repeat destruct sup; simpl.
apply i.
red; intros.
destruct H.
rewrite H0.
apply Rle_trans with (d (f0 x2) (g0 x2) + d (g0 x2) (h0 x2)).
apply d_metric.
assert (d (f0 x2) (g0 x2) <= x0) by
(apply i0; exists x2; trivial).
assert (d (g0 x2) (h0 x2) <= x1) by
(apply i1; exists x2; trivial).
auto with real.

destruct x as [f0 Hf].
simpl.
destruct sup; simpl.
apply Rle_antisym.
apply i.
red; intros.
destruct H.
rewrite metric_zero in H0; trivial.
right; trivial.
apply i.
destruct X_inhabited as [x0].
exists x0.
constructor.
symmetry; apply d_metric.

destruct x as [f0 Hf]; destruct y as [g0 Hg].
apply subset_eq_compatT.
extensionality x.
apply d_metric.
simpl in H.
destruct sup in H.
simpl in H.
rewrite H in i; clear H.
apply Rle_antisym.
apply i; exists x; trivial.
constructor.
cut (d (f0 x) (g0 x) >= 0); auto with real.
apply d_metric.
Qed.

Definition UniformTopology : TopologicalSpace :=
MetricTopology uniform_metric uniform_metric_is_metric.

Lemma uniform_metric_complete: complete d d_metric ->
complete uniform_metric uniform_metric_is_metric.
Proof. hammer_hook "UniformTopology" "UniformTopology.uniform_metric_complete".
intros.
assert (forall y:Net nat_DS (MetricTopology d d_metric), cauchy d y ->
{ y0:Y | net_limit y y0 }) as cauchy_limit.
intros.
apply constructive_definite_description.
apply -> unique_existence; split.
apply H; trivial.
apply (Hausdorff_impl_net_limit_unique y).
apply T3_sep_impl_Hausdorff.
apply normal_sep_impl_T3_sep.
apply metrizable_impl_normal_sep.
exists d; trivial; apply MetricTopology_metrizable.

red; intros f ?.
unshelve refine (let H1 := _ in let H2 := _ in ex_intro _
(exist _ (fun x:X => proj1_sig (cauchy_limit
(fun n:nat => proj1_sig (f n) x) (H1 x))) H2) _); [ | clearbody H1 | clearbody H1 H2 ].
intros.
red; intros.
destruct (H0 eps H1) as [N].
exists N; intros.
apply Rle_lt_trans with (uniform_metric (f m) (f n)).
unfold uniform_metric.
destruct (f m) as [f0 Hf]; destruct (f n) as [g0 Hg]; destruct sup.
simpl.
apply i.
exists x; trivial; constructor.
apply H2; trivial.

assert (1 > 0) by (red; auto with real).
destruct (H0 1 H2) as [N].
pose (fN := f N).
assert (f N = fN) by reflexivity.
destruct fN as [fN [M]].
assert (forall (n:nat) (x:X), (n >= N)%nat -> d (proj1_sig (f n) x)
(proj1_sig (f N) x) < 1).
intros.
apply Rle_lt_trans with (uniform_metric (f n) (f N)).
unfold uniform_metric; destruct (f n) as [f0 Hf];
destruct (f N) as [g0 Hg]; destruct sup; simpl.
apply i0.
exists x; trivial.
constructor.
apply H3; trivial.
constructor.
assert (forall x:X,
d (fN x) (proj1_sig (cauchy_limit _ (H1 x))) <= 1).
intros.
apply lt_plus_epsilon_le.
intros.
destruct cauchy_limit; simpl.
pose proof (metric_space_net_limit_converse _ _
(MetricTopology_metrizable _ d d_metric) nat_DS
(fun n:nat => proj1_sig (f n) x) x0 n).
destruct (H7 eps H6) as [i0].
pose (N' := max N i0).
apply Rle_lt_trans with (d (fN x) (proj1_sig (f N') x) +
d x0 (proj1_sig (f N') x)).
rewrite metric_sym with (x:=x0) (y:=proj1_sig (f N') x); trivial.
apply d_metric.
replace (fN x) with (proj1_sig (f N) x).
assert (d (proj1_sig (f N) x) (proj1_sig (f N') x) < 1).
rewrite metric_sym; trivial.
apply H5.
apply le_max_l.
assert (d x0 (proj1_sig (f N') x) < eps).
apply H8.
apply le_max_r.
auto with real.
rewrite H4; reflexivity.
exists (M+1).
red; intros.
destruct H7.
rewrite H8; clear H8.
apply Rle_trans with (d (y0 x) (fN x) + d (fN x)
(proj1_sig (cauchy_limit _ (H1 x)))).
apply d_metric.
assert (d (y0 x) (fN x) <= M).
apply i.
exists x; trivial.
auto with real.

apply metric_space_net_limit with uniform_metric.
apply MetricTopology_metrizable.
intros.
assert (eps/2 > 0) by lra.
destruct (H0 (eps/2) H4) as [N].
exists N; intros.
apply Rle_lt_trans with (eps/2); try lra.
unfold uniform_metric; remember (f j) as fj; destruct fj as [fj].
destruct sup; simpl.
apply i.
red; intros.
destruct H7.
rewrite H8; clear y H8.
apply lt_plus_epsilon_le; intros.
destruct (cauchy_limit (fun n:nat => proj1_sig (f n) x0) (H1 x0));
simpl.
pose proof (metric_space_net_limit_converse _ _
(MetricTopology_metrizable _ d d_metric) nat_DS
(fun n:nat => proj1_sig (f n) x0) x1 n).
destruct (H9 eps0 H8) as [N'].
pose (N'' := max N N').
apply Rle_lt_trans with (d x1 (proj1_sig (f N'') x0) +
d (proj1_sig (f N'') x0) (proj1_sig (f j) x0)).
repeat rewrite <- Heqfj; simpl.
apply d_metric.
assert (d x1 (proj1_sig (f N'') x0) < eps0).
apply H10.
apply le_max_r.
assert (d (proj1_sig (f N'') x0) (proj1_sig (f j) x0) < eps/2).
apply Rle_lt_trans with (uniform_metric (f N'') (f j)).
unfold uniform_metric; destruct (f N'') as [f1];
destruct (f j) as [f2]; destruct sup; simpl.
apply i0; exists x0; trivial.
apply H5; trivial.
apply le_max_l.
rewrite (Rplus_comm (eps/2) eps0).
auto with real.
Qed.

End UniformTopology.

Arguments uniform_space {X} {Y}.
Arguments uniform_metric {X} {Y}.
Arguments UniformTopology {X} {Y}.

Section UniformTopology_and_continuity.

Variable X:TopologicalSpace.
Variable Y:Type.
Variable d:Y->Y->R.
Variable y0:point_set X -> Y.
Hypothesis d_metric: metric d.
Hypothesis X_inh: inhabited (point_set X).

Lemma continuous_functions_at_point_closed_in_uniform_metric:
forall x0:point_set X,
closed (fun f:uniform_space d y0 => continuous_at (proj1_sig f) x0
(Y:=MetricTopology d d_metric))
(X:=UniformTopology d y0 d_metric X_inh).
Proof. hammer_hook "UniformTopology" "UniformTopology.continuous_functions_at_point_closed_in_uniform_metric".
intros.
match goal with |- @closed ?X ?F => cut (Included (@closure X F) F) end.
intros.
match type of H with | Included ?A ?B => assert (A=B) end.
apply Extensionality_Ensembles; split; trivial;
apply closure_inflationary.
rewrite <- H0; apply closure_closed.
red; intros f0 ?.
red.
apply first_countable_sequence_closure in H.
destruct H as [f []].
pose proof (MetricTopology_metrizable _ d d_metric
(proj1_sig f0 x0)).
apply open_neighborhood_basis_is_neighborhood_basis in H1.
apply continuous_at_neighborhood_basis with (1:=H1).
intros.
destruct H2.
assert (r/3>0) by lra.
destruct (metric_space_net_limit_converse _ _
(MetricTopology_metrizable _ _
(uniform_metric_is_metric _ _ d y0 d_metric X_inh))
nat_DS f f0 H0 (r/3) H3) as [N].
assert (neighborhood
(inverse_image (proj1_sig (f N))
(open_ball _ d (proj1_sig (f N) x0) (r/3))) x0).
apply H.
pose proof (MetricTopology_metrizable _ d d_metric
(proj1_sig (f N) x0)).
apply open_neighborhood_basis_is_neighborhood_basis in H5.
apply H5.
constructor; trivial.
match goal with H5:neighborhood ?U x0 |- neighborhood ?V x0 =>
cut (Included U V) end.
intros.
destruct H5 as [U []].
exists U; auto with sets.
red; intros.
destruct H6.
destruct H6.
constructor.
constructor.
apply Rle_lt_trans with
(d (proj1_sig f0 x0) (proj1_sig (f N) x0) +
d (proj1_sig (f N) x0) (proj1_sig f0 x)).
apply d_metric.
apply Rle_lt_trans with
(d (proj1_sig f0 x0) (proj1_sig (f N) x0) +
d (proj1_sig (f N) x0) (proj1_sig (f N) x) +
d (proj1_sig (f N) x) (proj1_sig f0 x)).
assert (d (proj1_sig (f N) x0) (proj1_sig f0 x) <=
d (proj1_sig (f N) x0) (proj1_sig (f N) x) +
d (proj1_sig (f N) x) (proj1_sig f0 x)) by apply d_metric.
lra.
assert (forall x':point_set X,
d (proj1_sig f0 x') (proj1_sig (f N) x') < r/3).
intros.
apply Rle_lt_trans with (uniform_metric d y0 d_metric X_inh f0 (f N)).
unfold uniform_metric; destruct f0 as [f0]; destruct (f N) as [fN];
destruct sup; simpl.
apply i.
exists x'; trivial.
constructor.
apply H4; simpl; auto with arith.
rewrite (metric_sym _ d d_metric (proj1_sig (f N) x) (proj1_sig f0 x)).
pose proof (H7 x0); pose proof (H7 x).
lra.

apply metrizable_impl_first_countable.
exists (uniform_metric d y0 d_metric X_inh).
exact (uniform_metric_is_metric _ _ d y0 d_metric X_inh).
apply MetricTopology_metrizable.
Qed.

Lemma continuous_functions_closed_in_uniform_metric:
closed (fun f:uniform_space d y0 => continuous (proj1_sig f)
(Y:=MetricTopology d d_metric))
(X:=UniformTopology d y0 d_metric X_inh).
Proof. hammer_hook "UniformTopology" "UniformTopology.continuous_functions_closed_in_uniform_metric".
replace (fun f:uniform_space d y0 => continuous (proj1_sig f)
(Y:=MetricTopology d d_metric)) with
(IndexedIntersection (fun (x0:point_set X) (f:uniform_space d y0) =>
continuous_at (proj1_sig f) x0 (Y:=MetricTopology d d_metric))).
apply (@closed_indexed_intersection (UniformTopology d y0 d_metric X_inh)).
apply continuous_functions_at_point_closed_in_uniform_metric.

apply Extensionality_Ensembles; split; intros f ?.
destruct H.
apply pointwise_continuity; trivial.
constructor; intros x.
unfold In in H |-*.
apply continuous_func_continuous_everywhere; trivial.
Qed.

End UniformTopology_and_continuity.


Require Import Cybele.Cybele.
Require Import Cybele.Reifiable.
Import Monad.

Definition sig1 := Sig.Make nil ((nat: Type) :: nil).

Definition sum (n m: nat): M sig1 nat :=
  let! s := tmp_ref sig1 0 n in
  let! s' := !s in
  do! s :=! s' + m in
  !s.

Compute sum 2 3 (State.of_prophecy (Prophecy.of_nat sig1 0)).

Lemma sum1: nat.
  cybele (sum 2 3).
Defined.
Print sum1.

Definition sig2 := Sig.Make (existT _ _ Reifiable.Nat :: nil) nil.

Definition input: M sig2 nat :=
  let s := input_ref sig2 0 3 in
  do! s :=! 5 in
  !s.

Lemma input1: nat.
  cybele input.
Defined.
Print input1.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  zNil : Zlst.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.

Theorem plus_comm: forall (n m: natural), plus n m = plus m n.
Proof.
  induction n; induction m.
  { simpl. rewrite IHn. rewrite <- IHm. simpl. rewrite IHn. reflexivity. }
  { simpl. rewrite IHn. simpl. reflexivity. }
  { simpl. rewrite <- IHm. simpl. reflexivity. }
  { reflexivity. }
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (len (qreva x y)) (plus (len x) (len y)).
Proof.
  induction x; induction y; simpl; try reflexivity.
  +
lfind.  simpl.
Admitted.


Require Import Coq.Lists.List.
Require Import Coq.Init.Datatypes.
Import ListNotations.
Section STV.
Require Export Arith.

Variable cand: Type.
Definition cand_eq : cand -> cand -> bool. Admitted.
Definition ballot := (nat * (list cand)) % type.

Inductive Node :=
    state:                     (** intermediate states  **)
       (list ballot)           (*  undistributed ballots *)
     * nat                     (*  remaining seats       *)
     * (list cand)             (*  hopeful candidates    *)
     * (cand -> (list ballot)) (*  piles                 *)
     * (cand -> nat)           (*  tallies               *)
     * (list cand)             (*  elected candidates    *)
     -> Node
  | winners:                   (** final state          **)
       list cand
     -> Node.                  (*  election winners      *)

(* shorthands *)
Definition nbdy : list cand := [].                    (* empty candidate list *)
Definition nty  : cand -> nat := fun x => 0.          (* null tally *)
Definition nas  : cand -> list ballot := fun x => []. (* null vote assignment *)

Inductive PD  {A: Type} : list A -> Prop :=
   PDe :  PD  ( nil)
 | PDc :  forall a:A,forall l: list A, PD l /\ ~(In a l) -> (PD  (cons a l)).

(* the new tally is the old tally with c's votes incremented by one *)
Definition inc (c:cand) (t: cand -> nat) (nt: cand -> nat) : Prop :=
  (nt c = t c + 1)%nat /\  forall d, d <> c -> nt d = t d.

(* the new assignment is the old assignment with ballot b added for candidate c *)
Definition add (c:cand) (b:ballot) (a: cand -> list ballot) (na: cand -> list ballot) : Prop :=
  na c = b::(a c) /\  forall d, d <> c -> na d = a d.

(* l and nl are equal except that nl additionally contaeqe x *)
Definition eqe {A: Type} (x:A) (l: list A) (nl: list A) : Prop :=
  exists l1 l2: list A, l = l1 ++ l2 /\ nl = l1 ++ [x] ++ l2.

(* l contaeqe x and replacing x with y in l yields nl *)
Definition rep {A:Type} (x y: A) (l nl: list A) :=
  exists l1 l2: list A, l = l1 ++ [x] ++ l2 /\ nl = l1 ++ [y] ++ l2.

Fixpoint index (l : list cand) (c : cand) : option nat :=
  match l with
  | []      => None
  | c' :: l' =>
    if cand_eq c c' then Some 0
    else
      match index l' c with
      | None   => None
      | Some n => Some (S n)
      end
  end.

Definition bweight (b: ballot) : nat :=
  match b with
  | (w, _) => w
  end.

Definition blist (b: ballot) : list cand :=
  match b with
  | (_, l) => l
  end.

Definition unpack (i: option nat) (d: nat) : nat :=
  match i with
  | Some j => j
  | None => d
  end.

Definition multiply_weight (i: nat) (b: ballot) : ballot :=
  match b with
  | (j, l) => (i * j, l)
  end.

Inductive Pf (b: list ballot) (q: nat) (s: nat) : Node -> Type :=
  ax : forall u r h p t e,                           (** start counting                                                **)
  u = b ->                                           (*  if all the ballots are unallocated                             *)
  r = s ->                                           (*  if all the seats are vacant                                    *)
  PD h  ->                                           (*  if all hopeful candidates are unique                           *)
  p = nas ->                                         (*  if all piles are empty                                         *)
  t = nty ->                                         (*  all tallies are zero                                           *)
  e = nbdy ->                                        (*  nobody has been elected                                        *)
  Pf b q s (state (u, r, h, p, t, e))
| db : forall u r h p t e   un pn,                   (** distribute ballots to piles                                   **)
  Pf b q s (state (u, r, h, p, t, e)) ->             (*  if at any time                                                 *)
  u <> [] ->                                         (*  there are votes to distribute                                  *)
  (forall i : ballot, (In i u) ->                    (*  each ballot is assigned to at least one pile of a hopeful      *)
    (exists (j : cand), (In j h)                     (*    candidate                                                    *)
                        /\ (In i (pn j)))) ->
  (forall (i : cand) (l : ballot), (In i h) ->       (*  ensure that candidate is first amongst hopefuls for each       *)
    (forall (j : cand), (In j h) -> unpack (index (blist l) j) 0 (*    ballot on their pile                                         *)
      >  unpack (index (blist l) i) 0) -> (In l (p i))) ->
  un = [] ->                                         (*  the undistributed ballots list is empty                        *)
  Pf b q s (state (un, r, h, pn, t, e))
| tv : forall u r h p t e   tn,                      (** tally votes                                                   **)
  Pf b q s (state (u, r, h, p, t, e)) ->             (*  if at any time                                                 *)
  t = nty ->                                         (*  the tally is empty                                             *)
  u = []  ->                                         (*  there are no undistributed ballots                             *)
  (forall i : cand, (In i h) ->                      (*  the tally for a candidate is the count of their pile weighted  *)
    tn i = fold_left (fun x y => x + y)              (*  by the weight of the ballots                                   *)
                     (map bweight (p i))
                     0) ->
  Pf b q s (state (u, r, h, p, tn, e))
| el : forall u r h p t e  un rn hn pn tn en  is iss,(** elect a candidate and redistribute their votes                **)
  Pf b q s (state (u, r, h, p, t, e)) ->             (*  if at any time                                                 *)
  (forall i : cand, In i is -> t i >= 1) ->          (*  a number of candidates meet the quota                          *)
  (forall i : cand,                                  (*  the elected candidates are removed from the hopefuls list      *)
    (In i is) /\ (In i h) = (In i hn)) ->
  (forall i : cand,                                  (*  the elected candidates are added to the elected list           *)
    (In i is) \/ (In i e) = (In i en)) ->
  tn = nty ->                                        (*  the tally is emptied                                           *)
  rn = r - 1 ->                                      (*  the number of remaining seats is reduced by one                *)
  (forall i: cand, (In i h) -> eqe i (iss i) is) ->
  un = fold_left                                     (*  the elected candidate's pile is redistributed.                 *)
       (fun x y => x ++ y)                           (*    with transfer value                                          *)
       (map (fun i => map (multiply_weight
                           (fold_left
                            (fun x y => x * y)
                            (map t (iss i))
                            1))
                           (p i))
        is)
       [] ->
  (forall i: cand, In i h ->                         (*  scale other piles with transfer value                         *)
    pn i = map (multiply_weight
                (fold_left (fun x y => x * y)
                           (map t is)
                           1))
               (p i)) ->
  Pf b q s (state (un, rn, hn, pn, tn, en))
| em : forall u r h p t e   un hn tn   i,            (** eliminate a candidate                                         **)
  Pf b q s (state (u, r, h, p, t, e)) ->             (*  if at any time                                                 *)
  r > length h ->                                    (*  there are more hopefuls than remaining seats                   *)
  t <> nty ->                                        (*  the votes have been tallied                                    *)
  (forall i : cand, (In i h) -> (t i) < q) ->        (*  no hopeful candidate meets the quota                           *)
  un = p i ->                                        (*  the eliminated candidate's pile is to be redistributed         *)
  eqe i hn h ->                                      (*  the eliminated candidate is removed from the hopefuls list     *)
  tn = nty ->                                        (*  empty the tallies                                              *)
  Pf b q s (state (un, r, hn, p, tn, e))
| ew : forall u r h p t e   w,                       (** elected win                                                   **)
  Pf b q s (state (u, r, h, p, t, e)) ->             (*  if at any time                                                 *)
  length h <= r ->                                   (*  we have as many seats as hopeful candidates                    *)
  w = e ++ h ->                                      (*  the winners are the already elected and the remaining hopefuls *)
  Pf b q s (winners w).

Definition encrypt : nat -> nat. Admitted.
Definition decrypt : nat -> nat. Admitted.
Theorem encrypt_inverse : forall (n : nat), encrypt(decrypt n) = n. Admitted.
Theorem decrypt_inverse : forall (n : nat), decrypt(encrypt n) = n. Admitted.

Definition h_add : nat -> nat -> nat. Admitted.
Theorem h_add_homomorphism : forall (n m : nat), h_add (encrypt n) (encrypt m) = encrypt (n + m). Admitted.

Definition first_pref_column := (nat   (* candidate index, plaintext *)
                                 * nat (* preference, encrypted      *)
                                 * nat (* weight, encrypted          *)
                                ) % type.
Definition first_preference_ballot := list first_pref_column.

Inductive SS_Node :=
    sstate:                            (** intermediate states             **)
       (list first_preference_ballot)  (*  first-preference representation  *)
     * (list nat)                      (*  hopefuls                         *)
     * (nat -> nat)                    (*  tallies                          *)
     -> SS_Node
  | swinners:                          (** final state                     **)
       (list cand)
     -> SS_Node.                         (*  election winners                 *)

Definition fpc_cand : first_pref_column -> nat. Admitted.
Definition fpc_weight : first_pref_column -> nat. Admitted.

Definition h_add_weights_b (c : nat) (b : first_preference_ballot)  : nat :=
  fold_left h_add
            (map fpc_weight (filter
                             (fun x : first_pref_column => beq_nat (fpc_cand x) c)
                             b))
            (encrypt 0).

Definition h_add_weights (b : list first_preference_ballot) (c : nat) : nat :=
  fold_left h_add
            (map (h_add_weights_b c) b)
            (encrypt 0).

Inductive Pfss (b: list ballot) (q: nat) (s: nat) : SS_Node -> Type :=
  ft : forall f h t  tn, (** compute first preference tallies **)
  Pfss b q s (sstate (f, h, t)) ->
    (forall i : nat, (In i h) -> tn i = decrypt (h_add_weights f i)) ->
  Pfss b q s (sstate (f, h, tn)).


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e256m2e224p2e192p2e96m1_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


(* Rose tree *)
Inductive t (A : Type) := Leaf (a : A) | Node (sib : list (t A)).


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Functor Functor.Const_Func Functor.Functor_Ops.
From Categories Require Import Ext_Cons.Prod_Cat.Prod_Cat Ext_Cons.Prod_Cat.Operations.
From Categories Require Import NatTrans.Operations NatTrans.NatIso.
From Categories Require Import Archetypal.Discr.Discr.
From Categories Require Import Limits.Limit Limits.Pointwise.
From Categories Require Import Ext_Cons.Arrow.
From Categories Require Import Coq_Cats.Type_Cat.Type_Cat Coq_Cats.Type_Cat.GenProd.

(**
  This file shows that if a category is complete, then for any pair of objects
  x and y, we have (Arrow C) (Hom C x y) is isomorphic to
  Hom C x (Limit_of (Discr_Func Arr_y)).
  This of course would be a contradiction as soon as we have some objects c and
  d for which
  (Hom C c d) has more than one element. In other words, any complete category
   is a preorder category!!!

  The proof is precisely the proof that is given in Awodey's book
  "Category Theory" to show that any small and complete category is a preorder
  category. In deed, the constraints on universe variables generated by this
  proof, restricts C such that the level of its objects is less than or
  equal to the level of its arrows (Remember that in this development smallness
  and largeness is relative to universe levels).
*)

Section Complete_Preorder.
  Context (C : Category) (CC : Complete C) (x y : C).

  Local Definition Arr_y := (fun w : (Arrow C) => y).

  Local Definition LimOf_Arr_y := (LimitOf (Discr_Func Arr_y)).

  Local Definition GenProd_of_const_Hom_x_y :=
    Type_Cat_GenProd
      _
      (((@Fix_Bi_Func_1
           (C^op) _ _ x (Hom_Func.Hom_Func C)) ∘ (Discr_Func Arr_y)) _o)%object.

  Local Hint Extern 1 => cbn.

  Local Program Definition Func_Iso :
    (
      (Discr_Func
         (((@Fix_Bi_Func_1
              (C^op) _ _ x (Hom_Func.Hom_Func C))
             ∘ (Discr_Func Arr_y)) _o)%object
      )
        ≃ ((@Fix_Bi_Func_1
              (C^op) _ _ x (Hom_Func.Hom_Func C)) ∘ (Discr_Func Arr_y))%functor
    )%natiso
    :=
    {|
      iso_morphism := {|Trans := fun c h => h|};
      inverse_morphism := {|Trans := fun c h => h|}
    |}.

  Local Definition
        Local_Right_KanExt_Iso_Limits_Pointwise_LimOf_Arr_y__ISO__GenProd_of_const_Hom_x_y :
    (Local_Right_KanExt_Iso
      Func_Iso
      (Rep_Preserve_Limits _ x LimOf_Arr_y)
      ≃≃
      GenProd_of_const_Hom_x_y
      ::> LoKan_Cone_Cat _ _)%isomorphism
    := Local_Right_KanExt_unique _ _ _ _
  .

  Local Definition Hom_x_LimOf_Arr_y_ISO_Arrow_C_to_Hom_x_y :
    (((x –≻ ((LimOf_Arr_y _o) tt))%object%morphism)
       ≃≃ (Arrow C → x –≻ y)%morphism ::> Type_Cat)%isomorphism :=
    LoKan_Cone_Iso_object_Iso
      _
      _
      Local_Right_KanExt_Iso_Limits_Pointwise_LimOf_Arr_y__ISO__GenProd_of_const_Hom_x_y
      tt
  .

End Complete_Preorder.


Require Import Helpers.Helpers.
Require Import Proc.
Require Import ProcTheorems.
Require Import Abstraction.

(** * Reasoning about crashes and recovery

  [Spec.Proc] defines the execution of a computer that can crash: after a
  crash, the computer stops executing, then reboots, and then runs recovery.
  The computer may crash during recovery.  To support reasoning about crashes,
  [proc_spec] above uses recovered condidition: each [proc_spec] must describe
  in which condition the computer may reboot through a recovered condition, and
  proofs of [proc_spec] must show that an implementation won't recover in any
  other recovered condition.

  You will also have to show that for every code state in which your
  implementation may end up in after a crash, your recovery procedure repairs
  the code state in which it crashed correctly and the repaired state
  corresponds to a correct spec state. Since [rexec] allows crashes during
  recovery, you must show that invoking recovery several times is ok.  This
  means you have to show that recovered condition of your recovery procedure
  implies its precondition and that the recovery procedure is idempotent.

 *)

Hint Constructors rexec : core.
Hint Constructors exec : core.
Hint Constructors exec_recover : core.

Theorem clos_refl_trans_1n_unit_tuple : forall `(R: unit * A -> unit * A -> Prop) x y u u',
    Relation_Operators.clos_refl_trans_1n R (u, x) (u', y) ->
    Relation_Operators.clos_refl_trans_1n
      (fun x y =>
         R (tt, x) (tt, y)) x y.
Proof.
  intros.
  destruct u, u'.
  remember (tt, x).
  remember (tt, y).
  generalize dependent x.
  generalize dependent y.
  induction H; intuition subst.
  - inversion Heqp; subst.
    constructor.
  - destruct y.
    destruct u.
    especialize IHclos_refl_trans_1n; intuition.
    especialize IHclos_refl_trans_1n; intuition.
    econstructor; eauto.
Qed.

(** Define what it means to run recovery in recovered state : *)
Definition proc_loopspec `(spec: Specification A unit unit State)
           `(rec': proc unit) `(rec: proc unit)
           (abs: Abstraction State) :=
  forall a w state,
    abstraction abs w state ->
    pre (spec a state) ->
    forall rv rv' w',
      Relation_Operators.clos_refl_trans_1n
        (fun '(_, w) '(rv', w') => rexec rec' rec w (Recovered rv' w'))
        (rv, w) (rv', w') ->
      forall rv'' w'',
        exec rec' w' (Finished rv'' w'') ->
        exists state'',
          abstraction abs w'' state'' /\
          post (spec a state) rv'' state''.

(** Define what it means for a spec to be idempotent: *)
Definition idempotent `(spec: Specification A T unit State) :=
  forall a state,
    pre (spec a state) ->
    forall v state', recovered (spec a state) v state' ->
            (** idempotency: recovered condition implies precondition to
               re-run on every crash *)
            exists a', pre (spec a' state') /\
                  (** postcondition transitivity: establishing the
                     postcondition from a recovered state is sufficient to
                     establish it with respect to the original initial
                     state (note all with the same ghost state) *)
                  forall rv state'', post (spec a' state') rv state'' ->
                                post (spec a state) rv state''.

(* Idempotents theorem: *)
Theorem idempotent_loopspec : forall `(rec: proc unit) `(rec': proc unit)
                                     `(spec: Specification A unit unit State)
                                     (abs: Abstraction State),
    forall (Hspec: proc_spec spec rec' rec abs),
      idempotent spec ->
      proc_loopspec spec rec' rec abs.
Proof.
  unfold proc_loopspec; intros.
  apply clos_refl_trans_1n_unit_tuple in H2.
  repeat match goal with
         | [ u: unit |- _ ] => destruct u
         end.

  generalize dependent a.
  generalize dependent state.
  induction H2; intros.
  - eapply RExec in H3.
    eapply Hspec in H3; eauto.
  - eapply Hspec in H0; simpl in *; safe_intuition (repeat deex; eauto).
    eapply H in H4; eauto; repeat deex.
    specialize (H4 _ _ ltac:(eauto)); repeat deex; intuition.
    specialize (IHclos_refl_trans_1n _ ltac:(eauto) _ ltac:(eauto)).
    safe_intuition (repeat deex; eauto).
Qed.

Theorem compose_recovery : forall `(spec: Specification A'' T unit State)
                             `(rspec: Specification A' unit unit State)
                             `(spec': Specification A T unit State)
                             `(p: proc T) `(rec: proc unit) `(rec': proc unit)
                             `(abs: Abstraction State),
    forall (Hspec: proc_spec spec p rec abs)
      (Hrspec: proc_loopspec rspec rec' rec abs)
      (Hspec_spec':
         forall (a:A) state, pre (spec' a state) ->
                    exists (a'':A''),
                      pre (spec a'' state) /\
                      (forall v state', post (spec a'' state) v state' ->
                               post (spec' a state) v state') /\
                      (forall v state', recovered (spec a'' state) v state' ->
                               exists a', pre (rspec a' state') /\
                                     forall v' state'',
                                       post (rspec a' state') v' state'' ->
                                       recovered (spec' a state) v' state'')),
      proc_spec spec' p (_ <- rec; rec') abs.
Proof.
  intros.
  unfold proc_spec; intros.
  eapply Hspec_spec' in H0; safe_intuition;
    repeat deex.
  clear Hspec_spec'.
  destruct r.
  - match goal with
    | [ Hexec: rexec p _ _ _ |- _ ] =>
      eapply rexec_finish_any_rec in Hexec;
        eapply Hspec in Hexec
    end; simpl in *; intuition (repeat deex; eauto).
  - inv_rexec.
    match goal with
    | [ Hexec: exec_recover _ _ _ _ |- _ ] =>
      eapply exec_recover_bind_inv in Hexec
    end; repeat deex.
    match goal with
    | [ Hexec: exec_recover rec _ _ _ |- _ ] =>
      eapply RExecCrash in Hexec; eauto
    end; repeat deex.
    match goal with
    | [ Hexec: rexec p _ _ _ |- _ ] =>
      eapply Hspec in Hexec
    end; simpl in *; safe_intuition (repeat deex; eauto).
    (* H3: recover -> exists a' *)
    (* H6: recover *)
    eapply H3 in H6; repeat deex.
    match goal with
    | [ Hexec: exec rec' _ _ |- _ ] =>
      eapply Hrspec in Hexec
    end; simpl in *; safe_intuition (repeat deex; eauto).
Qed.

Theorem rec_wipe_compose : forall `(rec: proc unit) `(rec2: proc unit)
                             `(abs1: Abstraction State1)
                             (wipe1: State1 -> State1 -> Prop)
                             `(spec: Specification A unit unit State1)
                             `(abs2: LayerAbstraction State1 State2)
                             (wipe2: State2 -> State2 -> Prop),
    rec_wipe rec abs1 wipe1 ->
    proc_loopspec spec rec2 rec abs1 ->
    forall (Hspec: forall state0 state0' state,
          abstraction abs2 state0 state0' ->
          wipe1 state0 state ->
          exists a, pre (spec a state) /\
               forall state' r,
                 post (spec a state) r state' ->
                 exists state2', wipe2 state0' state2' /\
                            abstraction abs2 state' state2'),
    rec_wipe (_ <- rec; rec2) (abstraction_compose abs1 abs2) wipe2.
Proof.
  unfold rec_wipe; intros.
  eapply spec_abstraction_compose; simpl.
  eapply compose_recovery; eauto.
  destruct a; simpl; intuition.
  descend; intuition eauto.
  specialize (Hspec _ _ _ ltac:(eauto) ltac:(eauto)).
  repeat deex.
  descend; intuition eauto.
Qed.

(** Helpers for defining step-based semantics. *)

Definition Semantics State T := State -> T -> State -> Prop.

Definition pre_step {opT State}
           (bg_step: State -> State -> Prop)
           (step: forall `(op: opT T), Semantics State T) :
  forall T (op: opT T), Semantics State T :=
  fun T (op: opT T) state v state'' =>
    exists state', bg_step state state' /\
          step op state' v state''.

Definition post_step {opT State}
           (step: forall `(op: opT T), Semantics State T)
           (bg_step: State -> State -> Prop) :
  forall T (op: opT T), Semantics State T :=
  fun T (op: opT T) state v state'' =>
    exists state', step op state v state' /\
          bg_step state' state''.

Definition op_spec `(sem: Semantics State T) : Specification unit T unit State :=
  fun (_:unit) state =>
    {|
      pre := True;
      post :=
        fun v state' => sem state v state';
      recovered :=
        fun r state' =>
          r = tt /\ (state' = state \/ exists v, sem state v state');
    |}.

(** Helpers for defining wipe relations after a crash. *)

Definition no_wipe {State} (state state' : State) : Prop := state' = state.
Hint Unfold no_wipe : core.

Definition no_crash {State} (state state' : State) : Prop := False.
Hint Unfold no_crash : core.