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

(* Synatactic properties about parallel reduction. (Excluding confluence.) *)

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


(* TODO: move these definitions to the OTT file. *)

Inductive multipar S D ( a : tm) : tm -> Prop :=
| mp_refl : multipar S D a a
| mp_step : forall b c, Par S D a b -> multipar S D b c -> multipar S D a c.(* ------------------------------------------ *)

(* Synatactic properties about parallel reduction. (Excluding confluence.) *)

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


(* TODO: move these definitions to the OTT file. *)

Inductive multipar S D ( a : tm) : tm -> Prop :=
| mp_refl : multipar S D a a
| mp_step : forall b c, Par S D a b -> multipar S D b c -> multipar S D a c.(* ------------------------------------------ *)

(* Synatactic properties about parallel reduction. (Excluding confluence.) *)

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


(* TODO: move these definitions to the OTT file. *)

Inductive multipar S D ( a : tm) : tm -> Prop :=
| mp_refl : multipar S D a a
| mp_step : forall b c, Par S D a b -> multipar S D b c -> multipar S D a c.(*
Inductive consistent : tm -> tm -> Prop :=
| consistent_a_Star   : consistent a_Star a_Star
| consistent_a_Pi     : forall rho A1 B1 A2 B2,
    lc_tm A1 ->
    lc_tm (a_Pi rho A1 B1) ->
    lc_tm A2 ->
    lc_tm (a_Pi rho A2 B2) ->
    consistent (a_Pi rho A1 B1) (a_Pi rho A2 B2)
| consistent_a_CPi    : forall phi1 A1 phi2 A2,
    lc_constraint phi1 ->
    lc_tm (a_CPi phi1 A1) ->
    lc_constraint phi2 ->
    lc_tm (a_CPi phi2 A2) ->
    consistent (a_CPi phi1 A1) (a_CPi phi2 A2)
| consistent_Path     : forall T p1 p2,
    Path T p1 -> Path T p2 ->
    consistent p1 p2
| consistent_a_Const  : forall T, consistent (a_Const T)(a_Const T)
| consistent_a_App    : forall p1 p2 b1 b2 rho,
    lc_tm b1 -> lc_tm b2 ->
    consistent p1 p2 ->
    consistent (a_App p1 rho b1) (a_App p2 rho b2)
| consistent_a_CApp    : forall p1 p2 b1 b2,
    lc_co b1 -> lc_co b2 ->
    consistent p1 p2 ->
    consistent (a_CApp p1 b1) (a_CApp p2 b2)
| consistent_a_Step_R : forall a b,
    lc_tm a ->
    not (value_type b) -> consistent a b
| consistent_a_Step_L : forall a b,
    lc_tm a ->
    not (value_type b) -> consistent b a.
Hint Constructors consistent.
*)

(*
Inductive erased_tm : tm -> Prop :=
| erased_a_Bullet :
    (erased_tm a_Bullet)
 | erased_a_Star :
     (erased_tm a_Star)
 | erased_a_Var_f : forall (x:tmvar),
     (erased_tm (a_Var_f x))
 | erased_a_Abs : forall L rho (b:tm),
     ( forall x , x `notin` L -> erased_tm  ( open_tm_wrt_tm b (a_Var_f x) )  )  ->
     (erased_tm (a_UAbs rho b))
 | erased_a_App : forall rho (a b:tm),
     (erased_tm a) ->
     (erased_tm b) ->
     (erased_tm (a_App a rho b))
 | erased_a_Pi : forall L rho (A B:tm),
     (erased_tm A) ->
      ( forall x , x `notin` L -> erased_tm  ( open_tm_wrt_tm B (a_Var_f x) )  )  ->
     (erased_tm (a_Pi rho A B))
 | erased_a_CPi : forall L (A A1 A2: tm) (B:tm),
     (erased_tm A1) ->  (erased_tm A2) -> (erased_tm A) ->
      ( forall c , c `notin` L -> erased_tm  ( open_tm_wrt_co B (g_Var_f c) )  )  ->
     (erased_tm (a_CPi (Eq A1 A2 A) B))
 | erased_a_CAbs : forall L (A A1 A2:tm) (b:tm),
      (forall c , c `notin` L -> erased_tm  ( open_tm_wrt_co b (g_Var_f c) )  )  ->
     (erased_tm (a_UCAbs b))
 | erased_a_CApp : forall (a:tm),
     (erased_tm a) ->
     (erased_tm (a_CApp a g_Triv))
 | erased_a_Const : forall T,
     erased_tm (a_Const T)
 | erased_a_Fam : forall F,
     erased_tm (a_Fam F)
.

Hint Constructors erased_tm.
*)

