Add LoadPath ".".
Add LoadPath "/Users/sweirich/github/deepspec/metalib/" as Metalib.
Require Import Metalib.Metatheory.

Require Import systemt_inf.
Require Import Ch9.

(* This *part* of a development for chapter 46. I didn't have time to fill in
   all of the details (there are a LOT of admits below), but it should help
   make the chapter clear and precise. *)

(* ------------ Observable equivalence -------------------- *)

(* These are contexts --- basically we can consider them as terms
   with a "hole" in them. *)
Inductive ctx : Set :=
| ctx_top  : ctx    (* written  \circ in PFPL *)
| ctx_s    : ctx -> ctx
| ctx_rec1 : ctx -> exp -> atom -> atom -> typ -> exp -> ctx
| ctx_rec2 : exp -> ctx -> atom -> atom -> typ -> exp -> ctx
| ctx_rec3 : exp -> exp -> atom -> atom -> typ -> ctx -> ctx
| ctx_abs  : typ -> atom -> ctx -> ctx
| ctx_app1 : ctx -> exp -> ctx
| ctx_app2 : exp -> ctx -> ctx.

Notation close := close_exp_wrt_exp.

(* Written C { e } in PFPL *)
Fixpoint replace (C : ctx) (e : exp) :=
  match C with
  | ctx_top => e
  | ctx_s C => s (replace C e)
  | ctx_rec1 C e1 x y t e2 => rec (replace C e) e1 (close x (abs t (close y e2)))
  | ctx_rec2 e0 C x y t e2 => rec e0 (replace C e) (close x (abs t (close y e2)))
  | ctx_rec3 e0 e1 x y t C => rec e0 e1 (close x (abs t (close y (replace C e))))
  | ctx_abs t x C => abs t (close x (replace C e))
  | ctx_app1 C e2 => app (replace C e) e2
  | ctx_app2 e1 C => app e1 (replace C e)
  end.

(* Written   C : G |> t ~> G' |> t' *)
Inductive typing_ctx : ctx -> env -> typ -> env -> typ -> Prop :=
| typing_ctx_top : forall G t, typing_ctx ctx_top G t G t
| typing_ctx_s   : forall G t G' C,
    typing_ctx C G t G' typ_nat ->
    typing_ctx (ctx_s C) G t G' typ_nat
