Set Implicit Arguments.
Require Import GMuAnnot.Prelude.
Require Import GMuAnnot.InfrastructureFV.
Require Import GMuAnnot.InfrastructureOpen.
Require Import TLC.LibLogic.
Require Import TLC.LibLN.
(* large portions of this are based on the TLC formalisation of FSub *)

Lemma subst_tt_fresh : forall Z U T,
  Z \notin fv_typ T -> subst_tt Z U T = T.
Proof.
  induction T using typ_ind' ; simpl; intros; f_equal*.
  - case_var*.
  - symmetry.
    apply map_id.
    introv Lin.
    handleforall.
    symmetry.
    apply* Hforall.
Qed.

(** Substitution distributes on the open operation. *)

Lemma subst_tt_open_tt_rec : forall T1 T2 X P n, type P ->
  subst_tt X P (open_tt_rec n T2 T1) =
  open_tt_rec n (subst_tt X P T2) (subst_tt X P T1).
Proof.
  introv WP. generalize n.
  induction T1 using typ_ind' ; intros k; simpls; f_equal*.
  - crush_compare.
  - case_var*. rewrite* <- open_tt_rec_type.
  - rewrite* List.map_map.
    rewrite* List.map_map.
    apply List.map_ext_in.
    handleforall.
    introv Lin.
    apply* Hforall.
Qed.

Lemma subst_tt_open_tt : forall T1 T2 X P, type P ->
  subst_tt X P (open_tt T1 T2) =
  open_tt (subst_tt X P T1) (subst_tt X P T2).
Proof.
  unfold open_tt. autos* subst_tt_open_tt_rec.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma subst_tt_open_tt_var : forall X Y U T, Y <> X -> type U ->
  (subst_tt X U T) open_tt_var Y = subst_tt X U (T open_tt_var Y).
Proof.
  introv Neq Wu. rewrite* subst_tt_open_tt.
  simpl. case_var*.
Qed.