(* NOTE: we have a database 'erased' for proving that terms are erased. *)

(* Tactics concerning erased terms. *)

Ltac erased_pick_fresh x :=
  match goal with
    [ |- erased_tm ?s ] =>
    let v := match s with
             | a_UAbs _ _  => erased_a_Abs
             | a_Pi _ _ _  => erased_a_Pi
             | a_CPi _ _   => erased_a_CPi
             | a_UCAbs _   => erased_a_CAbs
             end
    in pick fresh x and apply v
  end.Ltac erased_inversion :=
  repeat match goal with
  | [H : erased_tm (a_UAbs _ _)|- _ ] =>
    inversion H; subst; clear H
  | [H : erased_tm (a_App _ _ _)|- _ ] =>
    inversion H; subst; clear H
  | [H : erased_tm (a_Pi _ _ _)|- _ ] =>
    inversion H; subst; clear H
  | [H : erased_tm (a_CPi _ _)|- _ ] =>
    inversion H; subst; clear H
  | [H : erased_tm (a_UCAbs _ ) |- _ ] =>
    inversion H; subst; clear H
  | [H : erased_tm (a_CApp _ _)|- _ ] =>
    inversion H; subst; clear H
end.(*

Lemma erased_tm_erase_mutual :
  (forall a, lc_tm a -> erased_tm (erase a))
  /\ (forall a, lc_brs a -> True)
  /\ (forall a, lc_co a -> True)
  /\ (forall phi, lc_constraint phi -> forall a b A, phi = (Eq a b A) ->
                                         erased_tm (erase a) /\ erased_tm (erase b)
                                         /\ erased_tm (erase A)).

Proof.
  apply lc_tm_lc_brs_lc_co_lc_constraint_mutind; intros; simpl; eauto.
  all: try solve [ try (destruct rho); simpl; eauto].
  all: try solve [erased_case].
  - destruct rho; eauto. pick fresh x and apply erased_a_Abs. 
    replace (a_Var_f x) with (erase (a_Var_f x)); eauto.
    rewrite open_tm_erase_tm; eauto.
    eauto.
    (*irrel*)
    pick fresh x and apply erased_a_Abs.
    replace (a_Var_f x) with (erase (a_Var_f x)); eauto.
    rewrite open_tm_erase_tm; eauto. econstructor. admit.
  - destruct phi. destruct (H _ _ _ eq_refl) as (h0 & h1 & h2). simpl.
    erased_case.
  - inversion H2. subst. tauto.
Qed. *)

(*
Lemma erased_tm_erase : forall a, lc_tm a -> erased_tm (erase a).
Proof.
  intros.
  destruct erased_tm_erase_mutual.
  eauto.
Qed.

Hint Resolve erased_tm_erase : erased. *)


