(* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *)
(** * Extensions to [Coq.Bool.Bool]                           *)
(* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *)

(** Dependent case analysis with proof of equality for [bool]. But
    note that since we've moved the [b] argument you can't use the
    [inversion b using bool_depcaseeq] tactic, alas. Instead use
    [apply (bool_depcaseeq b P)].

    N.B., the [destruct_if remember] tactic can be used instead,
    and often does what we want by this term. However, the plain
    [destruct_if] tactic does not, since it doesn't give the equality
    proof.

    N.B., if you don't need the equality, note that you can do
    regular dependent inversion via [inversion b using bool_rect]. *)
Definition bool_depcaseeq
    (b  : bool)
    (P  : bool -> Type)
    (tt : b = true  -> P true)
    (ff : b = false -> P false)
    : P b :=
        match b as b0 return (b = b0 -> P b0) with
        | true  => tt
        | false => ff
        end (refl_equal b).

(** Dependent inversion with proof of equality for [bool]. *)
Definition bool_depinveq (b : bool) (P : bool -> Type) :=
    if b as b0 return (
        if b0
        then (b0 = true  -> P true)  -> P b0
        else (b0 = false -> P false) -> P b0)
    then fun tt => tt (refl_equal _)
    else fun ff => ff (refl_equal _).

(* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *)
(*
Coq.Bool.Bool
    Is_true : bool -> Prop.

    diff_true_false (true = false) : False.
    diff_false_true (false = true) : False
    eq_true_false_abs (b:bool) (b = true) (b = false) : False

    not_true_is_false (b:bool) (b <> true) : b = false
    not_false_is_true (b:bool) (b <> false) : b = true

    eqb (a b:bool) : bool
    eqb_reflx (b:bool) : eqb b b = true
    eqb_prop (a b:bool) (eqb a b = true) : a = b.
    eqb_subst (P:bool -> Prop) (a b:bool) (eqb a b = true) (P a) : P b

    ...etc...

Coq.Bool.IfProp
    IfProp (A B:Prop) : bool -> Prop
    Iftrue : A -> IfProp A B true
    Iffalse : B -> IfProp A B false
    ...etc...
*)

(* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *)
(* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ fin. *)


Require Export sflib.
Require Import Omega.
Require Import jrdefs.

Theorem exinf_eq_1 : forall k,
                     forall a b,
                       comp (rk k) (sd_coface (S k)) a b <-> a = b.
Proof.
  intros k a b. split; intro H.
  Case "->".
    destruct H as [x]. unfold sd_coface in H. unfold rk in H. omega.
  Case "<-".
    subst. destruct (le_lt_dec b k); unfold sd_coface; unfold rk.
    SCase "b <= k". exists b. omega.
    SCase "b > k". exists (S b). omega.
Qed.

Theorem exinf_eq_2 : forall i k,
                     forall a b,
                       i <= S k ->
                       comp (comp (jk (S k)) (comp (rk (S k)) (sd_coface i))) (jk k) a b <->
                       comp (jk (S k)) (comp (rk (S k)) (sd_coface i)) a b.
Proof.
  intros i k a b H. split; intro K.
  Case "<-". assert (K1 := K). destruct K as [x K]. assert (K2 := K).
  destruct K as [K L]. destruct L as [y L].
    destruct L as [L M]. destruct L as [z L]. destruct L as [L1 L2].
    destruct (lt_eq_lt_dec a (S k)); try destruct s.
    SCase "a <= k". unfold jk in K. assert (N:a = x) by omega. subst. apply K2.
    SCase "a = S k". assert (N:i <= a) by omega.
      exists y. split. exists (S (S k)). split.
      unfold sd_coface. omega.
      unfold jk in K. unfold jk in M. unfold sd_coface in L1.
      unfold rk in L2. unfold rk. omega.
      apply M.
    SCase "a > S k".
      exists a. split. exists (S a). split. unfold sd_coface. omega.
      unfold rk. omega. unfold jk. right. split. apply l.
      unfold jk in K. unfold sd_coface in L1. unfold rk in L2. unfold jk in M.
      clear K1. clear K2. omega.
  Case "->". exists a. split. unfold jk. omega. apply K.
Qed.

Theorem exinf_eq_3 : forall i k,
                     forall a b,
                       (S (S k)) <= (S i) ->
                       comp (rk k) (sd_coface (S i)) a b <->
                       comp (sd_coface i) (rk k) a b.