(** Opening up a body t with a type u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma subst_tt_intro : forall X T2 U,
  X \notin fv_typ T2 -> type U ->
  open_tt T2 U = subst_tt X U (T2 open_tt_var X).
Proof.
  introv Fr Wu. rewrite* subst_tt_open_tt.
  rewrite* subst_tt_fresh. simpl. case_var*.
Qed.

Lemma subst_commutes_with_unrelated_opens : forall Xs T V Y,
    (forall X, List.In X Xs -> X <> Y) ->
    type V ->
    subst_tt Y V (open_tt_many_var Xs T) =
    (open_tt_many_var Xs (subst_tt Y V T)).
  induction Xs as [| Xh Xt]; introv Hneq Htyp.
  - cbn. eauto.
  - cbn.
    fold (open_tt_many_var Xt (T open_tt_var Xh)).
    fold (open_tt_many_var Xt (subst_tt Y V T open_tt_var Xh)).
    rewrite* subst_tt_open_tt_var; eauto with listin.
Qed.

Lemma subst_intro_commutes_opens : forall Xs T Y V,
    Y \notin fv_typ T ->
    (forall X, List.In X Xs -> X <> Y) ->
    type V ->
    open_tt_many_var Xs (open_tt T V) =
    subst_tt Y V (open_tt_many_var Xs (T open_tt_var Y)).
  induction Xs as [| Xh Xt]; introv Hfv Hneq Htyp.
  - cbn. apply* subst_tt_intro.
  - cbn.
    fold (open_tt_many_var Xt (open_tt T V open_tt_var Xh)).
    fold (open_tt_many_var Xt ((T open_tt_var Y) open_tt_var Xh)).
    rewrite* subst_commutes_with_unrelated_opens.
    f_equal.
    rewrite* <- subst_tt_open_tt_var.
    + rewrite* <- subst_tt_intro.
    + apply* Hneq. cbn; eauto.
    + eauto with listin.
Qed.

Lemma sublist_tail_prop : forall A (Uh : A) (Ut : list A) (P : A -> Prop),
  (forall U : A, List.In U (Uh :: Ut) -> P U) ->
  forall U : A, List.In U Ut -> P U.
  introv Hbigger Hin.
  apply* Hbigger.
  cbn.
  eauto.
Qed.

Lemma sublist_head_prop : forall A (Uh : A) (Ut : list A) (P : A -> Prop),
  (forall U : A, List.In U (Uh :: Ut) -> P U) ->
  P Uh.
  introv Hbigger.
  apply* Hbigger.
  cbn.
  eauto.
Qed.

Lemma subst_tt_intro_many : forall Xs T Us,
    length Xs = length Us ->
    DistinctList Xs ->
    (forall X, List.In X Xs -> X \notin fv_typ T) ->
    (forall X U, List.In X Xs -> List.In U Us -> X \notin fv_typ U) ->
    (forall U, List.In U Us -> type U) ->
    open_tt_many Us T = subst_tt_many Xs Us (open_tt_many_var Xs T).
  induction Xs as [| Xh Xt]; introv Hleneq Hdistinct HXfv HXUfv XUtyp.
  - destruct Us.
    + cbv. trivial.
    + inversions Hleneq.
  - destruct Us as [| Uh Ut].
    + inversions Hleneq.
    + cbn.
      fold (open_tt_many_var Xt (T open_tt_var Xh)).
      rewrite* <- subst_intro_commutes_opens; eauto with listin.
      * apply* IHXt; try solve [intuition; eauto with listin].
        -- inversion* Hdistinct.
        -- introv XiXt.
           lets* Hless: fv_smaller T Uh 0.
           fold (open_tt T Uh) in Hless.
           intro Hin.
           apply Hless in Hin.
           rewrite in_union in Hin.
           destruct Hin as [Hin | Hin].
           ++ apply* HXfv. listin.
           ++ apply* HXUfv; listin.
      * inversions Hdistinct.
        introv XiXt.
        intro. subst. contradiction.
Qed.

(** Substitution for a fresh name is identity. *)

Lemma subst_te_fresh : forall X U e,
  X \notin fv_trm e -> subst_te X U e = e.
Proof.
  induction e using trm_ind'; simpl; intros; f_equal*; autos* subst_tt_fresh.
  - symmetry.
    apply map_id. introv Lin.
    symmetry.
    apply* subst_tt_fresh.
  - apply* IHe.
    rewrite notin_union in H0.
    destruct H0.
    lets*: fv_fold_general H0.
  - unfold map_clause_trm_trm.
    rewrite List.Forall_forall in *.
    rewrite <- List.map_id.
    apply List.map_ext_in.
    intros cl clin.
    lets* Heq: H cl clin.
    destruct cl.
    f_equal.
    apply* Heq.
    rewrite notin_union in H0.
    destruct H0.
    lets*: fv_fold_in_clause.
Qed.

(** Substitution distributes on the open operation. *)

Lemma subst_te_open_te : forall e T X U, type U ->
  subst_te X U (open_te e T) =
  open_te (subst_te X U e) (subst_tt X U T).
Proof.
  intros. unfold open_te. generalize 0.
  induction e using trm_ind'; intro n0; simpls; f_equal*;
    autos* subst_tt_open_tt_rec.
  - unfold open_typlist_rec.
    rewrite List.map_map.
    rewrite List.map_map.
    apply List.map_ext.
    intro.
    apply* H0.
  - unfold map_clause_trm_trm.
    repeat rewrite List.map_map.
    apply List.map_ext_in.
    intros cl clin.
    rewrite List.Forall_forall in *.
    lets* Heq: H0 cl clin.
    destruct cl.
    f_equal.
    eauto.
Qed.

(** Substitution and open_var for distinct names commute. *)

Lemma subst_te_open_te_var : forall X Y U e, Y <> X -> type U ->
  (subst_te X U e) open_te_var Y = subst_te X U (e open_te_var Y).
Proof.
  introv Neq Wu. rewrite* subst_te_open_te.
  simpl. case_var*.
Qed.

(** Opening up a body t with a type u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma subst_te_intro : forall X U e,
  X \notin fv_trm e -> type U ->
  open_te e U = subst_te X U (e open_te_var X).
Proof.
  introv Fr Wu. rewrite* subst_te_open_te.
  rewrite* subst_te_fresh. simpl. case_var*.
Qed.

(** Substitution for a fresh name is identity. *)
Lemma subst_ee_fresh : forall x k u e,
  x \notin fv_trm e -> subst_ee x k u e = e.
Proof.
  induction e using trm_ind'; simpl; intros; f_equal*.
  - case_if*.
    inversions C.
    false* in_singleton_self.
  - apply IHe.
    rewrite notin_union in H0.
    destruct H0.
    lets*: fv_fold_base_clause.
  - unfold map_clause_trm_trm.
    rewrite <- List.map_id.
    apply List.map_ext_in.
    intros cl clin.
    rewrite List.Forall_forall in *.
    lets* Heq: H clin.
    unfold clauseTerm in Heq.
    lets Hfv: fv_fold_in_clause.
    lets* Hfv2: Hfv cl clauses.
    unfold clauseTerm in Hfv2.
    destruct cl.
    f_equal.
    apply Heq.
    rewrite notin_union in H0.
    destruct H0.
    apply* Hfv2.
Qed.

(** Substitution distributes on the open operation. *)
Lemma subst_ee_open_ee : forall t1 t2 u k x, term u ->
  subst_ee x k u (open_ee t1 t2) =
  open_ee (subst_ee x k u t1) (subst_ee x k u t2).
Proof.
  intros. unfold open_ee. generalize 0.
  induction t1 using trm_ind'; intro n0; simpls; f_equal*.
  - crush_eq.
  - case_if*. rewrite* <- open_ee_rec_term.
  - unfold map_clause_trm_trm.
    repeat rewrite List.map_map.
    apply List.map_ext_in.
    intros cl clin.
    rewrite List.Forall_forall in *.
    lets* IH: H0 clin.
    destruct cl.
    f_equal.
    eauto.
Qed.

(** Substitution and open_var for distinct names commute. *)
Lemma subst_ee_open_ee_var : forall vk x y k u e, y <> x -> term u ->
  open_ee (subst_ee x k u e) (trm_fvar vk y) = subst_ee x k u (open_ee e (trm_fvar vk y)).
Proof.
  introv Neq Wu. rewrite* subst_ee_open_ee.
  simpl. case_if*.
Qed.

(** Opening up a body t with a type u is the same as opening
  up the abstraction with a fresh name x and then substituting u for x. *)

Lemma subst_ee_intro : forall vk x u e,
  x \notin fv_trm e -> term u ->
  open_ee e u = subst_ee x vk u (open_ee e (trm_fvar vk x)).
Proof.
  introv Fr Wu. rewrite* subst_ee_open_ee.
  rewrite* subst_ee_fresh. simpl. case_if*.
Qed.

(** Interactions between type substitutions in terms and opening
  with term variables in terms. *)

Lemma subst_te_open_ee_var : forall Z P vk x e,
  open_ee (subst_te Z P e) (trm_fvar vk x) = subst_te Z P (open_ee e (trm_fvar vk x)).
Proof.
  introv. unfold open_ee. generalize 0.
  induction e using trm_ind'; intros; simpl; f_equal*.
  - crush_eq.
  - unfold map_clause_trm_trm.
    repeat rewrite List.map_map.
    apply List.map_ext_in.
    intros cl clin.
    rewrite List.Forall_forall in *.
    lets* IH: H clin.
    destruct cl.
    f_equal.
    eauto.
Qed.

(** Interactions between term substitutions in terms and opening
  with type variables in terms. *)

Lemma subst_ee_open_te_var : forall z k u e X, term u ->
  (subst_ee z k u e) open_te_var X = subst_ee z k u (e open_te_var X).
Proof.
  introv. unfold open_te. generalize 0.
  induction e using trm_ind'; intros; simpl; f_equal*.
  - case_if*. symmetry. autos* open_te_rec_term.
  - unfold map_clause_trm_trm.
    repeat rewrite List.map_map.
    apply List.map_ext_in.
    intros cl clin.
    rewrite List.Forall_forall in *.
    lets* IH: H clin.
    destruct cl.
    f_equal.
    eauto.
Qed.

(** Substitutions preserve local closure. *)

Lemma subst_map_reverse_type : forall Tparams Z P,
    type P ->
    (forall Tparam : typ,
        List.In Tparam Tparams -> type P -> type (subst_tt Z P Tparam)) ->
    forall Tparam : typ, List.In Tparam (List.map (subst_tt Z P) Tparams) -> type Tparam.
  introv HP HTP.
  introv Tin.
  apply List.in_map_iff in Tin.
  destruct Tin as [T Tand].
  destruct Tand as [Teq Tin].
  rewrite <- Teq.
  apply* HTP.
Qed.

Lemma subst_tt_type : forall T Z P,
  type T -> type P -> type (subst_tt Z P T).
Proof.
  induction 1; intros; simpl; auto.
  - case_var*.
  - apply_fresh* type_all as X. rewrite* subst_tt_open_tt_var.
  - econstructor.
    apply* subst_map_reverse_type.
Qed.

Lemma subst_commutes_with_unrelated_opens_te_te : forall Xs e V Y,
    (forall X, List.In X Xs -> X <> Y) ->
    type V ->
    subst_te Y V (open_te_many_var Xs e) =
    (open_te_many_var Xs (subst_te Y V e)).
  induction Xs as [| Xh Xt]; introv Hneq Htyp.
  - cbn. eauto.
  - cbn.
    fold (open_te_many_var Xt (e open_te_var Xh)).
    fold (open_te_many_var Xt (subst_te Y V e open_te_var Xh)).
    rewrite* subst_te_open_te_var; eauto with listin.
Qed.

Lemma subst_commutes_with_unrelated_opens_te_ee : forall Xs e v y k,
    term v ->
    subst_ee y k v (open_te_many_var Xs e) =
    (open_te_many_var Xs (subst_ee y k v e)).
  induction Xs as [| Xh Xt]; introv Htyp.
  - cbn. eauto.
  - cbn.
    fold (open_te_many_var Xt (e open_te_var Xh)).
    fold (open_te_many_var Xt (subst_ee y k v e open_te_var Xh)).
    rewrite* subst_ee_open_te_var; eauto with listin.
Qed.

Lemma subst_te_term : forall e Z P,
    term e -> type P -> term (subst_te Z P e)
with subst_te_value : forall e Z P,
    value e -> type P -> value (subst_te Z P e).
Proof.
  - lets: subst_tt_type. induction 1; intros; cbn; auto.
    + constructor*.
      apply* subst_map_reverse_type.
    + apply_fresh* term_abs as x. rewrite* subst_te_open_ee_var.
    + apply_fresh* term_tabs as x.
      rewrite* subst_te_open_te_var.
      rewrite* subst_te_open_te_var.
    + apply_fresh* term_fix as x.
      rewrite* subst_te_open_ee_var.
      rewrite* subst_te_open_ee_var.
    + apply_fresh* term_let as x. rewrite* subst_te_open_ee_var.
    + econstructor; eauto.
      intros cl clinmap Alphas x Hlen Hdist Afresh xfresh xfreshA.
      destruct cl as [clA clT].
      unfold map_clause_trm_trm in clinmap.
      lets cl2: clinmap.
      apply List.in_map_iff in cl2.
      destruct cl2 as [[cl'A cl'T] [cl'eq cl'in]].
      inversion cl'eq. subst.
      cbn.
      lets* IH: H2 cl'in Alphas x Hlen Hdist.
      cbn in IH.
      instantiate (1:=(L \u \{ Z })) in Afresh.
      assert (Hpull:
          open_te_many_var Alphas (subst_te Z P cl'T) open_ee_varlam x
          =
          subst_te Z P (open_te_many_var Alphas cl'T open_ee_varlam x)
        ).
      * rewrite <- subst_commutes_with_unrelated_opens_te_te.
        rewrite* subst_te_open_ee_var.
        -- intros A AAlpha.
           assert (A \notin L \u \{ Z }); solve [apply* Afresh | eauto].
        -- eauto.
      * rewrite Hpull.
        apply* IH.
        introv Ain.
        assert (A \notin L \u \{ Z}); eauto.
  - lets: subst_tt_type; induction 1; intros; cbn; auto;
      match goal with
      | H: term _ |- _ => rename H into Hterm end.
    + apply value_abs.
      inversions Hterm.
      apply_fresh* term_abs as x.
      rewrite* subst_te_open_ee_var.
    + apply value_tabs. inversion Hterm.
      apply_fresh* term_tabs as x.
      rewrite* subst_te_open_te_var.
      rewrite* subst_te_open_te_var.
    + constructor*.
      inversions Hterm.
      constructor*.
    + constructor*.
      constructor*.
      * apply* value_is_term.
      * apply* subst_map_reverse_type.
        inversion* Hterm.
Qed.

(* this may be problematic as I now require e2 to be value not only term, but maybe it will be enough? *)
Lemma subst_ee_term : forall e1 Z e2 k,
    term e1 -> value e2 -> term (subst_ee Z k e2 e1)
with subst_ee_value : forall e1 Z e2 k,
    value e1 -> value e2 -> value (subst_ee Z k e2 e1).
Proof.
  - induction 1; intros; simpl; auto.
    + case_if*. apply~ value_regular.
    + apply_fresh* term_abs as y. rewrite* subst_ee_open_ee_var.
      apply~ value_regular.
    + apply_fresh* term_tabs as Y; rewrite* subst_ee_open_te_var;
        apply~ value_regular.
    + apply_fresh* term_fix as y; rewrite* subst_ee_open_ee_var;
        apply~ value_regular.
    + apply_fresh* term_let as y. rewrite* subst_ee_open_ee_var;
                                    apply~ value_regular.
    + econstructor; eauto.
      intros cl clinmap Alphas x Hlen Hdist Afresh xfresh xfreshA.
      destruct cl as [clA clT].
      unfold map_clause_trm_trm in clinmap.
      lets cl2: clinmap.
      apply List.in_map_iff in cl2.
      destruct cl2 as [[cl'A cl'T] [cl'eq cl'in]].
      inversion cl'eq. subst.
      cbn.
      lets* IH: H1 cl'in Alphas x Hlen Hdist.
      cbn in IH.
      instantiate (1:=(L \u \{ Z })) in Afresh.
      rewrite* <- subst_commutes_with_unrelated_opens_te_ee.
      * rewrite* subst_ee_open_ee_var.
        apply* IH.
        intros A AAlpha.
        assert (A \notin L \u \{ Z }); solve [apply* Afresh | eauto].
        apply~ value_regular.
      * apply~ value_regular.
  - induction 1; intros; simpl; auto;
      try match goal with
      | H: term (trm_abs _ _) |- _ => rename H into Hterm
      | H: term (trm_tabs _) |- _ => rename H into Hterm
      end.
    + apply value_abs. inversions Hterm.
      apply_fresh* term_abs as y. rewrite* subst_ee_open_ee_var.
      apply~ value_regular.
    + apply value_tabs; inversions Hterm.
      apply_fresh* term_tabs as Y; rewrite* subst_ee_open_te_var;
        apply~ value_regular.
    + case_if~.
    + inversions H1.
      constructor*.
    + econstructor.
      * econstructor.
        -- apply* value_is_term.
        -- inversion* H.
      * apply* IHvalue.
Qed.

(* Lemma adding_free_is_ok : forall A E F, *)
(*     ok (E & F) -> *)
(*     A # E -> *)
(*     A # F -> *)
(*     ok (E & (withtyp A) & F)%env. *)
(*   induction F using env_ind; introv Hok HE HF. *)
(*   - rewrite concat_empty_r. *)
(*     constructor*. *)
(*   - rewrite concat_assoc. *)
(*     rewrite concat_assoc in Hok. *)
(*     apply ok_push_inv in Hok. *)
(*     econstructor. *)
(*     + apply* IHF. *)
(*     + simpl_dom. *)
(*       rewrite notin_union. *)
(*       rewrite notin_union. *)
(*       split*. *)
(* Qed. *)

(* Lemma adding_free_is_ok_many : forall As E F, *)
(*     ok (E & F) -> *)
(*     DistinctList As -> *)
(*     (forall A, List.In A As -> A \notin dom E) -> *)
(*     (forall A, List.In A As -> A \notin dom F) -> *)
(*     ok (add_types E As & F). *)
(*   induction As as [| Ah Ats]; introv Hok HD HE HF. *)
(*   - cbn. eauto. *)
(*   - cbn. *)
(*     rewrite <- concat_assoc. *)
(*     apply IHAts; eauto with listin. *)
(*     + rewrite concat_assoc. *)
(*       apply adding_free_is_ok; eauto with listin. *)
(*     + inversion* HD. *)
(*     + introv Hin. *)
(*       simpl_dom. *)
(*       rewrite notin_union. *)
(*       split. *)
(*       * apply* notin_singleton. *)
(*         inversions HD. *)
(*         intro; subst. contradiction. *)
(*       * eauto with listin. *)
(* Qed. *)

Lemma subst_idempotent : forall U Z P,
    Z \notin fv_typ P ->
    subst_tt Z P U = subst_tt Z P (subst_tt Z P U).
  induction U using typ_ind'; introv FV; try solve [cbn; eauto].
  - cbn.
    case_if.
    + rewrite* subst_tt_fresh.
    + cbn. case_if. eauto.
  - cbn.
    rewrite* <- IHU1.
    rewrite* <- IHU2.
  - cbn.
    rewrite* <- IHU1.
    rewrite* <- IHU2.
  - cbn.
    rewrite* <- IHU.
  - cbn. f_equal.
    rewrite List.map_map.
    apply* List.map_ext_in.
    introv ain.
    rewrite List.Forall_forall in *.
    eauto.
Qed.

Lemma subst_idempotent_through_many_open : forall Tts Z U P,
    type P ->
    Z \notin fv_typ P ->
    subst_tt Z P (open_tt_many Tts U) =
    subst_tt Z P (open_tt_many Tts (subst_tt Z P U)).
  induction Tts; introv TP FV.
  - cbn. apply* subst_idempotent.
  - cbn.
    rewrite* IHTts.
    rewrite* (IHTts Z (open_tt (subst_tt Z P U) a) P).
    f_equal. f_equal.
    repeat rewrite* subst_tt_open_tt.
    f_equal.
    apply* subst_idempotent.
Qed.

Lemma subst_removes_var : forall T U Z,
    Z \notin fv_typ U ->
    Z \notin fv_typ (subst_tt Z U T).
  induction T using typ_ind'; introv FU; cbn; eauto.
  - case_if; cbn; eauto.
  - rewrite list_fold_map.
    rewrite List.Forall_forall in *.
    apply* notin_fold.
Qed.

Lemma subst_commutes_open_tt_many : forall Ts Z P U,
    type P ->
    Z \notin fv_typ P ->
    Z \notin fv_typ U ->
    subst_tt Z P (open_tt_many Ts U) =
    open_tt_many (List.map (subst_tt Z P) Ts) U.
  induction Ts as [| Th Tts]; introv TP FP FU.
  - cbn. apply* subst_tt_fresh.
  - cbn.
    rewrite* subst_idempotent_through_many_open.
    rewrite* subst_tt_open_tt.
    rewrite* (@subst_tt_fresh Z P U).
    apply* IHTts.
    unfold open_tt.
    lets* FO: fv_open U (subst_tt Z P Th) 0.
    destruct FO as [FO | FO].
    + rewrite FO.
      apply notin_union; split*.
      apply* subst_removes_var.
    + rewrite* FO.
Qed.

(* Lemma add_types_map_subst_tb : forall As Z P, *)
(*     map (subst_tb Z P) (add_types empty As) *)
(*     = *)
(*     add_types empty As. *)
(*   induction As as [| Ah Ats]; introv. *)
(*   - cbn. autorewrite with rew_env_map. trivial. *)
(*   - cbn. autorewrite with rew_env_map. cbn. rewrite IHAts. trivial. *)
(* Qed. *)

(* Lemma add_types_through_map : forall Z P E F As, *)
(*     map (subst_tb Z P) (add_types E As & F) *)
(*     = *)
(*     add_types (map (subst_tb Z P) E) As & (map (subst_tb Z P) F). *)
(*   intros. *)
(*   autorewrite with rew_env_map. *)
(*   f_equal. *)
(*   rewrite <- (concat_empty_r E). *)
(*   rewrite add_types_assoc. *)
(*   autorewrite with rew_env_map. *)
(*   rewrite add_types_assoc. *)
(*   f_equal. *)
(*   apply add_types_map_subst_tb. *)
(* Qed. *)

Fixpoint subst_te_many (Xs : list var) (Us : list typ) (e : trm) :=
  match (Xs, Us) with
  (* | ((List.cons X Xt), (List.cons U Ut)) => subst_tt X U (subst_tt_many Xt Ut T) *)
  | ((List.cons X Xt), (List.cons U Ut)) => subst_te_many Xt Ut (subst_te X U e)
  | _ => e
  end.

Lemma subst_commutes_with_unrelated_opens_te : forall Xs e V Y,
    (forall X, List.In X Xs -> X <> Y) ->
    type V ->
    subst_te Y V (open_te_many_var Xs e) =
    (open_te_many_var Xs (subst_te Y V e)).
  induction Xs as [| Xh Xt]; introv Hneq Htyp.
  - cbn. eauto.
  - cbn.
    fold (open_te_many_var Xt (e open_te_var Xh)).
    fold (open_te_many_var Xt (subst_te Y V e open_te_var Xh)).
    rewrite* subst_te_open_te_var; eauto with listin.
Qed.

Lemma subst_intro_commutes_opens_te : forall Xs e Y V,
    Y \notin fv_trm e ->
    (forall X, List.In X Xs -> X <> Y) ->
    type V ->
    open_te_many_var Xs (open_te e V) =
    subst_te Y V (open_te_many_var Xs (e open_te_var Y)).
  induction Xs as [| Xh Xt]; introv Hfv Hneq Htyp.
  - cbn. apply* subst_te_intro.
  - cbn.
    fold (open_te_many_var Xt (open_te e V open_te_var Xh)).
    fold (open_te_many_var Xt ((e open_te_var Y) open_te_var Xh)).
    rewrite* subst_commutes_with_unrelated_opens_te.
    f_equal.
    rewrite* <- subst_te_open_te_var.
    + rewrite* <- subst_te_intro.
    + apply* Hneq. cbn; eauto.
    + eauto with listin.
Qed.

Lemma subst_te_intro_many : forall Xs e Us,
    length Xs = length Us ->
    DistinctList Xs ->
    (forall X, List.In X Xs -> X \notin fv_trm e) ->
    (forall X U, List.In X Xs -> List.In U Us -> X \notin fv_typ U) ->
    (forall U, List.In U Us -> type U) ->
    open_te_many Us e = subst_te_many Xs Us (open_te_many_var Xs e).
  induction Xs as [| Xh Xt]; introv Hleneq Hdistinct HXfv HXUfv XUtyp.
  - destruct Us.
    + cbv. trivial.
    + inversions Hleneq.
  - destruct Us as [| Uh Ut].
    + inversions Hleneq.
    + cbn.
      fold (open_te_many_var Xt (e open_te_var Xh)).
      inversions Hdistinct.
      rewrite IHXt; auto with listin.
      * f_equal.
        rewrite <- subst_intro_commutes_opens_te; eauto with listin.
        introv Xin.
        intro; subst. contradiction.
      * introv Xin.
        apply fv_open_te; eauto with listin.
Qed.

Lemma subst_tt_many_free : forall As Ts T,
    (forall A, List.In A As -> A \notin fv_typ T) ->
    T = subst_tt_many As Ts T.
  induction As; introv Afresh.
  - cbn. trivial.
  - destruct Ts.
    + cbn. trivial.
    + cbn. rewrite <- IHAs.
      * symmetry. apply subst_tt_fresh.
        auto with listin.
      * intros.
        rewrite subst_tt_fresh;
          auto with listin.
Qed.

Lemma subst_te_many_commutes_open : forall As Ts e x vk,
    length As = length Ts ->
    (forall A, List.In A As -> x <> A) ->
    open_ee (subst_te_many As Ts e) (trm_fvar vk x)
    =
    subst_te_many As Ts (open_ee e (trm_fvar vk x)).
  induction As as [| Ah Ats]; introv Hlen Afresh.
  - cbn. auto.
  - destruct Ts as [| Th Tts]; cbn in Hlen; try congruence.
    cbn. fold (open_ee (subst_te_many Ats Tts (subst_te Ah Th e)) (trm_fvar vk x)).
    rewrite IHAts; auto with listin.
    f_equal.
    apply subst_te_open_ee_var.
Qed.

Lemma subst_tb_id_on_fresh : forall E Z P,
    Z \notin fv_env E ->
    map (subst_tb Z P) E = E.
  induction E using env_ind; introv FE.
  - rewrite map_empty. trivial.
  - rewrite map_push.
    destruct v.
    rewrite fv_env_extend in FE.
    f_equal.
    + apply* IHE.
    + cbn.
      f_equal. f_equal.
      apply subst_tt_fresh. auto.
Qed.

Lemma subst_tt_many_id_on_fresh : forall T As Ps,
    (forall A, List.In A As -> A \notin fv_typ T) ->
    subst_tt_many As Ps T = T.
  induction As; destruct Ps; intros; try solve [cbn in *; congruence].
  cbn.
  rewrite subst_tt_fresh.
  - apply IHAs; auto with listin.
  - auto with listin.
Qed.

Lemma subst_tb_many_id_on_fresh_env : forall E As Ps,
    length As = length Ps ->
    (forall A, List.In A As -> A \notin fv_env E) ->
    map (subst_tb_many As Ps) E = E.
  intros.
  rewrite map_def.
  rewrite <- LibList_map.
  symmetry.
  rewrite <- map_id; auto.
  intros vb xin.
  destruct vb. cbn.
  f_equal; auto.
  unfold subst_tb_many. destruct b.
  rewrite subst_tt_many_id_on_fresh; auto.
  intros.
  induction E as [| B E].
  - contradiction.
  - lets HA: H0 H1.
    cbn in HA. fold (fv_env E) in HA.
    lets [? | ?]: List.in_inv xin; subst; cbn in HA; auto.
    apply IHE; auto.
    intros A' Ain.
    lets HA': H0 Ain.
    destruct B; destruct b; cbn in HA'. fold (fv_env E) in HA'.
    auto.
Qed.

Lemma subst_commute:
  forall (X : var) (U : typ) (A : var) (P T : typ),
    X <> A ->
    A \notin fv_typ U ->
    subst_tt X U (subst_tt A P T) = subst_tt A (subst_tt X U P) (subst_tt X U T).
Proof.
  induction T using typ_ind'; introv Neq Fr; cbn; auto;
    try solve [
          rewrite~ IHT1; rewrite~ IHT2
        ].
  - repeat case_if; subst; cbn; repeat case_if; eauto.
    rewrite~ subst_tt_fresh.
  - rewrite~ IHT.
  - rewrite List.Forall_forall in *.
    f_equal.
    repeat rewrite List.map_map.
    apply List.map_ext_in.
    intros T Tin.
    apply~ H.
Qed.

Lemma subst_ee_fix_term : forall e1 Z e2,
    term e1 -> term e2 -> term (subst_ee Z fix_var e2 e1)
with subst_ee_fix_value : forall e1 Z e2,
    value e1 -> term e2 -> value (subst_ee Z fix_var e2 e1).
Proof.
  - induction 1; intros; simpl; auto.
    + case_if*.
    + apply_fresh* term_abs as y. rewrite* subst_ee_open_ee_var.
    + apply_fresh* term_tabs as Y; rewrite* subst_ee_open_te_var;
        apply~ value_regular.
    + apply_fresh* term_fix as y; rewrite* subst_ee_open_ee_var;
        apply~ value_regular.
    + apply_fresh* term_let as y. rewrite* subst_ee_open_ee_var;
                                    apply~ value_regular.
    + econstructor; eauto.
      intros cl clinmap Alphas x Hlen Hdist Afresh xfresh xfreshA.
      destruct cl as [clA clT].
      unfold map_clause_trm_trm in clinmap.
      lets cl2: clinmap.
      apply List.in_map_iff in cl2.
      destruct cl2 as [[cl'A cl'T] [cl'eq cl'in]].
      inversion cl'eq. subst.
      cbn.
      lets* IH: H1 cl'in Alphas x Hlen Hdist.
      cbn in IH.
      instantiate (1:=(L \u \{ Z })) in Afresh.
      rewrite* <- subst_commutes_with_unrelated_opens_te_ee.
      * rewrite* subst_ee_open_ee_var.
        apply* IH.
        intros A AAlpha.
        assert (A \notin L \u \{ Z }); solve [apply* Afresh | eauto].
  - induction 1; intros; simpl; auto;
      try match goal with
      | H: term (trm_abs _ _) |- _ => rename H into Hterm
      | H: term (trm_tabs _) |- _ => rename H into Hterm
      end.
    + apply value_abs. inversions Hterm.
      apply_fresh* term_abs as y. rewrite* subst_ee_open_ee_var.
    + apply value_tabs; inversions Hterm.
      apply_fresh* term_tabs as Y; rewrite* subst_ee_open_te_var;
        apply~ value_regular.
    + case_if~.
      inversions C.
      congruence.
    + constructor*.
      inversions H1.
      constructor*.
    + inversions H.
      constructor*.
Qed.


(** * StlcProp: Properties of STLC *)

Set Warnings "-notation-overridden,-parsing".
From PLF Require Import Maps.
From PLF Require Import Types.
From PLF Require Import Stlc.
From PLF Require Import Smallstep.
Module STLCProp.
Import STLC.

(** In this chapter, we develop the fundamental theory of the Simply
    Typed Lambda Calculus -- in particular, the type safety
    theorem. *)

(* ################################################################# *)
(** * Canonical Forms *)

(** As we saw for the simple calculus in the [Types] chapter, the
    first step in establishing basic properties of reduction and types
    is to identify the possible _canonical forms_ (i.e., well-typed
    closed values) belonging to each type.  For [Bool], these are the
    boolean values [tru] and [fls]; for arrow types, they are
    lambda-abstractions.  *)

Lemma canonical_forms_bool : forall t,
  empty |- t \in Bool ->
  value t ->
  (t = tru) \/ (t = fls).
Proof.
  intros t HT HVal.
  inversion HVal; intros; subst; try inversion HT; auto.
Qed.

Lemma canonical_forms_fun : forall t T1 T2,
  empty |- t \in (Arrow T1 T2) ->
  value t ->
  exists x u, t = abs x T1 u.
Proof.
  intros t T1 T2 HT HVal.
  inversion HVal; intros; subst; try inversion HT; subst; auto.
  exists x0, t0.  auto.
Qed.

(* ################################################################# *)
(** * Progress *)

(** The _progress_ theorem tells us that closed, well-typed
    terms are not stuck: either a well-typed term is a value, or it
    can take a reduction step.  The proof is a relatively
    straightforward extension of the progress proof we saw in the
    [Types] chapter.  We give the proof in English first, then
    the formal version. *)

Theorem progress : forall t T,
  empty |- t \in T ->
  value t \/ exists t', t --> t'.

(** _Proof_: By induction on the derivation of [|- t \in T].

    - The last rule of the derivation cannot be [T_Var], since a
      variable is never well typed in an empty context.

    - The [T_Tru], [T_Fls], and [T_Abs] cases are trivial, since in
      each of these cases we can see by inspecting the rule that [t]
      is a value.

    - If the last rule of the derivation is [T_App], then [t] has the
      form [t1 t2] for some [t1] and [t2], where [|- t1 \in T2 -> T]
      and [|- t2 \in T2] for some type [T2].  The induction hypothesis
      for the first subderivation says that either [t1] is a value or
      else it can take a reduction step.

        - If [t1] is a value, then consider [t2], which by the
          induction hypothesis for the second subderivation must also
          either be a value or take a step.

            - Suppose [t2] is a value.  Since [t1] is a value with an
              arrow type, it must be a lambda abstraction; hence [t1
              t2] can take a step by [ST_AppAbs].

            - Otherwise, [t2] can take a step, and hence so can [t1
              t2] by [ST_App2].

        - If [t1] can take a step, then so can [t1 t2] by [ST_App1].

    - If the last rule of the derivation is [T_Test], then [t = test
      t1 then t2 else t3], where [t1] has type [Bool].  The first IH
      says that [t1] either is a value or takes a step.

        - If [t1] is a value, then since it has type [Bool] it must be
          either [tru] or [fls].  If it is [tru], then [t] steps to
          [t2]; otherwise it steps to [t3].

        - Otherwise, [t1] takes a step, and therefore so does [t] (by
          [ST_Test]). *)
Proof with eauto.
  intros t T Ht.
  remember (@empty ty) as Gamma.
  induction Ht; subst Gamma...
  - (* T_Var *)
    (* contradictory: variables cannot be typed in an
       empty context *)
    inversion H.

  - (* T_App *)
    (* [t] = [t1 t2].  Proceed by cases on whether [t1] is a
       value or steps... *)
    right. destruct IHHt1...
    + (* t1 is a value *)
      destruct IHHt2...
      * (* t2 is also a value *)
        assert (exists x0 t0, t1 = abs x0 T11 t0).
        eapply canonical_forms_fun; eauto.
        destruct H1 as [x0 [t0 Heq]]. subst.
        exists ([x0:=t2]t0)...

      * (* t2 steps *)
        inversion H0 as [t2' Hstp]. exists (app t1 t2')...

    + (* t1 steps *)
      inversion H as [t1' Hstp]. exists (app t1' t2)...

  - (* T_Test *)
    right. destruct IHHt1...

    + (* t1 is a value *)
      destruct (canonical_forms_bool t1); subst; eauto.

    + (* t1 also steps *)
      inversion H as [t1' Hstp]. exists (test t1' t2 t3)...
Qed.

(** **** Exercise: 3 stars, advanced (progress_from_term_ind)

    Show that progress can also be proved by induction on terms
    instead of induction on typing derivations. *)

Theorem progress' : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t --> t'.
Proof.
  intros t.
  induction t; intros T Ht; auto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Preservation *)

(** The other half of the type soundness property is the
    preservation of types during reduction.  For this part, we'll need
    to develop some technical machinery for reasoning about variables
    and substitution.  Working from top to bottom (from the high-level
    property we are actually interested in to the lowest-level
    technical lemmas that are needed by various cases of the more
    interesting proofs), the story goes like this:

      - The _preservation theorem_ is proved by induction on a typing
        derivation, pretty much as we did in the [Types] chapter.
        The one case that is significantly different is the one for
        the [ST_AppAbs] rule, whose definition uses the substitution
        operation.  To see that this step preserves typing, we need to
        know that the substitution itself does.  So we prove a...

      - _substitution lemma_, stating that substituting a (closed)
        term [s] for a variable [x] in a term [t] preserves the type
        of [t].  The proof goes by induction on the form of [t] and
        requires looking at all the different cases in the definition
        of substitition.  This time, the tricky cases are the ones for
        variables and for function abstractions.  In both, we discover
        that we need to take a term [s] that has been shown to be
        well-typed in some context [Gamma] and consider the same term
        [s] in a slightly different context [Gamma'].  For this we
        prove a...

      - _context invariance_ lemma, showing that typing is preserved
        under "inessential changes" to the context [Gamma] -- in
        particular, changes that do not affect any of the free
        variables of the term.  And finally, for this, we need a
        careful definition of...

      - the _free variables_ in a term -- i.e., variables that are
        used in the term in positions that are _not_ in the scope of
        an enclosing function abstraction binding a variable of the
        same name.

   To make Coq happy, of course, we need to formalize the story in the
   opposite order... *)

(* ================================================================= *)
(** ** Free Occurrences *)

(** A variable [x] _appears free in_ a term _t_ if [t] contains some
    occurrence of [x] that is not under an abstraction labeled [x].
    For example:
      - [y] appears free, but [x] does not, in [\x:T->U. x y]
      - both [x] and [y] appear free in [(\x:T->U. x y) x]
      - no variables appear free in [\x:T->U. \y:T. x y]

    Formally: *)

Inductive appears_free_in : string -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (var x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 ->
      appears_free_in x (app t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 ->
      appears_free_in x (app t1 t2)
  | afi_abs : forall x y T11 t12,
      y <> x  ->
      appears_free_in x t12 ->
      appears_free_in x (abs y T11 t12)
  | afi_test1 : forall x t1 t2 t3,
      appears_free_in x t1 ->
      appears_free_in x (test t1 t2 t3)
  | afi_test2 : forall x t1 t2 t3,
      appears_free_in x t2 ->
      appears_free_in x (test t1 t2 t3)
  | afi_test3 : forall x t1 t2 t3,
      appears_free_in x t3 ->
      appears_free_in x (test t1 t2 t3).

Hint Constructors appears_free_in.

(** The _free variables_ of a term are just the variables that appear
    free in it.  A term with no free variables is said to be
    _closed_. *)

Definition closed (t:tm) :=
  forall x, ~ appears_free_in x t.

(** An _open_ term is one that may contain free variables.  (I.e., every
    term is an open term; the closed terms are a subset of the open ones.
    "Open" precisely means "possibly containing free variables.") *)

(** **** Exercise: 1 star, standard (afi)

    In the space below, write out the rules of the [appears_free_in]
    relation in informal inference-rule notation.  (Use whatever
    notational conventions you like -- the point of the exercise is
    just for you to think a bit about the meaning of each rule.)
    Although this is a rather low-level, technical definition,
    understanding it is crucial to understanding substitution and its
    properties, which are really the crux of the lambda-calculus. *)

(* FILL IN HERE *)

(* Do not modify the following line: *)
Definition manual_grade_for_afi : option (nat*string) := None.
(** [] *)

(* ================================================================= *)
(** ** Substitution *)

(** To prove that substitution preserves typing, we first need a
    technical lemma connecting free variables and typing contexts: If
    a variable [x] appears free in a term [t], and if we know [t] is
    well typed in context [Gamma], then it must be the case that
    [Gamma] assigns a type to [x]. *)

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   Gamma |- t \in T ->
   exists T', Gamma x = Some T'.

(** _Proof_: We show, by induction on the proof that [x] appears free
      in [t], that, for all contexts [Gamma], if [t] is well typed
      under [Gamma], then [Gamma] assigns some type to [x].

      - If the last rule used is [afi_var], then [t = x], and from the
        assumption that [t] is well typed under [Gamma] we have
        immediately that [Gamma] assigns a type to [x].

      - If the last rule used is [afi_app1], then [t = t1 t2] and [x]
        appears free in [t1].  Since [t] is well typed under [Gamma],
        we can see from the typing rules that [t1] must also be, and
        the IH then tells us that [Gamma] assigns [x] a type.

      - Almost all the other cases are similar: [x] appears free in a
        subterm of [t], and since [t] is well typed under [Gamma], we
        know the subterm of [t] in which [x] appears is well typed
        under [Gamma] as well, and the IH gives us exactly the
        conclusion we want.

      - The only remaining case is [afi_abs].  In this case [t =
        \y:T11.t12] and [x] appears free in [t12], and we also know
        that [x] is different from [y].  The difference from the
        previous cases is that, whereas [t] is well typed under
        [Gamma], its body [t12] is well typed under [(y|->T11; Gamma],
        so the IH allows us to conclude that [x] is assigned some type
        by the extended context [(y|->T11; Gamma].  To conclude that
        [Gamma] assigns a type to [x], we appeal to lemma
        [update_neq], noting that [x] and [y] are different
        variables. *)

Proof.
  intros x t T Gamma H H0. generalize dependent Gamma.
  generalize dependent T.
  induction H;
         intros; try solve [inversion H0; eauto].
  - (* afi_abs *)
    inversion H1; subst.
    apply IHappears_free_in in H7.
    rewrite update_neq in H7; assumption.
Qed.

(** From the [free_in_context] lemma, it immediately follows that any
    term [t] that is well typed in the empty context is closed (it has
    no free variables). *)

(** **** Exercise: 2 stars, standard, optional (typable_empty__closed)  *)
Corollary typable_empty__closed : forall t T,
    empty |- t \in T  ->
    closed t.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Sometimes, when we have a proof of some typing relation
    [Gamma |- t \in T], we will need to replace [Gamma] by a different
    context [Gamma'].  When is it safe to do this?  Intuitively, it
    must at least be the case that [Gamma'] assigns the same types as
    [Gamma] to all the variables that appear free in [t]. In fact,
    this is the only condition that is needed. *)

Lemma context_invariance : forall Gamma Gamma' t T,
     Gamma |- t \in T  ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x) ->
     Gamma' |- t \in T.

(** _Proof_: By induction on the derivation of [Gamma |- t \in T].

      - If the last rule in the derivation was [T_Var], then [t = x]
        and [Gamma x = T].  By assumption, [Gamma' x = T] as well, and
        hence [Gamma' |- t \in T] by [T_Var].

      - If the last rule was [T_Abs], then [t = \y:T11. t12], with [T
        = T11 -> T12] and [y|->T11; Gamma |- t12 \in T12].  The
        induction hypothesis is that, for any context [Gamma''], if
        [y|->T11; Gamma] and [Gamma''] assign the same types to
        all the free variables in [t12], then [t12] has type [T12]
        under [Gamma''].  Let [Gamma'] be a context which agrees with
        [Gamma] on the free variables in [t]; we must show [Gamma' |-
        \y:T11. t12 \in T11 -> T12].

        By [T_Abs], it suffices to show that [y|->T11; Gamma' |-
        t12 \in T12].  By the IH (setting [Gamma'' = y|->T11;Gamma']),
        it suffices to show that [y|->T11;Gamma]
        and [y|->T11;Gamma'] agree on all the variables that
        appear free in [t12].

        Any variable occurring free in [t12] must be either [y] or
        some other variable.  [y|->T11; Gamma] and [y|->T11; Gamma']
        clearly agree on [y].  Otherwise, note that any
        variable other than [y] that occurs free in [t12] also occurs
        free in [t = \y:T11. t12], and by assumption [Gamma] and
        [Gamma'] agree on all such variables; hence so do [y|->T11; Gamma]
        and [y|->T11; Gamma'].

      - If the last rule was [T_App], then [t = t1 t2], with [Gamma |-
        t1 \in T2 -> T] and [Gamma |- t2 \in T2].  One induction
        hypothesis states that for all contexts [Gamma'], if [Gamma']
        agrees with [Gamma] on the free variables in [t1], then [t1]
        has type [T2 -> T] under [Gamma']; there is a similar IH for
        [t2].  We must show that [t1 t2] also has type [T] under
        [Gamma'], given the assumption that [Gamma'] agrees with
        [Gamma] on all the free variables in [t1 t2].  By [T_App], it
        suffices to show that [t1] and [t2] each have the same type
        under [Gamma'] as under [Gamma].  But all free variables in
        [t1] are also free in [t1 t2], and similarly for [t2]; hence
        the desired result follows from the induction hypotheses. *)

Proof with eauto.
  intros.
  generalize dependent Gamma'.
  induction H; intros; auto.
  - (* T_Var *)
    apply T_Var. rewrite <- H0...
  - (* T_Abs *)
    apply T_Abs.
    apply IHhas_type. intros x1 Hafi.
    (* the only tricky step... the [Gamma'] we use to
       instantiate is [x|->T11;Gamma] *)
    unfold update. unfold t_update. destruct (eqb_string x0 x1) eqn: Hx0x1...
    rewrite eqb_string_false_iff in Hx0x1. auto.
  - (* T_App *)
    apply T_App with T11...
Qed.

(** Now we come to the conceptual heart of the proof that reduction
    preserves types -- namely, the observation that _substitution_
    preserves types. *)

(** Formally, the so-called _substitution lemma_ says this:
    Suppose we have a term [t] with a free variable [x], and suppose
    we've assigned a type [T] to [t] under the assumption that [x] has
    some type [U].  Also, suppose that we have some other term [v] and
    that we've shown that [v] has type [U].  Then, since [v] satisfies
    the assumption we made about [x] when typing [t], we can
    substitute [v] for each of the occurrences of [x] in [t] and
    obtain a new term that still has type [T]. *)

(** _Lemma_: If [x|->U; Gamma |- t \in T] and [|- v \in U],
    then [Gamma |- [x:=v]t \in T]. *)

Lemma substitution_preserves_typing : forall Gamma x U t v T,
  (x |-> U ; Gamma) |- t \in T ->
  empty |- v \in U   ->
  Gamma |- [x:=v]t \in T.

(** One technical subtlety in the statement of the lemma is that
    we assume [v] has type [U] in the _empty_ context -- in other
    words, we assume [v] is closed.  This assumption considerably
    simplifies the [T_Abs] case of the proof (compared to assuming
    [Gamma |- v \in U], which would be the other reasonable assumption
    at this point) because the context invariance lemma then tells us
    that [v] has type [U] in any context at all -- we don't have to
    worry about free variables in [v] clashing with the variable being
    introduced into the context by [T_Abs].

    The substitution lemma can be viewed as a kind of "commutation
    property."  Intuitively, it says that substitution and typing can
    be done in either order: we can either assign types to the terms
    [t] and [v] separately (under suitable contexts) and then combine
    them using substitution, or we can substitute first and then
    assign a type to [ [x:=v] t ] -- the result is the same either
    way.

    _Proof_: We show, by induction on [t], that for all [T] and
    [Gamma], if [x|->U; Gamma |- t \in T] and [|- v \in U], then
    [Gamma |- [x:=v]t \in T].

      - If [t] is a variable there are two cases to consider,
        depending on whether [t] is [x] or some other variable.

          - If [t = x], then from the fact that [x|->U; Gamma |-
            x \in T] we conclude that [U = T].  We must show that
            [[x:=v]x = v] has type [T] under [Gamma], given the
            assumption that [v] has type [U = T] under the empty
            context.  This follows from context invariance: if a
            closed term has type [T] in the empty context, it has that
            type in any context.

          - If [t] is some variable [y] that is not equal to [x], then
            we need only note that [y] has the same type under
            [x|->U; Gamma] as under [Gamma].

      - If [t] is an abstraction [\y:T11. t12], then the IH tells us,
        for all [Gamma'] and [T'], that if [x|->U; Gamma' |- t12
        \in T'] and [|- v \in U], then [Gamma' |- [x:=v]t12 \in T'].

        The substitution in the conclusion behaves differently
        depending on whether [x] and [y] are the same variable.

        First, suppose [x = y].  Then, by the definition of
        substitution, [[x:=v]t = t], so we just need to show [Gamma |-
        t \in T].  But we know [x|->U; Gamma |- t \in T], and,
        since [y] does not appear free in [\y:T11. t12], the context
        invariance lemma yields [Gamma |- t \in T].

        Second, suppose [x <> y].  We know [x|->U; y|->T11; Gamma
        |- t12 \in T12] by inversion of the typing relation, from
        which [y|->T11; x|->U; Gamma |- t12 \in T12] follows by
        the context invariance lemma, so the IH applies, giving us
        [y|->T11; Gamma |- [x:=v]t12 \in T12].  By [T_Abs],
        [Gamma |- \y:T11. [x:=v]t12 \in T11->T12], and by the
        definition of substitution (noting that [x <> y]), [Gamma |-
        \y:T11. [x:=v]t12 \in T11->T12] as required.

      - If [t] is an application [t1 t2], the result follows
        straightforwardly from the definition of substitution and the
        induction hypotheses.

      - The remaining cases are similar to the application case.

    _Technical note_: This proof is a rare case where an induction on
    terms, rather than typing derivations, yields a simpler argument.
    The reason for this is that the assumption [x|->U; Gamma |- t
    \in T] is not completely generic, in the sense that one of the
    "slots" in the typing relation -- namely the context -- is not
    just a variable, and this means that Coq's native induction tactic
    does not give us the induction hypothesis that we want.  It is
    possible to work around this, but the needed generalization is a
    little tricky.  The term [t], on the other hand, is completely
    generic. *)

Proof with eauto.
  intros Gamma x U t v T Ht Ht'.
  generalize dependent Gamma. generalize dependent T.
  induction t; intros T Gamma H;
    (* in each case, we'll want to get at the derivation of H *)
    inversion H; subst; simpl...
  - (* var *)
    rename s into y. destruct (eqb_stringP x y) as [Hxy|Hxy].
    + (* x=y *)
      subst.
      rewrite update_eq in H2.
      inversion H2; subst.
      eapply context_invariance. eassumption.
      apply typable_empty__closed in Ht'. unfold closed in Ht'.
      intros.  apply (Ht' x0) in H0. inversion H0.
    + (* x<>y *)
      apply T_Var. rewrite update_neq in H2...
  - (* abs *)
    rename s into y. rename t into T. apply T_Abs.
    destruct (eqb_stringP x y) as [Hxy | Hxy].
    + (* x=y *)
      subst. rewrite update_shadow in H5. apply H5.
    + (* x<>y *)
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold update, t_update.
      destruct (eqb_stringP y z) as [Hyz | Hyz]; subst; trivial.
      rewrite <- eqb_string_false_iff in Hxy.
      rewrite Hxy...
Qed.

(* ================================================================= *)
(** ** Main Theorem *)

(** We now have the tools we need to prove preservation: if a closed
    term [t] has type [T] and takes a step to [t'], then [t']
    is also a closed term with type [T].  In other words, the small-step
    reduction relation preserves types. *)

Theorem preservation : forall t t' T,
  empty |- t \in T  ->
  t --> t'  ->
  empty |- t' \in T.

(** _Proof_: By induction on the derivation of [|- t \in T].

    - We can immediately rule out [T_Var], [T_Abs], [T_Tru], and
      [T_Fls] as final rules in the derivation, since in each of these
      cases [t] cannot take a step.

    - If the last rule in the derivation is [T_App], then [t = t1 t2],
      and there are subderivations showing that [|- t1 \in T11->T] and
      [|- t2 \in T11] plus two induction hypotheses: (1) [t1 --> t1']
      implies [|- t1' \in T11->T] and (2) [t2 --> t2'] implies [|- t2'
      \in T11].  There are now three subcases to consider, one for
      each rule that could be used to show that [t1 t2] takes a step
      to [t'].

        - If [t1 t2] takes a step by [ST_App1], with [t1] stepping to
          [t1'], then, by the first IH, [t1'] has the same type as
          [t1] ([|- t1 \in T11->T]), and hence by [T_App] [t1' t2] has
          type [T].

        - The [ST_App2] case is similar, using the second IH.

        - If [t1 t2] takes a step by [ST_AppAbs], then [t1 =
          \x:T11.t12] and [t1 t2] steps to [[x:=t2]t12]; the desired
          result now follows from the substitution lemma.

    - If the last rule in the derivation is [T_Test], then [t = test
      t1 then t2 else t3], with [|- t1 \in Bool], [|- t2 \in T], and
      [|- t3 \in T], and with three induction hypotheses: (1) [t1 -->
      t1'] implies [|- t1' \in Bool], (2) [t2 --> t2'] implies [|- t2'
      \in T], and (3) [t3 --> t3'] implies [|- t3' \in T].

      There are again three subcases to consider, depending on how [t]
      steps.

        - If [t] steps to [t2] or [t3] by [ST_TestTru] or
          [ST_TestFalse], the result is immediate, since [t2] and [t3]
          have the same type as [t].

        - Otherwise, [t] steps by [ST_Test], and the desired
          conclusion follows directly from the first induction
          hypothesis. *)

Proof with eauto.
  remember (@empty ty) as Gamma.
  intros t t' T HT. generalize dependent t'.
  induction HT;
       intros t' HE; subst Gamma; subst;
       try solve [inversion HE; subst; auto].
  - (* T_App *)
    inversion HE; subst...
    (* Most of the cases are immediate by induction,
       and [eauto] takes care of them *)
    + (* ST_AppAbs *)
      apply substitution_preserves_typing with T11...
      inversion HT1...
Qed.

(** **** Exercise: 2 stars, standard, recommended (subject_expansion_stlc)

    An exercise in the [Types] chapter asked about the _subject
    expansion_ property for the simple language of arithmetic and
    boolean expressions.  This property did not hold for that language,
    and it also fails for STLC.  That is, it is not always the case that,
    if [t --> t'] and [has_type t' T], then [empty |- t \in T].
    Show this by giving a counter-example that does _not involve
    conditionals_.

    You can state your counterexample informally in words, with a brief
    explanation. *)

(* FILL IN HERE *)

(* Do not modify the following line: *)
Definition manual_grade_for_subject_expansion_stlc : option (nat*string) := None.
(** [] *)

(* ################################################################# *)
(** * Type Soundness *)

(** **** Exercise: 2 stars, standard, optional (type_soundness)

    Put progress and preservation together and show that a well-typed
    term can _never_ reach a stuck state.  *)

Definition stuck (t:tm) : Prop :=
  (normal_form step) t /\ ~ value t.

Corollary soundness : forall t t' T,
  empty |- t \in T ->
  t -->* t' ->
  ~(stuck t').
Proof.
  intros t t' T Hhas_type Hmulti. unfold stuck.
  intros [Hnf Hnot_val]. unfold normal_form in Hnf.
  induction Hmulti.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Uniqueness of Types *)

(** **** Exercise: 3 stars, standard (unique_types)

    Another nice property of the STLC is that types are unique: a
    given term (in a given context) has at most one type. *)

Theorem unique_types : forall Gamma e T T',
  Gamma |- e \in T ->
  Gamma |- e \in T' ->
  T = T'.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Additional Exercises *)

(** **** Exercise: 1 star, standard (progress_preservation_statement)

    Without peeking at their statements above, write down the progress
    and preservation theorems for the simply typed lambda-calculus (as
    Coq theorems).
    You can write [Admitted] for the proofs. *)
(* FILL IN HERE *)

(* Do not modify the following line: *)
Definition manual_grade_for_progress_preservation_statement : option (nat*string) := None.
(** [] *)

(** **** Exercise: 2 stars, standard (stlc_variation1)

    Suppose we add a new term [zap] with the following reduction rule

                         ---------                  (ST_Zap)
                         t --> zap

and the following typing rule:

                      ------------------            (T_Zap)
                      Gamma |- zap \in T

    Which of the following properties of the STLC remain true in
    the presence of these rules?  For each property, write either
    "remains true" or "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]
(* FILL IN HERE *)
      - Progress
(* FILL IN HERE *)
      - Preservation
(* FILL IN HERE *)
*)

(* Do not modify the following line: *)
Definition manual_grade_for_stlc_variation1 : option (nat*string) := None.
(** [] *)

(** **** Exercise: 2 stars, standard (stlc_variation2)

    Suppose instead that we add a new term [foo] with the following
    reduction rules:

                       -----------------                (ST_Foo1)
                       (\x:A. x) --> foo

                         ------------                   (ST_Foo2)
                         foo --> tru

    Which of the following properties of the STLC remain true in
    the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]
(* FILL IN HERE *)
      - Progress
(* FILL IN HERE *)
      - Preservation
(* FILL IN HERE *)
*)

(* Do not modify the following line: *)
Definition manual_grade_for_stlc_variation2 : option (nat*string) := None.
(** [] *)

(** **** Exercise: 2 stars, standard (stlc_variation3)

    Suppose instead that we remove the rule [ST_App1] from the [step]
    relation. Which of the following properties of the STLC remain
    true in the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]
(* FILL IN HERE *)
      - Progress
(* FILL IN HERE *)
      - Preservation
(* FILL IN HERE *)
*)

(* Do not modify the following line: *)
Definition manual_grade_for_stlc_variation3 : option (nat*string) := None.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (stlc_variation4)

    Suppose instead that we add the following new rule to the
    reduction relation:

            ----------------------------------        (ST_FunnyTestTru)
            (test tru then t1 else t2) --> tru

    Which of the following properties of the STLC remain true in
    the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]
(* FILL IN HERE *)
      - Progress
(* FILL IN HERE *)
      - Preservation
(* FILL IN HERE *)

    [] *)

(** **** Exercise: 2 stars, standard, optional (stlc_variation5)

    Suppose instead that we add the following new rule to the typing
    relation:

                 Gamma |- t1 \in Bool->Bool->Bool
                     Gamma |- t2 \in Bool
                 ------------------------------          (T_FunnyApp)
                    Gamma |- t1 t2 \in Bool

    Which of the following properties of the STLC remain true in
    the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]
(* FILL IN HERE *)
      - Progress
(* FILL IN HERE *)
      - Preservation
(* FILL IN HERE *)

    [] *)

(** **** Exercise: 2 stars, standard, optional (stlc_variation6)

    Suppose instead that we add the following new rule to the typing
    relation:

                     Gamma |- t1 \in Bool
                     Gamma |- t2 \in Bool
                    ---------------------               (T_FunnyApp')
                    Gamma |- t1 t2 \in Bool

    Which of the following properties of the STLC remain true in
    the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]
(* FILL IN HERE *)
      - Progress
(* FILL IN HERE *)
      - Preservation
(* FILL IN HERE *)

    [] *)

(** **** Exercise: 2 stars, standard, optional (stlc_variation7)

    Suppose we add the following new rule to the typing relation
    of the STLC:

                         ------------------- (T_FunnyAbs)
                         |- \x:Bool.t \in Bool

    Which of the following properties of the STLC remain true in
    the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]
(* FILL IN HERE *)
      - Progress
(* FILL IN HERE *)
      - Preservation
(* FILL IN HERE *)

    [] *)

End STLCProp.

(* ================================================================= *)
(** ** Exercise: STLC with Arithmetic *)

(** To see how the STLC might function as the core of a real
    programming language, let's extend it with a concrete base
    type of numbers and some constants and primitive
    operators. *)

Module STLCArith.
Import STLC.

(** To types, we add a base type of natural numbers (and remove
    booleans, for brevity). *)

Inductive ty : Type :=
  | Arrow : ty -> ty -> ty
  | Nat  : ty.

(** To terms, we add natural number constants, along with
    successor, predecessor, multiplication, and zero-testing. *)

Inductive tm : Type :=
  | var : string -> tm
  | app : tm -> tm -> tm
  | abs : string -> ty -> tm -> tm
  | const  : nat -> tm
  | scc : tm -> tm
  | prd : tm -> tm
  | mlt : tm -> tm -> tm
  | test0 : tm -> tm -> tm -> tm.

(** **** Exercise: 5 stars, standard (stlc_arith)

    Finish formalizing the definition and properties of the STLC
    extended with arithmetic. This is a longer exercise. Specifically:

    1. Copy the core definitions for STLC that we went through,
        as well as the key lemmas and theorems, and paste them
        into the file at this point. Do not copy examples, exercises,
        etc. (In particular, make sure you don't copy any of the []
        comments at the end of exercises, to avoid confusing the
        autograder.)

        You should copy over five definitions:
          - Fixpoint susbt
          - Inductive value
          - Inductive step
          - Inductive has_type
          - Inductive appears_free_in

        And five theorems, with their proofs:
          - Lemma context_invariance
          - Lemma free_in_context
          - Lemma substitution_preserves_typing
          - Theorem preservation
          - Theorem progress

        It will be helpful to also copy over "Reserved Notation",
        "Notation", and "Hint Constructors" for these things.

    2. Edit and extend the five definitions (subst, value, step,
        has_type, and appears_free_in) so they are appropriate
        for the new STLC extended with arithmetic.

    3. Extend the proofs of all the five properties of the original
        STLC to deal with the new syntactic forms. Make sure Coq
        accepts the whole file. *)

(* FILL IN HERE *)

(* Do not modify the following line: *)
Definition manual_grade_for_stlc_arith : option (nat*string) := None.
(** [] *)

End STLCArith.

(* Thu Feb 7 20:09:24 EST 2019 *)


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

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

Inductive lst : Type := Nil : lst |Cons : natural -> lst -> 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 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 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.

Fixpoint revflat (revflat_arg0 : tree) : lst
           := match revflat_arg0 with
              | Leaf => Nil
              | Node d l r => append (revflat l) (Cons d (revflat r))
              end.

Fixpoint qrevaflat (qrevaflat_arg0 : tree) (qrevaflat_arg1 : lst) : lst
           := match qrevaflat_arg0, qrevaflat_arg1 with
              | Leaf, x => x
              | Node d l r, x => qrevaflat l (Cons d (qrevaflat r x))
              end.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Theorem theorem0 : forall (x : tree) (y : lst), eq (append (revflat x) y) (qrevaflat x y).
Proof.
   induction x.
   - intros. simpl. lfind. Admitted.


Require Import interfaces.Category.
Require Import interfaces.Functor.

(** * Monoidal structures *)

(** Since a given category may involve several monoidal structure,
  we separate the corresponding interface into a submodule. *)

Module Type MonoidalStructure (C : Category).
  Import C.

  Include Bifunctor C C C.

  Parameter unit : C.t.
  Parameter assoc : forall A B C, C.iso (omap A (omap B C)) (omap (omap A B) C).
  Parameter lunit : forall A, C.iso (omap unit A) A.
  Parameter runit : forall A, C.iso (omap A unit) A.

  Axiom assoc_coh :
    forall A B C D : C.t,
      fmap (assoc A B C) (C.id D) @
        assoc A (omap B C) D @
        fmap (C.id A) (assoc B C D) =
      assoc (omap A B) C D @
        assoc A B (omap C D).

  Axiom unit_coh :
    forall A B : C.t,
      fmap (runit A) (C.id B) @ assoc A unit B =
      fmap (C.id A) (lunit B).

End MonoidalStructure.

(** Then a monoidal category is a category with a submodule for
  a tensor product. *)

Module Type MonoidalDefinition (C : Category).
  Declare Module Tens : MonoidalStructure C.
End MonoidalDefinition.

Module MonoidalTheory (C : Category) (M : MonoidalDefinition C).
  Import C M.

  Notation "1" := Tens.unit : obj_scope.
  Infix "*" := Tens.omap : obj_scope.
  Infix "*" := Tens.fmap : hom_scope.
  Notation α := Tens.assoc.
  Notation λ := Tens.lunit.
  Notation ρ := Tens.runit.

End MonoidalTheory.

Module Type Monoidal :=
  Category.Category
    <+ MonoidalDefinition
    <+ MonoidalTheory.

(** * Cartesian monoidal structures *)

(** ** Definition *)

Module Type CartesianStructureDefinition (C : Category).
  Import C.

  (** Terminal object *)

  Parameter unit : t.
  Parameter ter : forall X, C.m X unit.

  Axiom ter_uni : forall {X} (x y : C.m X unit), x = y.

  (** Binary products *)

  Parameter omap : t -> t -> t.
  Parameter p1 : forall {A B}, m (omap A B) A.
  Parameter p2 : forall {A B}, m (omap A B) B.
  Parameter pair : forall {X A B}, m X A -> m X B -> m X (omap A B).

  Axiom p1_pair : forall {X A B} (f : m X A) (g : m X B), p1 @ pair f g = f.
  Axiom p2_pair : forall {X A B} (f : m X A) (g : m X B), p2 @ pair f g = g.
  Axiom pair_pi : forall {X A B} x, @pair X A B (p1 @ x) (p2 @ x) = x.

End CartesianStructureDefinition.

(** ** Consequences *)

(** We show in particular that cartesian structures are a special case
  of monoidal structure. *)

Module CartesianStructureTheory (C : Category) (P : CartesianStructureDefinition C)
    <: MonoidalStructure C.

  Import C.
  Include P.

  Local Infix "&" := omap (at level 40, left associativity) : obj_scope.

  (** *** Useful lemmas *)

  Lemma p1_pair_rewrite {X A B Y} (f : m X A) (g : m X B) (x : m Y X) :
    p1 @ pair f g @ x = f @ x.
  Proof.
    rewrite <- compose_assoc, p1_pair; auto.
  Qed.

  Lemma p2_pair_rewrite {X A B Y} (f : m X A) (g : m X B) (x : m Y X) :
    p2 @ pair f g @ x = g @ x.
  Proof.
    rewrite <- compose_assoc, p2_pair; auto.
  Qed.

  Lemma pair_uni {X A B} (x : m X (omap A B)) (f : m X A) (g : m X B) :
    p1 @ x = f ->
    p2 @ x = g ->
    x = pair f g.
  Proof.
    intros. subst.
    rewrite pair_pi. auto.
  Qed.

  Lemma pair_compose {X A B Y} (f : m X A) (g : m X B) (x : m Y X) :
    pair f g @ x = pair (f @ x) (g @ x).
  Proof.
    apply pair_uni.
    - apply p1_pair_rewrite.
    - apply p2_pair_rewrite.
  Qed.

  (** *** Bifunctor structure *)

  Definition fmap {A1 A2 B1 B2} (f1 : m A1 B1) (f2 : m A2 B2) :=
    pair (f1 @ p1) (f2 @ p2).

  Proposition fmap_id (A B : t) :
    fmap (id A) (id B) = id (omap A B).
  Proof.
    unfold fmap. symmetry.
    apply pair_uni; rewrite compose_id_left, compose_id_right; auto.
  Qed.

  Proposition fmap_compose {A1 A2 B1 B2 C1 C2} :
    forall (g1 : m B1 C1) (g2 : m B2 C2) (f1: m A1 B1) (f2: m A2 B2),
      fmap (g1 @ f1) (g2 @ f2) = fmap g1 g2 @ fmap f1 f2.
  Proof.
    intros. unfold fmap. symmetry.
    apply pair_uni.
    - rewrite p1_pair_rewrite, compose_assoc, p1_pair, compose_assoc. auto.
    - rewrite p2_pair_rewrite, compose_assoc, p2_pair, compose_assoc. auto.
  Qed.

  Include BifunctorTheory C C C.
  Local Infix "&" := fmap : hom_scope.

  (** *** Monoidal structure *)

  Program Definition assoc (A B C : t) : C.iso (A & (B & C)) ((A & B) & C) :=
    {|
      fw := pair (pair p1 (p1 @ p2)) (p2 @ p2);
      bw := pair (p1 @ p1) (pair (p2 @ p1) p2);
    |}.
  Next Obligation.
    rewrite !pair_compose. symmetry. apply pair_uni.
    - rewrite compose_id_right, !compose_assoc, !p1_pair. auto.
    - rewrite compose_id_right, !compose_assoc, !p1_pair, !p2_pair, pair_pi. auto.
  Qed.
  Next Obligation.
    rewrite !pair_compose. symmetry. apply pair_uni.
    - rewrite compose_id_right, !compose_assoc, !p2_pair, !p1_pair, pair_pi. auto.
    - rewrite compose_id_right, !compose_assoc, !p2_pair. auto.
  Qed.

  Program Definition lunit (A : t) : iso (unit & A) A :=
    {|
      fw := p2;
      bw := pair (ter A) (id A);
    |}.
  Next Obligation.
    rewrite pair_compose. symmetry. apply pair_uni.
    - apply ter_uni.
    - rewrite compose_id_right, compose_id_left. auto.
  Qed.
  Next Obligation.
    apply p2_pair.
  Qed.

  Program Definition runit (A : t) : iso (A & unit) A :=
    {|
      fw := p1;
      bw := pair (id A) (ter A);
    |}.
  Next Obligation.
    rewrite pair_compose. symmetry. apply pair_uni.
    - rewrite compose_id_right, compose_id_left. auto.
    - apply ter_uni.
  Qed.
  Next Obligation.
    apply p1_pair.
  Qed.

  Proposition assoc_coh (A B C D : t) :
    (assoc A B C & id D) @ assoc A (B & C) D @ (id A & assoc B C D) =
    assoc (A & B) C D @ assoc A B (C & D).
  Proof.
    unfold assoc, fmap; cbn.
    repeat
      (apply pair_uni ||
       rewrite ?compose_assoc, ?compose_id_left, ?compose_id_right ||
       rewrite ?p1_pair, ?p2_pair, ?pair_compose);
      auto.
  Qed.

  Proposition unit_coh (A B : t) :
    (runit A & id B) @ assoc A unit B = id A & lunit B.
  Proof.
    unfold runit, lunit, fmap; cbn.
    repeat
      (apply pair_uni ||
       rewrite ?compose_assoc, ?compose_id_left, ?compose_id_right ||
       rewrite ?p1_pair, ?p2_pair, ?pair_compose);
      auto.
  Qed.

End CartesianStructureTheory.

(** ** Cartesian category interface *)

Module Type CartesianDef (C : Category).
  Declare Module Prod : MonoidalStructure C.
End CartesianDef.

Module CartesianTheory (C : Category) (M : CartesianDef C).
  Import C M.
  Notation T := Prod.unit.
  Infix "&" := Prod.omap (at level 40, left associativity) : obj_scope.
  Infix "&" := Prod.fmap : hom_scope.
End CartesianTheory.

Module Type Cartesian :=
  Category.Category <+ CartesianDef <+ CartesianTheory.


From ZornsLemma Require Export Families.
From ZornsLemma Require Import EnsemblesSpec.

Record Filter (X:Type) : Type := {
  filter_family: Family X;
  filter_intersection: forall S1 S2:Ensemble X,
    In filter_family S1 -> In filter_family S2 ->
    In filter_family (Intersection S1 S2);
  filter_upward_closed: forall S1 S2:Ensemble X,
    In filter_family S1 -> Included S1 S2 ->
    In filter_family S2;
  filter_full: In filter_family Full_set;
  filter_empty: ~ In filter_family Empty_set
}.

Arguments filter_family {X}.

Record filter_basis {X:Type} (F:Filter X) (B:Family X) : Prop := {
  filter_basis_elements: Included B (filter_family F);
  filter_basis_cond: forall S:Ensemble X,
    In (filter_family F) S -> exists S':Ensemble X,
    In B S' /\ Included S' S
}.

From ZornsLemma Require Export IndexedFamilies.
From ZornsLemma Require Export FiniteTypes.

Lemma filter_finite_indexed_intersection: forall {X:Type} (F:Filter X)
  {A:Type} (S:IndexedFamily A X),
  FiniteT A -> (forall a:A, In (filter_family F) (S a)) ->
  In (filter_family F) (IndexedIntersection S).
Proof.
intros.
induction H.
rewrite empty_indexed_intersection.
apply filter_full.
replace (IndexedIntersection S) with
  (Intersection (IndexedIntersection (fun a:T => S (Some a)))
                (S None)).
apply filter_intersection.
apply IHFiniteT; auto.
apply H0.
apply Extensionality_Ensembles; split; red; intros.
destruct H1.
destruct H1.
constructor.
destruct a; (apply H1 || apply H2).
destruct H1.
constructor; trivial.
constructor; auto.

destruct H1 as [g].
replace (IndexedIntersection S) with
  (IndexedIntersection (fun x:X0 => S (f x))).
apply IHFiniteT; auto.
apply Extensionality_Ensembles; split; red; intros.
destruct H3.
constructor.
intros.
pose proof (H3 (g a)).
congruence.
destruct H3.
constructor.
intro.
apply H3.
Qed.

Section filter_from_basis.

Variable X:Type.
Variable B:Family X.
Hypothesis B_nonempty: Inhabited B.
Hypothesis B_empty: ~ In B Empty_set.
Hypothesis B_basis_cond: forall S1 S2:Ensemble X,
  In B S1 -> In B S2 -> exists T:Ensemble X,
  In B T /\ Included T (Intersection S1 S2).

Definition Build_Filter_from_basis : Filter X.
refine (Build_Filter X [ S:Ensemble X | exists T:Ensemble X,
                       In B T /\ Included T S ] _ _ _ _).
intros.
destruct H.
destruct H0.
destruct H as [T1 []].
destruct H0 as [T2 []].
destruct (B_basis_cond T1 T2 H H0) as [T' []].
constructor.
exists T'; split; trivial.
red; intros.
apply H4 in H5.
destruct H5.
constructor; auto.

intros.
destruct H.
destruct H as [T []].
constructor.
exists T; split; auto with sets.

constructor.
destruct B_nonempty as [T].
exists T; split; trivial.
red; intros; constructor.
red; intro.
destruct H.
destruct H as [T []].
assert (T = Empty_set).
apply Extensionality_Ensembles; split; auto with sets.
destruct H1.
contradiction B_empty.
Defined.

Lemma filter_from_basis_basis: filter_basis Build_Filter_from_basis B.
Proof.
constructor.
simpl.
red; intros S ?.
constructor.
exists S; split; auto with sets.
intros.
simpl in H.
destruct H.
exact H.
Qed.

End filter_from_basis.

Arguments Build_Filter_from_basis {X}.

From ZornsLemma Require Export FiniteTypes.
From ZornsLemma Require Export IndexedFamilies.

Record filter_subbasis {X:Type} (F:Filter X) (B:Family X) : Prop := {
  filter_subbasis_elements: Included B (filter_family F);
  filter_subbasis_cond: forall S:Ensemble X,
    In (filter_family F) S -> exists J:Type, FiniteT J /\
          exists T:J->Ensemble X,
          (forall j:J, In B (T j)) /\
          Included (IndexedIntersection T) S
}.

Section filter_from_subbasis.

Variable X:Type.
Variable B:Family X.
Hypothesis B_subbasis_cond: forall (J:Type) (V:J->Ensemble X),
  FiniteT J -> (forall j:J, In B (V j)) ->
  Inhabited (IndexedIntersection V).

From ZornsLemma Require Import FiniteIntersections.

Definition Build_Filter_from_subbasis: Filter X.
refine (Build_Filter_from_basis (finite_intersections B) _ _ _).
exists Full_set.
constructor.
red; intro.
pose proof (finite_intersection_is_finite_indexed_intersection _ _ H).
destruct H0 as [J [? [V []]]].
assert (Inhabited (IndexedIntersection V)).
apply B_subbasis_cond; trivial.
rewrite <- H2 in H3.
destruct H3.
destruct H3.

intros.
exists (Intersection S1 S2); split; auto with sets.
constructor 3; trivial.
Defined.

Lemma filter_from_subbasis_subbasis:
  filter_subbasis Build_Filter_from_subbasis B.
Proof.
assert (filter_basis Build_Filter_from_subbasis (finite_intersections B)).
apply filter_from_basis_basis.
destruct H.
constructor.
assert (Included B (finite_intersections B)); auto with sets.
red; intros.
constructor; trivial.

intros.
destruct (filter_basis_cond0 S H) as [S' []].
pose proof (finite_intersection_is_finite_indexed_intersection
  _ _ H0).
destruct H2 as [J [? [V []]]].
exists J; split; trivial.
exists V; split; trivial.
rewrite <- H4; trivial.
Qed.

End filter_from_subbasis.

Arguments Build_Filter_from_subbasis {X}.

Definition ultrafilter {X:Type} (F:Filter X) : Prop :=
  forall S:Ensemble X, In (filter_family F) S \/
                       In (filter_family F) (Ensembles.Complement S).

From ZornsLemma Require Import ZornsLemma.

Lemma ultrafilter_extension: forall {X:Type} (F:Filter X),
  exists U:Filter X, Included (filter_family F) (filter_family U) /\
                     ultrafilter U.
Proof.
intros.
pose (PO := { F':Filter X | Included (filter_family F) (filter_family F') }).
pose (PO_ord := fun (F1' F2':PO) =>
  Included (filter_family (proj1_sig F1')) (filter_family (proj1_sig F2'))).
assert (exists U:PO, premaximal PO_ord U).
apply ZornsLemmaForPreorders.
constructor.
red; intro.
destruct x.
red; simpl.
auto with sets.
red; intros.
destruct x; destruct y; destruct z.
red in H; simpl in H.
red in H0; simpl in H0.
red; simpl.
auto with sets.

intros.
From ZornsLemma Require Import DecidableDec.
destruct (classic_dec (Inhabited S)) as [Hnonempty|Hempty].
unshelve refine (let H0:=_ in let H1:=_ in let H2:=_ in let H3:=_ in
  let ub:=Build_Filter X (IndexedUnion (fun F':{F':PO | In S F'} =>
    filter_family (proj1_sig (proj1_sig F')))) H0 H1 H2 H3 in _);
  [ | clearbody H0 | clearbody H0 H1 | clearbody H0 H1 H2 | clearbody H0 H1 H2 H3 ].
intros.
destruct H0 as [F1'].
destruct H1 as [F2'].
destruct F1' as [[F1']].
destruct F2' as [[F2']].
simpl in H0.
simpl in H1.
destruct (H (exist _ F1' i) (exist _ F2' i1)); trivial.
red in H2; simpl in H2.
apply H2 in H0.
exists (exist _ (exist _ F2' i1)  i2).
simpl.
apply filter_intersection; trivial.
red in H2; simpl in H2.
apply H2 in H1.
exists (exist _ (exist _ F1' i) i0).
simpl.
apply filter_intersection; trivial.

intros.
destruct H1 as [[[F1']]].
simpl in H1.
exists (exist _ (exist _ F1' i) i0).
simpl.
apply filter_upward_closed with x; trivial.
destruct Hnonempty.
exists (exist _ x H2).
simpl.
apply filter_full.

red; intro.
inversion_clear H3 as [F'].
contradict H4.
apply filter_empty.

assert (Included (filter_family F) (filter_family ub)).
simpl.
red; intros.
destruct Hnonempty.
exists (exist _ x0 H5).
simpl.
destruct x0 as [F'].
simpl.
auto.

exists (exist _ ub H4).
intros.
red; simpl.
red; intros.
exists (exist _ y H5).
simpl.
trivial.

assert (Included (filter_family F) (filter_family F)).
auto with sets.
exists (exist _ F H0).
intros.
contradiction Hempty.
exists y; trivial.

destruct H as [[U]].
exists U; split; trivial.
red; intros.
classical_right.
assert (forall S':Ensemble X, In (filter_family U) S' ->
  Inhabited (Intersection S' (Ensembles.Complement S))).
intros.
apply NNPP; red; intro.
contradiction H0.
apply filter_upward_closed with S'; trivial.
red; intros.
apply NNPP; red; intro.
contradiction H2.
exists x.
auto with sets.

unshelve refine (let H2:=_ in let H3:=_ in let H4:=_ in
  let Uext := Build_Filter_from_basis
       (Im (filter_family U) (fun S':Ensemble X =>
          Intersection S' (Ensembles.Complement S))) H2 H3 H4 in _).
exists (Ensembles.Complement S).
exists Full_set.
apply filter_full.
apply Extensionality_Ensembles; split; auto with sets.
red; intros.
constructor; trivial; constructor.
red; intro.
inversion_clear H3 as [S'].
destruct (H1 S' H4) as [x].
rewrite <- H5 in H3.
destruct H3.

intros.
destruct H4.
destruct H5.
exists (Intersection y y0).
split; auto with sets.
exists (Intersection x x0).
apply filter_intersection; trivial.
apply Extensionality_Ensembles; split; red; intros.
destruct H8.
rewrite H6 in H8; destruct H8.
rewrite H7 in H9; destruct H9.
constructor; trivial; constructor; trivial.
destruct H8.
destruct H8.
constructor.
rewrite H6; constructor; trivial.
rewrite H7; constructor; trivial.

assert (Included (filter_family U) (filter_family Uext)).
red; intros.
apply filter_upward_closed with (Intersection x (Ensembles.Complement S)).
assert (filter_basis Uext
  (Im (filter_family U) (fun S':Ensemble X =>
                        Intersection S' (Ensembles.Complement S)))).
apply filter_from_basis_basis.
destruct H6.
apply filter_basis_elements0.
exists x; trivial.
auto with sets.
assert (Included (filter_family F) (filter_family Uext)).
auto with sets.

assert (PO_ord (exist _ U i) (exist _ Uext H6)).
red.
exact H5.
apply H in H7.
apply H7.
change (In (filter_family Uext) (Ensembles.Complement S)).
assert (filter_basis Uext (Im (filter_family U)
  (fun S':Ensemble X => Intersection S' (Ensembles.Complement S)))).
apply filter_from_basis_basis.
destruct H8.
apply filter_basis_elements0.
exists Full_set.
apply filter_full.
apply Extensionality_Ensembles; split; auto with sets.
red; intros.
constructor; trivial; constructor.
Qed.

From ZornsLemma Require Export InverseImage.

Definition filter_direct_image {X Y:Type} (f:X->Y) (F:Filter X) : Filter Y.
refine (Build_Filter Y
  [ S:Ensemble Y | In (filter_family F) (inverse_image f S) ]
  _ _ _ _).
intros.
destruct H.
destruct H0.
constructor.
rewrite inverse_image_intersection.
apply filter_intersection; trivial.

intros.
destruct H.
constructor.
apply filter_upward_closed with (inverse_image f S1); auto with sets.

constructor.
rewrite inverse_image_full.
apply filter_full.

red; intro.
destruct H.
rewrite inverse_image_empty in H.
revert H; apply filter_empty.
Defined.

Section filter_sum.

Variable X:Type.
Variable F G:Filter X.
Hypothesis F_G_compat: forall S T:Ensemble X,
  In (filter_family F) S -> In (filter_family G) T ->
  Inhabited (Intersection S T).

Definition filter_sum : Filter X.
refine (Build_Filter_from_basis
  (Im [ p:(Ensemble X)*(Ensemble X) |
        let (S,T):=p in In (filter_family F) S /\
                       In (filter_family G) T ]
    (fun p:(Ensemble X)*(Ensemble X) => let (S,T):=p in
       Intersection S T))
  _ _ _).
exists Full_set.
exists ( (Full_set, Full_set) ).
constructor.
split; apply filter_full.
apply Extensionality_Ensembles; split; red; intros.
constructor; constructor.
constructor.

red; intro.
inversion_clear H.
destruct x as [S T].
destruct H0.
destruct H.
assert (Inhabited (Intersection S T)).
apply F_G_compat; trivial.
rewrite <- H1 in H2.
destruct H2.
destruct H2.
intros.
destruct H.
destruct x as [S1 T1].
destruct H0.
destruct H0.
destruct x as [S2 T2].
exists (Intersection y y0).
split; auto with sets.
destruct H0.
destruct H.
destruct H.
exists ( (Intersection S1 S2, Intersection T1 T2) ).
constructor; split; apply filter_intersection; trivial.
rewrite H1; rewrite H2.
apply Extensionality_Ensembles; split; red; intros.
destruct H5.
destruct H5.
destruct H6.
constructor; constructor; trivial.
destruct H5.
destruct H5; destruct H6.
constructor; constructor; trivial.
Defined.

End filter_sum.

Arguments filter_sum {X}.


Require Import ZArith.
 Require Import Field.
 From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat ssralg ssrint rat.

 Require Import rat_of_Z.
 Export rat_of_Z.

 Set Implicit Arguments.
 Unset Strict Implicit.
 Unset Printing Implicit Defensive.

 Import GRing.Theory.

 Local Open Scope ring_scope.

 (* In this file we craft automated decision procedures for equalities in type *)
 (* rat, modulo the structure of field. We do this is two steps:               *)
 (*   i) we define  custom ring/fields tactics using an opaque cast for        *)
 (*     numeral constants. This optimizes the normalisation of expressions     *)
 (*     featuring "large" numeral constants by optimizing the                  *)
 (*     reification/interpretation steps.                                      *)
 (*   ii) we wrap this tactic is a preprocessing code, which accomodates       *)
 (*     expressions of type convertible but non syntactically equal to rat.    *)
 (*    This is typical of the use of the ssralg generic structures.            *)

 (* Declaration of customized ring and field tactics for the rat datatype. *)

 Lemma rat_morph_Z :
   ring_morph
     zeroq oneq addq mulq subq oppq (@eq rat)
     Z0 (Zpos xH) Zplus Zmult Zminus Zopp Zeq_bool
     rat_of_Z.
 Proof.
 pose R := [unitRingType of rat].
 rewrite -[zeroq]/(@GRing.zero R) -[oneq]/(@GRing.one R).
 rewrite -[addq]/(@GRing.add R) -[mulq]/(@GRing.mul R).
 rewrite -[subq]/(fun x y => @GRing.add R x (@GRing.opp R y)).
 rewrite -[oppq]/(@GRing.opp R) /R{R}.
 split; rewrite rat_of_ZEdef => //; case=> [|a|a]; try case=> [|b|b] //=;
   rewrite ?addr0 ?add0r ?sub0r ?mulr0 ?mul0r ?rat_of_Z_neg ?opprK //;
   rewrite ?mulrNN 1?[_ * - _]mulrC ?mulNr -1?opprB ?opprK -1?Z.pos_sub_opp ?rat_of_Z_opp;
   try congr (- _);
   rewrite ?rat_of_Z_add // 1?addrC //;
   rewrite ?rat_of_Z_mul // 1?mulrC //;
   rewrite ?rat_of_Z_sub // ?opprB // 1?addrC //.
   by move/Zeq_bool_eq->.
 by move/Zeq_bool_eq=> [->].
 Qed.

 (* Make the reification process know about the rat_of_Z cast *)
 Ltac Zcst t :=
   match t with
   | rat_of_Z ?u => constr:u
   | oneq => constr:(Zpos xH)
   | zeroq => constr:Z0
   | _ => constr:InitialRing.NotConstant
   end.

 (* Actual registration of the ring/field structures *)
 Add Field rat_Zfield :
   rat_field_theory
     (morphism rat_morph_Z,
      constants [Zcst]).

 (* Preprocessing of an equality between two terms of type rat but which      *)
 (* involves arbitrary rat instances of the generic ssralg structures.        *)
 (* Since reification is syntactic we first convert both handsides to a 'flat'*)
 (* normal form version, using only the datas of the rat field (rat, oneq,    *)
 (* addq,...). We also unroll power to multiplications as we did not manage   *)
 (* to deal with this properly with the customizations of the ring/field      *)
 (* tactic. *)

 Fixpoint powq (r : rat) (n : nat) :=
   match n with
   | 0 => oneq
   | 1 => r
   | m.+1 => mulq r (powq r m)
   end.

 Ltac transf_unary transf x concr_op :=
   let t := transf x in constr:(concr_op t).

 Ltac transf_binary transf x1 x2 concr_op :=
   let t1 := transf x1 in let t2 := transf x2 in constr:(concr_op t1 t2).

 Definition NothingHappened := false.

 (* Pure generic constructs. *)
 Ltac generic_transf transf t :=
   match t with
   | (@GRing.mul ?any_struct) ?x1 ?x2 =>
       let res := transf_binary transf x1 x2 mulq in constr:res
   | (@GRing.add ?any_struct) ?x1 ?x2 =>
       let res := transf_binary transf x1 x2 addq in constr:res
   | (@GRing.opp ?any_struct) ?x =>
       let res := transf_unary transf x oppq in constr:res
   | (@GRing.inv ?any_struct) ?x =>
       let res := transf_unary transf x invq in constr:res
   | GRing.one ?any_struct => constr:oneq (* 1 in any_struct as a ring. *)
   | GRing.zero ?any_struct => constr:zeroq (* 0 in any_struct as a ring. *)
   | @exprz ?any_thing ?x1 ?x2 =>
        match x2 with
        | Posz ?n => let t1 := transf x1 in constr:(powq t1 n)
        end
   | _ => constr:NothingHappened
   end.

 (* Given t supposed to be in int, output the rat_transf of t%:~R. *)
 (* Warning this performs transformations that are not provable by *)
 (* convertibity so we do not call this code and only leave it for *)
 (* the record.*)
 Ltac int_to_rat_transf r1 r2 t :=
   let res := generic_transf ltac:(int_to_rat_transf r1 r2) t in
     match res with
     | NothingHappened => constr:(@intmul r1 (GRing.one r2) t)
     | _ => constr:res
     end.

 (* Given an expression t in the generic rat ring, generate its translation
    in rat using concrete operations in rat. *)
 Ltac rat_transf t :=
   let res := generic_transf rat_transf t in
     match res with
     | NothingHappened =>
       match t with
       (* Catch generic expression of type int embedded in rat. *)
       | @intmul ?rat_thing1 (GRing.one ?rat_thing2) ?any_int =>
         (* Expand 5%:~R into 1%Q + (0%Q + 1%Q + ... + 1%Q) and the like.*)
         match any_int with
         | Posz 0 => constr:zeroq
         | Posz 1 => constr:oneq
         | GRing.one ?any_struct => constr:oneq
         | GRing.zero ?any_struct => constr:zeroq
         | Posz (S ?n) =>
             let y := constr:((Posz n)%:~R : rat) in
               let t := rat_transf y in constr:(addq t oneq)
         (* Simplify (n^0)%:~R into oneq and rec call rat_transf on n%:~R on*)
         (* n^1%:~R *)
         | @exprz ?any_thing ?x1 ?x2 =>
             match x2 with
               | Posz 0 => constr:oneq
               | Posz 1 =>
                 let y := constr:(@intmul rat_thing1 (GRing.one rat_thing2) x1) in
                 let t := rat_transf y in constr:t
               | _ => constr:t
             end
         | _ => constr:t
             (* This alternative code would allow transformation under a _%:~R*)
              (*  that are valid but not provable by conversion: *)
             (* let new_int := *)
                   (* int_to_rat_transf rat_thing1 rat_thing2 any_int in *)
             (*   constr:new_int *)
         end
       (* Catch inverses in the form x^-1. *)
       | @exprz ?rat_thing1 ?x
             (@GRing.opp ?rat_thing2 (GRing.one ?rat_thing3)) =>
           let t := rat_transf x in constr:(invq t)
       | _ => constr:t
       end
     | _ => constr:res
     end.

 (* Reduction of elaborated instances of rat to a mere rat *)
 Ltac to_rat_type :=
   rewrite -?[GRing.Ring.sort _]/rat;
   rewrite -?[GRing.Zmodule.sort _]/rat;
   rewrite -?[Equality.sort (GRing.Zmodule.eqType _)]/rat;
   rewrite -?[Equality.sort (GRing.Ring.eqType _)]/rat.

 (* The prefield tactic operates on a goal which is an equality between *)
 (* two terms in rat. It reduces the type of the equality to 'rat, *)
 (* applies the previous rat_transf transformation to *)
 (* both handsides and proves these modifications by reflexivity. *)
 (* After a successful run of the tactic, we get a new version of the initial *)
 (* goal ready for normalization, almost. *)

 (* At last step: the 'symmetry' before the second reflexivity *)
 (* optimizes the conversion due to the heuristic applied by reflexivity *)
 (* which reduces the left hand side first. *)

 Ltac prefield :=
   match goal with
   | |- ?x1 = ?x2 =>
     let t1 := rat_transf x1 in let t2 := rat_transf x2 in
     let lhs := fresh "lhs" in
     let rhs := fresh "rhs" in
       (* now we should reduce also by hand the type hidden in (@eq) *)
       to_rat_type;
       pose lhs := (t1 : rat); unfold powq in lhs;
       pose rhs := (t2 : rat); unfold powq in rhs;
       transitivity lhs; unfold lhs; clear lhs;
       [ reflexivity
       | transitivity rhs; unfold rhs; clear rhs;
         [| symmetry; reflexivity ] ]
 end.

 (* In our case, the uniterpreted terms in a goal to which we apply ring/field *)
 (* are integers variables embedded in rat. We make sure that all the *)
 (* convertible occurrences of a same variable share the same symbol to ensure *)
 (* that the reification behaves well and avoid silly incompleteness.*)
 (* Note that we carefully re-cast the pattern to the mere rat to avoid Coq *)
 (* expanding an elaborated instance of ssralg structure...*)

 Ltac catch_embedded := let emb := fresh "emb" in set emb := ((_)%:~R : rat).

 (* Due to a current incompleteness of the ring/field tactic, we need to make *)
 (* sure that all occurrences of zeroq (resp. oneq) are in fact under the form *)
 (* of rat_of_Z 0 (resp. rat_of_Z 1). This would not be needed in the case of *)
 (* convertible values, but here these are only provable equalities because *)
 (* we locked rat_of_Z. Fixed in coq trunk. *)

 Ltac patch_incomplete_field := rewrite ?rat_of_Z_0  ?rat_of_Z_1.

 (* We finally gather all the ingredients in a single tactic. *)
 (* The last rewrite operation would better be part of the intlia tactic.*)
 Ltac rat_field :=
 prefield;
 patch_incomplete_field;
 repeat catch_embedded;
 field;
 rewrite ?rat_of_ZEdef /=.

 Ltac rat_field_simplify :=
 prefield;
 patch_incomplete_field;
 repeat catch_embedded;
 field_simplify;
 rewrite ?rat_of_ZEdef /=.


From Coq.Lists          Require Import List.
From Coq.Numbers.NatInt Require        NZLog.
From Coq.Strings        Require        String.
From CryptolToCoq       Require Import SAWCoreScaffolding.

Import ListNotations.

Definition Vec (n : nat) (a : Type) : Type := list a.

Fixpoint gen (n : nat) (a : Type) (f : nat -> a) {struct n} : Vec n a.
  refine (
      match n with
      | O   => []
      | S n' =>  f O :: gen n' _ (fun n => f (S n))
      end
    ).
Defined.

Fixpoint atWithDefault (n : nat) (a : Type) (default : a) (v : Vec n a) (index : nat) : a.
  refine (
      match n with
      | O => default
      | S n' =>
        match v with
        | [] => default
        | h :: t =>
          match index with
          | O => h
          | S index' => atWithDefault n' _ default t index'
          end
        end
      end
  ).
Defined.

Definition map (a b : Type) (f : a -> b) (n : Nat) (xs : Vec n a) :=
  map f xs.

Fixpoint foldr (a b : Type) (n : Nat) (f : a -> b -> b) (base : b) (v : Vec n a) : b :=
  match n with
  | O => base
  | S n' =>
    match v with
    | [] => base
    | hd :: tl => f hd (foldr _ _ n' f base tl)
    end
  end.

(* Definition atWithDefault := VectorExtra.atWithDefault. *)
Definition EmptyVec := @nil.
(* Definition gen := VectorExtra.gen. *)

Definition coerceVec (a : sort 0) (m n : Nat) (eq : Eq Nat m n) (v : Vec m a) : Vec n a :=
  match
    identity_sym eq in identity _ n'
    return Vec n' a -> Vec n a
  with
  | identity_refl _ => fun x => x
  end v.

Theorem gen_add m n T : forall f, gen (m + n) T f = gen m T f ++ gen n T (fun x => f (m + x)).
Proof.
  induction m; intros.
  {
    simpl.
    reflexivity.
  }
  {
    simpl.
    f_equal.
    now rewrite IHm.
  }
Qed.

Fixpoint zipFunctional (a b : sort 0) (m n : Nat) (xs : Vec m a) (ys : Vec n b)
  : Vec (Nat.min m n) (a * b) :=
  match (m, n) with
  | (S m', S n') =>
    match (xs, ys) with
    | (x :: xs, y :: ys) => (x, y) :: zipFunctional _ _ m' n' xs ys
    | _ => []
    end
  | _ => []
  end.

Definition zipWithFunctional (a b c : Type) (f : a -> b -> c) (n : Nat) (xs : Vec n a) (ys : Vec n b) :=
  map _ _ (fun p => f (fst p) (snd p)) n (zipFunctional _ _ _ _ xs ys).