Inductive erased_sort : sort -> Prop :=
| erased_Tm : forall a, erased_tm a -> erased_sort (Tm a)
| erased_Co : forall a b A, erased_tm a -> erased_tm b -> erased_tm A -> erased_sort (Co (Eq a b A)).(*

Lemma erased_tm_erase_mutual :
  (forall a, lc_tm a -> erased_tm (erase a))
  /\ (forall a, lc_brs a -> True)
  /\ (forall a, lc_co a -> True)
  /\ (forall phi, lc_constraint phi -> forall a b A, phi = (Eq a b A) ->
                                         erased_tm (erase a) /\ erased_tm (erase b)
                                         /\ erased_tm (erase A)).

Proof.
  apply lc_tm_lc_brs_lc_co_lc_constraint_mutind; intros; simpl; eauto.
  all: try solve [ try (destruct rho); simpl; eauto].
  all: try solve [erased_case].
  - destruct rho; eauto. pick fresh x and apply erased_a_Abs. 
    replace (a_Var_f x) with (erase (a_Var_f x)); eauto.
    rewrite open_tm_erase_tm; eauto.
    eauto.
    (*irrel*)
    pick fresh x and apply erased_a_Abs.
    replace (a_Var_f x) with (erase (a_Var_f x)); eauto.
    rewrite open_tm_erase_tm; eauto. econstructor. admit.
  - destruct phi. destruct (H _ _ _ eq_refl) as (h0 & h1 & h2). simpl.
    erased_case.
  - inversion H2. subst. tauto.
Qed. *)

(*
Lemma erased_tm_erase : forall a, lc_tm a -> erased_tm (erase a).
Proof.
  intros.
  destruct erased_tm_erase_mutual.
  eauto.
Qed.

Hint Resolve erased_tm_erase : erased. *)


Inductive erased_sort : sort -> Prop :=
| erased_Tm : forall a, erased_tm a -> erased_sort (Tm a)
| erased_Co : forall a b A, erased_tm a -> erased_tm b -> erased_tm A -> erased_sort (Co (Eq a b A)).(*

Lemma erased_tm_erase_mutual :
  (forall a, lc_tm a -> erased_tm (erase a))
  /\ (forall a, lc_brs a -> True)
  /\ (forall a, lc_co a -> True)
  /\ (forall phi, lc_constraint phi -> forall a b A, phi = (Eq a b A) ->
                                         erased_tm (erase a) /\ erased_tm (erase b)
                                         /\ erased_tm (erase A)).

Proof.
  apply lc_tm_lc_brs_lc_co_lc_constraint_mutind; intros; simpl; eauto.
  all: try solve [ try (destruct rho); simpl; eauto].
  all: try solve [erased_case].
  - destruct rho; eauto. pick fresh x and apply erased_a_Abs. 
    replace (a_Var_f x) with (erase (a_Var_f x)); eauto.
    rewrite open_tm_erase_tm; eauto.
    eauto.
    (*irrel*)
    pick fresh x and apply erased_a_Abs.
    replace (a_Var_f x) with (erase (a_Var_f x)); eauto.
    rewrite open_tm_erase_tm; eauto. econstructor. admit.
  - destruct phi. destruct (H _ _ _ eq_refl) as (h0 & h1 & h2). simpl.
    erased_case.
  - inversion H2. subst. tauto.
Qed. *)

(*
Lemma erased_tm_erase : forall a, lc_tm a -> erased_tm (erase a).
Proof.
  intros.
  destruct erased_tm_erase_mutual.
  eauto.
Qed.

Hint Resolve erased_tm_erase : erased. *)


Inductive erased_sort : sort -> Prop :=
| erased_Tm : forall a, erased_tm a -> erased_sort (Tm a)
| erased_Co : forall a b A, erased_tm a -> erased_tm b -> erased_tm A -> erased_sort (Co (Eq a b A)).(* Check Forall_forall *)

Definition erased_context : context -> Prop :=
  Forall (fun p => match p with (a,s) => erased_sort s end).Definition joins S D a b := exists c, erased_context S /\ erased_tm a /\ erased_tm b /\
                               multipar S D a c /\ multipar S D b c.

rewrite (@co_subst_co_tm_intro y); eauto. apply subst_co