| typing_ctx_rec1 : forall C G t G' t' x y e0 e1,
    typing_ctx C G t G' typ_nat ->
    typing G' e0 t' ->
    value e1 ->
    typing ((y ~ t') ++ (x ~ typ_nat) ++ G') e1  t' ->
    typing_ctx (ctx_rec1 C e0 x y t' e1) G t G' t'
| typing_ctx_rec2 : forall C G t G' t' x y e0 e1,
    typing G' e0 typ_nat ->
    typing_ctx C G t G' t' ->
    value e1 ->
    typing ((y ~ t') ++ (x ~ typ_nat) ++ G') e1 t' ->
    typing_ctx (ctx_rec2 e0 C x y t' e1) G t G' t'
| typing_ctx_rec3 : forall C G t G' t' x y e0 e1,
    typing G' e0 typ_nat ->
    typing G' e1 t' ->
    typing_ctx C G t ((y ~ t') ++ (x ~ typ_nat) ++ G') t' ->
    typing_ctx (ctx_rec3 e0 e1 x y t' C) G t G' t'
| typing_ctx_abs : forall C G G' t t1 t2 x,
    typing_ctx C G t ((x ~ t1) ++ G') t2 ->
    typing_ctx (ctx_abs t1 x C) G t G' (typ_arr t1 t2)
| typing_ctx_app1 : forall C G G' t t2 t' e2,
    typing_ctx C G t G' (typ_arr t2 t') ->
    typing G' e2 t2 ->
    typing_ctx (ctx_app1 C e2) G t G' t'
| typing_ctx_app : forall C G G' t t2 t' e1,
    typing G' e1 (typ_arr t2 t') ->
    typing_ctx C G t G' t2  ->
    typing_ctx (ctx_app2 e1 C) G t G' t'.

Hint Constructors typing_ctx.

(* The replacement operation preserves types *)
Lemma typing_replace : forall C G t G' t' e,
   typing_ctx C G t G' t' -> typing G e t -> typing G' (replace C e) t'.
Proof.
  intros C G t G' t' e H H1.
  induction H; simpl; auto.
  - eapply (typing_rec_exists x);
      autorewrite with lngen; auto.
    apply val_abs. apply (lc_abs_exists y).  autorewrite with lngen. eapply typing_lc; eauto.
    eapply (typing_abs_exists y);
      autorewrite with lngen; eauto.
  - eapply (typing_rec_exists x);
      autorewrite with lngen; auto.
    apply val_abs. apply (lc_abs_exists y).  autorewrite with lngen. eapply typing_lc; eauto.
    eapply (typing_abs_exists y);
      autorewrite with lngen; eauto.
  - eapply (typing_rec_exists x G' _ _ _ t');
      autorewrite with lngen; auto.
    apply val_abs. apply (lc_abs_exists y).  autorewrite with lngen. eapply typing_lc; eauto.
    eapply (typing_abs_exists y);
      autorewrite with lngen; eauto.
  - eapply (typing_abs_exists x);
      autorewrite with lngen; eauto.
  - eapply typing_app; eauto.
  - eapply typing_app; eauto.
Qed.

(* Lemma 46.1 *)
Lemma extension : forall G G' t t' C, typing_ctx C G t G' t' ->
                                 exists G'', G = G'' ++ G'.
Proof.
  intros. induction H; auto.
  - exists nil. simpl. auto.
  - destruct IHtyping_ctx as [G'' EQ].
    exists (G'' ++ (y ~ t') ++ (x ~ typ_nat)).
    simpl_env. auto.
  - destruct IHtyping_ctx as [G'' EQ].
    exists (G'' ++ (x ~ t1)).
    simpl_env. auto.
Qed.

(* Composition of two contexts, written  C1 { C2 { o }} *)

Fixpoint compose (C1 : ctx) (C2 : ctx) : ctx :=
  match C1 with
  | ctx_top => C2
  | ctx_s C => ctx_s (compose C C2)
  | ctx_rec1 C e1 x y t e2 => ctx_rec1 (compose C C2) e1 x y t e2
  | ctx_rec2 e0 C x y t e2 => ctx_rec2 e0 (compose C C2) x y t e2
  | ctx_rec3 e0 e1 x y t C => ctx_rec3 e0 e1 x y t (compose C C2)
  | ctx_abs t x C => ctx_abs t x (compose C C2)
  | ctx_app1 C e2 => ctx_app1 (compose C C2) e2
  | ctx_app2 e1 C => ctx_app2 e1 (compose C C2)
  end.

Lemma replace_compose : forall C1 C2 e, replace C1 (replace C2 e) = replace (compose C1 C2) e.
Proof.
  intros C1. induction C1; intros; simpl; try rewrite IHC1; auto.
Qed.

(* Lemma 46.2 *)
Lemma typing_compose : forall C1 C2 G t G' t' G'' t'',
    typing_ctx C1 G t G' t' ->
    typing_ctx C2 G' t' G'' t'' ->
    typing_ctx (compose C2 C1) G t G'' t''.
Proof.
  intros.
  induction H0; intros; simpl; eauto.
Qed.

(* Definition 46.4 *)

(* Precondition, e1 and e2 are complete programs, i.e. are closed and have type nat. *)
Definition kleene_equivalence e1 e2 :=
  exists v, value v /\ multistep e1 v /\ multistep e2 v.

(* NOTE: Bob claims that this relation is clearly reflexive. But we can't
   prove that yet. *)

Lemma kleene_sym  : forall e1 e2, kleene_equivalence e1 e2 -> kleene_equivalence e2 e1.
Proof.
  unfold kleene_equivalence.
  intros.  destruct H as [v [V [M1 M2]]].
  exists v. auto.
Qed.

Lemma kleene_trans : forall e1 e2 e3, kleene_equivalence e1 e2 -> kleene_equivalence e2 e3
                                 -> kleene_equivalence e1 e3.
Proof.
  unfold kleene_equivalence.
  intros.  destruct H as [v [V [M1 M2]]]. destruct H0 as [v' [V' [M1' M2']]].
  exists v. split. auto. admit. (* derterminancy of evaluation *)
Admitted.

(* Definition 46.5 *)

Definition observational_equivalence G e e' t :=
  typing G e  t /\ typing G e' t /\
  forall C,
    typing_ctx C G t nil typ_nat ->
    kleene_equivalence (replace C e) (replace C e').

(* We want to prove 46.6 next, but first we need a general definition of
   a "consistent congruence relation" *)

Record consistent_equivalence (R : env -> exp -> exp -> typ -> Prop) := mkO
{
  (* Only holds for well-typed terms (with the same type) *)
  typed : forall G e1 e2 t , R G e1 e2 t -> typing G e1 t /\ typing G e2 t;

  (* Is an equivalence relation *)
  refl : forall G e t, typing G e t -> R G e e t;
  sym  : forall G e1 e2 t, R G e1 e2 t -> R G e2 e1 t;
  trans : forall G e1 e2 e3 t, R G e1 e2 t -> R G e2 e3 t -> R G e1 e3 t;

  (* Is consistent *)
  consistent :  forall e1 e2,
      R nil e1 e2 typ_nat -> kleene_equivalence e1 e2;

  (* Is a congruence *)
  congruence : forall G e e' t,
      R G e e' t -> forall C G' t', typing_ctx C G t G' t'
                              -> R G' (replace C e) (replace C e') t'
}.

(* Lemma 46.6 (first part). *)
Lemma observational_notyet : consistent_equivalence observational_equivalence.
Admitted.
(* We can't actually prove this yet because it relies on the
reflexivity of kleene_equivalence. *)

(* However, we can prove everything else. *)
Lemma  observational_typed :
  forall G e1 e2 t , observational_equivalence G e1 e2 t -> typing G e1 t /\ typing G e2 t.
Proof.
  intros.  destruct H as [T1 [T2 CTX]]. auto.
Qed.

  (* Is an equivalence relation *)
Lemma observational_sym  : forall G e1 e2 t, observational_equivalence G e1 e2 t -> observational_equivalence G e2 e1 t.
Proof.
  unfold observational_equivalence.
  intros. destruct H as [T1 [T2 CTX]].
  repeat split; auto.
  intros C CC.
  apply kleene_sym. auto.
Qed.

Lemma observational_trans :
  forall G e1 e2 e3 t, observational_equivalence G e1 e2 t
                  -> observational_equivalence G e2 e3 t
                  -> observational_equivalence G e1 e3 t.
Proof.
  unfold observational_equivalence.
  intros.
  destruct H as [T1 [T2 CTX]].
  destruct H0 as [T1' [T2' CTX']].
  repeat split; auto.
  intros C CC.
  apply kleene_trans with (e2 := replace C e2). auto. auto.
Qed.

 (* Is consistent *)
Lemma  observational_consistent :  forall e1 e2,
    observational_equivalence nil e1 e2 typ_nat -> kleene_equivalence e1 e2.
Proof.
  unfold observational_equivalence.
  intros.
  destruct H as [T1 [T2 CTX]].
  apply CTX with (C := ctx_top).
  eapply typing_ctx_top.
Qed.

  (* Is a congruence *)
Lemma observational_congruence : forall G e e' t,
    observational_equivalence G e e' t -> forall C G' t',
      typing_ctx C G t G' t'
      -> observational_equivalence G' (replace C e) (replace C e') t'.
Proof.
  intros.
  unfold observational_equivalence.
  destruct (observational_typed _ _ _ _ H) as [T1 T2].
  repeat split. eapply typing_replace; eauto.
  eapply typing_replace; eauto.
  intros C' CT'.
  rewrite replace_compose.
  rewrite replace_compose.
  destruct H as [Te [Te' CTX]].
  eapply CTX.
  eapply typing_compose; eauto.
Qed.

(* ------------ *)

(* Lemma 46.6 *)
(* Observational equivalence is the *largest* consistent_equivalence *)

Lemma coarsest :
  forall R G e1 e2 t,
    consistent_equivalence R -> R G e1 e2 t -> observational_equivalence G e1 e2 t.
Proof.
  intros R G e1 e2 t OPEN H.
  destruct (typed R OPEN _ _ _ _ H).
  unfold observational_equivalence.
  split. auto.
  split. auto.
  intros C CT.
  pose (CONG := congruence R OPEN _ _ _ _ H C nil typ_nat CT).
  clearbody CONG.
  pose (CONS := consistent R OPEN _ _ CONG).
  auto.
Qed.

(*  ----------------- closing substitutions --------------------- *)

Definition closing_subst := list (atom * exp).

Inductive typing_cs : env -> closing_subst -> Prop :=
| typing_cs_nil : typing_cs nil nil
| typing_cs_cons : forall G g x t e,
    typing nil e t ->
    typing_cs G g ->
    x `notin` dom G \u dom g ->
    typing_cs ((x ~ t) ++ G) ((x ~ e) ++ g).

Hint Constructors typing_cs.

Lemma typing_cs_dom : forall G g, typing_cs G g -> dom G = dom g.
Proof.
  induction 1; simpl; auto.
  rewrite IHtyping_cs. auto.
Qed.
Lemma typing_cs_uniq1 : forall G g, typing_cs G g -> uniq G.
Proof.
  induction 1; simpl; auto.
Qed.
Lemma typing_cs_uniq2 : forall G g, typing_cs G g -> uniq g.
Proof.
  induction 1; simpl; auto.
Qed.

Fixpoint apply_cs (g : closing_subst) (e : exp) : exp :=
  match e with
  | var_f y => match binds_lookup exp y g with
              | inl (exist _ e0 _) => e0
              | inr _ => e
                end
  | s e1 => s (apply_cs g e1)
  | app e1 e2 => app (apply_cs g e1) (apply_cs g e2)
  | abs t e1 => abs t (apply_cs g e1)
  | rec e0 e1 e2 => rec (apply_cs g e0) (apply_cs g e1) (apply_cs g e2)
  | _ => e
  end.

Inductive eq_cs (R : env -> exp -> exp -> typ -> Prop) : env -> closing_subst -> closing_subst -> Prop :=
| eq_cs_nil  : eq_cs R nil nil nil
| eq_cs_cons : forall G g1 g2 x t e1 e2,
    eq_cs R G g1 g2 ->
    R nil e1 e2 t ->
    x `notin` dom g1 \u dom g2 \u dom G ->
    eq_cs R ((x ~ t) ++ G) ((x ~ e1)++ g1) ((x ~ e2) ++ g2).

Hint Constructors eq_cs.

Lemma eq_cs_typing : forall G g1 g2,
    eq_cs observational_equivalence G g1 g2 -> typing_cs G g1 /\ typing_cs G g2.
Proof.
  intro G. induction G; intros. inversion H. auto.
  inversion H. subst.
  destruct (observational_typed  _ _ _ _ H3).
  destruct (IHG _ _ H2).
  split. econstructor; eauto.
  econstructor; eauto.
Qed.

(* -----   Lemma 46.7 -------  *)

Lemma apply_nil : forall e, apply_cs nil e = e.
Proof.
  induction e; simpl; try rewrite IHe; auto.
  rewrite IHe1. rewrite IHe2. rewrite IHe3. auto.
  rewrite IHe1. rewrite IHe2. auto.
Qed.

Lemma apply_fresh : forall G e t, typing G e t -> forall G1 G2 g, G = (G1 ++ G2) -> typing_cs G2 g -> apply_cs g e = e.
Proof.
  induction 1; intros; subst; auto.
  - Opaque binds_lookup.
    simpl.

(* If e1 is already closed.  *)
Lemma apply_cons : forall x e1 g e,
    uniq ((x ~ e1) ++ g) ->
    apply_cs ((x ~ e1) ++ g) e = subst_exp e1 x (apply_cs g e).
Proof.
Admitted.
  intros.
  inversion H. subst.
  induction e; try solve [simpl; auto].
  - Opaque binds_lookup.
    simpl.
    destruct (eq_var x0 x).
    + subst.
      destruct (binds_lookup exp x ((x, e1) :: g)).
      destruct s.
      destruct (binds_cons_1 _ x x _ _ g b) as [[E F]| G]. auto.
      apply binds_dom_contradiction in G. contradiction. auto.
      assert False. unfold not in n. eapply n.
      apply binds_cons_2. auto. eauto. contradiction.
    + destruct (binds_lookup exp x0 ((x, apply_cs g e1):: g)). destruct s.
      destruct (binds_cons_1 _ x0 x _ _ g b) as [[E F]| G]. contradiction.
      simpl.
      destruct (binds_lookup exp x0 g). destruct s.
      eapply binds_unique; eauto.
      apply n0 in G. contradiction.
      simpl.
      destruct (binds_lookup exp x0 g). destruct s.
      assert False. unfold not in n0. eapply n0. eauto. contradiction.
      auto.
  - destruct (KeySetFacts.eq_dec x0 x).
    + subst.
      destruct (binds_lookup exp x g). destruct s.
      apply binds_In in b. contradiction.
      simpl. admit.
    + destruct (binds_lookup exp x0 g). destruct s.
      admit.
      simpl. destruct (x0 == x). contradiction. admit.
  - simpl in IHe. rewrite IHe. auto.
  - simpl in *. rewrite IHe1. rewrite IHe2. rewrite IHe3. auto.
Admitted. *)

(* If e1 is not closed *)
Lemma apply_cons2 : forall x e1 g e,
    uniq ((x ~ apply_cs g e1) ++ g) ->
    apply_cs ((x ~ apply_cs g e1) ++ g) e = apply_cs g (subst_exp e1 x e).
Proof.
  intros.
  inversion H. subst.
  induction e; try solve [simpl; auto].
  - Opaque binds_lookup.
    simpl.
    destruct (eq_var x0 x).
    + subst.
      destruct (binds_lookup exp x ((x, apply_cs g e1) :: g)).
      destruct s.
      destruct (binds_cons_1 _ x x _ _ g b) as [[E F]| G]. auto.

      apply binds_dom_contradiction in G. contradiction. auto.
      assert False. unfold not in n. eapply n.
      apply binds_cons_2. auto. eauto. contradiction.
    + destruct (binds_lookup exp x0 ((x, apply_cs g e1):: g)). destruct s.
      destruct (binds_cons_1 _ x0 x _ _ g b) as [[E F]| G]. contradiction.
      simpl.
      destruct (binds_lookup exp x0 g). destruct s.
      eapply binds_unique; eauto.
      apply n0 in G. contradiction.
      simpl.
      destruct (binds_lookup exp x0 g). destruct s.
      assert False. unfold not in n0. eapply n0. eauto. contradiction.
      auto.
  - simpl. simpl in IHe. rewrite IHe. auto.
  - simpl. simpl in *. rewrite IHe1. rewrite IHe2. rewrite IHe3. auto.
  - simpl. simpl in IHe. rewrite IHe. auto.
  - simpl in *. rewrite IHe1. rewrite IHe2.  auto.
Qed.

Lemma apply_cs_typing : forall G g, typing_cs G g -> forall e t, typing G e t -> typing nil (apply_cs g e) t.
Proof.
  intros G g H. induction H.
  intros. rewrite apply_nil. auto.
  intros.
  pose (K := typing_uniq _ _ _ H2). inversion K. subst. clear K.
  rewrite apply_cons.
  apply IHtyping_cs.
  eapply typing_subst_simple. eauto.
  eapply typing_weakening with (F := G)(E:=nil) in H.
  rewrite app_nil_r in H. auto.
  rewrite app_nil_r. auto. auto.
Qed.

(* Closing substitutions close terms. *)
Lemma closing_typed : forall G g, typing_cs G g ->
    forall e e' t, observational_equivalence G e e' t ->
    observational_equivalence nil (apply_cs g e) (apply_cs g e') t.
Proof.
  intros.  unfold observational_equivalence in *.
  destruct H0 as [T1 [T2 CT]].
  split. eapply apply_cs_typing. eauto. eauto.
  split. eapply apply_cs_typing. eauto. eauto.
  intros C CTX.
Admitted.

Lemma closed_context : forall C g t,
    typing_ctx C nil t nil typ_nat -> forall G, typing_cs G g ->
    forall e, replace C (apply_cs g e) = apply_cs g (replace C e).
Proof.
  intros C. induction C; intros;  simpl; auto.
  - inversion H.
    erewrite IHC; eauto.
  - inversion H.
    erewrite IHC; eauto.
    admit.
Admitted.

Lemma closing_eq : forall G e e' t g g',
    observational_equivalence G e e' t -> eq_cs observational_equivalence G g g' ->
    observational_equivalence nil (apply_cs g e) (apply_cs g' e') t.
Proof.
  intros.
  unfold observational_equivalence.
  destruct (observational_typed _ _ _ _ H) as [h0 h1].
  destruct (eq_cs_typing _ _ _ H0) as [Tg Tg'].
  split. apply apply_cs_typing with (G := G); eauto.
  split. apply apply_cs_typing with (G := G); eauto.
  intros C CT.
  rewrite closed_context with (t := t)(G := G); auto.
  rewrite closed_context with (t := t)(G := G); auto.
Admitted.

(* --------------------- 46.2 Logical equivalence -------------------------- *)

Fixpoint closed_logical_equivalence (e e' : exp) (t : typ) {struct t} : Prop :=
  match t with
  | typ_nat => typing nil e typ_nat /\ typing nil e' typ_nat /\ kleene_equivalence e e'
  | typ_arr t1 t2 =>
    typing nil e (typ_arr t1 t2) /\ typing nil e' (typ_arr t1 t2) /\
    forall e1 e1', closed_logical_equivalence e1 e1' t1 ->
              closed_logical_equivalence (app e e1) (app e' e1') t2
  end.

(* ------------------ proof by nat-induction --------------------- *)

Fixpoint from_nat (n : nat) : exp :=
  match n with
  | O => z
  | S n => s (from_nat n)
  end.

Inductive as_nat : nat -> exp -> Prop :=
| as_nat_z : as_nat O z
| as_nat_s : forall n e, as_nat n e -> as_nat (S n) (s e).
Hint Constructors as_nat.

Lemma to_nat : forall e, value e -> typing nil e typ_nat -> exists n, as_nat n e.
Proof.
  intros e V. induction V; intros.
  inversion H. exists O. auto.
  inversion H.
  destruct (IHV H2) as [m A].
  exists (S m). auto.
  inversion H0.
Qed.

Lemma as_from_nat : forall n, as_nat n (from_nat n).
Proof. induction n.
       simpl. auto.
       simpl in *. auto.
Qed.

Lemma nat_induction : forall e e', closed_logical_equivalence e e' typ_nat
                              -> forall (R : exp -> exp -> Prop), R z z -> (forall v, value v -> R v v -> R (s v) (s v)) -> R e e'.
Proof.
  intros.
  unfold closed_logical_equivalence in H.
  unfold kleene_equivalence in H.
  destruct H as [T1 [T2 [v [VV [Se Se']]]]].
  destruct (to_nat v VV). admit.
  generalize dependent e. generalize dependent e'. generalize dependent v. induction x.
  - intros. inversion H. subst.  (* Need to know that R is closed under reverse_evaluation *)
    admit.
  - intros. inversion H. subst.
    assert (R (s e0) (s e0) -> R e e'). admit.
    apply H2. apply H1. inversion VV. auto.
    inversion VV.
    apply (IHx e0); eauto. admit. admit. admit. admit.
Admitted.

(* ------------------ sym & trans --------------------- *)

Lemma closed_logical_typing : forall t e e',
    closed_logical_equivalence e e' t -> typing nil e t /\ typing nil e' t.
Proof.
  induction t; intros; simpl in *.
  destruct H as [H1 [H2 _]]. auto.
  destruct H as [H1 [H2 G3]].
  auto.
Qed.

(* Lemma 46.9 *)
Lemma closed_logical_sym : forall e e' t,
    closed_logical_equivalence e e' t -> closed_logical_equivalence e' e t.
Admitted.

Lemma closed_logical_trans : forall e e' e'' t,
    closed_logical_equivalence e e' t ->
    closed_logical_equivalence e' e'' t ->
    closed_logical_equivalence e e'' t.
Admitted.

(* -------------- extension to open terms --------------------- *)

Definition logical_equivalence G e e' t :=
  typing G e t /\
  typing G e' t /\
  forall g g', eq_cs (fun G => closed_logical_equivalence) G g g' ->
          closed_logical_equivalence (apply_cs g e) (apply_cs g' e') t.

Lemma logical_sym : forall G e e' t,
    logical_equivalence G e e' t -> logical_equivalence G e' e t.
Admitted.

Lemma logical_trans : forall G e e' e'' t,
    logical_equivalence G e e' t ->
    logical_equivalence G e' e'' t ->
    logical_equivalence G e e'' t.
Admitted.

(* -------------------------- 46.3 ---------------------------- *)

Lemma converse_evaluation_logical : forall e e' t,
    closed_logical_equivalence e e' t -> forall d, eval e e -> closed_logical_equivalence d e' t.
Proof.
  intros e e' t. induction t.
  - intros.
    unfold closed_logical_equivalence in *. unfold kleene_equivalence in *.
    admit.
  - intros.
    simpl in *.
    admit.
Admitted.

Lemma consistency_logical : forall e e', closed_logical_equivalence e e' typ_nat -> kleene_equivalence e e'.
Proof.
  unfold closed_logical_equivalence.
  intros. destruct H as [h0 [h1 h2]].
  auto.
Qed.

Lemma logical_refl : forall G e t, typing G e t -> logical_equivalence G e e t.
Proof.
  intros G e t H.
  induction H; unfold logical_equivalence;
    split; eauto; split; eauto; intros g g' EQ.
  - admit.
  - simpl. split. auto. split. auto.
    unfold kleene_equivalence. exists z. split. auto. split. admit. admit.
  - admit.
Admitted.

Lemma termination : forall e, typing nil e typ_nat -> exists v, multistep e v /\ value v.
Proof.
  intros e H.
  apply logical_refl in H.
  unfold logical_equivalence in H.
  destruct H as [_ [_ H0]].
  destruct (H0 nil nil) as [k0 [k1 k2]].
  apply eq_cs_nil.
  unfold kleene_equivalence in k2.
  destruct k2 as [v [VV [Ms1 Ms2]]].
  exists v. simpl in *. split. rewrite apply_nil in Ms1.  auto.
  auto.
Qed.

(* This wasn't obvious before, but it is provable now. *)
Lemma kleene_refl : forall e, typing nil e typ_nat -> kleene_equivalence e e.
Proof.
  intros e H.
  apply termination in H.
  unfold kleene_equivalence.
  destruct H as [v [MS V]].
  exists v. auto.
Qed.

Lemma observational : consistent_equivalence observational_equivalence.
  apply mkO.
  - apply observational_typed.
  - intros. unfold observational_equivalence.
    split. auto. split. auto. intros.
    apply kleene_refl.
    apply typing_replace with (G := G) (t:=t). auto. auto.
  - apply observational_sym.
  - apply observational_trans.
  - apply observational_consistent.
  - apply observational_congruence.
Qed.

(* Lemma 46.16 *)
Lemma logical_congruence :
  forall C0 G t G0 t0,
    typing_ctx C0 G t G0 t0 ->
    forall e e', logical_equivalence G e e' t ->
            logical_equivalence G0 (replace C0 e) (replace C0 e') t0.
Proof.
  intros C0 G t G0 t0 H. induction H; intros; simpl; auto.
  - unfold logical_equivalence in *.
    destruct H0 as [Te [Te' LL]].
    split. econstructor. eapply typing_replace; eauto.
    split. econstructor. eapply typing_replace; eauto.
    intros g g' EQ.
    simpl.
    split. econstructor. eapply apply_cs_typing with (G := G').
    admit. eapply typing_replace; eauto.  (* equal cs are typed. *)
    split. econstructor. eapply apply_cs_typing.
    admit. eapply typing_replace; eauto.
    destruct (IHtyping_ctx e e') as [k0 [k1 FF]].
    repeat split.  auto. auto. auto.
    destruct (FF g g') as [h0 [h1 GG]]. auto.
    unfold kleene_equivalence in *.
    destruct GG as [v [MS1 MS2]].
    exists (s v). split. auto.
    split. admit. admit. (* multistep is a congruence *)
Admitted.

Lemma consistent_equivalence_logical : consistent_equivalence logical_equivalence.
Proof.
  apply mkO.
  - intros. unfold logical_equivalence in H.
    destruct H as [T1 [T2 _]]. auto.
  - apply logical_refl.
  - apply logical_sym.
  - apply logical_trans.
  - (* consistent *) intros.
    destruct H as [T1 [T2 C]].
    destruct (C nil nil) as [h0 [h1 k]]. eauto.
    rewrite apply_nil in k.
    rewrite apply_nil in k.
    auto.
  - (* congruent *)
    intros.
    eapply logical_congruence; eauto.
Qed.

(* Theorem 46.17 *)
(* Logical equivalence implies observational equivalence. *)
Lemma closed_logical_is_observational : forall G e e' t,
    logical_equivalence G e e' t ->
    observational_equivalence G e e' t.
Proof.
  intros.
  eapply coarsest.
  eapply consistent_equivalence_logical. auto.
Qed.

(* Lemma 46.19 *)
Lemma closed_observational_is_logical : forall t e e',
    observational_equivalence nil e e' t -> closed_logical_equivalence e e' t.
Proof.
  induction t.
  - intros. unfold closed_logical_equivalence, observational_equivalence in *.
    destruct H as [T1 [T2 CT]].
    split. auto. split. auto.
    pose (K := CT ctx_top (@typing_ctx_top nil typ_nat)).
    simpl in K. auto.
  - intros.
    pose (M := H).
    destruct M as [T1 [T2 CT]].
    split. auto. split. auto.
    intros e1 e1' Le1.
    destruct (closed_logical_typing _ _ _ Le1) as [U1 U2].
    assert (observational_equivalence nil e1 e1' t1).
    { eapply closed_logical_is_observational.
      unfold logical_equivalence.
      split. auto. split. auto.
      intros. inversion H0. subst.
      rewrite apply_nil.
      rewrite apply_nil.
      auto. }
    assert (observational_equivalence nil (app e e1) (app e' e1') t2).
    { eapply observational_trans with (e2 := app e e1').
      replace (app e e1) with (replace (ctx_app2 e ctx_top) e1); auto.
      replace (app e e1') with (replace (ctx_app2 e ctx_top) e1'); auto.
      eapply observational_congruence. eauto.
      eauto.
      replace (app e e1') with (replace (ctx_app1 ctx_top e1') e); auto.
      replace (app e' e1') with (replace (ctx_app1 ctx_top e1') e'); auto.
      eapply observational_congruence. eauto.
      eauto. }
    eauto.
Qed.

(* Lemma 46.19 *)
Lemma observational_is_logical : forall G e e' t,
    observational_equivalence G e e' t -> logical_equivalence G e e' t.
Proof.
  intros.
  unfold logical_equivalence.
  destruct (observational_typed _ _ _ _ H) as [T1 T2].
  split. auto.
  split. auto.
  intros g g' EQg.
  apply closed_observational_is_logical.
  apply closing_eq with (G := G). auto.
  admit. (* map Lemma 46.19 *)
Admitted.

(*  ---------------- section 46.4 ------------------- *)

(* We've already proven many of the general laws shown in this section.
For example (45.5a-c) and (46.7a) are part of consistent_equivalence_logical. *)

Lemma substitution_logical : forall G e1 e1' t e2 e2' t' x,
    uniq ((x ~ t) ++ G) ->
    logical_equivalence G e1 e1' t -> logical_equivalence ((x ~ t) ++ G) e2 e2' t' ->
    logical_equivalence G ([x ~> e1] e2) ([x ~> e1'] e2') t'.
Proof.
  intros.
  inversion H. subst.
  assert (logical_equivalence G (abs t (close x e2)) (abs t (close x e2')) (typ_arr t t')).
  {
    replace (abs t (close x e2)) with (replace (ctx_abs t x ctx_top) e2); auto.
    replace (abs t (close x e2')) with (replace (ctx_abs t x ctx_top) e2'); auto.
    apply logical_congruence with (G := (x ~ t) ++ G) (t := t'); auto.
  }
  destruct H1 as [T1 [T2 REL]].
  unfold logical_equivalence.
  split.  admit. split. admit. (* typing stuff *)
  intros g g' EQ.
  rewrite <- apply_cons2.
  rewrite <- apply_cons2.
  eapply REL.
  apply eq_cs_cons. auto.
  unfold logical_equivalence in H0.
  destruct H0 as [U1 [U2 REL2]].
  apply REL2. auto.
  admit.
  admit.
  admit.
Admitted.

(* 46.4.2 *)

Lemma extensionality : forall G x t1 e e' t2,
    logical_equivalence ((x ~ t1) ++ G) (app e (var_f x)) (app e' (var_f x)) t2 ->
    logical_equivalence G e e' (typ_arr t1 t2).
Proof.
  intros.
  unfold logical_equivalence in *.
  destruct H as [T1 [T2 REL]].
  split. admit. split. admit.
  intros g g' EQ.
  simpl.
  split. admit. split. admit.
  intros e1 e1' EQ2.
  assert (eq_cs (fun _ : env => closed_logical_equivalence) ((x ~ t1) ++ G) ((x ~ e1) ++ g) ((x ~ e1') ++ g')).
  { apply eq_cs_cons. auto. auto.
    admit. }
  apply REL in H.
  simpl in H.
  assert (forall x e1 g, exists p, binds_lookup exp x ((x, e1) :: g) = inl (exist _ e1 p)).
  admit.
  destruct (H0 x e1 g) as [p BL].
  admit.
  Admitted.


(* TLC in Coq
 *
 * Module: tlc.syntax.pattern
 * Purpose: Contains the syntax of patterns.
 *)

Require Import mathcomp.ssreflect.eqtype.
Require Import mathcomp.ssreflect.ssrbool.
Require Import mathcomp.ssreflect.ssreflect.
Require Import mathcomp.ssreflect.ssrnat.
Require Import tlc.syntax.constructor.

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

(* Forms of patterns in matching expressions *)
Inductive pattern :=
| PWildcard
| PParameter (j : nat)
| PConstructor (c : constructor)
| PApplication (f a : pattern).

(* Equality *)
Section eq.

  (* Boolean equality *)
  Fixpoint pattern_eq p1 p2 :=
    match p1, p2 with
    | PWildcard, PWildcard => true
    | PParameter j1, PParameter j2 => j1 == j2
    | PConstructor c1, PConstructor c2 => c1 == c2
    | PApplication f1 a1, PApplication f2 a2 =>
      pattern_eq f1 f2 && pattern_eq a1 a2
    | _, _ => false
    end.

  (* Boolean equality reflection *)
  Lemma pattern_eqP : Equality.axiom pattern_eq.
  Proof.
    elim=> [| j1 | c1 | f1 IHf a1 IHa] [| j2 | c2 | f2 a2] //=;
      try by constructor.
    - by have [<- | neqx] := j1 =P j2; last (by right; case); constructor.
    - by have [<- | neqx] := c1 =P c2; last (by right; case); constructor.
    - have [<- | neqx] := IHf f2; last (by right; case); simpl.
      have [<- | neqx] := IHa a2; last (by right; case); simpl.
      by constructor.
  Qed.

  (* EqType canonical structures *)
  Definition pattern_eqMixin := EqMixin pattern_eqP.
  Canonical pattern_eqType := EqType pattern pattern_eqMixin.

End eq.

(* Constructor coercions *)
Coercion PConstructor : constructor >-> pattern.

(* Notation scope *)
Declare Scope pattern_scope.
Bind Scope pattern_scope with pattern.
Delimit Scope pattern_scope with pattern.

Notation "{-p p -}" := (p%pattern)
  (at level 0, p at level 100, no associativity, only parsing).

(* Constructor notations *)
Notation "'%'" := PWildcard
  (at level 0, no associativity) : pattern_scope.
Notation "$ j" := (PParameter j)
  (at level 0, j at level 0, no associativity, format "'$' j") : pattern_scope.
Notation "f ' a" := (PApplication f a)
  (at level 10, left associativity) : pattern_scope.

(* Derived constructor notations for pairs *)
Definition PPair p1 p2 := {-p CPair ' p1 ' p2 -}.
Notation "( p1 , p2 , .. , pn )" := (PPair (.. (PPair p1 p2) ..) pn)
  : pattern_scope.

(* Derived constructor notations for booleans *)
Definition PTrue := PConstructor CTrue.
Definition PFalse := PConstructor CFalse.
Definition pattern_of_bool b := if b then PTrue else PFalse.
Coercion pattern_of_bool : bool >-> pattern.

(* Derived constructor notations for naturals *)
Definition PZero := PConstructor CZero.
Definition PSucc n := {-p CSucc ' n -}.
Notation "n .+1" := (PSucc n) : pattern_scope.
Fixpoint pattern_of_nat n :=
  match n with
  | 0 => PZero
  | n.+1 => PSucc (pattern_of_nat n)
  end.
Fixpoint nat_of_pattern p :=
  match p with
  | PConstructor CZero => Some 0
  | PApplication (PConstructor CSucc) p' =>
    match nat_of_pattern p' with
    | Some n' => Some (n'.+1)
    | None => None
    end
  | _ => None
  end.
Definition pattern_of_uint n :=
  pattern_of_nat (Nat.of_num_uint n).
Definition uint_of_pattern p :=
  match nat_of_pattern p with
  | Some n => Some (Nat.to_num_uint n)
  | None => None
  end.
Numeral Notation pattern pattern_of_uint uint_of_pattern : pattern_scope.

(* Derived constructor notations for lists *)
Definition PNil := PConstructor CNil.
Notation "[ ]" := PNil : pattern_scope.
Definition PCons p ps := {-p CCons ' p ' ps -}.
Notation "p :: ps" := (PCons p ps) : pattern_scope.
Notation "[ p1 , .. , pn ]" := {-p p1 :: (.. (pn :: []) ..) -}
  : pattern_scope.


From mathcomp Require Import ssreflect.
From Coq.Logic Require Export ClassicalFacts JMeq FunctionalExtensionality.

Axiom p_prop_extensionality : prop_extensionality.

Lemma prop_eqTrue : forall (P : Prop) (p : P), JMeq p I.
Proof.
  move => P p.
  have: (P = True).
  {
    apply: provable_prop_ext.
    exact p_prop_extensionality.
    by [].
  }
  move => eqP.
  move: eqP p =>->.
  case.
  reflexivity.
Qed.

Lemma p_proof_irrelevance_jmeq : forall (P : Prop) (p : P) (Q : Prop) (q : Q), JMeq p q.
Proof.
  move => P p Q q.
  apply: (@JMeq_trans _ True _ _ I _).
  exact: prop_eqTrue.
  symmetry.
  exact: prop_eqTrue.
Qed.

Lemma p_proof_irrelevance : proof_irrelevance.
Proof.
  move => P p1 p2.
  apply: JMeq_eq.
  exact: p_proof_irrelevance_jmeq.
Qed.

Lemma eq_exist_eq : forall {A} (P : A -> Prop) (a1 a2 : A) (prf1 : P a1) (prf2 : P a2),
    a1 = a2 -> exist P a1 prf1 = exist P a2 prf2.
Proof.
  move => A P a1 a2 prf1 prf2 eqa.
  subst.
  rewrite(_ : prf1 = prf2).
  reflexivity.
  exact: p_proof_irrelevance.
Qed.

Axiom
  dependent_unique_choice :
    forall (A:Type) (B:A -> Type) (R:forall x:A, B x -> Prop),
      (forall x : A, exists! y : B x, R x y) ->
      (exists f : (forall x:A, B x), forall x:A, R x (f x)).

Theorem unique_choice :
 forall (A B:Type) (R:A -> B -> Prop),
   (forall x:A, exists! y : B, R x y) ->
   (exists f:A->B, forall x:A, R x (f x)).
Proof.
  move => A B R cond.
  by apply: dependent_unique_choice.
Qed.

Lemma eq_JMeq {A} : forall {x y : A}, x = y -> JMeq x y.
Proof.
  move => x y =>->.
  exact: JMeq_refl.
Qed.


Require Export CatSem.CAT.functor.

Set Implicit Arguments.
Unset Strict Implicit.

Unset Automatic Introduction.

Section NT_def.

Variables obC obD: Type.
Variable morC : obC -> obC -> Type.
Variable morD : obD -> obD -> Type.
Variable C: Cat_struct morC.
Variable D: Cat_struct morD.

Definition trafo_comm (F G: Functor C D)
          (alpha: forall c:obC, morD (F c) (G c)):=
     forall c d f, alpha c ;; #G f == #F f ;; alpha d.

Class NT_struct {F G: Functor C D}
         (alpha: forall c: obC, morD (F  c) (G  c)) := {
  trafo_ax: forall c d f, alpha c ;; #G f == #F f ;; alpha d
}.

Record NT (F G: Functor C D) := {
  trafo:> forall c: obC, morD (F c) (G c);
  nt_struct:> NT_struct trafo
}.

Existing Instance nt_struct.

Lemma NTcomm (F G: Functor C D)(alpha: forall c, morD (F c) (G c))
         (H:NT_struct alpha)
         (c d: obC)(f: morC c d):
       alpha c ;; #G f == #F f ;; alpha d.
Proof.
  intros F G a c d f.
  apply trafo_ax.
Qed.

Variables F G: Functor C D.

Definition EXT_NT : relation (NT F G) :=
       fun a b => forall c: obC, a c == b c.

Lemma EXT_NT_refl: Reflexive (EXT_NT).
Proof.
  unfold Reflexive.
  intros  x c.
  cat.
Qed.

Lemma EXT_NT_sym: Symmetric EXT_NT.
Proof.
  unfold Symmetric.
  intros x y H c.
  apply hom_sym.
  apply H.
Qed.

Lemma EXT_NT_trans: Transitive EXT_NT.
Proof.
  unfold Transitive.
  intros x y z H H' c.
  apply hom_trans with (y c);
  auto.
Qed.

Lemma eq_NT_equiv : @Equivalence (NT F G)
         (fun a b => forall c: obC, a c == b c).
Proof.
  split.
  assert (H:=EXT_NT_refl);
  auto.
  assert (H:=EXT_NT_sym);
  auto.
  assert (H:=EXT_NT_trans);
  auto.
Qed.

Definition EXT_NT_oid := Build_Setoid eq_NT_equiv.

End NT_def.

Existing Instance nt_struct.

(*
Notation "a =NT= b" := (eq_NT1 a b) (at level 80).
*)

(** the vertical identity NT *)

Section VIDNT.

Variables obC obD: Type.
Variable morC : obC -> obC -> Type.
Variable morD : obD -> obD -> Type.
Variable C: Cat_struct morC.
Variable D: Cat_struct morD.
Variable F: Functor C D.

Program Definition vidNT : NT F F := Build_NT
  (trafo := fun c => id (F c)) _ .
Next Obligation.
Proof.
  apply Build_NT_struct.
  cat.
Qed.

End VIDNT.

Section vcompNT.
(* Variables C D: Category. *)
Variables obC obD: Type.
Variable morC : obC -> obC -> Type.
Variable morD : obD -> obD -> Type.
Variable C: Cat_struct morC.
Variable D: Cat_struct morD.

Variables F G H: Functor C D.
Variables (a:NT F G) (b:NT G H).

Definition vcompNT1 := fun c => a c ;; b c.

Lemma vcompNT1_ax: forall c d f,
          vcompNT1 c ;; #H f == #F f ;; vcompNT1 d.
Proof.
  intros c d f.
  unfold vcompNT1.
  rewrite assoc.
  rewrite (NTcomm b).
  rewrite <- assoc.
  rewrite (NTcomm a).
  rewrite assoc.
  apply hom_refl.
Qed.

Definition vcompNT := Build_NT (Build_NT_struct vcompNT1_ax).

End vcompNT.

Notation "a # b" := (vcompNT b a) (at level 50, left associativity).

(** lemmata about vertical composition *)
Section vcompNT_lemmata.
Variables obC obD: Type.
Variable morC : obC -> obC -> Type.
Variable morD : obD -> obD -> Type.
Variable C: Cat_struct morC.
Variable D: Cat_struct morD.

Variable F G: Functor C D.
Variable alpha: NT F G.

Notation "a =NT= b" := (EXT_NT a b) (at level 80).

Lemma vidNTl: alpha # vidNT F =NT= alpha.
Proof.
  unfold EXT_NT, vidNT.
  intro c; simpl.
  unfold vcompNT1;
  simpl. apply idl.
Qed.

Lemma vidNTr: vidNT G # alpha =NT= alpha.
Proof.
  unfold EXT_NT, vidNT.
  intro c; simpl.
  unfold vcompNT1; simpl.
  apply idr.
Qed.

Variables H J: Functor C D.
Variable beta: NT G H.
Variable gamma: NT H J.

Lemma vcompNT_assoc:
     gamma # (beta # alpha) =NT= (gamma # beta) # alpha.
Proof.
  unfold EXT_NT, vcompNT.
  simpl.
  unfold vcompNT1; simpl.
  intro c; apply assoc.
Qed.

End vcompNT_lemmata.


Require Import Bool.
Require Import ZF ZFcoc ZFfunext.
Require Import ModelCC.

Import BuildModel.
Import T J R.

(********************************************************************************)
(** Occurrences *)
Module B := VarMap.Bool.

  (* Non-occurrence : interp do not depend on variables in set [f] *)
  Definition noccur (f:B.map) (T:term) : Prop :=
    forall i i',
    (forall n, if f n then True else i n == i' n) ->
    int T i == int T i'.

  Lemma noc_var : forall f n, f n = false -> noccur f (Ref n).
red; simpl; intros.
specialize (H0 n).
rewrite H in H0; trivial.
Qed.

  Lemma noc_cst : forall f x, noccur f (cst x).
red; simpl; reflexivity.
Qed.

  Lemma noc_kind : forall f, noccur f kind.
red; simpl; reflexivity.
Qed.

  Lemma noc_prop : forall f, noccur f prop.
intros; apply noc_cst.
Qed.

  Lemma noc_app : forall f a b,
    noccur f a -> noccur f b -> noccur f (App a b).
unfold noccur; simpl; intros.
rewrite (H _ _ H1).
rewrite (H0 _ _ H1).
reflexivity.
Qed.

  Lemma noc_abs a b f :
    noccur f a ->
    noccur (B.cons false f) b ->
    noccur f (Abs a b).
red; simpl; intros.
apply cc_lam_ext.
 apply H; trivial.

 red; intros.
 apply H0.
 destruct n; simpl; trivial.
 apply H1.
Qed.

  Lemma noc_prod a b f :
    noccur f a ->
    noccur (B.cons false f) b ->
    noccur f (Prod a b).
red; simpl; intros.
apply cc_prod_ext.
 apply H; trivial.

 red; intros.
 apply H0.
 destruct n; simpl; trivial.
 apply H1.
Qed.

Ltac noc_tac :=
  lazymatch goal with
    |- noccur _ (App _ _) => apply noc_app; noc_tac
  | |- noccur _ (Abs _ _) => apply noc_abs; noc_tac
  | |- noccur _ (Prod _ _) => apply noc_prod; noc_tac
  | |- noccur _ (Ref _) => apply noc_var; reflexivity
  | |- noccur _ _ => try (red; reflexivity) (* closed case *)
  end.

(********************************************************************************)
(** Judgements with variance *)

Module OTeq.
Definition t := option term.
Definition eq := @eq (option term).
Definition eq_equiv : Equivalence eq := eq_equivalence.
Existing Instance eq_equiv.
End OTeq.
Module OT := VarMap.Make(OTeq).

(* Environments with tags on ordinal and recursive function variables *)
Record fenv := {
  tenv : env;
  ords : B.map; (* variables denoting ordinals *)
  fixs : OT.map (* variables denoting recursive functions with their domain *)
}.
Definition fenv_ := fenv.

Definition tinj e :=
  Build_fenv e (B.nil false) (OT.nil None).

Definition push_var e T :=
  Build_fenv (T::tenv e) (B.cons false (ords e)) (OT.cons None (fixs e)).

Definition push_fun e dom rng :=
  Build_fenv (Prod dom rng::tenv e)
    (B.cons false (ords e)) (OT.cons (Some dom) (fixs e)).

Definition push_ord e T :=
  Build_fenv (T::tenv e) (B.cons true (ords e)) (OT.cons None (fixs e)).

(* Additional judgments for fix body *)
Definition val_mono (e:fenv) i i' :=
    val_ok (tenv e) i /\
    val_ok (tenv e) i' /\
    forall n,
    if ords e n then i n ⊆ i' n
    else match fixs e n with
      Some T => forall x, x ∈ int T (V.shift (S n) i) -> cc_app (i n) x == cc_app (i' n) x
    | _ => i n == i' n
    end.

Lemma val_mono_refl : forall e i,
  val_ok (tenv e) i -> val_mono e i i.
split;[idtac|split]; simpl; auto with *.
intro n.
destruct (ords e n); auto with *.
destruct (fixs e n); auto with *.
Qed.

Lemma val_push_var : forall e i i' x x' T,
  val_mono e i i' ->
  x == x' ->
  x ∈ int T i ->
  x' ∈ int T i' ->
  val_mono (push_var e T) (V.cons x i) (V.cons x' i').
destruct 1 as (?&?&?); split;[idtac|split]; trivial.
 unfold push_var; simpl.
 apply vcons_add_var; trivial.

 unfold push_var; simpl.
 apply vcons_add_var; trivial.

 destruct n as [|n]; simpl; auto.
 generalize (H1 n).
 destruct (ords e n); trivial.
Qed.

Lemma val_push_ord : forall e i i' x x' T,
  val_mono e i i' ->
  x ⊆ x' ->
  x ∈ int T i ->
  x' ∈ int T i' ->
  val_mono (push_ord e T) (V.cons x i) (V.cons x' i').
destruct 1 as (?&?&?); split;[idtac|split]; trivial.
 unfold push_ord; simpl.
 apply vcons_add_var; trivial.

 unfold push_ord; simpl.
 apply vcons_add_var; trivial.

 destruct n as [|n]; simpl; auto.
 generalize (H1 n).
 destruct (ords e n); trivial.
Qed.

Lemma val_push_fun : forall e i i' f g T U,
  val_mono e i i' ->
  f ∈ int (Prod T U) i ->
  g ∈ int (Prod T U) i' ->
  fcompat (int T i) f g ->
  val_mono (push_fun e T U) (V.cons f i) (V.cons g i').
destruct 1 as (?&?&?); split;[idtac|split]; trivial.
 unfold push_fun; simpl.
 apply vcons_add_var; trivial.

 unfold push_fun; simpl.
 apply vcons_add_var; trivial.

 destruct n as [|n]; simpl; auto.
 generalize (H1 n).
 destruct (ords e n); trivial.
Qed.

(** Invariance *)
Definition var_equals e M :=
  forall i i', val_mono e i i' -> int M i == int M i'.

(** Covariance judgment *)
Definition var_mono e M :=
  forall i i', val_mono e i i' ->
  int M i ⊆ int M i'.

(** Function Extension judgment *)
Definition var_ext e dom M :=
  forall i i', val_mono e i i' ->
  fcompat (int dom i) (int M i) (int M i').

Lemma El_sub e T i i':
  var_mono e T ->
  val_mono e i i' ->
  int T i ⊆ int T i'.
intros.
apply H in H0.
red; auto.
Qed.
Lemma El_eq e T i i':
  var_equals e T ->
  val_mono e i i' ->
  int T i == int T i'.
intros.
apply H in H0.
rewrite H0; reflexivity.
Qed.

Definition spec_var e n :=
  ords e n || match fixs e n with Some _ => true | _ => false end.

  Lemma var_eq_noc : forall e t,
    noccur (spec_var e) t ->
    var_equals e t.
unfold noccur, var_equals, spec_var; intros.
apply H; intros.
destruct H0 as (_,(_,H0)).
generalize (H0 n).
destruct (ords e n); simpl; trivial.
destruct (fixs e n); simpl; trivial.
Qed.

  Lemma var_eq_app : forall e u v,
    var_equals e u ->
    var_equals e v ->
    var_equals e (App u v).
unfold var_equals; intros.
specialize H with (1:=H1).
specialize H0 with (1:=H1).
simpl.
rewrite H; rewrite H0; reflexivity.
Qed.

  Lemma var_eq_abs : forall e T M,
    var_equals e T ->
    var_equals (push_var e T) M ->
    var_equals e (Abs T M).
unfold var_equals; intros.
simpl.
apply cc_lam_ext; eauto.
red; intros.
apply H0.
specialize H with (1:=H1).
apply val_push_var; auto.
rewrite <- H3; rewrite <- H; trivial.
Qed.

  Lemma var_eq_prod : forall e T U,
    var_equals e T ->
    var_equals (push_var e T) U ->
    var_equals e (Prod T U).
red; simpl; intros.
specialize (H _ _ H1).
apply cc_prod_ext; trivial.
red; intros.
apply H0.
apply val_push_var; auto with *.
rewrite <- H3.
rewrite <- H; trivial.
Qed.

  Lemma var_eq_rec_call : forall e n x T U,
    ords e n = false ->
    fixs e n = Some T ->
    T <> kind ->
    typ (tenv e) (Ref n) (Prod (lift (S n) T) U) ->
    var_equals e x ->
    typ (tenv e) x (lift (S n) T) ->
    var_equals e (App (Ref n) x).
unfold var_equals; intros.
simpl.
specialize H3 with (1:=H5).
rewrite <- H3.
destruct H5 as (Hty,(Hty',Hrec)).
specialize Hrec with n.
rewrite H in Hrec; rewrite H0 in Hrec.
apply Hrec.
red in H4; specialize H4 with (1:=Hty); trivial.
apply in_int_not_kind in H4; trivial.
2:destruct T as [(T,Tm)|];simpl;[discriminate|elim H1;reflexivity].
unfold lift in H4; rewrite int_lift_rec_eq in H4.
rewrite V.lams0 in H4; trivial.
Qed.

  (** Covariance rules *)

  Lemma var_eq_sub : forall e M, var_equals e M -> var_mono e M.
unfold var_mono, var_equals; intros.
apply H in H0.
rewrite <- H0; reflexivity.
Qed.

  Lemma var_mono_ref : forall e n,
    ords e n = true ->
    var_mono e (Ref n).
unfold var_mono; intros.
destruct H0 as (_,(_,H0)).
generalize (H0 n); rewrite H.
simpl; intros; trivial.
Qed.

Lemma var_mono_prod : forall e T U,
  var_equals e T ->
  var_mono (push_var e T) U ->
  var_mono e (Prod T U).
red; red; intros.
red in H; specialize H with (1:=H1).
revert H2; simpl; apply cc_prod_covariant; intros.
 do 2 red; intros.
 rewrite H3; reflexivity.

 rewrite H; reflexivity.

 apply El_sub with (1:=H0).
 apply val_push_var; auto with *.
 rewrite <- H; trivial.
Qed.

  (** Function subtyping rules *)

  Lemma var_ext_abs : forall e U T M,
    var_mono e T ->
    var_equals (push_var e T) M ->
    typ (T::tenv e) M U ->
    var_ext e T (Abs T M).
unfold var_equals, var_ext; intros.
specialize El_sub with (1:=H)(2:=H2); clear H; intro H.
simpl.
red; intros.
rewrite cc_beta_eq; try assumption.
 assert (H3' := H _ H3).
 rewrite cc_beta_eq; trivial.
  apply H0.
  apply val_push_var; auto with *.

  red; red; intros.
  rewrite H5; reflexivity.

 red; red; intros.
 rewrite H5; reflexivity.
Qed.

(****************************************************************************************)
(** Compound judgements : typing + variance *)

Definition typ_equals e M T :=
  var_equals e M /\ typ (tenv e) M T.

Definition typ_mono e M T :=
  var_mono e M /\ typ (tenv e) M T.

Definition typ_ext e M A B :=
  var_ext e A M /\ typ (tenv e) M (Prod A B).

Instance typ_equals_morph e : Proper (eq_term ==> eq_term ==> iff) (typ_equals e).
apply morph_impl_iff2; auto with *.
do 4 red; intros.
destruct H1; split.
 red; intros.
 rewrite <- H; eauto.

 rewrite <- H; rewrite <- H0; eauto.
Qed.

(** ** Inference rules *)

(** Inclusion relation between judgements *)

  Lemma typ_eq_mono : forall e M T, typ_equals e M T -> typ_mono e M T.
destruct 1; split; trivial.
apply var_eq_sub; trivial.
Qed.

  Lemma typ_eq_ext : forall e M A B, typ_equals e M (Prod A B) -> typ_ext e M A B.
destruct 1; split; trivial.
do 2 red; intros.
apply H in H1.
rewrite H1; reflexivity.
Qed.

(** Subsumption *)
  Lemma typ_eq_subsumption e M T T' :
    typ_equals e M T -> sub_typ (tenv e) T T' -> T <> kind -> typ_equals e M T'.
destruct 1; split; trivial.
apply typ_subsumption with (2:=H1); trivial.
Qed.

(** Typing the three kind of variables *)

  Lemma typ_eq_ref : forall e n T,
    spec_var e n = false ->
    nth_error (tenv e) n = value T ->
    typ_equals e (Ref n) (lift (S n) T).
intros.
split.
 apply var_eq_noc; apply noc_var; trivial.
 apply typ_var; trivial.
Qed.

  Lemma typ_mono_ref : forall e n t T,
    ords e n = true ->
    nth_error (tenv e) n = value t ->
    T <> kind ->
    t <> kind ->
    sub_typ (tenv e) (lift (S n) t) T ->
    typ_mono e (Ref n) T.
intros.
split.
 apply var_mono_ref; trivial.

 apply typ_subsumption with (lift (S n) t); trivial.
  apply typ_var; trivial.

  destruct t as [(t,tm)|]; simpl in *; auto.
  discriminate.
Qed.

  Lemma typ_ext_ref e n T U :
    ords e n = false ->
    fixs e n = Some T ->
    nth_error (tenv e) n = Some (Prod T U) ->
    typ_ext e (Ref n)  (lift (S n) T) (lift1 (S n) U).
intros notord isfun varty.
split.
 red; simpl; intros.
 assert (var := proj2 (proj2 H) n).
 rewrite notord, isfun in var.
 red; intros.
 unfold lift in H0; rewrite int_lift_rec_eq in H0.
 rewrite V.lams0 in H0.
 auto.

 unfold lift, lift1.
 rewrite <- eq_lift_prod.
 apply typ_var; trivial.
Qed.

  Lemma typ_eq_abs : forall e s1 U T T' M,
    U <> kind ->
    s1=prop \/ s1=kind ->
    eq_typ (tenv e) T T' ->
    typ_equals e T s1 ->
    typ_equals (push_var e T) M U ->
    typ_equals e (Abs T M) (Prod T' U).
intros.
destruct H2; destruct H3.
split.
 apply var_eq_abs; trivial.

 apply typ_conv with (Prod T U); auto.
  apply typ_abs; trivial.

  apply eq_typ_prod; trivial.
  reflexivity.

 discriminate.
Qed.

  Lemma typ_ext_abs : forall e U T M,
    U <> kind ->
    typ_mono e T kind ->
    typ_equals (push_var e T) M U ->
    typ_ext e (Abs T M) T U.
intros.
destruct H0; destruct H1; split.
 apply var_ext_abs with U; trivial.

 apply typ_abs; trivial.
Qed.

Lemma typ_eq_app e u v V Ur T :
  V <> kind ->
  Ur <> kind ->
  sub_typ (tenv e) (subst v Ur) T ->
  typ_equals e u (Prod V Ur) ->
  typ_equals e v V ->
  typ_equals e (App u v) T.
intros Vnk Unk Tsub (uty,ueq) (vty,veq).
split.
 apply var_eq_app; trivial.

 apply typ_subsumption with (subst v Ur); trivial.
  apply typ_app with V; auto.

  destruct Ur as [(Ur,Urm)|]; simpl; trivial.
  discriminate.
Qed.

  Lemma typ_ext_app : forall e n x t u T,
    ords e n = false ->
    fixs e n = Some t ->
    T <> kind ->
    t <> kind ->
    u <> kind ->
    nth_error (tenv e) n = value (Prod t u) ->
    sub_typ (tenv e) (subst x (lift_rec (S n) 1 u)) T ->
    typ_equals e x (lift (S n) t) ->
    typ_equals e (App (Ref n) x) T.
intros.
destruct H6.
assert (typ (tenv e) (Ref n) (Prod (lift (S n) t) (lift_rec (S n) 1 u))).
 apply typ_var0; rewrite H4; split;[discriminate|].
 apply sub_refl.

 unfold lift; rewrite eq_lift_prod.
 reflexivity.
split.
 apply var_eq_rec_call with t (lift_rec (S n) 1 u); trivial.

 apply typ_subsumption with (subst x (lift_rec (S n) 1 u)); auto.
 2:destruct u as [(u,um)|]; trivial.
 2:discriminate.
 apply typ_app with (lift (S n) t); trivial.
 destruct t as [(t,tm)|]; trivial.
 discriminate.
Qed.

(** Derived rules for practical examples (basically applies subsumption beforehand) *)

  Lemma typ_eq_ref' : forall e n t T,
    spec_var e n = false ->
    nth_error (tenv e) n = value t ->
    t <> kind ->
    sub_typ (tenv e) (lift (S n) t) T ->
    typ_equals e (Ref n) T.
intros.
split.
 apply var_eq_noc; apply noc_var; trivial.

 apply typ_subsumption with (lift (S n) t); trivial.
  apply typ_var; trivial.

  destruct t as [(t,tm)|]; simpl in *; auto.
  discriminate.
Qed.

(*  Lemma typ_eq_app' : forall e u v V Ur T,
    V <> kind ->
    Ur <> kind ->
    sub_typ (tenv e) (subst v Ur) T ->
    typ_equals e u (Prod V Ur) ->
    typ_equals e v V ->
    typ_equals e (App u v) T.
intros.
destruct H2.
destruct H3.
split.
 apply var_eq_app; trivial.

 apply typ_subsumption with (subst v Ur); trivial.
  apply typ_app with V; auto.

  destruct Ur as [(Ur,Urm)|]; simpl; trivial.
  discriminate.
Qed.
*)
(*  Lemma typ_ext_app' e n x t u T :
    ords e n = false ->
    fixs e n = Some t ->
    t <> kind ->
    u <> kind ->
    nth_error (tenv e) n = value (Prod t u) ->
    sub_typ (tenv e) (subst x (lift1 (S n) u)) T ->
    typ_equals e x (lift (S n) t) ->
    typ_equals e (App (Ref n) x) T.
intros.
apply typ_eq_subsumption with (2:=H4).
 eapply typ_ext_app with (8:=H5); trivial.
  destruct t as [(t,tm)|]; simpl; trivial; discriminate.

  eapply typ_ext_ref with (4:=H3); trivial.

 destruct u as [(u,um)|]; simpl; trivial; discriminate.
Qed.
*)


(** BEGIN HIDE **)

Lemma double_sub n : n.*2 - n = n.
Proof. by rewrite -addnn addKn. Qed.

Lemma iota_Sr k : iota 1 k.+1 = iota 1 k ++ [:: k.+1].
Proof. by rewrite -[in LHS](addn1 k) iota_add add1n. Qed.

(** END HIDE **)

(* BEGIN HIDE *)
Section CoprimeProd.

Variables (I : eqType).

Lemma coprime_prodr (r : seq I) (P : pred I) (F : I -> nat) n :
  (forall x, x \in r -> P x -> coprime n (F x)) ->
  coprime n (\prod_(i <- r | P i) F i).
Proof.
elim: r => [|x r ihr] hc; first by rewrite big_nil coprimen1.
have {ihr} ihr : coprime n (\prod_(j <- r | P j) F j).
  by apply: ihr => y ry Py; rewrite hc // in_cons ry orbT.
by rewrite big_cons; case: ifP => Px //; rewrite coprime_mulr hc // in_cons eqxx.
Qed.

Lemma coprime_prodl (r : seq I) (P : pred I) (F : I -> nat) n :
  (forall x, x \in r -> P x -> coprime (F x) n) ->
  coprime (\prod_(i <- r | P i) F i) n.
Proof.
move=> h; rewrite coprime_sym; apply: coprime_prodr=> i; rewrite coprime_sym.
exact: h.
Qed.

End CoprimeProd.

(* END HIDE *)


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

From Coq Require Import List.
From Buchberger Require Import Bar.

Set Default Proof Using "Type".

Section OpenIndGoodRel.
Variable A : Type.
Variable lt R : Rel A.
Variable wflt : well_founded lt.

Inductive Min : list A -> Type :=
  | nmin : Min nil
  | cmin :
      forall (a : A) (l : list A),
      Min l -> (forall y : A, lt y a -> GRBar A R (y :: l)) -> Min (a :: l).
Local Hint Resolve nmin cmin : core.

Lemma OpenInd :
 forall xs : list A,
 Min xs ->
 (forall a : A, Min (a :: xs) -> GRBar A R (a :: xs)) -> GRBar A R xs.
Proof using wflt.
intros; red in |- *.
apply Ind; auto.
intros a; elim (wflt a); auto.
intros x H' H'0.
apply X0.
apply cmin; auto.
Qed.

End OpenIndGoodRel.


(**
Given a map between two functors, we get a pseudofunctor between their fundamental bigroupoids.

Authors: Dan Frumin, Niels van der Weide

Ported from: https://github.com/nmvdw/groupoids
 *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.Core.Examples.TwoType.

Section ApFunctor.
  Context {X Y : UU}
          (HX : isofhlevel 4 X)
          (HY : isofhlevel 4 Y).
  Variable (f : X → Y).

  Definition ap_functor_data
    : psfunctor_data (fundamental_bigroupoid X HX) (fundamental_bigroupoid Y HY).
  Proof.
    use make_psfunctor_data.
    - exact f.
    - exact (λ _ _, maponpaths f).
    - exact (λ _ _ _ _ s, maponpaths (maponpaths f) s).
    - exact (λ x, idpath (idpath (f x))).
    - exact (λ _ _ _ p q, !(maponpathscomp0 f p q)).
  Defined.

  Definition ap_functor_laws
    : psfunctor_laws ap_functor_data.
  Proof.
    repeat split.
    - intros x y p₁ p₂ p₃ s₁ s₂ ; cbn in *.
      exact (maponpathscomp0 (maponpaths f) s₁ s₂).
    - intros x y p ; cbn in *.
      induction p ; cbn.
      reflexivity.
    - intros x y p ; cbn in *.
      induction p ; cbn.
      reflexivity.
    - intros w x y z p q r ; cbn in *.
      induction p, q, r ; cbn.
      reflexivity.
    - intros x y z p q₁ q₂ s ; cbn in *.
      induction s ; cbn.
      exact (pathscomp0rid _).
    - intros x y z p₁ p₂ q s ; cbn in *.
      induction s ; cbn.
      exact (pathscomp0rid _).
  Qed.

  Definition ap_psfunctor
    : psfunctor (fundamental_bigroupoid X HX) (fundamental_bigroupoid Y HY).
  Proof.
    use make_psfunctor.
    - exact ap_functor_data.
    - exact ap_functor_laws.
    - split.
      + intros a.
        exact (fundamental_groupoid_2cell_iso Y HY (idpath(idpath (f a)))).
      + intros a b c p q.
        exact (fundamental_groupoid_2cell_iso Y HY (!(maponpathscomp0 f p q))).
  Defined.
End ApFunctor.