Require Import Arith.
Require Import Lists.List.
Require Import Coq.Relations.Relations.
Require Coq.Vectors.Vector.
Import Vector.VectorNotations.
Require Coq.Vectors.Fin.
Require Import Coq.Logic.Eqdep_dec.
Require Import Coq.Arith.Peano_dec.
Require Import Coq.Structures.Orders.
Require Import Program.

Hint Immediate eq_nat_dec.

Tactic Notation "solve_by_inversion_step" tactic(t) :=
  match goal with
    | H : _ |- _ => solve [ inversion H; subst; t ]
  end
    || fail "because the goal is not solvable by inversion.".

Tactic Notation "solve" "by" "inversion" "1" :=
  solve_by_inversion_step idtac.
Tactic Notation "solve" "by" "inversion" "2" :=
  solve_by_inversion_step (solve by inversion 1).
Tactic Notation "solve" "by" "inversion" "3" :=
  solve_by_inversion_step (solve by inversion 2).
Tactic Notation "solve" "by" "inversion" :=
  solve by inversion 1.

Theorem Forall_app : forall A (R : A -> Prop) l1 l2,
                       Forall R l1 -> Forall R l2 -> Forall R (l1 ++ l2).
Proof.
  induction l1; simpl; intros.
  auto.
  inversion H; constructor; auto.
Qed.

Notation "'sigma' x .. y ',' p" := (sigT (fun x => .. (sigT (fun y => p)) ..))
                                     (at level 180, x binder, right associativity)
                                   : type_scope.

Lemma fin_case :
  forall n (P : Fin.t (S n) -> Type),
    (P Fin.F1) ->
    (forall x, P (Fin.FS x)) ->
    (forall x, P x).
Proof.
  intros.
  refine (match x as x' in Fin.t n'
                return forall pf : n' = S n,
                         eq_rect n' Fin.t x' (S n) pf = x ->
                         P x with
            | Fin.F1 _ => _
            | Fin.FS _ _ => _
          end eq_refl _).
  - intros.
    inversion pf.
    subst.
    rewrite <- Eqdep_dec.eq_rect_eq_dec by apply eq_nat_dec.
    auto.
  - intros.
    inversion pf.
    subst.
    rewrite <- Eqdep_dec.eq_rect_eq_dec by apply eq_nat_dec.
    auto.
  - rewrite <- Eqdep_dec.eq_rect_eq_dec by apply eq_nat_dec.
    reflexivity.
Qed.

Ltac fin_dep_destruct v :=
  pattern v; apply fin_case; clear v; intros.