Proof.
  intros i k a b H. split; intro K; destruct K as [x K]; destruct K as [K L].
  Case "->". destruct (lt_eq_lt_dec a (S k)); try destruct s.
    SCase "a < k+1". exists a. split. unfold rk. omega.
      unfold sd_coface. unfold sd_coface in K. unfold rk in L. omega.
    SCase "a = k+1". subst. assert (e1: x = (S k)) by
        (unfold sd_coface in K; omega).
      exists b. unfold rk in L. split. unfold rk. omega.
      unfold sd_coface. omega.
    SCase "a > k+1". destruct a as [| a']. omega.
      exists a'. split. unfold rk. omega.
      unfold sd_coface. unfold sd_coface in K. unfold rk in L. omega.
  Case "<-". destruct (le_lt_dec a i).
    SCase "a <= i". exists a. split. unfold sd_coface. omega.
      unfold rk. unfold sd_coface in L. unfold rk in K. omega.
    SCase "a > i". exists (S a). split.
      unfold sd_coface. omega. unfold rk. unfold rk in K.
      unfold sd_coface in L. omega.
Qed.

Theorem exinf_eq_4 : forall h k,
                     forall a b,
                       h <= k ->
                       comp (rk k) (jk h) a b <->
                       comp (jk h) (rk k) a b.
Proof.
  intros h k a b J. split; intro H; assert (I:=H); destruct H as [x [H K]].
  Case "->". destruct (lt_eq_lt_dec a (S k)). destruct s.
    SCase "a <= k". exists a. split. unfold rk. omega. unfold jk.
      unfold jk in H. unfold rk in K. omega.
    SCase "a = k+1". exists b. split. unfold rk. unfold jk in H. unfold rk in K. omega.
      unfold jk. omega.
    SCase "a > k+1". destruct a as [| a']. omega. exists a'. split.
      unfold rk. omega. unfold jk. unfold jk in H. unfold rk in K. omega.
  Case "<-". destruct (le_lt_dec a h).
    SCase "a <= h". exists a. split. unfold jk. omega. unfold rk.
      unfold rk in H. unfold jk in K. omega.
    SCase "a > h". destruct (lt_eq_lt_dec a (S k)). destruct s.
      SSCase "h < a <= k". exists b. split. unfold rk in H. unfold jk in K.
        unfold jk. omega.
        unfold rk. unfold rk in H. unfold jk in K. omega.
      SSCase "h < a = k+1". subst. assert(e:x<=k) by (unfold rk in H; omega).
        subst. assert(e1:b<=x) by (unfold jk in K; omega). exists b.
        split. unfold jk. unfold jk in K. unfold rk in H. omega.
        unfold rk. omega.
      SSCase "k+1 < a". assert (e:S x = a) by (unfold rk in H; omega). subst.
        destruct (le_lt_dec b k).
        SSSCase "b <= k". exists b. split. unfold jk. omega.
          unfold rk. omega.
        SSSCase "b > k". exists (S b). split. unfold jk. unfold jk in K.
          unfold rk in H. omega.
          unfold rk. omega.
Qed.

Theorem exinf_eq_5 : forall i k,
                     forall a b,
                       comp (comp (jk k) (sd_coface i)) (jk k) a b <->
                       comp (jk k) (sd_coface i) a b.
Proof.
  intros i k a b. split; intro H.
  Case "<-". destruct H as [x H]. destruct H as [H K]. destruct K as [y K].
    destruct K as [K L]. destruct (le_lt_dec i a).
    SCase "i <= a". exists (S a). split. unfold sd_coface. omega.
      unfold jk. unfold jk in H. unfold sd_coface in K. unfold jk in L.
      omega.
    SCase "i > a". exists a. split. unfold sd_coface. omega.
      unfold jk. unfold jk in H. unfold sd_coface in K. unfold jk in L.
      omega.
  Case "->". exists a. split. unfold jk. omega. apply H.
Qed.

Theorem exinf_eq_6 : forall h k,
                      forall a b,
                        h < k ->
                        comp (jk h) (rk k) a b <->
                        comp (jk h) (sd_codegen k) a b.
Proof.
  intros h k a b J. split; intro H.
  Case "->". destruct H as [x [H K]]. destruct (le_lt_dec a k).
    SCase "a <= k". exists a. split. unfold sd_codegen. omega.
      unfold jk. unfold rk in H. unfold jk in K. omega.
    SCase "a > k". destruct a as [| a']. omega. exists a'.
      split. unfold sd_codegen. omega.
      unfold jk. unfold rk in H. unfold jk in K. omega.
  Case "<-". destruct H as [x [H K]]. destruct (lt_eq_lt_dec a (S k)); try destruct s.
    SCase "a <= k". exists a. split. unfold rk. omega.
      unfold jk. unfold sd_codegen in H. unfold jk in K. omega.
    SCase "a = k+1". exists x. split. unfold rk. unfold sd_codegen in H.
      unfold jk in K. omega.
      apply K.
    SCase "a > k+1". destruct a as [| a']. omega. exists a'. split.
      unfold rk. omega.
      unfold jk. unfold jk in K. unfold sd_codegen in H. omega.
Qed.

Theorem exinf_eq_7 : forall k,
                     forall a b,
                       comp (comp (jk k) (rk k)) (rk k) a b <->
                       comp (comp (jk k) (rk k)) (sd_codegen (S k)) a b.
Proof.
  intros k a b. split; intro H; assert (I:=H); destruct H as [x [H L]];
                assert (J:=L); destruct L as [y [L K]].
  Case "->". destruct (lt_eq_lt_dec a (S k)). destruct s.
    SCase "a <= k". exists a. split. unfold sd_codegen. left. omega.
      exists a. split. unfold rk. omega.
      unfold jk. unfold rk in H. unfold rk in L. unfold jk in K. left. omega.
    SCase "a = k+1". exists a. split. unfold sd_codegen. omega.
      exists y. split. unfold rk. unfold rk in H. unfold rk in L. omega.
      unfold jk. unfold rk in H. unfold rk in L. unfold jk in K. omega.
    SCase "a > k+1". destruct a as [| a']. omega.
      exists a'. split. unfold sd_codegen. omega.
      destruct (le_lt_dec a' (S k)).
      SSCase "a = k+2". exists y. split. unfold rk. unfold rk in H.
        unfold rk in L. unfold jk in K. omega.
        apply K.
      SSCase "a > k+2". destruct a' as [| a'']. omega. exists a''. split.
        unfold rk. omega. unfold jk. unfold rk in H. unfold rk in L. unfold jk in K.
        omega.
  Case "<-". destruct (lt_eq_lt_dec a (S k)). destruct s.
    SCase "a <= k". exists a. split. unfold rk. omega.
      exists a. split. unfold rk. omega.
      unfold jk. unfold sd_codegen in H. unfold rk in L. unfold jk in K. omega.
    SCase "a = k+1". exists y.
      split. unfold rk. unfold sd_codegen in H. unfold rk in L. omega.
      exists y. split. unfold rk. unfold sd_codegen in H. unfold rk in L. omega.
      apply K.
    SCase "a > k+1". destruct a as [| a']. omega. exists a'. split.
      unfold rk. omega. destruct (le_lt_dec a' (S k)).
      SSCase "a = k+2". exists y.  split. unfold rk. unfold sd_codegen in H.
        unfold rk in L. unfold jk in K. omega. apply K.
      SSCase "a > k+2". destruct a' as [| a'']. omega. exists a''. split.
        unfold rk. omega.
        unfold jk. unfold sd_codegen in H. unfold rk in L. unfold jk in K. omega.
Qed.

Theorem exinf_eq_8 : forall h k,
                     forall a b,
                       h <= k ->
                       comp (comp(sd_codegen h) (jk (S k))) (rk (S k)) a b <->
                       comp (comp (jk k) (rk k)) (sd_codegen h) a b.
Proof.
  intros h k a b J. split; intro H; assert (I:=H); destruct H as [x [H K]];
                    assert (I1:=K); destruct K as [y [K L]];
                    assert (H1:=H); assert (K1:=K); assert (L1:=L).
  Case "->". unfold rk in H1. unfold jk in K1. unfold sd_codegen in L1. destruct (le_lt_dec a h).
    SCase "a <= h". exists a. split. unfold sd_codegen. omega.
      exists a. split. unfold rk. omega. unfold jk. omega.
    SCase "a > h". destruct a as [| a']. omega. exists a'. split.
      unfold sd_codegen. omega. destruct (lt_eq_lt_dec a' (S k)). destruct s.
      SSCase "h < a < k+2". exists a'. split. unfold rk. omega. unfold jk. omega.
      SSCase "h < a = k+2". exists b. split. unfold rk. omega. unfold jk. omega.
      SSCase "k+2 < a". destruct a' as [| a'']. omega. exists a''. split.
        unfold rk. omega. unfold jk. omega.
  Case "<-". unfold sd_codegen in H1. unfold rk in K1. unfold jk in L1.
    destruct (lt_eq_lt_dec a (S (S k))). destruct s.
    SCase "a < k+2". exists a. split. unfold rk. omega.
      exists a. split. unfold jk. omega. unfold sd_codegen. omega.
    SCase "a = k+2". destruct (le_lt_dec b h).
      SSCase "b <= h". exists b. split. unfold rk. omega.
        exists b. split. unfold jk. omega. unfold sd_codegen. omega.
      SSCase "b > h". exists (S b). split. unfold rk. omega.
        exists (S b). split. unfold jk. omega. unfold sd_codegen. omega.
    SCase "a > k+2". destruct a as [| a']. omega. exists a'.
      split. unfold rk. omega. destruct (le_lt_dec b h).
      SSCase "b <= h". exists b. split. unfold jk. omega. unfold sd_codegen. omega.
      SSCase "b > h". exists (S b). split. unfold jk. omega. unfold sd_codegen. omega.
Qed.

Theorem exinf_eq_9 : forall h k,
                      forall a b,
                        k <= h ->
                        comp (comp (sd_codegen h) (jk k)) (rk k) a b <->
                        comp (comp (jk k) (rk k)) (sd_codegen (S h)) a b.
Proof.
  intros h k a b J. split; intro H; assert (I:=H); destruct H as [x [H K]];
                    assert (I1:=K); destruct K as [y [K L]];
                    assert (H1:=H); assert (K1:=K); assert (L1:=L).
  Case "->". unfold rk in H1. unfold jk in K1. unfold sd_codegen in L1.
    destruct (le_lt_dec a (S h)).
    SCase "a <= h+1". exists a. split. unfold sd_codegen. omega.
      destruct (lt_eq_lt_dec a (S k)). destruct s.
      SSCase "a <= k <= h". exists a. split. unfold rk. omega. unfold jk. omega.
      SSCase "a = k+1 <= h+1". exists b. split. unfold rk. omega. unfold jk. omega.
      SSCase "k+1 < a <= h+1". destruct a as [| a']. omega. exists a'. split.
        unfold rk. omega. unfold jk. omega.
    SCase "a > h+1". destruct a as [| a']. omega. exists a'. split.
      unfold sd_codegen. omega. destruct (lt_eq_lt_dec a' (S k)). destruct s. omega.
      SSCase "h=k=a-2". exists b. split. unfold rk. omega. unfold jk. omega.
      SSCase "a > k+2, h+1". destruct a' as [| a'']. omega. exists a''.
        split. unfold rk. omega. unfold jk. omega.
  Case "<-". unfold sd_codegen in H1. unfold rk in K1. unfold jk in L1.
    destruct (lt_eq_lt_dec a (S k)). destruct s.
    SCase "a <= k". exists a. split. unfold rk. omega.
      exists a. split. unfold jk. omega. unfold sd_codegen. omega.
    SCase "a=k+1". destruct (le_lt_dec b h).
      SSCase "b <= h". exists b. split. unfold rk. omega.
        exists b. split. unfold jk. omega. unfold sd_codegen. omega.
      SSCase "b > h". exists (S b). split. unfold rk. omega.
        exists (S b). split. unfold jk. omega. unfold sd_codegen. omega.
    SCase "a > k+1". destruct a as [| a']. omega. exists a'.
      split. unfold rk. omega. destruct (le_lt_dec b h).
      SSCase "b <=h". exists b. split. unfold jk. omega. unfold sd_codegen. omega.
      SSCase "b > h". exists (S b). split. unfold jk. omega. unfold sd_codegen. omega.
Qed.


Require Export BoilerplateSemantics.

(******************************************************************************)
(* Weakening lemmas                                                           *)
(******************************************************************************)

Lemma shift_value {t} :
  ∀ {c}, Value t → Value (shiftTm c t).
Proof.
  induction t; simpl; intros; try contradiction; destruct_conjs; auto.
Qed.

Lemma weaken_value u :
  ∀ {t}, Value t → Value (weakenTm t u).
Proof.
  induction u; simpl; auto using shift_value.
Qed.

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

Lemma can_form_tarr {Γ t T1 T2} (v: Value t) (wt: Typing Γ t (tarr T1 T2)) :
  ∃ t2, t = abs T1 t2.
Proof.
  depind wt; try contradiction; exists t; reflexivity.
Qed.

Lemma can_form_tall {Γ t T} (v: Value t) (wt: Typing Γ t (tall T)) :
  ∃ t1, t = tabs t1.
Proof.
  depind wt; try contradiction; exists t; reflexivity.
Qed.

Lemma can_form_tprod {Γ t T1 T2} (v: Value t) (wt: Typing Γ t (tprod T1 T2)) :
  ∃ t1 t2, t = prod t1 t2 ∧ Typing Γ t1 T1 ∧ Typing Γ t2 T2.
Proof.
  depind wt; try contradiction; exists t1, t2; split; auto.
Qed.

Lemma matching_defined {Γ p T1 Δ} (wp: PTyping Γ p T1 Δ) :
  ∀ {t1}, Value t1 → Typing Γ t1 T1 → ∀ t2, ∃ t2', Match p t1 t2 t2'.
Proof.
  induction wp; intros t1 v1 wt1 t2.
  - exists (substTm sub_here t1 t2).
    refine M_Var.
  - destruct (can_form_tprod v1 wt1) as (t11 & t12 & eq & wt11 & wt12); subst.
    destruct v1 as [v11 v12].
    apply (weaken_typing Δ1) in wt12.
    assert (val12' : Value (weakenTm t12 (lengthExt Δ1)))
       by (apply weaken_value; auto).
    destruct (IHwp2 (weakenTm t12 (lengthExt Δ1)) val12' wt12 t2) as [t2' m2].
    destruct (IHwp1 _ v11 wt11 t2') as [t2'' m1].
    rewrite <- (PTyping_bindPat_lengthExt wp1) in m2.
    exists t2''.
    exact (M_Prod m2 m1).
Qed.

Lemma progress {t U} (wt: Typing empty t U) :
  Value t ∨ ∃ t', red t t'.
Proof with try (subst; eauto using red).
  depind wt; simpl; auto.
  - inversion H.
  - destruct IHwt1 as [v1|[t1' r1]]...
    destruct IHwt2 as [v2|[t2' r2]]...
    destruct (can_form_tarr v1 wt1)...
  - destruct IHwt as [vt|[t1' r1]]...
    destruct (can_form_tall vt wt)...
  - destruct IHwt1 as [v1|[t1' r1]]...
    destruct IHwt2 as [v2|[t2' r2]]...
  - destruct IHwt1 as [v1|[t1' r1]]...
    destruct (matching_defined H v1 wt1 t2)...
Qed.

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

Lemma local_preservation_lett {p t1 t2 t2'} (m: Match p t1 t2 t2') :
  ∀ {Γ T1 T2 Δ}, PTyping Γ p T1 Δ → Typing Γ t1 T1 →
    Typing (extend Γ Δ) t2 T2 → Typing Γ t2' T2.
Proof.
  induction m; intros Γ T1 T2 Δ wp wt1 wt2.
  - dependent destruction wp.
    eauto using subst_evar_typing, subst_evar.
  - dependent destruction wp.
    dependent destruction wt1.
    rewrite (PTyping_bindPat_lengthExt wp1) in *.
    rewrite extend_append in wt2.
    eauto using weaken_typing.
Qed.

Lemma preservation {Γ t U} (wt: Typing Γ t U) :
  ∀ {t'}, red t t' → Typing Γ t' U.
Proof.
  induction wt; intros t' r; inversion r; subst; eauto using Typing.
  - dependent destruction wt1; eauto using subst_evar_typing.
  - dependent destruction wt; eauto using subst_etvar_typing.
  - eauto using local_preservation_lett.
Qed.


Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Import Logic. Import Decidable.
Require Import
        Definitions
        Lemmas
        Infrastructure
        Soundness.

Lemma ptype_uniq: forall mu u A B,
 sto_ok mu ->
 pvalue u -> ptype mu u A -> ptype mu u B -> A = B.
Proof.
  introv ok pval ptyp1 ptyp2.
  inductions pval; try solve[inverts* ptyp1; inverts* ptyp2].
Qed.

Lemma TypedReduce_unique: forall P v mu r1 r2 (A: typ),
    sto_ok mu -> value v -> (exists B, typing nil P v Inf B) -> TypedReduce (v, mu) A r1 -> TypedReduce (v, mu) A r2 -> r1 = r2.
Proof.
  introv ok Val H R1 R2.
  gen r2.
  lets R1': R1.
  inductions R1; introv R2;
    try solve [inverts~ R2].
  -
  inverts~ R2.
  forwards*: ptype_uniq H0 H9. subst*.
  -
  inverts~ R2.
  forwards*: ptype_uniq H0 H9. subst*.
Qed.

Lemma  TypeLists_unique: forall v r1 r2 A P mu ,
    P |== mu -> value v -> (exists B, typing nil P v Inf B) ->  TypeLists (v,mu) A r1 ->  TypeLists (v,mu) A r2 -> r1 = r2.
Proof.
  introv ok Val H R1 R2.
  gen r2.
  lets R1': R1.
  inductions R1; introv R2;
    try solve [inverts* R2].
  - inverts* R2.
    inverts ok.
    forwards*: TypedReduce_unique H0 H6.
    congruence.
  - inverts* R2.
    inverts ok.
    forwards*: TypedReduce_unique H0 H6.
    congruence.
    lets ok': ok.
    inverts ok.
    inverts H.
    forwards*: TypedReduce_preservation H0.
    forwards*: TypedReduce_prv_value H0.
    forwards*: TypedReduce_unique H0 H6.
    inverts* H5.
Qed.

Lemma fill_eq: forall mu E0 e0 E e1 r1 r2 mu1 mu2,
  fill E0 e0 = fill E e1 ->
  step (e0, mu) (r1,mu1) ->
  step (e1, mu) (r2,mu2) ->
  wellformed E ->
  wellformed E0 ->
  E = E0 /\ e0 = e1.
Proof.
  introv eq red1 red2 wf1 wf2. gen mu mu1 mu2 E e0 e1 r1 r2.
  inductions E0; unfold fill in *;  intros;
  try solve[inductions E; unfold fill in *; inverts* eq;
  inverts wf1;
  forwards*: step_not_value red1];
  try solve[inductions E; unfold fill in *; inverts* eq];
  try solve[inductions E; unfold fill in *; inverts* eq;
  inverts wf2;
  forwards*: step_not_value red2].
Qed.

Lemma typing_chk: forall E e P A,
 typing E P e Inf A ->
 typing E P e Chk A.
Proof.
  introv typ.
  eapply typ_consist; eauto.
Qed.

Lemma typing_chk2: forall E e P A,
 typing E P e Inf A ->
 exists B, typing E P e Chk B /\ consist E A B.
Proof.
  introv typ.
  exists A. splits.
  eapply typ_consist; auto.
  eapply consist_refl;eauto.
Qed.

Lemma fill_chk: forall F e dir P A,
 typing empty P (fill F e) dir A ->
 exists B, typing empty P e Chk B.
Proof.
  introv typ.
  destruct F; unfold fill in *;inverts* typ.
  -
  forwards*: typing_chk H4.
  -
  inverts H0.
  forwards*: typing_chk H6.
  -
  inverts H0.
  forwards*: typing_chk H6.
  -
  inverts H0.
  forwards*: typing_chk H7.
  -
  inverts H0.
  forwards*: typing_chk H4.
  -
  inverts H0.
  forwards*: typing_chk H5.
  -
  inverts H0.
  forwards*: typing_chk H6.
  -
  forwards*: typing_chk H4.
  -
  inverts H0.
  exists*.
Qed.

Lemma pattern_abs_uniq: forall A B1 B2,
 pattern_abs A B1 ->
 pattern_abs A B2 ->
 B1 = B2.
Proof.
  introv pa1 pa2.
  inverts pa1; inverts* pa2.
Qed.

Lemma pattern_all_uniq: forall A B1 B2,
 pattern_all A B1 ->
 pattern_all A B2 ->
 B1 = B2.
Proof.
  introv pa1 pa2.
  inverts pa1; inverts* pa2.
Qed.

Lemma pattern_ref_uniq: forall A B1 B2,
 pattern_ref A B1 ->
 pattern_ref A B2 ->
 B1 = B2.
Proof.
  introv pa1 pa2.
  inverts pa1; inverts* pa2.
Qed.

Theorem step_unique: forall P mu A e r1 r2,
   P |== mu -> typing nil P e Chk A -> step (e, mu) r1 -> step (e, mu) r2 -> r1 = r2.
Proof.
  introv well Typ Red1.
  gen P A r2.
  lets Red1' : Red1.
  inductions Red1;
    introv well Typ Red2.
  -
    inverts* Red2;
    try solve[destruct F; unfold fill in H0; inverts* H0];
    try solve[
    forwards*: typing_regular Typ;destructs~ H1;destruct F; unfold fill in H0; inverts* H0;
    inverts* H5;
    inverts* H9;
    forwards: step_not_value Red1; auto; inverts H0];
    try solve[
    forwards*: typing_regular Typ;destructs~ H1;destruct F; unfold fill in H0; inverts* H0;
    inverts* H3;
    inverts* H7;
    forwards: step_not_value Red1; auto; inverts H0];
    try solve[ destruct F; unfold fill in *; inverts* H0;
    forwards: step_not_value Red1; auto; inverts* H0];
    try solve[destruct F; unfold fill in H5; inverts* H5].
    + forwards*: fill_eq H0.
      destruct H1. subst. inverts Typ.
      forwards*: fill_chk H3. inverts* H5.
      forwards*: IHRed1 Red1 H4. congruence.
    +  forwards*: fill_eq H0.
      destruct H1. subst. inverts Typ.
      forwards*: fill_chk H3. inverts* H5.
      forwards*: IHRed1 Red1 H4. congruence.
    +
     forwards*: typing_regular Typ.
     destructs~ H1.
     destruct F; unfold fill in *; inverts* H0;
     try solve[inverts H6; inverts H10;forwards: step_not_value Red1; auto;inverts* H0].
    + forwards*: typing_regular Typ.
     destructs~ H1.
     destruct F; unfold fill in *; inverts* H0;
     try solve[     inverts* H6;
     inverts* H10;
     forwards: step_not_value Red1; auto; inverts* H0].
    +
     forwards*: typing_regular Typ.
     destructs~ H1.
     destruct F; unfold fill in *; inverts* H0;
     try solve[
     inverts* H4;
     inverts* H9;
     forwards: step_not_value Red1; auto; inverts* H0].
    +
      forwards*: typing_regular Typ.
     destructs~ H1.
     destruct F; unfold fill in *; inverts* H0;
     try solve[
     inverts* H4;
     inverts* H9;
     forwards: step_not_value Red1; auto; inverts* H0].
    +
    forwards*: typing_regular Typ.
     destructs~ H1.
     destruct F; unfold fill in *; inverts* H0;
     try solve[
     inverts* H3;
     inverts* H6;
     forwards: step_not_value Red1; auto; inverts* H0].
  -
    inverts Red2;
    try solve[destruct F; unfold fill in H0; inverts H0];
    try solve[forwards: typing_regular Typ;
    destructs~ H1;
    destruct F; unfold fill in *; inverts H0;
    inverts H5;
    inverts H9;
    forwards: step_not_value Red1; auto; inverts H0];
    try solve[
      forwards: typing_regular Typ;
     destructs~ H1;
     destruct F; unfold fill in *; inverts H0;
     inverts H4;
     inverts H8;
     forwards: step_not_value Red1; auto; inverts H0
    ];
    try solve[
      destruct F; unfold fill in *; inverts H0;
      forwards: step_not_value Red1; auto; inverts H0
    ];
    try solve[destruct F; unfold fill in *; inverts H3].
    + forwards*: fill_eq H0.
      destruct H1. subst. inverts Typ.
      forwards*: fill_chk H3. inverts H5.
      forwards*: IHRed1 Red1 H4. congruence.
    +  forwards*: fill_eq H0.
      destruct H1. subst. inverts Typ.
      forwards: fill_chk H3. inverts* H5.
    +
     forwards: typing_regular Typ.
     destructs~ H1.
     destruct F; unfold fill in *; inverts H0;
     try solve[
     inverts H6;
     inverts H10;
     forwards: step_not_value Red1; auto; inverts H0].
    +
      forwards: typing_regular Typ.
     destructs~ H1.
     destruct F; unfold fill in *; inverts H0;
     try solve[ inverts H6;
     inverts H10;
     forwards: step_not_value Red1; auto; inverts H0 ].
    +
    forwards: typing_regular Typ.
    destructs~ H1.
    destruct F; unfold fill in *; inverts H0;
    try solve[ inverts H3;
    inverts H7;
    forwards: step_not_value Red1; auto; inverts H0 ].
    +
    forwards: typing_regular Typ.
     destructs~ H1.
     destruct F; unfold fill in *; inverts H0;
     try solve[ inverts H4;
     inverts H9;
     forwards: step_not_value Red1; auto; inverts H0 ].
     +
    forwards: typing_regular Typ.
     destructs~ H1.
     destruct F; unfold fill in *; inverts H0;
     try solve[ inverts H4;
     inverts H9;
     forwards: step_not_value Red1; auto; inverts H0 ].
     +
     forwards ha: typing_regular Typ.
     lets(hb&hc&hd):ha.
     destruct F; unfold fill in *; inverts H0;
     try solve[ inverts hc;
     inverts H1;
     forwards: step_not_value Red1; auto; inverts H0 ].
  - inverts Red2;
    try solve[destruct F; unfold fill in H0; inverts H0];
    try solve[reflexivity];
    try solve[inverts H3];
    try solve[forwards: step_not_value Red1; auto; inverts H0].
    inverts Typ. inverts H1;
    forwards*: IHRed1 Red1 H4.
    inverts Typ. inverts H1;
    forwards*: IHRed1 Red1 H5;
    inverts H1.
  -
    inverts* Red2;
    try solve[destruct F; unfold fill in H4; inverts* H4;
    forwards: step_not_value H8; auto; inverts H4];
    try solve[inverts H7].
    +
     forwards*: typing_regular Typ.
     destructs~ H5.
     destruct F; unfold fill in *; inverts* H4;
     try solve[
     inverts* H7;
     inverts* H11;
     forwards: step_not_value H8; auto; inverts* H0].
    +
     forwards*: typing_regular Typ.
     destructs~ H5.
     destruct F; unfold fill in *; inverts* H4;
     try solve[
     inverts* H7;
     inverts* H11;
     forwards: step_not_value H8; auto; inverts* H0].
    +
    inverts Typ. inverts H5. inverts H16. inverts H17.
    forwards: pattern_abs_uniq H2 H14. inverts H7.
    forwards*: TypeLists_unique H3 H15.
    congruence.
    +
    inverts Typ. inverts H5.
    inverts H16. inverts H17.
    forwards*: pattern_abs_uniq H2 H14. inverts H7.
    forwards*: TypeLists_unique H3 H15.
    congruence.
    +
    inverts H11. inverts* H13.
    exfalso; apply H14; eauto.
    inverts Typ. inverts H5.
    inverts H17. inverts H13.
    lets typ: H6. inverts H6.
    forwards*: typing_regular typ.
    destructs~ H6.
    inverts* H13.
  -
    inverts* Red2;
    try solve[destruct F; unfold fill in H4; inverts* H4;
    forwards: step_not_value H8; auto; inverts H4];
    try solve[inverts H7].
    +
    forwards*: typing_regular Typ.
     destructs~ H5.
     destruct F; unfold fill in *; inverts* H4;
     try solve[
     inverts* H7;
     inverts* H11;
     forwards: step_not_value H8; auto; inverts* H0].
    +
    forwards*: typing_regular Typ.
     destructs~ H5.
     destruct F; unfold fill in *; inverts* H4;
     try solve[
     inverts* H7;
     inverts* H11;
     forwards: step_not_value H8; auto; inverts* H0].
    +
    forwards*: pattern_abs_uniq H2 H14. inverts H4.
    inverts Typ. inverts H5. inverts H17.
    forwards*: TypeLists_unique H3 H15.
    congruence.
  -
    inverts* Red2;
    try solve[destruct F; unfold fill in H3; inverts* H3;
    forwards: step_not_value H7; auto; inverts H3];
    try solve[inverts H6].
    inverts* H1.
    inverts* H11. inverts* H13.
    inverts Typ. inverts H3. inverts H16.
    inverts H13.
    forwards*: typing_regular H4.
    destructs~ H5.
    inverts* H4.
    inverts* H15.
    exfalso; apply H14; eauto.
  -
    inverts Red2;
    try solve[destruct F; unfold fill in H0; inverts H0];
    try solve[reflexivity];
    try solve[inverts H0];
    try solve[forwards: step_not_value Red1; auto; inverts H0].
    forwards*: ptype_uniq H1 H7.
    subst*.
  -
    inverts Red2;
    try solve[destruct F; unfold fill in H0; inverts H0];
    try solve[reflexivity];
    try solve[inverts H3];
    try solve[forwards: step_not_value Red1; auto; inverts H0].
    +
    inverts Typ. inverts H1.
    forwards*: IHRed1 Red1 H4.
    congruence.
    +
    inverts Typ. inverts H1.
    forwards*: IHRed1 Red1 H5.
    congruence.
  -
    inverts Red2;
    try solve[destruct F; unfold fill in H2; inverts H2];
    try solve[reflexivity];
    try solve[inverts H5];
    try solve[forwards: step_not_value H6; auto; inverts H2];
    try solve[forwards: step_not_value H7; auto; inverts H2].
    inverts Typ. inverts H3; try solve[
    forwards*: TypedReduce_unique H1 H8];
    try solve[inverts H10;
    forwards*: TypedReduce_unique H1 H8].
  -
    inverts* Red2;
    try solve[destruct F; unfold fill in H3; inverts H3];
    try solve[destruct F; unfold fill in *; inverts H3];
    try solve[inverts* H8];
    try solve[inverts* H8];
    try solve[inverts* H4];
    try solve[
      destruct F; unfold fill in *; inverts H3;
      forwards*: step_not_value H7; auto; inverts H; auto].
    +
    forwards*: typing_regular Typ.
     destructs~ H2.
     destruct F; unfold fill in *; inverts* H1;
     try solve[
     inverts* H4;
     inverts* H;
     forwards: step_not_value H5; auto; inverts* H0].
    +
    forwards*: typing_regular Typ.
     destructs~ H2.
     destruct F; unfold fill in *; inverts* H1;
     try solve[
      inverts* H4;
      inverts* H8;
      forwards: step_not_value H5; auto; inverts* H0].
    +
      forwards* ha: pattern_all_uniq H0 H8.
      inverts* ha.
    + inverts* H8.
      exfalso; apply H10.
      inverts H9.
      inverts Typ. inverts H2. inverts H14. inverts H11.
      lets typ: H3.
      inverts H3.
      forwards*: typing_regular typ.
      destructs~ H3.
      inverts H11.
      pick fresh x and apply consist_all; auto.
  -
    inverts* Red2;
    try solve[destruct F; unfold fill in *; inverts* H3;
    forwards*: step_not_value H7];
    try solve[inverts H5].
    +
     forwards*: typing_regular Typ.
     destructs~ H3.
     destruct F; unfold fill in *; inverts* H2;
     try solve[
     inverts* H5;
     inverts* H9;
     forwards: step_not_value H6; auto; inverts* H0].
    +
    forwards*: typing_regular Typ.
     destructs~ H3.
     destruct F; unfold fill in *; inverts* H2;
     try solve[
     inverts* H5;
     inverts* H10;
     forwards: step_not_value H6; auto; inverts* H0].
    +
    inverts H8.
    inverts H1.
    inverts H8.
    inverts Typ. inverts H2. inverts H13.
    inverts H10.
    forwards*: typing_regular H3.
    destructs~ H4.
    inverts* H3.
    inverts* H11.
    exfalso; apply H9; eauto.
  -
    inverts Red2;
    try solve[destruct F; unfold fill in H1; inverts H1];
    try solve[destruct F; unfold fill in *; inverts H1];
    try solve[inverts* H6];
    try solve[
      destruct F; unfold fill in *; inverts H1;
      forwards: step_not_value H7; auto; inverts H1].
    +
    forwards*: typing_regular Typ.
     destructs~ H4.
     destruct F; unfold fill in *; inverts* H1;
     try solve[
     inverts* H6;
     inverts* H10;
     forwards: step_not_value H7; auto; inverts* H0].
    +
    forwards*: typing_regular Typ.
     destructs~ H4.
     destruct F; unfold fill in *; inverts* H1;
     try solve[
     inverts* H6;
     inverts* H10;
     forwards: step_not_value H7; auto; inverts* H0].
    +
    forwards: pattern_ref_uniq H3 H12. inverts H1.
    inverts Typ. inverts H4. inverts H15.
    forwards*: TypeLists_unique H2 H11.
    congruence.
    +
    forwards: pattern_ref_uniq H3 H12. inverts H1.
    inverts Typ. inverts H4. inverts H15.
    forwards*: TypeLists_unique H2 H11.
    congruence.
    +
    inverts* H11. inverts H12.
    inverts well. inverts H4.
    exfalso; apply H13; eauto.
    eapply consist_ref; eauto.
    inverts Typ. inverts H11.
    inverts H18. inverts H16. inverts H12.
    rewrite H5 in *.
    forwards*: H8.
    forwards*: typing_regular H12.
    forwards*: sto_ok_value H7.
    forwards*: principle_typ_inf H12.
    rewrite H20; eauto.
  -
    inverts* Red2;
    try solve[destruct F; unfold fill in H1; inverts H1];
    try solve[destruct F; unfold fill in *; inverts H1];
    try solve[inverts* H6];
    try solve[
      destruct F; unfold fill in *; inverts H1;
      forwards: step_not_value H7; auto; inverts H1].
    +
    forwards*: typing_regular Typ.
     destructs~ H4.
     destruct F; unfold fill in *; inverts* H1;
     try solve[
     inverts* H6;
     inverts* H10;
     forwards: step_not_value H7; auto; inverts* H0].
    +
    forwards*: typing_regular Typ.
    destructs~ H4.
    destruct F; unfold fill in *; inverts* H1;
    try solve[
    inverts* H6;
    inverts* H10;
    forwards: step_not_value H7; auto; inverts* H0].
    +
    inverts Typ. inverts H4.
    forwards*: pattern_ref_uniq H3 H12. inverts H4.
    inverts H15.
    forwards*: TypeLists_unique H2 H11.
    inverts* H6.
  -
    inverts* Red2;
    try solve[destruct F; unfold fill in H3; inverts H3];
    try solve[destruct F; unfold fill in *; inverts H1];
    try solve[inverts* H6];
    try solve[
      destruct F; unfold fill in *; inverts H3;
      forwards: step_not_value H7; auto; inverts H3].
    inverts H2.
    inverts Typ. inverts H3. inverts H16.
    inverts H14.
    forwards*: typing_regular H4.
    destructs~ H5.
    exfalso; apply H13.
    forwards*: ptype_inf H4.
    forwards*: ptype_uniq H16 H10.
    inverts* H18.
    inverts* H10.
    inverts* H15.
  -
    inverts* Red2;
    try solve[destruct F; unfold fill in H0; inverts H0];
    try solve[destruct F; unfold fill in *; inverts H0];
    try solve[inverts* H4];
    try solve[
      destruct F; unfold fill in *; inverts H1;
      forwards: step_not_value H5; auto; inverts H1].
  -
    inverts* Red2;
    try solve[destruct F; unfold fill in H1; inverts H1];
    try solve[destruct F; unfold fill in *; inverts H1];
    try solve[inverts* H6];
    try solve[
      destruct F; unfold fill in *; inverts H1;
      forwards: step_not_value H5; auto; inverts H0].
    +
    forwards*: typing_regular Typ.
     destructs~ H2.
     destruct F; unfold fill in *; inverts* H1;
     try solve[
     inverts* H4;
     inverts* H7;
     forwards: step_not_value H5; auto; inverts* H0].
    +
    forwards*: typing_regular Typ.
     destructs~ H2.
     destruct F; unfold fill in *; inverts* H1;
     try solve[
     inverts* H4;
     inverts* H7;
     forwards: step_not_value H5; auto; inverts* H0].
     +
     inverts Typ. inverts H2.
    forwards*: pattern_ref_uniq H0 H6. inverts H2; auto.
    +
    inverts H7. exfalso; apply H10.
    inverts Typ. inverts H2.
    inverts H12. inverts H11. inverts H3.
    forwards*: consist_regular H2.
    destructs~ H3. inverts H8.
    inverts H9.
    inverts well. inverts H9.
    rewrite H14 in *.
    forwards*: H16.
    forwards*: principle_typ_inf H9.
    forwards*: sto_ok_value H4.
    rewrite H18; eauto.
  -
    inverts* Red2;
    try solve[destruct F; unfold fill in H2; inverts H2];
    try solve[destruct F; unfold fill in *; inverts H2];
    try solve[inverts* H5];
    try solve[
      destruct F; unfold fill in *; inverts H2;
      forwards: step_not_value H6; auto; inverts H2].
    inverts H1.
    inverts Typ. inverts H2.
    inverts H12. inverts H11.
    forwards*: typing_regular H3.
    destructs~ H8.
    forwards*: ptype_inf H3.
    forwards*: ptype_uniq H9 H13. subst.
    exfalso; apply H10.
    inverts* H13.
    eapply consist_ref; eauto.
    inverts* H12.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(** %\subsection*{ support :  concat.v }%*)
(** - concatenation of sequences, denoted by "++" (Haskell notation) plus some
 preliminary lemmas *)
Set Implicit Arguments.
Unset Strict Implicit.
Require Export conshdtl.

Section MAIN.
Variable A : Setoid.

(** %\label{concat}% *)
Definition concat :
  forall (n m : Nat) (f : seq n A) (g : seq m A), seq (n + m) A.
simple induction n.
simpl in |- *.
intros.
exact g.
intros.
simpl in |- *.
exact (f (Build_finiteT (lt_O_Sn n0));; X _ (Seqtl f) g).
(* ie. (concat (f0 :: (Seqtl f) g)) = f0 :: (concat (Seqtl f) g) *)
Defined.

Infix "++" := concat (at level 60, right associativity).

Lemma concat_comp :
 forall (n m : Nat) (f f' : seq n A) (g g' : seq m A),
 f =' f' in _ -> g =' g' in _ -> f ++ g =' f' ++ g' in _.
simple induction n.
intros.
simpl in |- *.
assumption.
(* the induction step *)
intros.
set (fg := f ++ g) in |- *.
set (fg' := f' ++ g') in |- *.
simpl in |- *.
red in |- *.
destruct x.
destruct index as [| n1].
unfold fg in |- *.
unfold fg' in |- *.
simpl in |- *.
auto with algebra.
(**)
apply Trans with ((Seqtl f ++ g) (Build_finiteT (lt_S_n _ _ in_range_prf)));
 auto with algebra.
apply Trans with ((Seqtl f' ++ g') (Build_finiteT (lt_S_n _ _ in_range_prf)));
 auto with algebra.
apply Ap_comp; auto with algebra.
apply (H _ (Seqtl f) (Seqtl f') g g'); auto with algebra.
change (Seqtl f =' Seqtl f' in _) in |- *.
apply Seqtl_comp; auto with algebra.
Qed.

Hint Resolve concat_comp: algebra.

Variable n m : Nat.

Lemma cons_concat :
 forall (a a' : A) (v v' : seq n A) (w w' : seq m A),
 a =' a' in _ ->
 v =' v' in _ -> w =' w' in _ -> a;; v ++ w =' (a';; v') ++ w' in _.
intros.
apply Trans with ((a;; v) ++ w).
intro i.
destruct i.
destruct index as [| n0].
simpl in |- *.
auto with algebra.
rename in_range_prf into p.
apply Trans with ((v ++ w) (Build_finiteT (lt_S_n _ _ p))); auto with algebra.
apply Trans with ((Seqtl (a;; v) ++ w) (Build_finiteT (lt_S_n _ _ p)));
 auto with algebra.
change ((a;; v) ++ w =' (a';; v') ++ w' in seq (S n + m) A) in |- *.
apply concat_comp; auto with algebra.
Qed.

Hint Resolve cons_concat: algebra.

Lemma concat_cons :
 forall (a a' : A) (v v' : seq n A) (w w' : seq m A),
 a =' a' in _ ->
 v =' v' in _ -> w =' w' in _ -> (a';; v') ++ w' =' a;; v ++ w in _.
intros; apply Sym; apply cons_concat; auto with algebra.
Qed.

Hint Resolve concat_cons: algebra.

Lemma cons_concat_special :
 forall (a : A) (v : seq n A) (v' : seq m A),
 a;; v ++ v' =' (a;; v) ++ v' in _.
intros.
intro i.
destruct i.
destruct index as [| n0].
simpl in |- *.
auto with algebra.
rename in_range_prf into p.
apply Trans with ((v ++ v') (Build_finiteT (lt_S_n _ _ p)));
 auto with algebra.
apply Trans with ((Seqtl (a;; v) ++ v') (Build_finiteT (lt_S_n _ _ p)));
 auto with algebra.
Qed.

Lemma concat_first_element :
 forall (v : seq (S n) A) (w : seq m A) (Hnm : 0 < S (n + m)) (Hn : 0 < S n),
 (v ++ w) (Build_finiteT Hnm) =' v (Build_finiteT Hn) in _.
intros.
apply Trans with (head v); auto with algebra.
Qed.

Lemma head_eats_concat :
 forall (v : seq (S n) A) (w : seq m A), head (v ++ w) =' head v in _.
intros.
unfold head in |- *; auto with algebra.
Qed.

Lemma Seqtl_concat :
 forall (v : seq (S n) A) (w : seq m A), Seqtl (v ++ w) =' Seqtl v ++ w in _.
intros.
apply Trans with (Seqtl (hdtl v ++ w)); auto with algebra.
apply Trans with (Seqtl (head v;; Seqtl v ++ w)); auto with algebra.
unfold hdtl in |- *.
apply Seqtl_comp; auto with algebra.
change (Seqtl (head v;; Seqtl v ++ w) =' Seqtl v ++ w in seq (n + m) A)
 in |- *.
generalize dependent (Seqtl_cons_inv (head v) (Seqtl v ++ w)).
auto.
Qed.

Lemma concat_Seqtl :
 forall (v : seq (S n) A) (w : seq m A), Seqtl v ++ w =' Seqtl (v ++ w) in _.
intros.
apply Sym.
apply Seqtl_concat.
Qed.

End MAIN.

Infix "++" := concat (at level 60, right associativity).
Hint Resolve concat_comp: algebra.
Hint Resolve cons_concat concat_cons: algebra.
Hint Resolve concat_first_element head_eats_concat: algebra.
Hint Resolve Seqtl_concat concat_Seqtl: algebra.
Hint Resolve cons_concat_special: algebra.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Cprime P Q : Universe, ((wd_ A B /\ (wd_ P Q /\ (wd_ Q C /\ (wd_ P C /\ (wd_ C Cprime /\ (col_ A B C /\ (col_ A B Cprime /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q Cprime))))))))) -> col_ P A B)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C J K G : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ J A /\ (wd_ J C /\ (wd_ G C /\ (wd_ G B /\ (wd_ K A /\ (wd_ K B /\ (col_ B J G /\ (col_ B C G /\ (col_ A B K /\ col_ A C J)))))))))))) -> col_ C B A)).
Proof.
  time tac.
Qed.

End FOFProblem.


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

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Module LinearLambdaCalculus.

Inductive q : Type :=
  | qlin : q
  | qun : q.

Inductive b : Type :=
  | btrue : b
  | bfalse : b.

Inductive id : Type :=
  | Id : nat -> id.

Reserved Notation "'qty'" (at level 10).

Inductive ty : Type :=
  | ty_bool : qty
  | ty_pair : ty -> ty -> qty
  | ty_arrow : ty -> ty -> qty

where "'qty'" := (q -> ty).

Notation "T ** T'" := (ty_pair T T') (at level 20, left associativity).

Notation "T --> T'" := (ty_arrow T T') (at level 40, left associativity).

Inductive tm : Type :=
  | tmvar : id -> tm
  | tmbool : q -> b -> tm
  | tmif : tm -> tm -> tm -> tm
  | tmpair : q -> tm -> tm -> tm
  | tmsplit : tm -> id -> id -> tm -> tm
  | tmabs : q -> id -> ty -> tm -> tm
  | tmapp : tm -> tm -> tm.

Inductive ctx : Type :=
  | empty_ctx : ctx
  | update_ctx : ctx -> id -> ty -> ctx.

Notation "'[]'" := empty_ctx (at level 10).

Notation "G '::' x T" := (update_ctx G x T) (at level 15, left associativity).

Proposition update_ctx_unique : forall G G' x x' T T',
  update_ctx G x T = update_ctx G' x' T' -> G = G' /\ x = x' /\ T = T'.
Proof.
  induction G; induction G'; intros; inversion H; split; auto.
Qed.

Fixpoint update_l_ctx x T G :=
  match G with
  | [] => update_ctx ([]) x T
  | update_ctx G' x' T' => update_ctx (update_l_ctx x T G') x' T'
  end.

Notation "x T '::' G" := (update_l_ctx x T G) (at level 14, right associativity).

Lemma ctx_singleton : forall x T,
  update_ctx ([]) x T = update_l_ctx x T ([]).
Proof.
  intros. simpl. reflexivity.
Qed.

Notation "'[' x T ']'" := (update_ctx ([]) x T) (at level 10).

Lemma ctx_lr : forall x x' T T',
  update_ctx (update_ctx empty_ctx x T) x' T' = update_l_ctx x T (update_ctx empty_ctx x' T').
Proof.
  intros. simpl. reflexivity.
Qed.

Lemma ctx_lr' : forall G x x' T T',
  update_ctx (update_l_ctx x T G) x' T' = update_l_ctx x T (update_ctx G x' T').
Proof.
  induction G.
  - intros. simpl. reflexivity.
  - intros. rewrite <- IHG. simpl. reflexivity.
Qed.

Reserved Notation "G1 'o' G2" (at level 20).

Fixpoint concat_ctx (G1 : ctx) (G2 : ctx) : ctx :=
  match G1 with
  | [] => G2
  | update_ctx G1' x T => G1' o (update_l_ctx x T G2)
  end

where "G1 'o' G2" := (concat_ctx G1 G2).

Proposition concat_ctx_update : forall G1 G2 i T,
  G1 o (update_ctx G2 i T) = update_ctx (G1 o G2) i T.
Proof.
  induction G1. induction G2.
  - intros. simpl. reflexivity.
  - intros i' T. simpl. reflexivity.
  - intros G2 i' T.
    assert (Hlr : (update_ctx G1 i t) o G2 = G1 o (update_l_ctx i t G2)). { reflexivity. }
    rewrite -> Hlr. apply IHG1 with (G2 := update_l_ctx i t G2).
Qed.

Corollary concat_ctx_null_r : forall G, G o [] = G.
Proof.
  induction G.
  - simpl. reflexivity.
  - simpl. assert (H : update_ctx G i t = update_ctx (G o []) i t). { rewrite -> IHG. reflexivity. }
    rewrite -> H. apply concat_ctx_update.
Qed.

Corollary concat_ctx_singleton : forall G i T, G o (update_ctx ([]) i T) = update_ctx G i T.
Proof.
  induction G.
  - intros. simpl. reflexivity.
  - intros i' T. simpl. rewrite -> concat_ctx_update. rewrite -> IHG. reflexivity.
Qed.

Example concat_ctx_update_lr : forall G1 G2 x T,
  (update_ctx G1 x T) o G2 = G1 o (update_l_ctx x T G2).
Proof. reflexivity. Qed.

Proposition concat_ctx_assoc : forall G1 G2 G3, (G1 o G2) o G3 = G1 o (G2 o G3).
Proof.
  intros. admit.
Qed.

Fixpoint ctx_contains (G : ctx) (i : id) (T : ty) : Prop :=
  match G with
  | [] => False
  | update_ctx G' i' T' => ((i = i') /\ (T = T')) \/ (ctx_contains G' i T)
  end.

Example ctx_contains_test_1 : forall x T, ctx_contains (update_ctx ([]) x T) x T.
Proof. intros. simpl. left. split; reflexivity. Qed.

Example ctx_contains_test_2 : forall G x T, ctx_contains (update_ctx G x T) x T.
Proof. intros. simpl. left. split; reflexivity. Qed.

Proposition ctx_contains_concat : forall G1 G2 x T,
  ctx_contains ((update_ctx G1 x T) o G2) x T.
Proof.
  intros. induction G2.
  - simpl. rewrite -> concat_ctx_singleton. simpl. left. split; reflexivity.
  - rewrite -> concat_ctx_update. simpl. right. simpl in IHG2. apply IHG2.
Qed.

Proposition ctx_contains_concat' :
  forall G x T, ctx_contains G x T ->
  exists G1 G2, G = (update_ctx G1 x T) o G2.
Proof.
  intros. induction G.
  - inversion H.
  - simpl in H. inversion H.
    + inversion H0. subst. exists G. exists ([]). simpl. rewrite -> concat_ctx_singleton. reflexivity.
    + apply IHG in H0. inversion H0 as [G']. inversion H1 as [G''].
      exists G'. exists (update_ctx G'' i t). rewrite -> H2. rewrite -> concat_ctx_update. reflexivity.
Qed.

Proposition ctx_contains_concat'' : forall G1 G2 x T x' T',
  ctx_contains ( (update_ctx G1 x' T') o G2 ) x T ->
  (ctx_contains G1 x T) \/ (x = x' /\ T = T') \/ (ctx_contains G2 x T).
Proof.
  intros. induction G2.
  - simpl in H. rewrite -> concat_ctx_singleton in H. simpl in H. inversion H.
    + right. left. apply H0.
    + left. apply H0.
  - rewrite -> concat_ctx_update in H. simpl in H. inversion H.
    + right. right. simpl. left. apply H0.
    + simpl in IHG2. apply IHG2 in H0. inversion H0; try (left; apply H1).
      inversion H1; try (right; left; apply H2). right. right. simpl. right. apply H2.
Qed.

Inductive ctx_split : ctx -> ctx -> ctx -> Prop :=
  | M_Empty : ctx_split empty_ctx empty_ctx empty_ctx
  | M_Un : forall G G1 G2 x P,
      ctx_split G G1 G2 ->
      ctx_split (update_ctx G x (P qun)) (update_ctx G1 x (P qun)) (update_ctx G2 x (P qun))
  | M_Lin1 : forall G G1 G2 x P,
      ctx_split G G1 G2 ->
      ctx_split (update_ctx G x (P qlin)) (update_ctx G1 x (P qlin)) G2
  | M_Lin2 : forall G G1 G2 x P,
      ctx_split G G1 G2 ->
      ctx_split (update_ctx G x (P qlin)) G1 (update_ctx G2 x (P qlin)).

Reserved Notation "Q1 '<<' Q2" (at level 70).

Inductive q_rel : q -> q -> Prop :=
  | Q_Ref : forall Q, Q << Q
  | Q_Axiom : qlin << qun

where "Q1 '<<' Q2" := (q_rel Q1 Q2).

Lemma q_rel_trans : forall Q Q' Q'', Q << Q' -> Q' << Q'' -> Q << Q''.
Proof.
  induction Q; induction Q'; induction Q''; intros H H';
  try inversion H; try inversion H'; try apply Q_Ref; try apply Q_Axiom.
Qed.

Inductive q_rel' : q -> ty -> Prop :=
  | Q_Rel_Type : forall Q Q' P, Q << Q' -> q_rel' Q (P Q').

Proposition q_rel'_qlin : forall T, q_rel' qlin T.
Proof.
  induction T; induction q0; apply Q_Rel_Type; try apply Q_Ref; try apply Q_Axiom.
Qed.

Reserved Notation "Q '((' G '))'" (at level 30).

Inductive q_rel'' : q -> ctx -> Prop :=
  | Q_Rel_Ctx_Empty : forall Q, Q (( empty_ctx ))
  | Q_Rel_Ctx_Update : forall Q G x T,
      q_rel' Q T ->
      Q (( G )) ->
      Q (( update_ctx G x T ))

where "Q '((' G '))'" := (q_rel'' Q G).

Lemma q_rel''_concat_ctx : forall Q G1 G2,
  Q (( G1 )) ->
  Q (( G2 )) ->
  Q (( G1 o G2 )).
Proof.
  intros Q G1 G2 H H'. induction G2.
  - simpl. rewrite -> concat_ctx_null_r. apply H.
  - inversion H'. subst. apply IHG2 in H5. rewrite -> concat_ctx_update. apply Q_Rel_Ctx_Update.
    + apply H3.
    + apply H5.
Qed.

Proposition q_rel''_update_l_ctx : forall G Q x T,
  Q (( update_l_ctx x T G )) -> q_rel' Q T /\ Q (( G )).
Proof.
  induction G.
  - intros. rewrite <- ctx_singleton in H. inversion H. subst. split; try apply H3; try apply H5.
  - intros. rewrite <- ctx_lr' in H. inversion H. subst. apply IHG in H5. split.
    + inversion H5. apply H0.
    + apply Q_Rel_Ctx_Update; try apply H3. inversion H5. apply H1.
Qed.

Lemma q_rel''_concat_ctx' : forall G1 G2 Q,
  Q (( G1 o G2 )) -> Q (( G1 )) /\ Q (( G2 )).
Proof.
  induction G1. induction G2.
  - intros. split; apply Q_Rel_Ctx_Empty.
  - intros. split; try apply Q_Rel_Ctx_Empty. simpl in H. apply H.
  - intros.
    assert (Hlr : (update_ctx G1 i t) o G2 = G1 o (update_l_ctx i t G2) ). { reflexivity. }
    rewrite -> Hlr in H. apply IHG1 in H. inversion H as [H1 H2]. apply q_rel''_update_l_ctx in H2.
    inversion H2 as [H21 H22]. split; try apply H22. apply Q_Rel_Ctx_Update; try apply H21; try apply H1.
Qed.

Inductive q_rel''_except : q -> ctx -> id -> ty -> Prop :=
  | Q_Rel_Ctx_Except : forall Q G1 G2 x T,
      Q (( G1 )) ->
      Q (( G2 )) ->
      q_rel''_except Q ( (update_ctx G1 x T) o G2 ) x T.

Proposition q_rel''_except_invert : forall Q G1 G2 x T,
  q_rel''_except Q ( (update_ctx G1 x T) o G2 ) x T ->
  Q (( G1 )) /\ Q (( G2 )).
Proof.
  intros. inversion H. subst.
Qed.

Reserved Notation "G '|-' t '|' T" (at level 60).

Inductive ctx_ty : ctx -> tm -> ty -> Prop :=
  | T_Var : forall G1 G2 x T,
      qun (( concat_ctx G1 G2 )) ->
      (concat_ctx (update_ctx G1 x T) G2) |- (tmvar x) | T
  | T_Bool : forall G (Q : q) (B : b),
      qun (( G )) ->
      G |- (tmbool Q B) | ty_bool Q
  | T_If : forall G1 G2 t1 t2 t3 Q T,
      G1 |- t1 | ty_bool Q ->
      G2 |- t2 | T ->
      G2 |- t3 | T ->
      concat_ctx G1 G2 |- tmif t1 t2 t3 | T
  | T_Pair : forall G1 G2 t1 t2 T1 T2 Q,
      G1 |- t1 | T1 ->
      G2 |- t2 | T2 ->
      q_rel' Q T1 ->
      q_rel' Q T2 ->
      concat_ctx G1 G2 |- tmpair Q t1 t2 | (T1 ** T2) Q
  | T_Split : forall G1 G2 t1 t2 T1 T2 T x y Q,
      G1 |- t1 | (T1 ** T2) Q ->
      update_ctx (update_ctx G2 x T1) y T2 |- t2 | T ->
      concat_ctx G1 G2 |- tmsplit t1 x y t2 | T
  | T_Abs : forall Q G t2 T1 T2 x,
      Q (( G )) ->
      update_ctx G x T1 |- t2 | T2 ->
      G |- tmabs Q x T1 t2 | (T1 --> T2) Q
  | T_App : forall G1 G2 t1 t2 T11 T12 Q,
      G1 |- t1 | (T11 --> T12) Q ->
      G2 |- t2 | T11 ->
      concat_ctx G1 G2 |- tmapp t1 t2 | T12

where "G '|-' t '|' T" := (ctx_ty G t T).

Hint Constructors ctx_ty.

Lemma exchange : forall t x1 x2 T1 T2 T G1 G2,
  concat_ctx (update_ctx (update_ctx G1 x1 T1) x2 T2) G2 |- t | T ->
  concat_ctx (update_ctx (update_ctx G1 x2 T2) x1 T1) G2 |- t | T.
Proof.
  induction t.
  - intros. inversion H. subst.
    assert (Hc : ctx_contains ( (update_ctx G0 i T) o G3 ) i T).
    { apply ctx_contains_concat. }
    simpl in Hc. rewrite -> H0 in Hc. rewrite <- concat_ctx_update_lr in Hc.
    apply ctx_contains_concat'' in Hc. inversion Hc.
    { apply ctx_contains_concat' in H1. inversion H1 as [G']. inversion H3 as [G'']. rewrite -> H4.
      rewrite -> concat_ctx_update_lr. rewrite -> concat_ctx_update_lr. rewrite -> concat_ctx_assoc.
      apply T_Var. subst. rewrite -> concat_ctx_assoc in H0.

    inversion Hc as [G']. inversion H1 as [G'']. simpl.
  - admit.
  - intros. inversion H. subst.
Qed.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation; either version 2.1 of the License, or
(at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Export Raxioms.
Require Import RIneq.
Require Import Rfunctions.

Open Scope R_scope.

Implicit Type r : R.

Lemma Rmin_opp_opp_Rmax : forall r1 r2, Rmin (-r1) (-r2) = - (Rmax r1 r2).
Proof.
intros r1 r2 ; unfold Rmin, Rmax ; destruct (Rle_dec r1 r2) as [L1 | R1] ;
 destruct (Rle_dec (-r1) (-r2)) as [L2 | R2].
 assert (H := Ropp_le_cancel _ _ L2) ; apply Ropp_eq_compat ;
  apply Rle_antisym ; assumption.
 reflexivity.
 reflexivity.
 assert (H1 := Rnot_le_lt _ _ R1).
 assert (H2 := Ropp_lt_cancel _ _ (Rnot_le_lt _ _ R2)).
 apply False_ind ; apply Rlt_irrefl with r1 ; apply Rlt_trans with r2 ;
  assumption.
Qed.

Lemma Rmax_opp_opp_Rmin : forall r1 r2, Rmax (-r1) (-r2) = - (Rmin r1 r2).
Proof.
intros r1 r2.
replace (Rmin r1 r2) with (Rmin (--r1) (--r2)) by (rewrite Ropp_involutive ; intuition).
 rewrite Rmin_opp_opp_Rmax ; rewrite Ropp_involutive ; reflexivity.
Qed.

Lemma Rmin_eq_l : forall r1 r2, r1 <= r2 -> Rmin r1 r2 = r1.
Proof.
intros r1 r2 r1_le_r2 ; unfold Rmin ; destruct (Rle_dec r1 r2).
 reflexivity.
 contradiction.
Qed.

Lemma Rmin_eq_r : forall r1 r2, r1 <= r2 -> Rmin r2 r1 = r1.
Proof.
intros r1 r2 r1_le_r2 ; rewrite Rmin_comm ;
 apply Rmin_eq_l ; assumption.
Qed.

Lemma Rmax_eq_l : forall r1 r2, r2 <= r1 -> Rmax r1 r2 = r1.
Proof.
intros r1 r2 r1_le_r2 ; unfold Rmax ; destruct (Rle_dec r1 r2).
 destruct r.
 apply False_ind ; apply Rlt_irrefl with r2 ;
 apply Rle_lt_trans with r1 ; assumption.
 symmetry ; trivial.
 reflexivity.
Qed.

Lemma Rmax_eq_r : forall r1 r2, r2 <= r1 -> Rmax r2 r1 = r1.
Proof.
intros r1 r2 r1_le_r2 ; rewrite Rmax_comm ; apply Rmax_eq_l ;
 assumption.
Qed.

Lemma Rabs_eq_compat : forall r1 r2, r1 = r2 -> Rabs r1 = Rabs r2.
Proof.
intros ; subst ; reflexivity.
Qed.

Lemma Req_dec : forall r1 r2, {r1 = r2} + {r1 <> r2}.
Proof.
intros r1 r2.
destruct (total_order_T r1 r2) as [[Hlt|Heq]|Hgt].
right; intro Hn; apply (Rlt_irrefl r2);
  rewrite Hn in Hlt; assumption.
left; assumption.
right; intros Hn; apply (Rlt_irrefl r2);
  rewrite Hn in Hgt; assumption.
Qed.

Lemma Req_or_neq : forall r, {r = 0} + {r <> 0}.
Proof.
intros r; exact (Req_dec r 0).
Qed.

Lemma Rplus_eq_compat_r : forall r r1 r2, r1 = r2 -> r1 + r = r2 + r.
Proof.
intros r r1 r2 H; rewrite H; reflexivity.
Qed.

Lemma Rmult_eq_compat_r : forall r1 r2 r, r1 = r2 -> r1 * r = r2 * r.
Proof.
intros r1 r2 r r_neq.
 rewrite Rmult_comm.
 replace (r2 * r) with (r * r2) by field.
 apply Rmult_eq_compat_l ; assumption.
Qed.

Lemma Rmax_lt_lt_lt : forall x y z, Rmax x y < z <-> x < z /\ y < z.
 intros x y z. split.
  unfold Rmax. case (Rle_dec x y) ; intros Hyp Hyp2.
  split. apply Rle_lt_trans with (r2:=y) ; assumption. assumption.
  split. assumption. apply Rlt_trans with (r2:=x).
  assert (Temp : forall x y, ~ x <= y -> x > y).
   intros m n Hypmn. intuition.
  apply Temp ; clear Temp ; assumption.
  assumption.
  intros Hyp.
  unfold Rmax. case (Rle_dec x y).
  intro ; exact (proj2 Hyp).
  intro ; exact (proj1 Hyp).
Qed.

Lemma Rmax_le_le_le : forall x y z, Rmax x y <= z <-> x <= z /\ y <= z.
 intros x y z. split.
  unfold Rmax. case (Rle_dec x y) ; intros Hyp Hyp2.
  split. apply Rle_trans with (r2:=y) ; assumption. assumption.
  split. assumption. apply Rle_trans with (r2:=x).
  assert (Temp : forall x y, ~ x <= y -> x > y).
   intros m n Hypmn. intuition.
   left ; apply Temp ; clear Temp ; assumption.
  assumption.
  intros Hyp.
  unfold Rmax. case (Rle_dec x y).
  intro ; exact (proj2 Hyp).
  intro ; exact (proj1 Hyp).
Qed.

Lemma Rmin_gt_gt_gt : forall x y z, Rmin x y > z <-> x > z /\ y > z.
 intros x y z. split.
  unfold Rmin. case (Rle_dec x y) ; intros Hyp Hyp2.
  split. assumption.
  apply Rlt_le_trans with (r2:=x) ; intuition.
  split.
  apply Rlt_trans with (r2:=y). intuition.
  assert (Temp : forall x y, ~ x <= y -> x > y).
   intros m n Hypmn. intuition.
  apply Temp ; clear Temp ; assumption.
  assumption.
  intros Hyp.
  unfold Rmin. case (Rle_dec x y).
  intro ; exact (proj1 Hyp).
  intro ; exact (proj2 Hyp).
Qed.

Lemma Rmin_ge_ge_ge : forall x y z, Rmin x y >= z <-> x >= z /\ y >= z.
 intros x y z. split.
  unfold Rmin. case (Rle_dec x y) ; intros Hyp Hyp2.
  split ; [assumption | apply Rle_ge].
  apply Rle_trans with (r2:=x) ; intuition.
  split ; [apply Rle_ge | assumption].
  apply Rle_trans with (r2:=y). intuition.
  assert (Temp : forall x y, ~ x <= y -> x > y).
   intros m n Hypmn. intuition.
   left ; apply Temp ; clear Temp ; assumption.
  intros Hyp.
  unfold Rmin. case (Rle_dec x y).
  intro ; exact (proj1 Hyp).
  intro ; exact (proj2 Hyp).
Qed.

Lemma Rle_neq_lt : forall x y, x <= y /\ x <> y -> x < y.
Proof.
intros m n Hyp. unfold Rle in Hyp.
 destruct Hyp as (Hyp1,Hyp2).
 case Hyp1.
 intuition.
 intro Hfalse ; apply False_ind ; apply Hyp2 ; exact Hfalse.
Qed.


(* Admissibile ptt rules. *)

Require config.
Require Import config_tactics.
Require Import checking_tactics.
Require Import tt.
Require Import syntax.

Section PttAdmissible.

Local Instance havePrecondition : config.Precondition := {| config.flagPrecondition := config.Yes |}.
Context `{configReflection : config.Reflection}.
Context `{configBinaryProdType : config.BinaryProdType}.
Context `{configProdEta : config.ProdEta}.
Context `{configUniverses : config.Universes}.
Context `{configPropType : config.PropType}.
Context `{configIdType : config.IdType}.
Context `{configIdEliminator : config.IdEliminator}.
Context `{configEmptyType : config.EmptyType}.
Context `{configUnitType : config.UnitType}.
Context `{configBoolType : config.BoolType}.
Context `{configProdType : config.ProdType}.
Context `{configSyntax : syntax.Syntax}.

(* Some preliminary lemmata *)
Lemma EqTyWeakNat :
  forall {G D A B sbs},
    issubst sbs G D ->
    istype D A ->
    istype D B ->
    isctx G ->
    isctx D ->
    eqtype (ctxextend G (Subst A sbs))
           (Subst (Subst B (sbweak A)) (sbshift A sbs))
           (Subst (Subst B sbs) (sbweak (Subst A sbs))).
Proof.
  intros. magic.
  Unshelve. all:strictmagic.
Qed.

Lemma compWeakZero :
  forall {G A B u},
    isctx G ->
    istype G A ->
    istype G B ->
    isterm G u B ->
    eqtype G A (Subst A (sbcomp (sbweak B) (sbzero B u))).
Proof.
  intros. magic.
Qed.

Lemma EqTyWeakZero :
  forall {G A B u},
    isctx G ->
    istype G A ->
    istype G B ->
    isterm G u B ->
    eqtype G A (Subst (Subst A (sbweak B)) (sbzero B u)).
Proof.
  intros. magic.
Qed.

Lemma EqTyShiftZero :
  forall {G D A B v sbs},
    issubst sbs G D ->
    istype D A ->
    istype (ctxextend D A) B ->
    isterm D v A ->
    isctx G ->
    isctx D ->
    eqtype
      G
      (Subst (Subst B (sbshift A sbs)) (sbzero (Subst A sbs) (subst v sbs)))
      (Subst (Subst B (sbzero A v)) sbs).
Proof.
  intros. magic. Unshelve. all:strictmagic.
Qed.

Lemma EqTyCongZero :
  forall {G A1 A2 B1 B2 u1 u2},
    eqtype (ctxextend G A1) A2 B2 ->
    istype (ctxextend G A1) A2 ->
    istype (ctxextend G A1) B2 ->
    isctx G ->
    eqtype G A1 B1 ->
    eqterm G u1 u2 A1 ->
    istype G A1 ->
    istype G B1 ->
    isterm G u1 A1 ->
    isterm G u2 B1 ->
    eqtype G
           (Subst A2 (sbzero A1 u1))
           (Subst B2 (sbzero B1 u2)).
Proof.
  intros. magic.
Qed.

Lemma EqTyCongShift :
  forall {G D A1 A2 B1 B2 sbs1 sbs2},
    eqsubst sbs1 sbs2 G D ->
    eqtype D A1 A2 ->
    eqtype (ctxextend D A1) B1 B2 ->
    isctx G ->
    isctx D ->
    issubst sbs1 G D ->
    issubst sbs2 G D ->
    istype D A1 ->
    istype D A2 ->
    istype (ctxextend D A1) B1 ->
    istype (ctxextend D A2) B2 ->
    eqtype (ctxextend G (Subst A1 sbs1))
           (Subst B1 (sbshift A1 sbs1))
           (Subst B2 (sbshift A2 sbs2)).
Proof.
  intros. magic.
  Unshelve. all:strictmagic.
Qed.

Lemma EqTyCongWeak :
  forall {G A1 A2 B1 B2},
    eqtype G A1 A2 ->
    eqtype G B1 B2 ->
    isctx G ->
    istype G A1 ->
    istype G B1 ->
    istype G A2 ->
    istype G B2 ->
    eqtype (ctxextend G A1)
           (Subst B1 (sbweak A1))
           (Subst B2 (sbweak A2)).
Proof.
  intros. magic.
Qed.

Lemma EqSubstWeakNat :
  forall {G D A B u sbs},
    issubst sbs G D ->
    istype D A ->
    istype D B ->
    isterm D u B ->
    isctx G ->
    isctx D ->
    eqterm (ctxextend G (Subst A sbs))
           (subst (subst u (sbweak A)) (sbshift A sbs))
           (subst (subst u sbs) (sbweak (Subst A sbs)))
           (Subst (Subst B sbs) (sbweak (Subst A sbs))).
Proof.
  intros. magic.
  Unshelve. all:strictmagic.
Qed.

Lemma EqSubstWeakZero :
  forall {G A B u v},
    istype G A ->
    istype G B ->
    isterm G u A ->
    isterm G v B ->
    isctx G ->
    eqterm G
           (subst (subst u (sbweak B)) (sbzero B v))
           u
           A.
Proof.
  intros. magic.
Qed.

Lemma EqTermShiftZero :
  forall {G D A B u v sbs},
    issubst sbs G D ->
    istype D A ->
    istype (ctxextend D A) B ->
    isterm (ctxextend D A) u B ->
    isterm D v A ->
    isctx G ->
    isctx D ->
    eqterm
      G
      (subst (subst u (sbshift A sbs)) (sbzero (Subst A sbs) (subst v sbs)))
      (subst (subst u (sbzero A v)) sbs)
      (Subst (Subst B (sbzero A v)) sbs).
Proof.
  intros. magic.
  Unshelve. all:strictmagic.
Qed.

Lemma EqTermCongWeak :
  forall {G A1 A2 B1 B2 u1 u2},
    eqtype G A1 A2 ->
    eqtype G B1 B2 ->
    eqterm G u1 u2 B1 ->
    isctx G ->
    istype G A1 ->
    istype G B1 ->
    istype G B2 ->
    istype G A2 ->
    isterm G u1 B1 ->
    isterm G u2 B2 ->
    eqterm (ctxextend G A1)
           (subst u1 (sbweak A1))
           (subst u2 (sbweak A2))
           (Subst B1 (sbweak A1)).
Proof.
  intros. magic.
Qed.

End PttAdmissible.