From Undecidability.L Require Export Util.L_facts.
(* **** Closure calculus *)
Inductive Comp : Type :=
| CompVar (x:nat)
| CompApp (s : Comp) (t : Comp) : Comp
| CompClos (s : term) (A : list Comp) : Comp.
Coercion CompApp : Comp >-> Funclass.
Inductive lamComp : Comp -> Prop := lambdaComp s A: lamComp (CompClos (lam s) A).
Inductive validComp : Comp -> Prop :=
| validCompApp s t : validComp s -> validComp t -> validComp (s t)
| validCompClos (s : term) (A : list Comp) :
(forall a, a el A -> validComp a) -> (forall a, a el A -> lamComp a) -> bound (length A) s -> validComp (CompClos s A).
Hint Constructors Comp lamComp validComp : core.
Definition validEnv A := forall a, a el A -> validComp a (*/\ lamComp a)*).
Definition validEnv' A := forall a, a el A -> closed a.
Hint Unfold validEnv validEnv' : core.
Ltac inv_validComp :=
match goal with
| H : validComp (CompApp _ _) |- _ => inv H
| H : validComp (CompClos _ _)   |- _ => inv H
end.
Definition Comp_ind_deep'
(P : Comp -> Prop)
(Pl : list Comp -> Prop)
(IHVar : forall x : nat, P (CompVar x))
(IHApp : forall s : Comp, P s -> forall t : Comp, P t -> P (s t))
(IHClos : forall (s : term) (A : list Comp),
Pl A -> P (CompClos s A))
(IHNil : Pl nil)
(IHCons : forall (a:Comp) (A : list Comp),
P a -> Pl A -> Pl (a::A))
(x:Comp) : P x :=
(fix f c : P c:=
match c with
| CompVar x => IHVar x
| CompApp s t => IHApp s (f s) t (f t)
| CompClos s A => IHClos s A
((fix g A : Pl A :=
match A with
[] => IHNil
| a::A => IHCons a A (f a) (g A)
end) A)
end) x
.
Definition Comp_ind_deep
(P : Comp -> Prop)
(IHVar : forall x : nat, P (CompVar x))
(IHApp : forall s : Comp, P s -> forall t : Comp, P t -> P (s t))
(IHClos : forall (s : term) (A : list Comp),
(forall a, a el A -> P a) -> P (CompClos s A)) : forall x, P x.
(* Lemma subst_comm s x1 u1 x2 u2 : closed u1 -> closed u2 -> x1 <> x2 -> subst (subst s x1 u1) x2 u2 = subst (subst s x2 u2) x1 u1. Proof with try (congruence||auto). intros cl1 cl2 neq. revert x1 x2 neq;induction s;simpl;intros. -decide (n=x1); decide (n=x2); try rewrite cl1;try rewrite cl2;subst;simpl... +decide (x1=x1)... +decide (x2=x2)... +decide (n=x2);decide (n=x1)... -rewrite IHs1,IHs2... -rewrite IHs... Qed. *) (* Lemma subst_twice s x u1 u2 : closed u1 -> subst (subst s x u1) x u2 = subst s x u1. Proof with try (congruence||auto). intros cl. revert x;induction s;simpl;intros. -decide (n=x);subst. now rewrite cl. simpl. decide (n=x);subst;congruence. -rewrite IHs1,IHs2... -rewrite IHs... Qed.*)
(* Lemma subst_free a s k u y: closed a -> subst s k u = s -> subst (subst s y a) k u = subst s y a. (* Lemma bound_ge k s m: bound k s -> m >= k -> bound m s. *)
(* Lemma bound_subst' x s a y:  bound x s -> closed a -> bound x (subst s y a). *)
(* Fixpoint substList' (s:term) (x:nat) (A: list term): term := match A with | nil => s | a::A => substList' (subst s x a) (S x) A end.*)
Fixpoint substList (s:term) (x:nat) (A: list term): term :=
match s with
| var n => if Dec (x>n) then var n else nth (n-x) A (var n)
| app s t => app (substList s x A) (substList t x A)
| lam s => lam (substList s (S x) A)
end.
Fixpoint deClos (s:Comp) : term :=
match s with
| CompVar x => var x
| CompApp s t => app (deClos s) (deClos t)
| CompClos s A => substList s 0 (map deClos A)
end.
(* Reduction *)
Reserved Notation "s '>[(' l ')]' t" (at level 50, format "s  '>[(' l ')]'  t").
Declare Scope LClos.
Inductive CPow : nat -> Comp -> Comp -> Prop :=
| CPowRefl (s:Comp) : s >[(0)] s
| CPowTrans (s t u:Comp) i j : s >[(i)] t -> t >[(j)] u -> s >[(i+j)] u
| CPowAppL (s s' t :Comp) l: s >[(l)] s' -> (s t) >[(l)] (s' t)
| CPowAppR (s t t':Comp) l: t >[(l)] t' -> (s t) >[(l)] (s t')
| CPowApp  (s t:term) (A:list Comp) :
CompClos (app s t) A >[(0)] (CompClos s A) (CompClos t A)
| CPowVar (x:nat) (A:list Comp):
CompClos (var x) A >[(0)] nth x A (CompVar x)
| CPowVal (s t:term) (A B:list Comp):
lambda t -> (CompClos (lam s) A) (CompClos t B) >[(1)] (CompClos s ((CompClos t B)::A))
where "s  '>[(' l ')]'  t" := (CPow l s t)  : LClos.
Open Scope LClos.
Ltac inv_CompStep :=
match goal with
| H : (CompApp _ _) >(_) CompClos _ _ |- _ => inv H
| H : (CompClos _ _) >(_) CompApp _ _ |- _ => inv H
end.
Hint Constructors CPow : core.
Instance CPow'_App_properR n:
Proper (eq ==> (CPow n) ==> (CPow n)) CompApp.
(* Definition CStar s t:= exists k , CPow k s t .  Notation "s '>[]*' t" := (CStar s t) (at level 50)  : L.los.  Instance rStar'_PreOrder : PreOrder CStar.  Lemma rStar'_trans_l s s' t : s >[]* s' ->  s t >[]* s' t.  Lemma rStar'_trans_r (s t t' : Comp): t >[]* t' -> s t >[]* s t'.  Instance rStar'_App_proper : Proper ((star CStep) ==> (star CStep) ==> (star CStep)) CompApp.  Instance CStep_star_subrelation : subrelation CStep (star CStep).  *)
Hint Resolve deClos_validEnv : core.
Proof with repeat (subst || firstorder).
intros vs R. induction R;repeat inv_validComp...
-inv H3. constructor...
-inv H3. apply H1. apply nth_In. lia.
-inv H8. constructor;auto;intros a [?|?];subst;auto.
Qed.
Hint Resolve validComp_step : core.
(* Lemma deClos_correct''' s t : validComp s -> s >(0) t -> deClos s = deClos t. Proof with repeat (cbn in * || eauto || congruence || lia || subst). intros cs R. remember 0 as n eqn:eq in R. revert eq. induction R;intros ?;repeat inv_validComp... -destruct i... rewrite IHR1,IHR2... -destruct IHR... -rewrite IHR... -simpl. rewrite <- minus_n_O. rewrite <-map_nth with (f:=deClos)... Qed.  Lemma deClos_correct'' s t : validComp s -> s >(1) t -> deClos s = deClos t \/ deClos s ≻ deClos t. Proof with repeat (cbn in * || eauto || congruence || lia || subst). intros cs R. remember 1 as n eqn:eq in R. revert eq. induction R;intros ?;repeat inv_validComp... -destruct i... +destruct IHR2... apply deClos_correct''' in R1... left... aply deClos_correct''' in R1... right... right... split;eauto. destruct IHR. auto.  left... right... -destruct IHR. auto.  left... right... -left... -left. simpl. rewrite <- minus_n_O. rewrite <-map_nth with (f:=deClos)... -right. inv H. simpl. rewrite <-subst_substList... Qed.*)
Proof with repeat (cbn in * || eauto 10 using star || congruence || lia || subst).
intros cs R.
induction R...
-eapply pow_trans;eauto.
-inv cs;apply pow_step_congL...
-inv cs;apply pow_step_congR...
-rewrite <- minus_n_O. rewrite <-map_nth with (f:=deClos)...
-inv H. inv cs. inv H1. eexists;split... rewrite <- subst_substList...
Qed.
(*  (* relation that tries to capture that two closures 'reduce' to one another *)
Reserved Notation "s '=[]>' t" (at level 70).
Inductive reduceC : Comp -> Comp -> Prop :=
| redC s t: deClos s >* deClos t -> s =[]> t
where "s '=[]>' t" := (reduceC s t).
Hint Constructors reduceC.
(* ** Properties of the extended reduction relation *)
Instance reduceC_PreOrder : PreOrder reduceC.
Instance reduceC_App_proper :
Proper (reduceC ==> reduceC ==> reduceC) CompApp.
(* relation that tries to capture that two closures 'are the same' *)
Reserved Notation "s '=[]=' t" (at level 70).
Inductive equivC : Comp -> Comp -> Prop :=
| eqC s t: deClos s == deClos t -> s =[]= t
where "s '=[]=' t" := (equivC s t).
Hint Constructors equivC.
(* ** Properties of the equivalence relation *)
Instance equivC_Equivalence : Equivalence equivC.
Instance equivC_App_proper :
Proper (equivC ==> equivC ==> equivC) CompApp.
intros vs R. induction R;repeat inv_validComp.
-now rewrite IHR.
-now rewrite IHR.
-constructor. reflexivity.
-constructor. simpl. rewrite <- minus_n_O. rewrite <-map_nth with (f:= deClos). reflexivity.
-constructor. rewrite deClos_correct'. reflexivity. auto. auto.
Qed.
*)
(* Lemma lamComp_star s t : lamComp s -> s >[]* t -> s = t.  Lemma validComp_star s t: validComp s -> s >[]* t -> validComp t.  *)
(* Lemma deClos_lam p s: (λ s) = deClos p -> exists t, lamComp t /\ deClos t = (lam s) /\ p >[]* t.   Fixpoint normComp' s A:= match s with | app s t => (normComp' s A) (normComp' t A) | var x => CompClos (var x) A (*nth x A (CompVar x)*)
| lam s => CompClos (lam s) A
end.
Fixpoint normComp s :=
match s with
| CompApp s t => (normComp s) (normComp t)
| CompClos s A => normComp' s A
| s => s
end.

Lemma normComp_idem s: normComp (normComp s)=normComp s.