Ltac finite :=
  let rec finite' n x :=
      match n with
        | S ?n_ =>
          let x' := fresh "x" in
          pattern x; apply fin_case; [clear x | clear x; intros x'; finite' n_ x']
        | O => pattern x; apply Fin.case0
      end
  in
  match goal with
    | [ |- forall (x : Fin.t ?n), _ ] =>
      intros x; finite' n x
  end.

Lemma eq_fin_dec : forall {n} (f f' : Fin.t n), {f = f'} + {f <> f'}.
Proof.
  induction n; intros.
  apply Fin.case0; auto.
  fin_dep_destruct f; fin_dep_destruct f';
  try (right; intro; solve by inversion).
  left; auto.
  specialize (IHn x x0).
  destruct IHn.
  left; f_equal; auto.
  right. intro. inversion H. apply inj_pair2_eq_dec in H1. auto. auto.
Qed.

Hint Immediate eq_fin_dec.

Lemma eq_vector_dec_ind : forall {n A} (v v' : Vector.t A n), (forall i t, {v[@i] = t} + {v[@i] <> t}) -> {v = v'} + {v <> v'}.
Proof.
  induction n; dependent destruction v; dependent destruction v'; intros.
  left; auto.
  assert (forall (i : Fin.t n) (t : A), {v[@i] = t} + {v[@i] <> t}).
  intros.
  specialize (X (Fin.FS i) t); auto.
  specialize (IHn _ v v' X0).
  specialize (X Fin.F1 h0); simpl in X.
  destruct IHn; destruct X; subst;
  try (left; auto; fail).
  right; intro; inversion H; auto.
  right; intro; inversion H; auto; apply inj_pair2_eq_dec in H1; auto.
  right; intro; inversion H; auto; apply inj_pair2_eq_dec in H1; auto.
Qed.

Lemma eq_vector_dec : forall {n A} (P : forall (t t' : A), {t = t'} + {t <> t'}) (v v' : Vector.t A n), {v = v'} + {v <> v'}.
Proof.
  intros. apply eq_vector_dec_ind.
  intros. apply P.
Qed.

Hint Immediate eq_vector_dec.

Ltac simpl_exist :=
  repeat (
      repeat match goal with
               | [ H : existT _ _ _ = existT _ _ _ |- _] =>
                 (apply inj_pair2_eq_dec in H; [|eauto using eq_vector_dec; fail])
               | [ H : existT _ _ _ = existT _ _ _, _ : existT _ _ _ = existT _ _ _ |- _] =>
                 (apply inj_pair2_eq_dec in H; [|eauto using eq_vector_dec; fail])
               | [ H : existT _ _ _ = existT _ _ _, _ : existT _ _ _ = existT _ _ _, _ : existT _ _ _ = existT _ _ _ |- _] =>
                 (apply inj_pair2_eq_dec in H; [|eauto using eq_vector_dec; fail])
             end;
      subst; clear_dups
    ).

Lemma lift_fin_inj : forall {n} m (i : Fin.t n) j,
                       Fin.R m i = Fin.R m j -> i = j.
Proof.
  induction m; intros; simpl in H; auto.
  inversion H. apply inj_pair2_eq_dec in H1; eauto.
Qed.

Lemma vector_map_map : forall {n A B C} (f : B->C) (g:A->B) (v : Vector.t A n),
                         Vector.map f (Vector.map g v) = Vector.map (fun x => f (g x)) v.
Proof.
  induction v; auto.
  simpl. f_equal. auto.
Qed.

Lemma vector_map_inj : forall {n A B} (f : A -> B) (v v' : Vector.t A n)
                       (P : forall i t', f v[@i] = f t' -> v[@i] = t'),
                         Vector.map f v = Vector.map f v' -> v = v'.
Proof.
  induction v; intros; dependent destruction v'; auto.
  intros. f_equal.
  inversion H. specialize (P Fin.F1 h0). auto.
  assert (forall (i : Fin.t n) (t' : A), f v[@i] = f t' -> v[@i] = t').
  intros. specialize (P (Fin.FS i) t'). simpl in P. auto.
  specialize (IHv v' H0).
  inversion H. apply inj_pair2_eq_dec in H3; auto.
Qed.

Lemma fin_compare : forall {n}, Fin.t n -> Fin.t n -> comparison.
Proof.
  intros n. induction n.
  intros. apply Fin.case0; eauto.
  intros x y. fin_dep_destruct x; fin_dep_destruct y.
  apply Eq.
  apply Lt.
  apply Gt.
  apply IHn; eauto.
Qed.

Fixpoint fin_subst {A n} (t : A) (x : Fin.t (S n)) (y : Fin.t (S n)) : A + Fin.t n :=
  match n as n' return forall pf : n' = n, A + Fin.t n with
    | O => fun _ => inl t
    | S n' => fun pf =>
                match x in Fin.t m return forall pf : m = S n,
                                            A + Fin.t n with
                  | Fin.F1 _ => fun pfx =>
                                  match y in Fin.t m return forall pf : m = S n,
                                                              A + Fin.t n with
                                    | Fin.F1 _ => fun pfy => inl t
                                    | Fin.FS m y => fun pfy => inr (eq_rect m Fin.t y _ (f_equal pred pfy))
                                  end eq_refl
                  | Fin.FS k x => fun pfx =>
                                  match y in Fin.t m return forall pf : m = S n,
                                                              A + Fin.t n with
                                    | Fin.F1 _ => fun pfy => inr (eq_rect (S n') Fin.t Fin.F1 _ pf)
                                    | Fin.FS m y => fun pfy =>
                                                      match @fin_subst A n' t
                                                                       (eq_rect k Fin.t x _ (eq_trans (f_equal pred pfx) (eq_sym pf)))
                                                                       (eq_rect m Fin.t y _ (eq_trans (f_equal pred pfy) (eq_sym pf))) with
                                                        | inl t => inl t
                                                        | inr v => inr (eq_rect (S n') Fin.t (Fin.FS v) _ pf)
                                                      end
                                  end eq_refl
                end eq_refl
  end eq_refl.

Lemma fin_subst_eq : forall n A (t : A) (x : Fin.t (S n)), fin_subst t x x = inl t.
Proof with eauto.
  induction n; intros; fin_dep_destruct x; simpl...
  rewrite IHn...
Qed.

Fixpoint lift_fin_at {n} (i : Fin.t (S n)) (x : Fin.t n) : Fin.t (S n) :=
  match i in Fin.t ni, x in Fin.t nx return forall pf : ni = S n,
                                            forall pf' : nx = n,
                                              Fin.t (S n)
  with
    | Fin.F1 _, x => fun _ _ => Fin.FS x
    | Fin.FS _ i, Fin.F1 _ => fun _ _ => Fin.F1
    | Fin.FS ni i, Fin.FS nx x =>
      fun pf pf' =>
        eq_rect (S (S nx)) Fin.t
                (Fin.R 1 (lift_fin_at (eq_rect ni Fin.t i _ (eq_trans (f_equal pred pf) (eq_sym pf'))) x))
                _ (f_equal S pf')
  end eq_refl eq_refl.

Lemma lift_fin_at_inj : forall {n} (i : Fin.t (S n)) (x y : Fin.t n),
                          lift_fin_at i x = lift_fin_at i y -> x = y.
Proof.
  induction n; intros i x y; dependent destruction i; dependent destruction x; dependent destruction y; intros; inversion H; simpl_exist; eauto; f_equal; eauto.
Qed.

Hint Immediate lift_fin_at_inj.

Lemma fin_subst_neq : forall n A (t : A) (x y : Fin.t (S n)),
                        x <> y -> exists v, fin_subst t x y = inr v /\
                                            lift_fin_at x v = y.
Proof with eauto.
  induction n; dependent destruction x; dependent destruction y; intro;
  try (exfalso; eauto; fail);
  try (eapply Fin.case0; eauto; fail);
  try (eexists; split; simpl; eauto; fail).
  assert (x <> y); [intro; subst; apply H; auto|];
  specialize (IHn _ t x y H0); destruct IHn; destruct_pairs;
  eexists; simpl; rewrite H1; rewrite <- H2; split; eauto.
Qed.

Lemma eq_fin_subst : forall n A (t t' : A) (x y : Fin.t (S n)), fin_subst t x y = inl t' -> t = t'.
Proof with eauto.
  dependent induction n; intros;
  dependent destruction x; dependent destruction y;
  try (inversion H; auto).
  destruct (fin_subst t x y) eqn:H2; inversion H; inversion H1; subst...
Qed.

Ltac simpl_forall_list :=
  repeat match goal with
           | [ H : Forall _ ?l |- _ ] => is_list_constr l; inversion_clear H
           | _ => idtac
         end.

Module Type TermDef.
  Parameter symbol : Type.
  Parameter eq_symbol_dec : forall (s s' : symbol), {s = s'} + {s <> s'}.
  Hint Immediate eq_symbol_dec.
  Parameter arity : symbol -> nat.
End TermDef.

Module Expr (T : TermDef).
  Import T.
  Export T.

  Inductive term : nat -> Type :=
  | t_var : forall {n}, Fin.t n -> term n
  | t_term : forall {n} (s : symbol), Vector.t (term n) (arity s) -> term n
  .

  Definition termRect :=
      fun (P : forall n : nat, term n -> Type)
          (f : forall (n : nat) (t : Fin.t n), P n (@t_var n t))
          (f0 : forall (n : nat) (s : symbol) (t : Vector.t (term n) (arity s)),
                  (forall i, P n (Vector.nth t i)) -> P n (t_term s t)) =>
        fix F (n : nat) (t : term n) {struct t} : P n t :=
    match t as t0 in (term n0) return (P n0 t0) with
      | t_var n0 t0 => f n0 t0
      | t_term n0 s t0 => f0 n0 s t0 (fun i => F n0 (Vector.nth t0 i))
    end.

  Theorem eq_term_dec : forall {n} (t t' : term n), {t = t'} + {t <> t'}.
  Proof.
    intro. induction t using termRect; intros;
    destruct t'; try (right; intro; solve by inversion).
    assert (H := eq_fin_dec t t0).
    destruct H; subst.
    left; auto.
    right; intro; inversion H; simpl_exist; auto.
    assert (H := eq_symbol_dec s s0).
    destruct H; subst.
    assert (H := eq_vector_dec_ind t t0 X).
    destruct H; subst.
    left; auto.
    right; intro; inversion H; simpl_exist; auto.
    right; intro; inversion H; simpl_exist; auto.
  Qed.

  Hint Immediate eq_term_dec.

  Fixpoint lift_term {n} (t : term n) : term (S n) :=
    match t with
      | t_var _ j => t_var (Fin.R 1 j)
      | t_term _ s ts => t_term s (Vector.map lift_term ts)
    end.

  Fixpoint lift_term_by {n} i (t : term n) : term (i + n) :=
    match i with
      | 0 => t
      | S i => lift_term (lift_term_by i t)
    end.

  Theorem lift_term_inj : forall {n} (t t' : term n),
                            lift_term t = lift_term t' -> t = t'.
  Proof.
    induction t using termRect; intros t' H0; destruct t';
    simpl in H0; try (solve by inversion); inversion H0; simpl_exist; auto.
    apply vector_map_inj in H3; subst; auto.
  Qed.

  Hint Immediate lift_term_inj.

  Inductive type : nat -> Type :=
  | ty_term : forall {n : nat}, term n -> type n
  | ty_arrow : forall {n : nat}, type n -> type n -> type n
  | ty_forall : forall {n : nat}, type (S n) -> type n
  | ty_exists : forall {n : nat}, type (S n) -> type n
  | ty_bottom : forall {n : nat}, type n
  | ty_copair : forall {n : nat}, type n -> type n -> type n
  | ty_top : forall {n : nat}, type n
  | ty_pair : forall {n : nat}, type n -> type n -> type n
  .

  Ltac lift_dec_eq :=
    match goal with
      | [ |- { ?a ?b = ?a ?b' } + { ?a ?b <> ?a ?b' } ] =>
        let H := fresh "H" in
        let H0 := fresh "H" in
        assert (H : {b = b'} + {b <> b'});
          [ auto
          | destruct H;
            [ left; subst; auto
            | right; unfold not; intros H0; inversion H0; simpl_exist; auto
            ]
          ]
      | [ |- { ?a ?b ?c = ?a ?b' ?c' } + { ?a ?b ?c <> ?a ?b' ?c' } ] =>
        let H := fresh "H" in
        let H0 := fresh "H" in
        let H1 := fresh "H" in
        assert (H : {b = b'} + {b <> b'});
          [ auto
          | assert (H0 : {c = c'} + {c <> c'});
            [ auto
            | destruct H;
              [ destruct H0;
                [ left; subst; auto
                | right; unfold not; intros H1; inversion H1; simpl_exist; auto
                ]
              | right; unfold not; intros H1; inversion H1; simpl_exist; auto
              ]
            ]
          ]
      | [ |- { ?a ?b ?c ?d = ?a ?b' ?c' ?d' } + { ?a ?b ?c ?d <> ?a ?b' ?c' ?d' } ] =>
        let H := fresh "H" in
        let H0 := fresh "H" in
        let H1 := fresh "H" in
        let H2 := fresh "H" in
        assert (H : {b = b'} + {b <> b'});
          [ auto
          | assert (H0 : {c = c'} + {c <> c'});
            [ auto
            | assert (H1 : {d = d'} + {d <> d'});
              [ auto
              | destruct H;
                [ destruct H0;
                  [ destruct H1;
                    [ left; subst; auto
                    | right; unfold not; intros H2; inversion H2; simpl_exist; auto
                    ]
                  | right; unfold not; intros H2; inversion H2; simpl_exist; auto
                  ]
                | right; unfold not; intros H2; inversion H2; simpl_exist; auto
                ]
              ]
            ]
          ]
    end.

  Theorem eq_type_dec : forall {n} (t t' : type n), {t = t'} + {t <> t'}.
  Proof.
    intro. induction t; destruct t';
           try (right; intro; solve by inversion);
           try (lift_dec_eq).
  Qed.

  Hint Immediate eq_type_dec.

  Fixpoint lift_type {n} (t : type n) : type (S n) :=
  match t with
    | ty_term _ t => ty_term (lift_term t)
    | ty_arrow _ a b => ty_arrow (lift_type a) (lift_type b)
    | ty_forall _ a => ty_forall (lift_type a)
    | ty_exists _ a => ty_exists (lift_type a)
    | ty_copair _ a b => ty_copair (lift_type a) (lift_type b)
    | ty_bottom _ => ty_bottom
    | ty_pair _ a b => ty_pair (lift_type a) (lift_type b)
    | ty_top _ => ty_top
  end.

  Fixpoint lift_type_by {n} i (t : type n) : type (i + n) :=
    match i with
      | 0 => t
      | S i => lift_type (lift_type_by i t)
    end.

  Theorem lift_type_inj : forall {n} (t t' : type n),
                            lift_type t = lift_type t' -> t = t'.
  Proof.
    induction t; intros t' H; dependent destruction t'; inversion H; simpl_exist; f_equal; auto.
  Qed.

  Hint Immediate lift_type_inj.

  Fixpoint term_subst {n} (i : Fin.t (S n)) (t : term n) (u : term (S n)) : term n :=
    match u as u' in term n' return forall pf : n' = S n,
                                      term n
    with
      | t_var n' j => fun pf =>
                       match fin_subst t i (eq_rect n' Fin.t j _ pf) with
                         | inl t => t
                         | inr v => t_var v
                       end
      | t_term n' s ts => fun pf => t_term s (Vector.map (term_subst i t)
                                                         (eq_rect n' (fun i => Vector.t (term i) _) ts _ pf)
                                             )
    end eq_refl.

  Fixpoint type_subst {n} (i : Fin.t (S n)) (t : term n) (u : type (S n)) : type n :=
    match u as u' in type n' return forall pf : n' = S n,
                                      type n
    with
      | ty_term n' a => fun pf => ty_term (term_subst i t (eq_rect n' term a _ pf))
      | ty_arrow n' a b => fun pf => ty_arrow (type_subst i t (eq_rect n' type a _ pf)) (type_subst i t (eq_rect n' type b _ pf))
      | ty_forall n' a => fun pf => ty_forall (type_subst (Fin.R 1 i) (lift_term t) (eq_rect (S n') type a _ (f_equal S pf)))
      | ty_exists n' a => fun pf => ty_exists (type_subst (Fin.R 1 i) (lift_term t) (eq_rect (S n') type a _ (f_equal S pf)))
      | ty_copair n' a b => fun pf => ty_copair (type_subst i t (eq_rect n' type a _ pf)) (type_subst i t (eq_rect n' type b _ pf))
      | ty_bottom _ => fun pf => ty_bottom
      | ty_pair n' a b => fun pf => ty_pair (type_subst i t (eq_rect n' type a _ pf)) (type_subst i t (eq_rect n' type b _ pf))
      | ty_top _ => fun pf => ty_top
    end eq_refl.

    Inductive exp : nat -> nat -> Type :=
    | e_var : forall {n m : nat}, Fin.t n -> exp n m
    | e_app : forall {n m : nat}, exp n m -> exp n m -> exp n m
    | e_forall : forall {n m : nat}, exp n (S m) -> exp n m
    | e_exists : forall {n m : nat}, term m -> exp n m -> exp n m
    | e_ecase : forall {n m : nat}, exp n m -> exp (S n) (S m) -> exp n m
    | e_abs : forall {n m : nat}, exp (S n) m -> exp n m
    | e_tapp : forall {n m : nat}, exp n m -> term m -> exp n m
    | e_absurd : forall {n m}, exp n m -> exp n m
    | e_copair1 : forall {n m}, exp n m -> exp n m
    | e_copair2 : forall {n m}, exp n m -> exp n m
    | e_case : forall {n m}, exp n m -> exp (S n) m -> exp (S n) m -> exp n m
    | e_tt : forall {n m}, exp n m
    | e_pair : forall {n m}, exp n m -> exp n m -> exp n m
    | e_pair1 : forall {n m}, exp n m -> exp n m
    | e_pair2 : forall {n m}, exp n m -> exp n m
    .

    Theorem eq_exp_dec : forall {n m} (e e' : exp n m), {e = e'} + {e <> e'}.
    Proof.
      intros n m. induction e; destruct e';
                  try (right; intro; solve by inversion);
                  try (lift_dec_eq).
    Qed.

    Hint Immediate eq_exp_dec.

  Definition sub_exp {n m} (t : exp n m) : list (exp n m) :=
  match t with
    | e_var _ _ j => nil
    | e_app _ _ a b => cons a (cons b nil)
    | e_forall _ _ a => nil
    | e_exists _ _ a b => nil
    | e_ecase _ _ a b => nil
    | e_abs _ _ a => nil
    | e_tapp _ _ a b => nil
    | e_absurd _ _ a => cons a nil
    | e_copair1 _ _ a => cons a nil
    | e_copair2 _ _ a => cons a nil
    | e_case _ _ a b c => cons a nil
    | e_tt _ _ => nil
    | e_pair _ _ a b => cons a (cons b nil)
    | e_pair1 _ _ a => cons a nil
    | e_pair2 _ _ a => cons a nil
  end.

  Fixpoint lift_exp_at {n m} (i : Fin.t (S n)) (t : exp n m) : exp (S n) m :=
    match t in exp n' m' return Fin.t (S n') -> exp (S n') m'
    with
    | e_var _ _ j => fun i => e_var (lift_fin_at i j)
    | e_app _ _ a b => fun i => e_app (lift_exp_at i a) (lift_exp_at i b)
    | e_forall _ _ a => fun i => e_forall (lift_exp_at i a)
    | e_exists _ _ a b => fun i => e_exists a (lift_exp_at i b)
    | e_ecase _ _ a b => fun i => e_ecase (lift_exp_at i a) (lift_exp_at (Fin.FS i) b)
    | e_abs _ _ a => fun i => e_abs (lift_exp_at (Fin.FS i) a)
    | e_tapp _ _ a b => fun i => e_tapp (lift_exp_at i a) b
    | e_absurd _ _ a => fun i => e_absurd (lift_exp_at i a)
    | e_copair1 _ _ a => fun i => e_copair1 (lift_exp_at i a)
    | e_copair2 _ _ a => fun i => e_copair2 (lift_exp_at i a)
    | e_case _ _ a b c => fun i => e_case (lift_exp_at i a) (lift_exp_at (Fin.FS i) b) (lift_exp_at (Fin.FS i) c)
    | e_tt _ _ => fun i => e_tt
    | e_pair _ _ a b => fun i => e_pair (lift_exp_at i a) (lift_exp_at i b)
    | e_pair1 _ _ a => fun i => e_pair1 (lift_exp_at i a)
    | e_pair2 _ _ a => fun i => e_pair2 (lift_exp_at i a)
    end i.

  Definition lift_exp_n {n m} := @lift_exp_at n m Fin.F1.
  Hint Unfold lift_exp_n.

  Fixpoint lift_exp {n m} (t : exp n m) : exp n (S m) :=
  match t with
    | e_var _ _ j => e_var j
    | e_app _ _ a b => e_app (lift_exp a) (lift_exp b)
    | e_forall _ _ a => e_forall (lift_exp a)
    | e_exists _ _ a b => e_exists (lift_term a) (lift_exp b)
    | e_ecase _ _ a b => e_ecase (lift_exp a) (lift_exp b)
    | e_abs _ _ a => e_abs (lift_exp a)
    | e_tapp _ _ a b => e_tapp (lift_exp a) (lift_term b)
    | e_absurd _ _ a => e_absurd (lift_exp a)
    | e_copair1 _ _ a => e_copair1 (lift_exp a)
    | e_copair2 _ _ a => e_copair2 (lift_exp a)
    | e_case _ _ a b c => e_case (lift_exp a) (lift_exp b) (lift_exp c)
    | e_tt _ _ => e_tt
    | e_pair _ _ a b => e_pair (lift_exp a) (lift_exp b)
    | e_pair1 _ _ a => e_pair1 (lift_exp a)
    | e_pair2 _ _ a => e_pair2 (lift_exp a)
  end.

    Fixpoint exp_subst {n m} (i : Fin.t (S n)) (t : exp n m) (u : exp (S n) m) : exp n m :=
      let eq_rect_exp {n m n' m'} (pf : n' = S n) (pf' : m' = m) x :=
          eq_rect n' (fun i => exp i m) (eq_rect m' (fun i => exp n' i) x _ pf') _ pf
      in
      match u as u' in exp n' m' return forall pf : n' = S n,
                                        forall pf' : m' = m,
                                          exp n m
      with
        | e_var n' _ j => fun pf _ =>
                            match fin_subst t i (eq_rect n' Fin.t j _ pf) with
                              | inl t => t
                              | inr v => e_var v
                            end
        | e_app _ _ a b => fun pf pf' => e_app (exp_subst i t (eq_rect_exp pf pf' a)) (exp_subst i t (eq_rect_exp pf pf' b))
        | e_forall _ _ a => fun pf pf' => e_forall (exp_subst i (lift_exp t) (eq_rect_exp pf (f_equal S pf') a))
        | e_exists _ m' a b => fun pf pf' => e_exists (eq_rect m' term a _ pf') (exp_subst i t (eq_rect_exp pf pf' b))
        | e_ecase _ _ a b => fun pf pf' => e_ecase (exp_subst i t (eq_rect_exp pf pf' a)) (exp_subst (Fin.FS i) (lift_exp_n (lift_exp t)) (eq_rect_exp (f_equal S pf) (f_equal S pf') b))
        | e_abs _ _ a => fun pf pf' => e_abs (exp_subst (Fin.FS i) (lift_exp_n t) (eq_rect_exp (f_equal S pf) pf' a))
        | e_tapp _ _ a b => fun pf pf' => e_tapp (exp_subst i t (eq_rect_exp pf pf' a)) (eq_rect _ _ b _ pf')
        | e_absurd _ _ a => fun pf pf' => e_absurd (exp_subst i t (eq_rect_exp pf pf' a))
        | e_copair1 _ _ a => fun pf pf' => e_copair1 (exp_subst i t (eq_rect_exp pf pf' a))
        | e_copair2 _ _ a => fun pf pf' => e_copair2 (exp_subst i t (eq_rect_exp pf pf' a))
        | e_case _ _ a b c => fun pf pf' => e_case
                                              (exp_subst i t (eq_rect_exp pf pf' a))
                                              (exp_subst (Fin.FS i) (lift_exp_n t) (eq_rect_exp (f_equal S pf) pf' b))
                                              (exp_subst (Fin.FS i) (lift_exp_n t) (eq_rect_exp (f_equal S pf) pf' c))
        | e_tt _ _ => fun _ _ => e_tt
        | e_pair _ _ a b => fun pf pf' => e_pair (exp_subst i t (eq_rect_exp pf pf' a)) (exp_subst i t (eq_rect_exp pf pf' b))
        | e_pair1 _ _ a => fun pf pf' => e_pair1 (exp_subst i t (eq_rect_exp pf pf' a))
        | e_pair2 _ _ a => fun pf pf' => e_pair2 (exp_subst i t (eq_rect_exp pf pf' a))
      end eq_refl eq_refl.

    Theorem exp_subst_eq : forall {n m} i (u : exp n m),
                             exp_subst i u (e_var i) = u.
    Proof.
      intros. simpl. rewrite fin_subst_eq. auto.
    Qed.

    Reserved Notation "a '===>' b" (at level 60).

    Fixpoint exp_subst_term {n m} (i : Fin.t (S m)) (t : term m) (u : exp n (S m)) : exp n m :=
      let eq_rect_exp {n m n' m'} (pf : n' = n) (pf' : m' = S m) (x : exp n' m') :=
          eq_rect n' (fun i => exp i (S m)) (eq_rect m' (fun i => exp n' i) x _ pf') _ pf
      in
      match u as u' in exp n' m' return forall pf : n' = n,
                                        forall pf' : m' = S m,
                                          exp n m
      with
        | e_var n' _ j => fun pf pf' => eq_rect n' (fun i => exp i m) (e_var j) _ pf
        | e_app _ _ a b => fun pf pf' => e_app (exp_subst_term i t (eq_rect_exp pf pf' a)) (exp_subst_term i t (eq_rect_exp pf pf' b))
        | e_forall _ _ a => fun pf pf' => e_forall (exp_subst_term (Fin.FS i) (lift_term t) (eq_rect_exp pf (f_equal S pf') a))
        | e_exists _ m' a b => fun pf pf' => e_exists (term_subst i t (eq_rect m' term a _ pf')) (exp_subst_term i t (eq_rect_exp pf pf' b))
        | e_ecase _ _ a b => fun pf pf' => e_ecase (exp_subst_term i t (eq_rect_exp pf pf' a)) (exp_subst_term (Fin.FS i) (lift_term t) (eq_rect_exp (f_equal S pf) (f_equal S pf') b))
        | e_abs _ _ a => fun pf pf' => e_abs (exp_subst_term i t (eq_rect_exp (f_equal S pf) pf' a))
        | e_tapp _ m' a b => fun pf pf' => e_tapp (exp_subst_term i t (eq_rect_exp pf pf' a)) (term_subst i t (eq_rect m' term b _ pf'))
        | e_absurd _ _ a => fun pf pf' => e_absurd (exp_subst_term i t (eq_rect_exp pf pf' a))
        | e_copair1 _ _ a => fun pf pf' => e_copair1 (exp_subst_term i t (eq_rect_exp pf pf' a))
        | e_copair2 _ _ a => fun pf pf' => e_copair2 (exp_subst_term i t (eq_rect_exp pf pf' a))
        | e_case _ _ a b c => fun pf pf' => e_case
                                              (exp_subst_term i t (eq_rect_exp pf pf' a))
                                              (exp_subst_term i t (eq_rect_exp (f_equal S pf) pf' b))
                                              (exp_subst_term i t (eq_rect_exp (f_equal S pf) pf' c))
        | e_tt _ _ => fun _ _ => e_tt
        | e_pair _ _ a b => fun pf pf' => e_pair (exp_subst_term i t (eq_rect_exp pf pf' a)) (exp_subst_term i t (eq_rect_exp pf pf' b))
        | e_pair1 _ _ a => fun pf pf' => e_pair1 (exp_subst_term i t (eq_rect_exp pf pf' a))
        | e_pair2 _ _ a => fun pf pf' => e_pair2 (exp_subst_term i t (eq_rect_exp pf pf' a))
      end eq_refl eq_refl.

    Reserved Notation "a '===>' b" (at level 60).

    Inductive reduction : forall {n m}, exp n m -> exp n m -> Prop :=
    | reduction_beta : forall n m (a : exp (S n) m) b, e_app (e_abs a) b ===> exp_subst Fin.F1 b a
    | reduction_forall : forall n m (a : exp n (S m)) (b : term m), reduction (e_tapp (e_forall a) b) (exp_subst_term Fin.F1 b a)
    | reduction_absurd : forall n m (a : exp n m) b, e_app (e_absurd a) b ===> e_absurd a
    | reduction_ecase : forall n m t (a : exp n m) b, e_ecase (e_exists t a) b ===> exp_subst Fin.F1 a (exp_subst_term Fin.F1 t b)
    | reduction_case1 : forall n m (a : exp n m) u v, e_case (e_copair1 a) u v ===> exp_subst Fin.F1 a u
    | reduction_case2 : forall n m (a : exp n m) u v, e_case (e_copair2 a) u v ===> exp_subst Fin.F1 a v
    | reduction_pair1 : forall n m (a : exp n m) b, e_pair1 (e_pair a b) ===> a
    | reduction_pair2 : forall n m (a : exp n m) b, e_pair2 (e_pair a b) ===> b
    | reduction_context_app_1 : forall n m (a : exp n m) b a', a ===> a' -> e_app a b ===> e_app a' b
    | reduction_context_app_2 : forall n m (b : exp n m) a b', b ===> b' -> e_app a b ===> e_app a b'
    | reduction_context_abs : forall n m (a : exp (S n) m) a', a ===> a' -> e_abs a ===> e_abs a'
    | reduction_context_forall : forall n m (a : exp n (S m)) a', a ===> a' -> e_forall a ===> e_forall a'
    | reduction_context_exists : forall n m (a : exp n m) a' t, a ===> a' -> e_exists t a ===> e_exists t a'
    | reduction_context_ecase_1 : forall n m (a : exp n m) b a', a ===> a' -> e_ecase a b ===> e_ecase a' b
    | reduction_context_ecase_2 : forall n m (a : exp n m) b b', b ===> b' -> e_ecase a b ===> e_ecase a b'
    | reduction_context_tapp : forall n m (a : exp n m) a' t, a ===> a' -> e_tapp a t ===> e_tapp a' t
    | reduction_context_absurd : forall n m (a : exp n m) a', a ===> a' -> e_absurd a ===> e_absurd a'
    | reduction_context_case_1 : forall n m (a : exp n m) b c a', a ===> a' -> e_case a b c ===> e_case a' b c
    | reduction_context_case_2 : forall n m (a : exp n m) b c b', b ===> b' -> e_case a b c ===> e_case a b' c
    | reduction_context_case_3 : forall n m (a : exp n m) b c c', c ===> c' -> e_case a b c ===> e_case a b c'
    | reduction_context_copair1 : forall n m (a : exp n m) a', a ===> a' -> e_copair1 a ===> e_copair1 a'
    | reduction_context_copair2 : forall n m (a : exp n m) a', a ===> a' -> e_copair2 a ===> e_copair2 a'
    | reduction_context_pair_1 : forall n m (a : exp n m) b a', a ===> a' -> e_pair a b ===> e_pair a' b
    | reduction_context_pair_2 : forall n m (a : exp n m) b b', b ===> b' -> e_pair a b ===> e_pair a b'
    | reduction_context_pair1 : forall n m (a : exp n m) a', a ===> a' -> e_pair1 a ===> e_pair1 a'
    | reduction_context_pair2 : forall n m (a : exp n m) a', a ===> a' -> e_pair2 a ===> e_pair2 a'
    (* | reduction_trans : forall n m (a : exp n m) b c, a ===> b -> b ===> c -> a ===> c *)
    where "a '===>' b" := (@reduction _ _ a b)
    .

    Definition nf {n m} (e : exp n m) := forall e', e ===> e' -> False.

    Theorem nf_sub_exp : forall {n m} (e : exp n m), nf e -> Forall nf (sub_exp e).
    Proof.
      unfold nf; intros.
      destruct e; simpl; repeat constructor; intros e' He;
      eapply H; try (constructor; eauto; fail).
      eapply reduction_context_app_2; eauto.
      eapply reduction_context_pair_2; eauto.
    Qed.

    Inductive nfview : forall {n m}, exp n m -> Prop :=
    | nfv_unknown : forall n m (e : exp n m) (ns : list (exp n m)),
                      Forall nfview ns -> nfview_unknown e ->
                      nfview (fold_right (fun a b => e_app b a) e ns)
    | nfv_abs : forall n m (e : exp (S n) m),
                  nfview e -> nfview (e_abs e)
    | nfv_absurd : forall n m (e : exp n m),
                  nfview e -> nfview (e_absurd e)
    with nfview_unknown : forall {n m}, exp n m -> Prop :=
         | nfv_var : forall n m (i : Fin.t n), @nfview_unknown _ m (e_var i)
         | nfv_forall : forall n m (e : exp n (S m)),
                          nfview e -> nfview_unknown (e_forall e)
         | nfv_exists : forall n m t (e : exp n m),
                          nfview e -> nfview_unknown (e_exists t e)
         | nfv_ecase : forall n m (a : exp n m) (b : exp (S n) (S m)),
                         (forall x y, a = e_exists x y -> False) ->
                         nfview a -> nfview b -> nfview_unknown (e_ecase a b)
         | nfv_tapp : forall n m (a : exp n m) t,
                        (forall x, a = e_forall x -> False) ->
                        nfview a -> nfview_unknown (e_tapp a t)
         | nfv_copair1 : forall n m (a : exp n m),
                           nfview a -> nfview_unknown (e_copair1 a)
         | nfv_copair2 : forall n m (a : exp n m),
                           nfview a -> nfview_unknown (e_copair2 a)
         | nfv_case : forall n m (a : exp n m) b c,
                        (forall x, a = e_copair1 x -> False) ->
                        (forall x, a = e_copair2 x -> False) ->
                        nfview a -> nfview b -> nfview c -> nfview_unknown (e_case a b c)
         | nfv_tt : forall n m, @nfview_unknown n m e_tt
         | nfv_pair : forall n m (a : exp n m) b,
                        nfview a -> nfview b -> nfview_unknown (e_pair a b)
         | nfv_pair1 : forall n m (a : exp n m),
                         (forall x y, a = e_pair x y -> False) ->
                         nfview a -> nfview_unknown (e_pair1 a)
         | nfv_pair2 : forall n m (a : exp n m),
                         (forall x y, a = e_pair x y -> False) ->
                         nfview a -> nfview_unknown (e_pair2 a)
    .

    Ltac nf_nfview_helper p :=
      match goal with
        | [ IH : nf ?e -> nfview ?e |- nfview ?e ] =>
          let e := fresh "e" in
          let H := fresh "H" in
          apply IH; intros e H; exfalso; eapply p; constructor (solve [eauto])
      end.

    Theorem nf_nfview : forall n m (e : exp n m), nf e -> nfview e.
    Proof with eauto; try (constructor; eauto; fail).
      intros n m e. set (e0 := e).
      dependent induction e; intro p;
      assert (A := nf_sub_exp e0 p); subst e0; simpl in A; simpl_forall_list;
      repeat match goal with
                 [ A : nf ?e -> nfview ?e, B : nf ?e |- _ ] => apply A in B
             end;
      try (apply nfv_unknown with (ns:=nil); eauto; constructor; eauto;
           try (nf_nfview_helper p; fail);
           try (intros; subst; eapply p; constructor);
           fail);
      try (constructor (solve [eauto; nf_nfview_helper p]); fail).
      + destruct H; try (exfalso; eapply p; constructor; fail).
        apply nfv_unknown with (e:=e) (ns:=cons e2 ns)...
    Qed.

    Theorem nfview_nf : forall n m (e : exp n m), (nfview e -> nf e) /\ (nfview_unknown e -> nf e).
    Proof with eauto.
      intros n m e; set (e0 := e); dependent induction e;
      (assert (S2 : nfview_unknown e0 -> nf e0);
      [ subst e0; intro;
        destruct_pairs;
        try (intros e' H'; inversion H'; fail);
        inversion H; simpl_exist; subst; eauto
      | split; [|exact S2]; subst e0; intro;
        destruct_pairs;
        inversion H; simpl_exist; subst;
        try (match goal with
                 [ H : fold_right _ _ _ = _ |- _ ] => destruct ns; [ simpl in H; subst; auto
                                                                   | solve by inversion
                                                                   ]
             end; fail)
      ]); try (intros e' H'; inversion H'; simpl_exist; subst; eauto;
               match goal with
                 | [ H : nfview ?e -> nf ?e, _ : ?e ===> _ |- _ ] => unfold nf in H; eapply H; eauto
               end; fail
              ).
      + destruct ns; simpl in H4; subst; [ solve by inversion |].
        destruct ns; simpl in H4; inversion H4; simpl_exist; subst.
        * simpl_forall_list.
          intros e' H'; inversion H'; simpl_exist; subst.
          inversion H8.
          inversion H8.
          unfold nf in H3; eapply H3; eauto.
          unfold nf in H0; eapply H0; eauto.
        * simpl_forall_list.
          intros e' H'; inversion H'; simpl_exist; subst.
          unfold nf in H2; eapply H2... apply nfv_unknown with (e:=e) (ns:=cons e3 ns)...
          unfold nf in H0; eapply H0; eauto.
    Qed.

    Theorem nfview_app : forall {n m} (a b : exp n m), nfview (e_app a b) -> nfview a.
    Proof.
      intros.
      apply nfview_nf in H.
      apply nf_nfview. intro. intros. eapply H. eapply reduction_context_app_1. eauto.
    Qed.

End Expr.

Module Type TermCongruence (T : TermDef).
  Module E := Expr(T).
  Import E.
  Export E.
  Parameter cong : forall {n}, type n -> type n -> Prop.
End TermCongruence.

Module NJ (T : TermDef) (TC : TermCongruence(T)).
  Import TC.
  Export TC.
  Reserved Notation "x '≡' y" (at level 40).

  Inductive type_equiv : forall {n : nat}, relation (type n) :=
  | te_context_var : forall {n} {i}, @ty_term n (t_var i) ≡ ty_term (t_var i)
  | te_context_term : forall {n} {s : symbol} xs ys,
                        (forall i, @ty_term n (Vector.nth xs i) ≡ ty_term (Vector.nth ys i)) ->
                        ty_term (t_term s xs) ≡ ty_term (t_term s ys)
  | te_context_arrow : forall {n} {x y z t : type n},
                         x ≡ y ->
                         z ≡ t ->
                         ty_arrow x z ≡ ty_arrow y t
  | te_context_forall : forall {n} {x y : type (S n)},
                          x ≡ y ->
                          ty_forall x ≡ ty_forall y
  | te_context_exists : forall {n} {x y : type (S n)},
                          x ≡ y ->
                          ty_exists x ≡ ty_exists y
  | te_context_bottom : forall {n}, @ty_bottom n ≡ ty_bottom
  | te_context_copair : forall {n} {x y z t : type n},
                         x ≡ y ->
                         z ≡ t ->
                         ty_copair x z ≡ ty_copair y t
  | te_context_top : forall {n}, @ty_top n ≡ ty_top
  | te_context_pair : forall {n} {x y z t : type n},
                         x ≡ y ->
                         z ≡ t ->
                         ty_pair x z ≡ ty_pair y t
  | te_sym : forall {n} {x y : type n}, x ≡ y -> y ≡ x
  | te_trans : forall {n} {x y z : type n}, x ≡ y -> y ≡ z -> x ≡ z
  | te_term : forall {n} {x y : type n},
                cong x y -> x ≡ y
  | te_subst : forall {n i t} {x y : type (S n)},
                      x ≡ y -> type_subst i t x ≡ type_subst i t y
  | te_lift : forall {n} {x y : type n},
                x ≡ y -> lift_type x ≡ lift_type y
  where "x '≡' y" := (type_equiv x y).

  Theorem te_refl : forall {n : nat} (x : type n), x ≡ x.
  Proof.
    assert (forall n (t : term n), ty_term t ≡ ty_term t).
    induction t using termRect; constructor; eauto.
    induction x; try (constructor; eauto; fail).
  Qed.

  Definition liftΓ {n m} (Γ : Vector.t (type m) n) : Vector.t (type (S m)) n := Vector.map lift_type Γ.

  Theorem liftΓ_inj : forall {n m} (Γ1 Γ2 : Vector.t (type m) n),
                        liftΓ Γ1 = liftΓ Γ2 -> Γ1 = Γ2.
  Proof.
    induction Γ1; intros; dependent destruction Γ2; auto.
    simpl in H. inversion H. f_equal; simpl_exist; auto.
  Qed.

  Hint Immediate liftΓ_inj.

  Reserved Notation "Γ '⊢' t '∈' ty" (at level 40).

  Inductive has_type : forall {n m : nat}, Vector.t (type m) n -> exp n m -> type m -> Prop :=
  | p_var : forall {n m} {Γ : Vector.t (type m) n} i ty,
              ty ≡ Vector.nth Γ i -> Γ ⊢ e_var i ∈ ty
  | p_app : forall {n m} {Γ : Vector.t (type m) n} {u v s t ty},
            Γ ⊢ u ∈ ty_arrow s t ->
            Γ ⊢ v ∈ s ->
            ty ≡ t -> Γ ⊢ e_app u v ∈ ty
  | p_abs : forall {n m} {Γ : Vector.t (type m) n} {e t u ty},
              (t :: Γ) ⊢ e ∈ u ->
              ty ≡ ty_arrow t u -> Γ ⊢ e_abs e ∈ ty
  | p_forall : forall {n m} {Γ : Vector.t (type m) n} {e u ty},
                 (liftΓ Γ) ⊢ e ∈ u ->
                 ty ≡ ty_forall u -> Γ ⊢ e_forall e ∈ ty
  | p_exists : forall {n m} {Γ : Vector.t (type m) n} {t u p ty},
                 Γ ⊢ u ∈ type_subst Fin.F1 t p ->
                 ty ≡ ty_exists p -> Γ ⊢ e_exists t u ∈ ty
  | p_ecase : forall {n m} {Γ : Vector.t (type m) n} {u v p q ty},
                Γ ⊢ u ∈ ty_exists p ->
                (p :: liftΓ Γ) ⊢ v ∈ lift_type q ->
                ty ≡ q -> Γ ⊢ e_ecase u v ∈ ty
  | p_copair1 : forall {n m} {Γ : Vector.t (type m) n} {u s t ty},
                  Γ ⊢ u ∈ s ->
                  ty ≡ ty_copair s t -> Γ ⊢ e_copair1 u ∈ ty
  | p_copair2 : forall {n m} {Γ : Vector.t (type m) n} {v s t ty},
                  Γ ⊢ v ∈ t ->
                  ty ≡ ty_copair s t -> Γ ⊢ e_copair2 v ∈ ty
  | p_case : forall {n m} {Γ : Vector.t (type m) n} {a b u v1 v2 t ty},
               Γ ⊢ u ∈ ty_copair a b ->
               (a :: Γ) ⊢ v1 ∈ t ->
               (b :: Γ) ⊢ v2 ∈ t ->
               ty ≡ t -> Γ ⊢ e_case u v1 v2 ∈ ty
  | p_pair : forall {n m} {Γ : Vector.t (type m) n} {u v s t ty},
               Γ ⊢ u ∈ s ->
               Γ ⊢ v ∈ t ->
               ty ≡ ty_pair s t -> Γ ⊢ e_pair u v ∈ ty
  | p_pair1 : forall {n m} {Γ : Vector.t (type m) n} {u s t ty},
                  Γ ⊢ u ∈ ty_pair s t ->
                  ty ≡ s -> Γ ⊢ e_pair1 u ∈ ty
  | p_pair2 : forall {n m} {Γ : Vector.t (type m) n} {u s t ty},
                  Γ ⊢ u ∈ ty_pair s t ->
                  ty ≡ t -> Γ ⊢ e_pair2 u ∈ ty
  | p_absurd : forall {n m} {Γ : Vector.t (type m) n} {e t ty},
                 Γ ⊢ e ∈ ty_bottom ->
                 ty ≡ t -> Γ ⊢ e_absurd e ∈ ty
  | p_tt : forall {n m} {Γ : Vector.t (type m) n} {ty},
             ty ≡ ty_top -> Γ ⊢ e_tt ∈ ty
               where "Γ '⊢' t '∈' ty" := (has_type Γ t ty).

  Theorem p_equiv : forall {n m} Γ (e : exp n m) ty ty',
                      Γ ⊢ e ∈ ty -> ty ≡ ty' -> Γ ⊢ e ∈ ty'.
  Proof.
    intros. inversion H; simpl_exist;
    econstructor (solve [eauto; eapply te_trans; eauto; eapply te_sym; eauto]).
  Qed.

  Definition is_typable {n m : nat} (e : exp n m) := sigma Γ ty, Γ ⊢ e ∈ ty.
  Definition is_provable {n : nat} (ty : type n) := sigma {e : exp O n}, [] ⊢ e ∈ ty.
  Definition is_provable_nf {n : nat} (ty : type n) := (sigma {e : exp O n}, nf e * ([] ⊢ e ∈ ty))%type.

End NJ.

Module Ex1Term <: TermDef.
  Inductive symbol_ :=
  | s_zero
  | s_succ
  | s_plus
  | s_equal
  .

  Definition symbol := symbol_.

  Theorem eq_symbol_dec : forall (s s' : symbol), {s = s'} + {s <> s'}.
  Proof.
    decide equality.
  Qed.

  Fixpoint arity s :=
    match s with
      | s_zero => 0
      | s_succ => 1
      | s_plus => 2
      | s_equal => 2
    end.
End Ex1Term.

Module Ex1Congruence <: TermCongruence(Ex1Term).
  Module E := Expr(Ex1Term).
  Import E.
  Export E.

  Inductive cong_ {n} : relation (type n) :=
  | c_0_l : forall {x}, cong_ (ty_term (t_term s_plus [t_term s_zero []; x])) (ty_term x)
  | c_S_l : forall {x y}, cong_ (ty_term (t_term s_plus [t_term s_succ [x]; y])) (ty_term (t_term s_succ [t_term s_plus [x;  y]]))
  | c_plus_sym : forall {x y}, cong_ (ty_term (t_term s_plus [x; y])) (ty_term (t_term s_plus [y; x]))
  | c_equal_sym : forall {x y}, cong_ (ty_term (t_term s_equal [x; y])) (ty_term (t_term s_equal [y; x]))
  | c_refl : forall {x}, cong_ (ty_term (t_term s_equal [x; x])) ty_top
  | c_neq_0 : forall {x}, cong_ (ty_term (t_term s_equal [t_term s_succ [x]; t_term s_zero []])) ty_bottom
  | c_S_inj : forall {x y}, cong_ (ty_term (t_term s_equal [t_term s_succ [x]; t_term s_succ [y]]))
                                  (ty_term (t_term s_equal [x; y]))
  .
  Definition cong {n} := @cong_ n.
End Ex1Congruence.

Module Ex1NJ := NJ(Ex1Term)(Ex1Congruence).

Module Q1.
  Import Ex1NJ.

  Fixpoint t_of_nat {m} n : term m :=
    match n with
      | 0 => t_term s_zero []
      | S n => t_term s_succ [t_of_nat n]
    end.

  (* TODO : generate tactic by reflection from cong ? *)
  (* TODO : generalize eapply te_context_term ? *)
  Ltac simpl_equiv :=
  autounfold;
  let rec simpl_equiv' :=
  match goal with
    | [ |- ?x ≡ ?x ] => eapply te_refl
    | [ |- ty_term (t_term s_succ [?x]) ≡ _ ] =>
        let ty := type of x in
        let x' := fresh "x" in
        evar (x':ty); apply te_context_term with (ys:=[x']);
        [subst x'; simpl; finite; simpl; simpl_equiv]
    | [ |- ty_term (t_term s_plus [t_term s_zero []; _]) ≡ _ ] =>
      eapply te_trans; [eapply te_term; [eapply c_0_l] | simpl_equiv ]
    | [ |- ty_term (t_term s_plus [t_term s_succ [_]; _]) ≡ _ ] =>
      eapply te_trans; [eapply te_term; [eapply c_S_l] | simpl_equiv ]
    | [ |- ty_term (t_term s_equal [?x; ?y]) ≡ _ ] => eapply te_trans;[
          let ty := type of x in
          let x' := fresh "x" in
          let y' := fresh "y" in
          evar (x':ty); evar (y':ty); apply te_context_term with (ys:=[x'; y']);
          [subst x'; subst y'; simpl; finite; [simpl; simpl_equiv | simpl; simpl_equiv]]
        | match goal with
            | [ |- ty_term (t_term s_equal [t_term s_succ _; t_term s_succ _]) ≡ _ ] =>
              eapply te_trans; [ eapply te_term; [eapply c_S_inj] | simpl_equiv ]
            | [ |- ty_term (t_term s_equal [?x; ?x]) ≡ _ ] =>
              eapply te_trans; [ eapply te_term; [eapply c_refl] | simpl_equiv ]
            | [ |- ty_term (t_term s_equal [t_term s_succ [_]; t_term s_zero []]) ≡ _ ] =>
              eapply te_trans; [ eapply te_term; [eapply c_neq_0] | simpl_equiv ]
            | _ => idtac
          end
        ]
    | [ |- ty_arrow _ _ ≡ ty_arrow _ _ ] => eapply te_context_arrow; [ simpl_equiv | simpl_equiv ]
    | [ |- ty_forall _ ≡ ty_forall _ ] => eapply te_context_forall; [ simpl_equiv ]
    | _ => eapply te_refl
    | _ => idtac
  end in simpl_equiv' || (eapply te_sym; simpl_equiv').

  Theorem Q1a : is_provable (@ty_term 0 (t_term s_equal [t_term s_plus [t_of_nat 2; t_of_nat 3]; t_of_nat 5])).
  Proof with eauto.
    eexists e_tt.
    constructor.
    simpl_equiv.
  Qed.

  Theorem Q1b : is_provable (@ty_forall 0 (ty_term (t_term s_equal [t_term s_plus [t_of_nat 2; t_var Fin.F1]; t_term s_plus [t_of_nat 1; t_term s_plus [t_of_nat 1; t_var Fin.F1]]]))).
  Proof with eauto.
    eexists (e_forall e_tt).
    repeat (simpl_equiv || econstructor).
  Qed.

  Theorem Q1c : is_provable (@ty_arrow 0 (ty_term (t_term s_equal [t_term s_plus [t_of_nat 1; t_of_nat 1]; t_term s_zero []])) (ty_term (t_term s_equal [t_term s_plus [t_of_nat 16; t_of_nat 64]; t_of_nat 42]))).
  Proof with eauto.
    eexists.
    eapply p_abs; [eapply p_absurd;[apply p_var with (i:=Fin.F1)|]|].
    simpl_equiv. simpl_equiv.
    eapply te_context_arrow. simpl_equiv. eapply te_refl.
  Qed.

  Theorem Q1d : is_provable (@ty_forall 0 (ty_arrow (ty_term (t_term s_equal [t_var Fin.F1; t_of_nat 2])) (ty_term (t_term s_equal [t_term s_plus [t_of_nat 1; t_var Fin.F1]; t_of_nat 3])))).
  Proof with eauto.
    eexists.
    eapply p_forall;[eapply p_abs;[apply p_var with (i:=Fin.F1)|]|];
    repeat simpl_equiv.
  Qed.

End Q1.

Module Ex2Term <: TermDef.
  Inductive symbol_ :=
  | s_zero
  | s_succ
  | s_plus
  | s_equal
  | s_n
  .
  Definition symbol := symbol_.
  Theorem eq_symbol_dec : forall (s s' : symbol), {s=s'}+{s<>s'}.
  Proof. decide equality. Qed.
  Fixpoint arity s :=
    match s with
      | s_zero => 0
      | s_succ => 1
      | s_plus => 2
      | s_equal => 2
      | s_n => 1
    end.
End Ex2Term.

Module Ex2Congruence <: TermCongruence(Ex2Term).
  Module E := Expr(Ex2Term).
  Import E.
  Export E.

  Inductive cong_ {n} : relation (type n) :=
  | c_0_l : forall {x}, cong_ (ty_term (t_term s_plus [t_term s_zero []; x])) (ty_term x)
  | c_S_l : forall {x y}, cong_ (ty_term (t_term s_plus [t_term s_succ [x]; y])) (ty_term (t_term s_succ [t_term s_plus [x;  y]]))
  | c_plus_sym : forall {x y}, cong_ (ty_term (t_term s_plus [x; y])) (ty_term (t_term s_plus [y; x]))
  | c_equal_sym : forall {x y}, cong_ (ty_term (t_term s_equal [x; y])) (ty_term (t_term s_equal [y; x]))
  | c_refl : forall {x}, cong_ (ty_term (t_term s_equal [x; x])) ty_top
  | c_neq_0 : forall {x}, cong_ (ty_term (t_term s_equal [t_term s_succ [x]; t_term s_zero []])) ty_bottom
  | c_S_inj : forall {x y}, cong_ (ty_term (t_term s_equal [t_term s_succ [x]; t_term s_succ [y]]))
                                  (ty_term (t_term s_equal [x; y]))
  | c_n : forall {x},
            cong_ (ty_term (t_term s_n [x]))
                  (ty_copair
                     (ty_term (t_term s_equal [x; t_term s_zero []]))
                     (ty_exists (ty_pair
                                   (ty_term (t_term s_equal [lift_term x; t_term s_succ [t_var Fin.F1]]))
                                   (ty_term (t_term s_n [t_var Fin.F1]))
                                )
                     )
                  )
  .

  Definition cong {n} := @cong_ n.
End Ex2Congruence.

Module Ex2NJ := NJ(Ex2Term)(Ex2Congruence).

Module Q2.
  Import Ex2NJ.

  Theorem Q2 : is_provable (@ty_forall 0 (ty_pair
                                            (ty_arrow
                                               (ty_term (t_term s_n [t_var Fin.F1]))
                                               (ty_term (t_term s_n [t_term s_succ [t_var Fin.F1]]))
                                            )
                                            (ty_arrow
                                               (ty_term (t_term s_n [t_term s_succ [t_var Fin.F1]]))
                                               (ty_term (t_term s_n [t_var Fin.F1]))
                                            )
                                         )
                           ).
  Proof.
    (* eexists. do 3 constructor; simpl. *)
    (* + eapply p_equiv; [ eapply te_sym; eapply te_term; eapply c_n *)
    (*                   | eapply p_copair2; eapply p_exists; eapply p_pair; simpl ]. *)
    (*   eapply p_equiv; [ eapply te_sym; eapply te_term; eapply c_refl | eapply p_tt ]. *)
    (*   eapply p_equiv; [ | eapply p_var with (i:=Fin.F1) ]. *)
    (*   simpl; eapply te_refl. *)
    (* + eapply p_case; [ eapply p_equiv; [| eapply p_var with (i:=Fin.F1) ] *)
    (*                  |  *)
    (*                  | eapply p_pair2; eapply p_ecase; [|] *)
    (*                  ]; simpl. *)
    (*   eapply te_term; eapply c_n. *)
    (*   eapply p_absurd; eapply p_equiv; [| eapply p_var with (i:=Fin.F1) ]. simpl; eapply te_term; eapply c_neq_0. *)
    (*   simpl. eapply p_equiv; [|eapply p_var with (i:=Fin.F1)]. simpl. eapply te_refl. *)
    (*   simpl. eapply p_equiv; [|eapply p_var with (i:=Fin.F1)]. simpl. *)
  Admitted.

End Q2.

Module Ex3Term <: TermDef.
  Inductive symbol_ :=
  | s_p
  .
  Definition symbol := symbol_.
  Theorem eq_symbol_dec : forall (s s' : symbol), {s=s'}+{s<>s'}.
  Proof. decide equality. Qed.
  Fixpoint arity s :=
    match s with
      | s_p => 0
    end.
End Ex3Term.

Module Ex3Congruence <: TermCongruence(Ex3Term).
  Module E := Expr(Ex3Term).
  Import E.
  Export E.

  Inductive cong_ {n} : relation (type n) :=
  | c_p : cong_ (ty_term (t_term s_p []))
                (ty_arrow (ty_term (t_term s_p [])) ty_bottom)
  .

  Definition cong {n} := @cong_ n.
End Ex3Congruence.

Module Ex3NJ := NJ(Ex3Term)(Ex3Congruence).

Module Q3.
  Import Ex3NJ.

  Theorem Q3 : @is_provable 0 ty_bottom.
  Proof.
    eexists.
    eapply p_app; try eapply p_abs; try eapply p_app; try eapply p_var with (i:=Fin.F1);
    simpl; try eapply te_refl.
    eapply te_context_arrow; try apply te_refl.
    eapply te_term. eapply c_p.
    eapply te_term. eapply c_p.
  Qed.

End Q3.

Module Q4(T:TermDef)(TC:TermCongruence(T)).
  Module NJ4 := NJ(T)(TC).
  Import NJ4.
  Export NJ4.

  (* TODO : better name *)
  Inductive weak_equiv {n} : type n -> type n -> Prop :=
  | we_atom_l : forall i t, weak_equiv (ty_term (t_var i)) t
  | we_atom_r : forall i t, weak_equiv t (ty_term (t_var i))
  | we_term : forall s xs ys, weak_equiv (ty_term (t_term s xs)) (ty_term (t_term s ys))
  | we_arrow : forall a b c d, weak_equiv (ty_arrow a b) (ty_arrow c d)
  | we_forall : forall a b, weak_equiv (ty_forall a) (ty_forall b)
  | we_exists : forall a b, weak_equiv (ty_exists a) (ty_exists b)
  | we_bottom : weak_equiv ty_bottom ty_bottom
  | we_copair : forall a b c d, weak_equiv (ty_copair a b) (ty_copair c d)
  | we_top : weak_equiv ty_top ty_top
  | we_pair : forall a b c d, weak_equiv (ty_pair a b) (ty_pair c d)
  .

  Definition sans_confusion := forall n p q, p ≡ q -> @weak_equiv n p q.

  Ltac simpl_fold :=
    repeat match goal with
               [ H1 : context[fold_right _ _ nil] |- _ ] => simpl in H1; subst
           end.

  Ltac simpl_nf :=
    match goal with
      | [ H : nfview _ |- _ ] =>
        inversion H; simpl_exist; subst;
        try (solve by inversion);
        match goal with
            [ H0 : Forall nfview ?ns |- _ ] =>
            destruct ns; simpl;
            [ clear H H0
            | solve by inversion
            ]; simpl_fold
        end
      | [ H : nfview _ |- _ ] =>
        inversion H; simpl_exist; subst;
        [ match goal with
              [ H0 : Forall nfview ?ns |- _ ] =>
              destruct ns; simpl_fold; solve by inversion
          end
        |]
      | [ H : nfview (e_app _ _) |- _ ] => apply nfview_app in H
    end.

  Ltac simpl_empty_nf :=
    repeat match goal with
             | [ H : ?x = ?x -> _ |- _ ] =>
               let H0 := fresh "H" in
               assert (H0 : x = x); [ reflexivity | specialize (H H0); clear H0 ]
             | [ H : 1 = 0 -> _ |- _ ] => clear H
             | [ H : 0 = 1 -> _ |- _ ] => clear H
             | [ H : ?a, H0 : ?a -> ?b |- _ ] => specialize (H0 H)
           end.

  (* Lemma empty_nf : sans_confusion -> *)
  (*                  (forall n m Γ (e : exp n m) ty (P : Γ ⊢ e ∈ ty), *)
  (*                     n = 0 -> m = 0 -> nfview e -> *)
  (*                     (forall x, e <> e_absurd x) /\ *)
  (*                     (forall x y, e <> e_app x y) /\ *)
  (*                     (forall x y, e <> e_tapp x y) /\ *)
  (*                     (forall x, e <> e_pair1 x) /\ *)
  (*                     (forall x, e <> e_pair2 x) /\ *)
  (*                     (forall x y, e <> e_ecase x y) /\ *)
  (*                     (forall x y z, e <> e_case x y z) /\ *)
  (*                     ty <> ty_bottom *)
  (*                  ). *)
  (* Proof. *)
  (*   Ltac solver := *)
  (*     match goal with *)
  (*       | [ H : sans_confusion, H0 : _ ≡ _ |- _ ] => *)
  (*         (apply H in H0; try (inversion H0; simpl_exist; subst; *)
  (*                              try (apply Fin.case0; trivial; fail); *)
  (*                              try (unfold not; intro A; inversion A; fail); *)
  (*                              fail)) *)
  (*       | [ H0 : appcontext[?x = ?x -> False] |- _ ] => (eapply H0; eauto) *)
  (*       | [ H0 : appcontext[?x _ = ?x _ -> False] |- _ ] => (eapply H0; eauto) *)
  (*       | [ H0 : appcontext[?x _ _ = ?x _ _ -> False] |- _ ] => (eapply H0; eauto) *)
  (*       | [ H0 : appcontext[?x _ _ _ = ?x _ _ _ -> False] |- _ ] => (eapply H0; eauto) *)
  (*     end. *)

  (*   intros H n m Γ e ty P. *)
  (*   induction P; intros; subst; *)
  (*   repeat constructor; *)
  (*   try (intros; unfold not; intro A; inversion A; fail); *)
  (*   try (apply Fin.case0; trivial; fail); *)
  (*   solver; unfold not in *; *)
  (*   try (exfalso; simpl_nf; try inversion H6; simpl_exist; *)
  (*        simpl_empty_nf; destruct_pairs; *)
  (*        match goal with *)
  (*          | [ P : has_type Γ _ _ |- _ ] => *)
  (*            inversion P; simpl_exist; *)
  (*          try (apply Fin.case0; trivial; fail); *)
  (*          repeat solver *)
  (*        end; fail *)
  (*       ); *)
  (*   try ( exfalso; inversion H3; simpl_exist; subst; *)
  (*         destruct ns; simpl_fold; *)
  (*         [ inversion H6 *)
  (*         | destruct ns; inversion H1; simpl_exist; subst; simpl_forall_list; *)
  (*           apply nfview_app in H3; simpl_empty_nf; destruct_pairs; *)
  (*           [ inversion H6; simpl_exist; subst; *)
  (*             try (apply Fin.case0; auto; fail); *)
  (*             try (inversion P1; simpl_exist; subst; try solver; fail); *)
  (*             try solver *)
  (*           | solver *)
  (*           ] *)
  (*         ]; fail). *)
  (* Qed. *)

  (* Theorem sans_confusion_coherent : sans_confusion -> *)
  (*                                   forall (u : exp 0 0), nf u -> [] ⊢ u ∈ ty_bottom -> False. *)
  (* Proof. *)
  (*   intros H u nf p. *)
  (*   apply nf_nfview in nf. *)
  (*   assert (P := empty_nf H _ _ _ _ _ p). *)
  (*   assert (0=0). reflexivity. *)
  (*   specialize (P H0 H0 nf). *)
  (*   destruct_pairs. *)
  (*   apply H8; auto. *)
  (* Qed. *)

End Q4.

Module Q5(T:TermDef)(TC:TermCongruence(T)).
  Module NJ5 := Q4(T)(TC).
  Import NJ5.
  Export NJ5.

  Lemma vector_nth_map : forall {n A B} (f : A -> B) (v : Vector.t A n) i,
                           (Vector.map f v)[@i] = f v[@i].
  Proof.
    intros. eapply Vector.nth_map; eauto.
  Qed.

  Lemma vector_map_id : forall {n A} (v : Vector.t A n),
                          v = Vector.map (fun x => x) v.
  Proof.
    dependent induction v; simpl; f_equal; auto.
  Qed.

  Lemma vector_map_sur {n A B} (f g : A -> B) (v : Vector.t A n) :
    (forall i, f v[@i] = g v[@i]) ->
    Vector.map f v = Vector.map g v.
  Proof.
    dependent induction v; intros; simpl; auto.
    f_equal.
    specialize (H Fin.F1). auto.
    apply IHv; intros. specialize (H (Fin.FS i)). auto.
  Qed.

  Lemma term_subst_1_lift_term : forall {n} (t : term n) t',
                                   term_subst Fin.F1 t (lift_term t') = t'.
  Proof.
    dependent induction t' using termRect.
    destruct n; auto; apply Fin.case0; auto.
    simpl; f_equal. rewrite (vector_map_id t0); repeat rewrite vector_map_map.
    apply vector_map_sur. intros; eapply H.
  Qed.

  Lemma lift_term_term_subst :
    forall {n} i (t : term n) t',
      term_subst (Fin.FS i) (lift_term t) (lift_term t') = lift_term (term_subst i t t').
  Proof.
    dependent induction t' using termRect.
    destruct (eq_fin_dec i t0) eqn:H.
    subst. simpl. repeat rewrite fin_subst_eq. trivial.
    + simpl.
      assert (H0 := fin_subst_neq _ _ (lift_term t) i t0 n0).
      assert (H1 := fin_subst_neq _ _ t i t0 n0).
      destruct H0; destruct H1; destruct_pairs. rewrite H0. rewrite H1. simpl. repeat f_equal.
      rewrite <- H2 in H3. eauto.
    + simpl. f_equal. repeat rewrite vector_map_map.
      apply vector_map_sur. intros. eapply H. apply JMeq_refl.
  Qed.

  Lemma lift_type_term_subst :
    forall {n} i (t : term n) ty,
      type_subst (Fin.FS i) (lift_term t) (lift_type ty) = lift_type (type_subst i t ty).
  Proof.
    dependent induction ty; simpl; f_equal; auto using lift_term_term_subst.
  Qed.

  Lemma type_subst_1_lift_type : forall {n} (t : term n) t',
                                   type_subst Fin.F1 t (lift_type t') = t'.
  Proof.
    dependent induction t'; simpl; f_equal; auto using term_subst_1_lift_term.
    admit.
    admit.
  Qed.

  Lemma liftΓ_term_subst :
    forall {n m} i (t : term m) (Γ : Vector.t (type (S m)) n),
      Vector.map (type_subst (Fin.FS i) (lift_term t)) (liftΓ Γ) = liftΓ (Vector.map (type_subst i t) Γ).
  Proof.
    intros. dependent induction Γ; simpl; f_equal; auto using lift_type_term_subst.
  Qed.

  Lemma term_subst_comm : forall {n} (t : term n) t' a i,
                            term_subst Fin.F1 (term_subst i t t')
                                       (term_subst (Fin.FS i) (lift_term t) a) =
                            term_subst i t (term_subst Fin.F1 t' a).
  Proof.
    dependent induction a using termRect; intros.
    + destruct (eq_fin_dec (Fin.FS i) t0) eqn:H; subst.
      * simpl. repeat rewrite fin_subst_eq.
        apply term_subst_1_lift_term.
      * dependent destruction t0.
        simpl. repeat rewrite fin_subst_eq. auto.
        simpl. assert (i <> t0); [intro; subst; apply n0; auto|].
        assert (H1 := fin_subst_neq _ _ (lift_term t) i t0 H0).
        assert (H2 := fin_subst_neq _ _ t i t0 H0).
        destruct H1; destruct H2; destruct_pairs. rewrite H1. rewrite H2.
        rewrite <- H3 in H4. apply lift_fin_at_inj in H4. subst.
        destruct n; eauto; apply Fin.case0; eauto.
    + simpl. f_equal. repeat rewrite vector_map_map.
      apply vector_map_sur; intros. eapply H; eauto.
  Qed.

  Lemma type_subst_comm : forall {n} (t : term n) t' a i,
                            type_subst Fin.F1 (term_subst i t t')
                                       (type_subst (Fin.FS i) (lift_term t) a) =
                            type_subst i t (type_subst Fin.F1 t' a).
  Proof.
    dependent induction a; intros; simpl; try (f_equal; eauto using term_subst_comm; fail).
    (* lift_type needs to be replaced by lift_type_by, this is very difficult as n+m is not definitionally equal to m+n... *)
    (* or free_variable relation ? *)
    admit.
    admit.
  Qed.

  Theorem has_type_term_subst :
    forall {n m} Γ (u : exp n (S m)) ty i t (P : Γ ⊢ u ∈ ty),
      Vector.map (type_subst i t) Γ ⊢ exp_subst_term i t u ∈ type_subst i t ty.
  Proof.
    intros.
    dependent induction P; simpl;
    try (
        repeat match goal with
                 | [ H : (forall (_ : ?ty), _) |- _ ] =>
                   let x := fresh "x" in
                   evar (x : ty); specialize (H x);
                 match goal with
                   | [ x := ?a : ?b ~= ?c |- _ ] => unify b c; subst x
                   | [ x := _ : _ |- _ ] => subst x
                 end
               end;
        try (
            simpl in *; econstructor; eauto using te_subst;
            repeat match goal with
                     | [ H : ?ty ≡ ?ty' |- _ ] =>
                       match ty with
                         | type_subst _ _ _ => fail
                         | _ => eapply te_subst in H
                       end
                   end;
            eauto using te_subst; fail)).
    + econstructor. erewrite Vector.nth_map; eauto using te_subst.
    + econstructor.
      rewrite liftΓ_term_subst in IHP. eauto.
      eapply te_subst in H. eapply H.
    + econstructor. instantiate (1 := type_subst (Fin.FS i) (lift_term t) p).
      rewrite type_subst_comm. eapply IHP.
      eapply te_subst in H. eapply H.
    + simpl in IHP2. rewrite liftΓ_term_subst in IHP2. rewrite lift_type_term_subst in IHP2.
      econstructor; eauto using te_subst.

      Grab Existential Variables.
      eauto. eauto. eauto. eauto. eauto.
      eauto. eauto. eauto. eauto. eauto.
      eauto. eauto. eauto. eauto. eauto.
      eauto. eauto. eauto. eauto. eauto.
      eauto. eauto. eauto. eauto.
  Qed.

End Q5.

Module Q6(T:TermDef)(TC:TermCongruence(T)).
  Module NJ6 := Q5(T)(TC).
  Import NJ6.
  Export NJ6.

  Theorem admit {A} : A.
  Proof. admit. Qed.

  Fixpoint substΓ {n m} (i : Fin.t (S n)) (Γ : Vector.t (type m) (S n)) : Vector.t (type m) n
    := match i in Fin.t n' return forall pf : n' = S n,
                                    Vector.t (type m) n
       with
         | Fin.F1 _ => fun pf => Vector.tl Γ
         | Fin.FS n' i => fun pf =>
                            match n' as n'' return forall pf' : n'' = n',
                                                     Vector.t (type m) n
                            with
                              | 0 => fun pf' => Fin.case0 (fun _ => Vector.t (type m) n) (eq_rect _ Fin.t i _ (eq_sym pf'))
                              | S n'' => fun pf' => eq_rect (S n'') (Vector.t (type m))
                                                      (Vector.hd Γ :: substΓ
                                                                 (eq_rect n' Fin.t i _ (eq_sym pf'))
                                                                 (eq_rect n (Vector.t (type m)) (Vector.tl Γ) _
                                                                          (eq_trans (f_equal pred (eq_sym pf)) (eq_sym pf'))
                                                                 )
                                                      ) _ (eq_trans pf' (f_equal pred pf))
                            end eq_refl
       end eq_refl.

  Lemma substΓ_extend : forall {n m} (Γ : Vector.t (type m) (S n)) ty i,
                          ty :: substΓ i Γ = substΓ (Fin.FS i) (ty :: Γ).
  Proof.
    dependent induction Γ; intros; auto.
  Qed.

  Lemma substΓ_lift : forall {n m} (Γ : Vector.t (type m) (S n)) i,
                          liftΓ (substΓ i Γ) = substΓ i (liftΓ Γ).
  Proof.
    dependent induction Γ; intros;
    dependent destruction i; auto.
    destruct n; simpl.
    apply Fin.case0; auto.
    rewrite IHΓ; eauto.
  Qed.

  Lemma substΓ_index : forall {n m} (Γ : Vector.t (type m) (S n)) i i',
                          (substΓ i Γ)[@i'] = Γ[@lift_fin_at i i'].
  Proof.
    intros.
    dependent induction Γ; dependent destruction i; dependent destruction i'; intros; eauto.
    specialize (IHΓ n Γ eq_refl JMeq_refl i i'); eauto.
  Qed.

  Lemma has_type_lift : forall {n m} Γ (e : exp n m) ty,
                          Γ ⊢ e ∈ ty -> liftΓ Γ ⊢ lift_exp e ∈ lift_type ty.
  Proof.
    intros.
    dependent induction H;
      try (try econstructor;
           unfold liftΓ; try rewrite vector_nth_map;
           match goal with
             | [ H : _ ≡ _ |- _ ] => apply te_lift in H
           end;
           eauto;
           fail).
    (* true ? *)
    admit.
  Qed.

  Lemma weakening_lemma : forall {n m} Γ (e : exp n m) ty i,
                            substΓ i Γ ⊢ e ∈ ty -> Γ ⊢ lift_exp_at i e ∈ ty.
  Proof.
    intros.
    dependent induction H; simpl;
    try econstructor (solve [eauto]).
    + rewrite substΓ_index in H.
      econstructor; eauto.
    + econstructor; eauto;
      specialize (IHhas_type (t :: Γ) (Fin.FS i)); eauto.
    + econstructor; eauto.
      eapply (IHhas_type (liftΓ Γ) i);
      rewrite substΓ_lift; eauto.
    + econstructor; eauto.
      eapply (IHhas_type2 (p :: liftΓ Γ) (Fin.FS i));
      rewrite substΓ_lift; eauto.
  Qed.

  Theorem substitution_lemma :
    forall {n m} Γ v (e : exp (S n) m) ty i,
      Γ ⊢ e ∈ ty -> substΓ i Γ ⊢ v ∈ Γ[@i] -> substΓ i Γ ⊢ exp_subst i v e ∈ ty.
  Proof.
    Ltac solver :=
      repeat match goal with
               | [ H : (forall (_ : ?ty), _) |- _ ] =>
                 let x := fresh "x" in
                 evar (x : ty); specialize (H x);
                 match goal with
                   | [ x := ?a : ?b = ?c |- _ ] => unify b c; subst x
                   | [ x := ?a : ?b ~= ?c |- _ ] => unify b c; subst x
                   | [ x := _ : _ |- _ ] => subst x
                 end
             end.
    intros n m Γ v e ty i P.
    dependent induction P; intros;
    try (simpl; econstructor; try rewrite substΓ_lift; try rewrite substΓ_extend; eauto).
    + destruct (eq_fin_dec i i0); subst.
      rewrite exp_subst_eq; eapply p_equiv; eauto using te_sym.
      assert (H1 := fin_subst_neq _ _ v _ _ n0).
      destruct H1; destruct_pairs. simpl. rewrite H1.
      econstructor. rewrite substΓ_index. subst. eauto.
    + eapply IHP; eauto; eapply weakening_lemma; eauto.
    + eapply IHP; eauto.
      rewrite <- substΓ_lift; unfold liftΓ at 2; rewrite vector_nth_map.
      eapply has_type_lift; eauto.
    + eapply IHP2; eauto; simpl.
      unfold liftΓ at 2; rewrite vector_nth_map.
      eapply weakening_lemma; simpl.
      rewrite <- substΓ_lift; eapply has_type_lift; eauto.
    + eapply IHP2; eauto. eapply weakening_lemma; eauto.
    + eapply IHP3; eauto. eapply weakening_lemma; eauto.
  Qed.

  Lemma equivΓ_has_type : forall {n m} Γ Γ' (e : exp n m) ty,
    (forall i, Γ[@i] ≡ Γ'[@i]) ->
    Γ ⊢ e ∈ ty -> Γ' ⊢ e ∈ ty.
  Proof with eauto using te_refl, te_lift, te_trans, te_sym.
    intros. dependent induction H0;
      try econstructor (solve [eauto using te_trans, te_refl, te_sym]).
    + econstructor; eauto. eapply IHhas_type.
      intro; dependent destruction i...
    + econstructor; eauto. eapply IHhas_type.
      intro. unfold liftΓ; repeat rewrite vector_nth_map...
    + econstructor; eauto. eapply IHhas_type2. intro.
      dependent destruction i...
      unfold liftΓ; simpl; repeat rewrite vector_nth_map...
    + econstructor; eauto.
      * eapply IHhas_type2; intro; dependent destruction i...
      * eapply IHhas_type3; intro; dependent destruction i...
  Qed.

  Definition subject_reduction_hypothesis :=
    (forall n a b, @ty_exists n a ≡ ty_exists b ->
                   a ≡ b)
    /\ (forall n a b c d, @ty_arrow n a b ≡ ty_arrow c d ->
                          a ≡ c /\ b ≡ d)
    /\ (forall n a b c d, @ty_copair n a b ≡ ty_copair c d ->
                          a ≡ c /\ b ≡ d)
    /\ (forall n a b c d, @ty_pair n a b ≡ ty_pair c d ->
                          a ≡ c /\ b ≡ d).

  Theorem subject_reduction : subject_reduction_hypothesis ->
                              forall {n m} Γ (e : exp n m) e' ty,
                                Γ ⊢ e ∈ ty -> e ===> e' -> Γ ⊢ e' ∈ ty.
  Proof with eauto using p_equiv, te_refl, te_lift, te_trans, te_sym.
    intros H n m Γ e e' ty P; unfold subject_reduction_hypothesis in H; destruct_pairs.
    generalize dependent e'.
    induction P; intros e' R; inversion R; simpl_exist;
    try (econstructor (solve [eauto using p_equiv, te_sym])).
    + inversion P1; simpl_exist.
      apply H0 in H10; destruct_pairs.
      assert (HΓ : Γ = substΓ Fin.F1 (t0 :: Γ)); eauto; rewrite HΓ;
      eapply substitution_lemma...
    + inversion P1; simpl_exist. econstructor; eauto.
    + inversion P1; simpl_exist.
      assert (HΓ : Γ = substΓ Fin.F1 (type_subst Fin.F1 t p0 :: Γ)); eauto; rewrite HΓ.
      eapply substitution_lemma...
      assert (type_subst Fin.F1 t p0 :: Γ = Vector.map (type_subst Fin.F1 t) (p0 :: liftΓ Γ)); [|rewrite H4]. simpl. f_equal. rewrite (vector_map_id Γ) at 1. unfold liftΓ. rewrite vector_map_map. apply vector_map_sur. intro. rewrite type_subst_1_lift_type...
      assert (ty = type_subst Fin.F1 t (lift_type ty)); [| rewrite H5].
      rewrite type_subst_1_lift_type...
      eapply has_type_term_subst; eapply p_equiv; eauto using te_sym, te_lift.
      eapply equivΓ_has_type; eauto.
      intro; dependent destruction i; simpl...
    + inversion P1; simpl_exist.
      apply H1 in H10; destruct_pairs.
      assert (HΓ : Γ = substΓ Fin.F1 (a :: Γ)); eauto; rewrite HΓ;
      eapply substitution_lemma...
    + inversion P1; simpl_exist.
      apply H1 in H10; destruct_pairs.
      assert (HΓ : Γ = substΓ Fin.F1 (b :: Γ)); eauto; rewrite HΓ;
      eapply substitution_lemma...
    + inversion P; simpl_exist.
      apply H2 in H12; destruct_pairs.
      eauto using p_equiv, te_sym.
    + inversion P; simpl_exist.
      apply H2 in H12; destruct_pairs.
      eauto using p_equiv, te_sym.
  Qed.

End Q6.


From Coq Require Import ssreflect ssrfun ssrbool.
Local Set Warnings "-notation-overridden".
From mathcomp Require Export seq eqtype ssrnat.

Theorem fold_union :
  forall (A: eqType) (l: seq A) f base P,
    (forall acc a, P (f acc a) = P acc || P a) ->
             P (foldl f base l) = P base || (has P l).
Proof.
  move => A. elim => [ f base P HP /= | ]. by rewrite orbF.
  move => a l Hind f base P HP. rewrite /= Hind => //.
  by rewrite HP orbA.
Qed.

Theorem fold_intersection :
  forall (A: eqType) (l: seq A) f base P,
    (forall acc a, P (f acc a) = P acc && P a) ->
             P (foldl f base l) = (P base && all P l).
Proof.
  move => A. elim => [ f base P HP |  ]; first by rewrite andbT.
  move => a l Hind f base P HP. rewrite /= Hind => //.
  by rewrite HP andbA.
Qed.

Theorem sub_all_in: forall (T : eqType) (a1 a2 : pred T) (s: seq T),
    subpred (T:=T) (fun x => (x \in s) ==> a1 x) (fun x => (x \in s) ==> a2 x) ->
    all a1 s -> all a2 s.
Proof.
  move => T a1 a2 s Hsubpred.
  move => /allP HIn1. apply /allP => x Hx_in.
  move => /(_ x) in Hsubpred. rewrite Hx_in in Hsubpred.
  rewrite !implyTb in Hsubpred; auto.
Qed.

Theorem zip_uniq :
  forall (A B: eqType) (a: A) (b: B) (s1: seq A) (s2: seq B), uniq s1 -> uniq (zip s1 s2).
Proof.
  move => A B a b s1 s2.
  move => /uniqP Huniq.
  apply /(uniqP (a,b)) => x y Hx Hy.
  move => /(_ a x y) in Huniq.
  rewrite /in_mem /= in Hx, Hy, Huniq.
  move: (Hx) (Hy). rewrite !size_zip !leq_min => /andP[Hx1 Hx2] /andP[Hy1 Hy2].
  move => /(_ Hx1 Hy1) in Huniq.
  rewrite !nth_zip_cond Hx Hy. move => [H1 H2].
    by auto.
Qed.

Theorem index_uniq_zip :
  forall (A B: eqType) (a: A) (b: B) (s1: seq A) (s2: seq B),
    uniq s1 ->
    (a, b) \in (zip s1 s2) ->
               index (a, b) (zip s1 s2) = index a s1.
Proof.
  move => A B a b s1 s2 Huniq Hin.
  move: (Hin) => Hin'.
  apply (nth_index (a,b)) in Hin'. rewrite nth_zip_cond in Hin'.
  rewrite -index_mem in Hin. rewrite Hin in Hin'.
  case: Hin' => [Hin' _].
  rewrite -[in X in _ = X]Hin'. rewrite index_uniq => //.
  move: Hin. by rewrite size_zip leq_min => /andP[H1 H2].
Qed.


Load lab9strongInduction.
Require Import Coq.omega.Omega.

Fixpoint redeemBars (n : nat) : nat :=
 match n with
 | 0 => 0
 | 1 => 0
 | 2 => 0
 | 3 => 0
 | 4 => 0
 | 5 => 0
 | 6 => 0
 | 7 => 0
 | 8 => 0
 | 9 => 0
 | S(S(S(S(S(S(S(S(S(S n as n'))))))))) => 1 + redeemBars n'
 end.

Eval compute in (redeemBars 9).
Eval compute in (redeemBars 10).
Eval compute in (redeemBars 17).
Eval compute in (redeemBars 18).
Eval compute in (redeemBars 19).
Eval compute in (redeemBars 27).
Eval compute in (redeemBars 28).

Fixpoint div9 (n : nat) : nat :=
 match n with
 | 0 => 0
 | 1 => 0
 | 2 => 0
 | 3 => 0
 | 4 => 0
 | 5 => 0
 | 6 => 0
 | 7 => 0
 | 8 => 0
 | S(S(S(S(S(S(S(S(S n)))))))) => 1 + div9 n
 end.

Theorem result: forall n : nat, redeemBars(S n) = div9 n.
Proof.
induction n using strong_induction.

destruct n.
reflexivity.

destruct n.
reflexivity.

destruct n.
reflexivity.

destruct n.
reflexivity.

destruct n.
reflexivity.

destruct n.
reflexivity.

destruct n.
reflexivity.

destruct n.
reflexivity.

destruct n.
reflexivity.

assert (n < S (S (S (S (S (S (S (S (S n))))))))).
omega.
apply H in H0.

change (redeemBars (S (S (S (S (S (S (S (S (S (S n))))))))))) with (1 + redeemBars (S n)).
change (div9 (S (S (S (S (S (S (S (S (S n)))))))))) with (1 + div9 n).

rewrite H0.
reflexivity.
Qed.


Welcome to Coq ciosx:/builds/workspace/coq-8.5pl3-macos,(detached from 2290dbb) (2290dbb9c95b63e693ced647731623e64297f5c8)

Coq < Fixpoint beq_nat (n m : nat) : bool := match n with | O => match m with | O => true | S m' => false end | S n' => match m with | O => false | S m' => beq_nat n' m' end end.
beq_nat is defined
beq_nat is recursively defined (decreasing on 1st argument)

Coq < Theorem plus_1_neq_0_firsttry : forall n : nat, beq_nat (n + 1) 0 = false.
1 subgoal

  ============================
  forall n : nat, beq_nat (n + 1) 0 = false

plus_1_neq_0_firsttry < Proof.
1 subgoal

  ============================
  forall n : nat, beq_nat (n + 1) 0 = false

plus_1_neq_0_firsttry < info_auto.
Debug: (* info auto : *)
Debug: idtac.
1 subgoal

  ============================
  forall n : nat, beq_nat (n + 1) 0 = false

plus_1_neq_0_firsttry < intros n.
1 subgoal

  n : nat
  ============================
  beq_nat (n + 1) 0 = false

plus_1_neq_0_firsttry < simpl.
1 subgoal

  n : nat
  ============================
  beq_nat (n + 1) 0 = false

plus_1_neq_0_firsttry < destruct n as [| n'].
2 subgoals

  ============================
  beq_nat (0 + 1) 0 = false

subgoal 2 is:
 beq_nat (S n' + 1) 0 = false

plus_1_neq_0_firsttry < reflexivity.
1 subgoal

  n' : nat
  ============================
  beq_nat (S n' + 1) 0 = false

plus_1_neq_0_firsttry < reflexivity.
No more subgoals.

plus_1_neq_0_firsttry < Qed.
Proof.
info_auto.
intros n.
simpl.
destruct n as [| n'].
 reflexivity.

 reflexivity.

Qed.
plus_1_neq_0_firsttry is defined


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf1 : natural) (y : natural) (x : natural) : natural := Succ y.


(**
Here we define the basic notions of setoids.
 *)
Require Import prelude.all.

(**
Projections and builder functions of equivalence relations.
*)
Definition make_eq_rel
           {X : hSet}
           (rel : hrel X)
           (isrefl_rel : isrefl rel)
           (issymm_rel : issymm rel)
           (istrans_rel : istrans rel)
  : eqrel X
  := rel ,, ((istrans_rel ,, isrefl_rel) ,, issymm_rel).

Declare Scope setoid_scope.
Delimit Scope setoid_scope with setoid.
Notation "'id' g" := (eqrelrefl _ g) (at level 30) : setoid_scope.
Notation "! p" := (eqrelsymm _ _ _ p) : setoid_scope.
Notation "p @ q" := (eqreltrans _ _ _ _ p q) : setoid_scope.

(**
A setoid is just a pair of a set and an equivalence relation.
 *)
Definition setoid :=
  ∑ (X : hSet), eqrel X.

(**
Projections and builder functions of setoids.
 *)
Definition make_setoid
           {X : hSet}
           (R : eqrel X)
  : setoid
  := X ,, R.

Coercion carrier (X : setoid) : hSet := pr1 X.

Definition carrier_eq
           (X : setoid)
  : eqrel X
  := pr2 X.

Notation "x ≡ y" := (carrier_eq _ x y) (at level 70).

Definition isaprop_setoid_eq
           {X : setoid}
           (x y : X)
  : isaprop (x ≡ y).
Proof.
  apply (pr1 (carrier_eq X)).
Defined.

Definition setoid_path
           {X : setoid}
           {x y : X}
           (p : x = y)
  : x ≡ y.
Proof.
  induction p.
  apply (id _)%setoid.
Defined.

(**
Lastly, we define setoid morphisms.
 *)
Definition setoid_morphism (X₁ X₂ : setoid)
  := ∑ (f : X₁ → X₂), ∏ (x y : X₁), x ≡ y → f x ≡ f y.

(**
Projections and builder functions for setoid morphisms.
 *)
Definition make_setoid_morphism
           {X₁ X₂ : setoid}
           (f : X₁ → X₂)
           (Rf : ∏ (x y : X₁), x ≡ y → f x ≡ f y)
  : setoid_morphism X₁ X₂
  := f ,, Rf.

Definition map_carrier
           {X₁ X₂ : setoid}
           (f : setoid_morphism X₁ X₂)
  : X₁ → X₂
  := pr1 f.

Coercion map_carrier : setoid_morphism >-> Funclass.

Definition map_eq
           {X₁ X₂ : setoid}
           (f : setoid_morphism X₁ X₂)
           {x y : X₁}
  : x ≡ y → f x ≡ f y
  := pr2 f x y.

(**
Equality principle for setoid morphisms.
 *)
Definition setoid_morphism_eq
           {X₁ X₂ : setoid}
           (f g : setoid_morphism X₁ X₂)
           (e : ∏ (x : X₁), f x = g x)
  : f = g.
Proof.
  use subtypePath.
  - intro.
    do 3 (apply impred ; intro).
    apply isaprop_setoid_eq.
  - apply funextsec.
    exact e.
Defined.

Definition isaset_setoid_morphism (X₁ X₂ : setoid)
  : isaset(setoid_morphism X₁ X₂).
Proof.
  use isaset_total2.
  - apply isaset_set_fun_space.
  - intros f ; cbn.
    apply isasetaprop.
    repeat (apply impred ; intro).
    apply isaprop_setoid_eq.
Defined.


(***************************************************************************
* Safety for Simply Typed Lambda Calculus (CBV) - Definitions              *
* Brian Aydemir & Arthur Chargueraud, July 2007                            *
***************************************************************************)

Set Implicit Arguments.
Require Import LibLN.
Implicit Types x : var.

(** Grammar of types. *)

Inductive typ : Set :=
  | typ_var   : var -> typ
  | typ_arrow : typ -> typ -> typ.

(** Grammar of pre-terms. *)

Inductive trm : Set :=
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_abs  : trm -> trm
  | trm_app  : trm -> trm -> trm.

(** Opening up abstractions *)

Fixpoint open_rec (k : nat) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => If k = i then u else (trm_bvar i)
  | trm_fvar x    => trm_fvar x
  | trm_abs t1    => trm_abs (open_rec (S k) u t1)
  | trm_app t1 t2 => trm_app (open_rec k u t1) (open_rec k u t2)
  end.

Definition open t u := open_rec 0 u t.

Notation "{ k ~> u } t" := (open_rec k u t) (at level 67).
Notation "t ^^ u" := (open t u) (at level 67).
Notation "t ^ x" := (open t (trm_fvar x)).

(** Terms are locally-closed pre-terms *)

Inductive term : trm -> Prop :=
  | term_var : forall x,
      term (trm_fvar x)
  | term_abs : forall L t1,
      (forall x, x \notin L -> term (t1 ^ x)) ->
      term (trm_abs t1)
  | term_app : forall t1 t2,
      term t1 ->
      term t2 ->
      term (trm_app t1 t2).

(** Environment is an associative list mapping variables to types. *)

Definition env := LibEnv.env typ.

(** Typing relation *)

Reserved Notation "E |= t ~: T" (at level 69).

Inductive typing : env -> trm -> typ -> Prop :=
  | typing_var : forall E x T,
      ok E ->
      binds x T E ->
      E |= (trm_fvar x) ~: T
  | typing_abs : forall L E U T t1,
      (forall x, x \notin L ->
        (E & x ~ U) |= t1 ^ x ~: T) ->
      E |= (trm_abs t1) ~: (typ_arrow U T)
  | typing_app : forall S T E t1 t2,
      E |= t1 ~: (typ_arrow S T) ->
      E |= t2 ~: S ->
      E |= (trm_app t1 t2) ~: T

where "E |= t ~: T" := (typing E t T).

(** Definition of values (only abstractions are values) *)

Inductive value : trm -> Prop :=
  | value_abs : forall t1,
      term (trm_abs t1) -> value (trm_abs t1).

(** Reduction relation - one step in call-by-value *)

Inductive red : trm -> trm -> Prop :=
  | red_beta : forall t1 t2,
      term (trm_abs t1) ->
      value t2 ->
      red (trm_app (trm_abs t1) t2) (t1 ^^ t2)
  | red_app_1 : forall t1 t1' t2,
      term t2 ->
      red t1 t1' ->
      red (trm_app t1 t2) (trm_app t1' t2)
  | red_app_2 : forall t1 t2 t2',
      value t1 ->
      red t2 t2' ->
      red (trm_app t1 t2) (trm_app t1 t2').

Notation "t --> t'" := (red t t') (at level 68).

(** Goal is to prove preservation and progress *)

Definition preservation := forall E t t' T,
  E |= t ~: T ->
  t --> t' ->
  E |= t' ~: T.

Definition progress := forall t T,
  empty |= t ~: T ->
     value t
  \/ exists t', t --> t'.


Require Import Arith.
Require Import List.
Require Import Relations.
Require Import Wellfounded.
Require Import list_util.

(* LP *)
Inductive Formula : Set :=
|Var: nat -> Formula
|Neg: Formula -> Formula
|Imp: Formula -> Formula -> Formula
.

Notation "# n" := (Var n) (at level 80, no associativity) : LP_scope.
Notation "! f" := (Neg f) (at level 82, no associativity) : LP_scope.
Notation "f ==> g" := (Imp f g) (at level 85, right associativity) : LP_scope.

Open Scope LP_scope.
Fixpoint interpret (f:Formula) (a:nat->bool) := match f with |# n => a n | ! g => negb (interpret g a) | g ==> h => orb (negb (interpret g a)) (interpret h a) end.

Inductive LPAxiom: Formula -> Prop :=
|LPA1 : forall f g, LPAxiom (f==>g==>f)
|LPA2 : forall f g h, LPAxiom ((f==>g==>h)==>(f==>g)==>f==>h)
|LPA3 : forall f g, LPAxiom ((!f==>!g)==>g==>f)
.
Inductive LPTheorem : Formula -> Prop:=
|LPAx: forall f, LPAxiom f -> LPTheorem f
|LPImp: forall f g, LPTheorem (f==>g) -> LPTheorem f -> LPTheorem g
.
Inductive LPInf (p:list Formula) : Formula -> Prop:=
|LPIAx : forall f, LPAxiom f -> LPInf p f
|LPIIn : forall f, In f p -> LPInf p f
|LPIImp: forall f g, LPInf p (f==>g) -> LPInf p f -> LPInf p g
.
Hint Constructors LPAxiom LPTheorem LPInf.

Theorem LPTheorem_Inf: forall p f, LPTheorem f -> LPInf p f. Proof. intros. induction H; auto. apply LPIImp with f; auto. Qed.
Theorem LPInf_Theorem: forall f, LPInf nil f -> LPTheorem f. Proof. intros. induction H; auto. inversion H. apply LPImp with f; auto. Qed.
Theorem Inf_incl: forall f l m, incl l m -> LPInf l f -> LPInf m f. Proof. intros. induction H0; auto. apply LPIImp with f; auto. Qed.
Theorem Inf_cons: forall f l p, LPInf l f -> LPInf (p::l) f. Proof. intros. apply Inf_incl with l; auto. Qed.
Theorem imp_refl: forall l f, LPInf l (f==>f). Proof. intros. apply LPIImp with (f==>f==>f); auto. apply LPIImp with (f==>(f==>f)==>f); auto. Qed.
Theorem imp_intro: forall l f g, LPInf l f -> LPInf l (g==>f). Proof. intros. apply LPIImp with f; auto. Qed.
Hint Resolve LPTheorem_Inf LPInf_Theorem Inf_incl Inf_cons imp_refl imp_intro.

Theorem InfTh': forall p l m f, Add p l m -> LPInf m f -> LPInf l (p==>f). Proof. intros. induction H0; auto. apply Add_in with (x:=f) in H. apply H in H0. destruct H0; [subst p|]; auto. apply LPIImp with (p==>f); auto. apply LPIImp with (p==>f==>g); auto. Qed.
Theorem InfTh: forall p l f, LPInf (p::l) f -> LPInf l (p==>f). Proof. intros. apply InfTh' with (p::l); auto. Qed.
Theorem LPabsurd: forall p f g, LPInf p f -> LPInf p (!f) -> LPInf p g. Proof. intros. apply LPIImp with f; auto. apply LPIImp with (!g==>!f); auto. Qed.
Theorem contra': forall l m f g, Add (!f) l m -> LPInf m g -> LPInf m (!g) -> LPInf l f. Proof. intros. apply LPIImp with (f==>f); auto. apply LPIImp with (!f==>!(f==>f)); auto. apply InfTh' with m; auto. apply LPabsurd with g; auto. Qed.
Theorem contra: forall l f g, LPInf ((!f)::l) g -> LPInf ((!f)::l) (!g) -> LPInf l f. Proof. intros. apply contra' with ((!f)::l) g; auto. Qed.
Hint Resolve InfTh' InfTh LPabsurd contra' contra.

Theorem neg_elim: forall p f, LPInf p (!(!f)) -> LPInf p f. Proof. intros. apply LPIImp with (f==>f); auto. apply LPIImp with (!f==>!(f==>f)); auto. apply LPIImp with (!(!(f==>f))==>!(!f)); auto. Qed.
Theorem neg_intro: forall p f, LPInf p f -> LPInf p (!(!f)). Proof. intros. apply contra with f; auto. apply neg_elim; auto. Qed.
Theorem imp_trans: forall p f g h, LPInf p (f==>g) -> LPInf p (g==>h) -> LPInf p (f==>h). Proof. intros. apply InfTh. apply LPIImp with g; auto. apply LPIImp with f; auto. Qed.
Hint Resolve neg_elim neg_intro imp_trans.

Theorem neg_imp: forall p f g, LPInf p (f==>g) -> LPInf p (!f==>g) -> LPInf p g. Proof. intros. apply contra with f; apply LPIImp with (!g); auto. apply LPIImp with (!f==>!(!g)); auto. apply imp_trans with g; auto. apply LPIImp with (!(!f)==>!(!(g))); auto. apply imp_trans with f; auto. apply imp_trans with g; auto. Qed.

Definition LPand (f g:Formula) := !(f==>!g).
Definition LPor (f g:Formula) := !f==>g.
Notation "f &^ g" := (LPand f g) (at level 83, left associativity) : LP_scope.
Notation "f |^ g" := (LPor f g) (at level 84, left associativity) : LP_scope.

Theorem or_intro1: forall p f g, LPInf p f -> LPInf p (f|^g). Proof. intros. apply InfTh. apply contra with f; auto. Qed.
Theorem or_intro2: forall p f g, LPInf p g -> LPInf p (f|^g). Proof. intros. apply InfTh. auto. Qed.
Theorem or_elim: forall p f g h, LPInf p (f==>h) -> LPInf p (g==>h) -> LPInf p (f|^g) -> LPInf p h. Proof. intros. apply neg_imp with f; auto. apply imp_trans with g; auto. Qed.
Theorem and_intro: forall p f g, LPInf p f -> LPInf p g -> LPInf p (f&^g). Proof. intros. apply contra with g; auto. apply LPIImp with f; auto. Qed.
Theorem and_elim1: forall p f g, LPInf p (f&^g) -> LPInf p f. Proof. intros. apply contra with (f==>!g); auto. apply InfTh. apply LPabsurd with f; auto. Qed.
Theorem and_elim2: forall p f g, LPInf p (f&^g) -> LPInf p g. Proof. intros. apply contra with (f==>!g); auto. Qed.
Hint Resolve neg_imp or_intro1 or_intro2 or_elim and_intro and_elim1 and_elim2.

Theorem deMorgan1: forall f g p, LPInf p (! f |^ ! g) -> LPInf p (!(f&^g)). Proof. intros. apply contra with f; auto. apply and_elim1 with g; auto. apply or_elim with (!f) (!g); auto. apply InfTh. apply LPabsurd with g; auto. apply and_elim2 with f; auto. Qed.
Theorem deMorgan2: forall f g p, LPInf p (!f &^ !g) -> LPInf p (!(f|^g)). Proof. intros. apply contra with f; auto. apply or_elim with f g; auto. apply InfTh. apply LPabsurd with g; auto. apply and_elim2 with (!f); auto. apply and_elim1 with (!g); auto. Qed.
Theorem deMorgan3: forall f g p, LPInf p (!(f|^g)) -> LPInf p (!f &^ !g). Proof. intros. apply and_intro; apply contra with (f|^g); auto. Qed.
Theorem deMorgan4: forall f g p, LPInf p (!(f&^g)) -> LPInf p (!f |^ !g). Proof. intros. apply contra with (f &^ g); auto. apply LPIImp with (!(!f)&^!(!g)). apply InfTh. apply and_intro; apply neg_elim. apply and_elim1 with (!(!g)); auto. apply and_elim2 with (!(!f)); auto. apply deMorgan3; auto. Qed.
Hint Resolve deMorgan1 deMorgan2 deMorgan3 deMorgan4.

Definition Tautology f: Prop := forall a, interpret f a = true.

Inductive Vars: nat-> Formula ->Prop:=
|VarV: forall n, Vars n (#n)
|VarN: forall n f, Vars n f -> Vars n (!f)
|VarI1: forall n f g, Vars n f -> Vars n (f==>g)
|VarI2: forall n f g, Vars n g -> Vars n (f==>g)
.
Hint Constructors Vars.
Definition vars' : forall f, {l| forall x, In x l<->Vars x f}. induction f. exists (n::nil). intros x; split; intros. destruct H. subst x; auto. destruct H. inversion H; auto. destruct IHf as [l H]. exists l. intros x. split; intros. apply VarN; apply H; auto. apply H. inversion H0; auto. destruct IHf1 as [l H]. destruct IHf2 as [m H1]. exists (l++m). intros. split; intros. apply in_app_or in H0. destruct H0. apply H in H0; auto. apply H1 in H0; auto. apply in_or_app. inversion H0; [left; apply H|right; apply H1]; auto. Defined.
Definition vars: forall f, {l|NoDup l & forall x, In x l<->Vars x f}. intros. destruct (vars' f) as [l H]. exists (nodup nat_eq_dec l). apply NoDup_nodup. intros. split; intros. apply nodup_In in H0. apply H; auto. apply nodup_In. apply H; auto. Defined.

Theorem interpret_equiv: forall f a b, (forall n, Vars n f -> a n = b n) -> interpret f a = interpret f b. Proof. induction f; simpl; intros; auto. f_equal. apply IHf; auto. rewrite IHf1 with a b; auto. rewrite IHf2 with a b; auto. Qed.
Fixpoint assign_prep (l:list nat):= match l with nil => (fun _=>false, nil)::nil |n::m => map (fun p=>(fun x=>if nat_eq_dec x n then true else fst p x, (#n)::snd p)) (assign_prep m) ++ map (fun p=>(fst p, (! #n)::snd p)) (assign_prep m) end.
Theorem assign_prep_spec1: forall l n p, In p (assign_prep l) -> In n l <-> In (# n) (snd p) \/ In (! #n) (snd p). Proof. induction l; simpl; intros. destruct H. destruct p. simpl. split; intros. destruct H0. inversion H. subst l. destruct H0; destruct H0. destruct H.  apply in_app_or in H. destruct H; apply in_map_iff in H; destruct H as [y [H3 H4]]; subst p; simpl; split; intros. destruct H. subst a; auto. destruct (IHl n y); auto. apply H0 in H. destruct H; auto. destruct H. destruct H. inversion H; auto. right. destruct (IHl n y); auto. destruct H. inversion H. right. destruct (IHl n y); auto. destruct H. subst a; auto. destruct (IHl n y); auto. apply H0 in H. destruct H; auto. destruct H. destruct H. inversion H. right. destruct (IHl n y); auto. destruct H. inversion H; auto. right. destruct (IHl n y); auto. Qed.
Theorem assign_prep_spec2: forall l n p, In p (assign_prep l) -> ~In n l -> fst p n=false. Proof. induction l; simpl; intros. destruct H. destruct p. destruct H. auto. destruct H. apply in_app_or in H. destruct H; apply in_map_iff in H; destruct H as [y [H1 H2]]; subst p; simpl. destruct (nat_eq_dec n a). contradict H0; auto. apply IHl; auto. apply IHl; auto. Qed.
Theorem assign_prep_spec3: forall l n p, NoDup l -> In p (assign_prep l) -> In n l -> fst p n=true <-> In (# n) (snd p). Proof. intros l n p H. revert n p. induction H; intros. destruct H0. simpl in H1. apply in_app_or in H1. destruct H1; apply in_map_iff in H1; destruct H1 as [y [H3 H4]]; subst p; destruct H2; simpl. subst x; simpl. destruct (nat_eq_dec n n). split; intros; auto. contradict n0; auto. destruct (nat_eq_dec n x). subst x. split; intros; auto. split; intros; auto. right. apply IHNoDup; auto. apply IHNoDup; auto. destruct H2; auto. contradict n0; inversion H2; auto.
  subst x. split; intros. rewrite assign_prep_spec2 with l n y in H1; auto. inversion H1. destruct H1. inversion H1. contradict H. destruct assign_prep_spec1 with l n y; auto. split; intros. right. apply IHNoDup; auto. destruct H2. inversion H2. apply IHNoDup; auto. Qed.
Theorem assign_prep_spec4: forall l n p, NoDup l -> In p (assign_prep l) -> In n l -> fst p n=false <-> In (! # n) (snd p). Proof. intros l n p H. revert n p. induction H; intros. destruct H0. simpl in H1. apply in_app_or in H1. destruct H1; apply in_map_iff in H1; destruct H1 as [y [H3 H4]]; subst p; destruct H2; simpl. subst x; simpl. destruct (nat_eq_dec n n). split; intros; auto. inversion H1. destruct H1. inversion H1. contradict H. destruct (assign_prep_spec1) with l n y; auto. contradict n0; auto. destruct (nat_eq_dec n x). subst x. split; intros; auto. inversion H2. destruct H2. inversion H2. contradict H. destruct (assign_prep_spec1) with l n y; auto. split; intros; auto. right. apply IHNoDup; auto. destruct H2. inversion H2. apply IHNoDup; auto. subst x. split; intros; auto. apply assign_prep_spec2 with l; auto. split; intros. right. apply IHNoDup; auto. destruct H2. inversion H2.  subst x; contradiction. apply IHNoDup; auto. Qed.
Theorem assign_prep_spec5: forall l a, NoDup l -> exists p, In p (assign_prep l) /\ forall n, In n l->a n=fst p n. Proof. intros. induction H; simpl; intros. exists (fun _=>false, nil). split; auto. destruct (IHNoDup) as [[b r] [H1 H2]]. simpl in H2. remember (a x) as c. destruct c. exists (fun y=>if nat_eq_dec y x then true else b y, (#x)::r). split. apply in_or_app. left. apply in_map_iff. exists (b,r); auto. intros. simpl. destruct H3. subst x. destruct (nat_eq_dec n n); auto. contradict n0; auto. destruct (nat_eq_dec n x). subst x. auto. apply H2; auto. exists (b, (! #x)::r). split. apply in_or_app. right. apply in_map_iff. exists (b,r); auto. simpl. intros. destruct H3. subst x. rewrite <- Heqc. rewrite <- assign_prep_spec2 with l n (b,r); auto. auto. Qed.

Definition Tauto_dec: forall f, {Tautology f}+{~Tautology f}. intros. destruct (vars f) as [l H1 H2]. remember (find (fun p=>negb (interpret f (fst p))) (assign_prep l)). destruct o. right. intros C. symmetry in Heqo. apply find_some in Heqo. destruct Heqo. rewrite C in H0. inversion H0. symmetry in Heqo. left. intros a. destruct (assign_prep_spec5 l a) as [p [H3 H4]]; auto. apply find_none with (x:=p) in Heqo; auto. rewrite interpret_equiv with (b:=fst p); auto. destruct (interpret f (fst p)); auto. intros. apply H4. apply H2; auto. Defined.
Theorem Theorem_Tauto: forall f, LPTheorem f -> Tautology f. Proof. intros. intros a. induction H. destruct H. simpl. destruct (interpret f a); simpl; auto. apply Bool.orb_true_r. simpl. destruct (interpret h a); destruct (interpret g a); destruct (interpret f a);simpl; auto.  simpl. destruct (interpret g a); destruct (interpret f a); simpl; auto. simpl in IHLPTheorem1. destruct (interpret g a); auto. contradict IHLPTheorem1. rewrite IHLPTheorem2. simpl. discriminate. Qed.
Theorem interpretTh: forall f (a:nat->bool) l, (forall n, Vars n f->In (if a n then (#n) else (!(#n))) l) -> LPInf l (if (interpret f a) then f else (!(f))). Proof. intros. induction f; intros. simpl. auto. simpl. destruct (interpret f a); simpl; auto. simpl. destruct (interpret f2 a). rewrite Bool.orb_true_r. auto. destruct (interpret f1 a); simpl. apply contra with f2; auto. apply LPIImp with f1; auto. apply InfTh. apply LPabsurd with f1; auto. Qed.
Theorem Tauto_Theorem: forall f, Tautology f -> LPTheorem f. Proof. intros. cut (forall m, (forall p, In p (assign_prep m) -> LPInf (snd p) f) -> LPTheorem f). intros. destruct (vars f) as [v H1 H2]. apply H0 with v. intros. replace f with (if interpret f (fst p) then f else (!f)). apply interpretTh. intros. remember (fst p n) as b. destruct b. apply assign_prep_spec3 with v; auto. apply H2; auto. apply assign_prep_spec4 with v; auto. apply H2; auto. replace (interpret f (fst p)) with true; auto.
  induction m; simpl; intros. cut (LPInf (snd (fun _:nat=>false, nil)) f); intros; auto. apply IHm. intros. apply neg_imp with (#a); apply InfTh. replace ((#a)::snd p) with (snd (fun x=>if nat_eq_dec x a then true else fst p x, (#a)::snd p)); auto. apply H0. apply in_or_app. left. apply in_map_iff. exists p; auto. replace ((! # a)::snd p) with (snd (fst p, (! # a)::snd p)); auto. apply H0. apply in_or_app. right. apply in_map_iff. exists p; auto. Qed.

Definition Theorem_dec: forall f, {LPTheorem f}+{~LPTheorem f}. intros. destruct (Tauto_dec f); [left|right]. apply Tauto_Theorem; auto. contradict n. apply Theorem_Tauto; auto. Defined.


Require Export GeoCoq.Elements.OriginalProofs.lemma_Euclid4.
Require Export GeoCoq.Elements.OriginalProofs.proposition_14.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_righttogether :
   forall A B C G,
   Per G A B -> Per B A C -> TS G B A C ->
   RT G A B B A C /\ BetS G A C.
Proof.
intros.
assert (Per B A G) by (conclude lemma_8_2).
assert (neq A G) by (conclude_def Per ).
assert (neq G A) by (conclude lemma_inequalitysymmetric).
let Tf:=fresh in
assert (Tf:exists D, (BetS G A D /\ Cong A D G A)) by (conclude lemma_extension);destruct Tf as [D];spliter.
assert (eq B B) by (conclude cn_equalityreflexive).
assert (neq A B) by (conclude_def Per ).
assert (Out A B B) by (conclude lemma_ray4).
assert (Supp G A B B D) by (conclude_def Supp ).
assert (nCol B A G) by (conclude_def TS ).
assert (nCol G A B) by (forward_using lemma_NCorder).
assert (CongA G A B G A B) by (conclude lemma_equalanglesreflexive).
assert (Col G A D) by (conclude_def Col ).
assert (neq A D) by (forward_using lemma_betweennotequal).
assert (neq D A) by (conclude lemma_inequalitysymmetric).
assert (Per D A B) by (conclude lemma_collinearright).
assert (Per B A D) by (conclude lemma_8_2).
assert (CongA B A C B A D) by (conclude lemma_Euclid4).
assert (RT G A B B A C) by (conclude_def RT ).
assert (TS C B A G) by (conclude lemma_oppositesidesymmetric).
assert (BetS G A C) by (conclude proposition_14).
close.
Qed.

End Euclid.


(**
Definitions for deferred recursion
*)

(** The fixpoint axiom *)

Require Export HsToCoq.Err.

Axiom deferredFix: forall {a r} `{Default r}, ((a -> r) -> (a -> r)) -> a -> r.

(** Variants for differing arities *)

Definition deferredFix1 {a r} `{Default r} : ((a -> r) -> (a -> r)) -> a -> r
  := deferredFix.

Definition curry : forall {a b r}, (((a * b) -> r) -> a -> b -> r)
  := fun _ _ _ f x y => f (x, y).

Definition uncurry : forall {a b r}, ((a -> b -> r) -> (a * b) -> r)
  := fun _ _ _ f '(x, y) => f x y.

Definition deferredFix2 {a b r} `{Default r} : ((a -> b -> r) -> (a -> b-> r)) -> a -> b -> r
  := fun f => curry (deferredFix (fun g => uncurry (f (curry g)))).

Definition deferredFix3 {a b c r} `{Default r} : ((a -> b -> c -> r) -> (a -> b -> c -> r)) -> a -> b -> c -> r
  := fun f => curry (deferredFix2 (fun g => uncurry (f (curry g)))).

Definition deferredFix4 {a b c d r} `{Default r} : ((a -> b -> c -> d -> r) -> (a -> b -> c -> d-> r)) -> a -> b -> c -> d -> r
  := fun f => curry (deferredFix3 (fun g => uncurry (f (curry g)))).

(** The fixpoint unrolling axiom *)

Definition recurses_on {a b} (P : a -> Prop) (R : a -> a -> Prop) (f : (a -> b) -> (a -> b)) :=
  forall g h x, P x -> (forall y, P y ->  R y x -> g y = h y) -> f g x = f h x.

Axiom deferredFix_eq_on: forall {a b} `{Default b} (f : (a -> b) -> (a -> b)) (P : a -> Prop) (R : a -> a -> Prop),
   well_founded R -> recurses_on P R f ->
   forall x, P x -> deferredFix f x = f (deferredFix f) x.